text:
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
module Data.StoreSpec where

import           Control.Applicative
import           Control.Exception (evaluate)
import           Control.Monad (unless)
import           Control.Monad.Fail (MonadFail)
import qualified Data.Array.Unboxed as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short as SBS
import           Data.Complex (Complex(..))
import           Data.Containers (mapFromList, setFromList)
import           Data.Fixed (Pico)
import           Data.Generics (listify)
import           Data.HashMap.Strict (HashMap)
import           Data.HashSet (HashSet)
import           Data.Hashable (Hashable)
import           Data.Int
import           Data.IntMap (IntMap)
import           Data.IntSet (IntSet)
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import           Data.Monoid
import           Data.Proxy (Proxy(..))
import           Data.Sequence (Seq)
import           Data.Sequences (fromList)
import           Data.Set (Set)
import           Data.Store
import           Data.Store.Internal
import           Data.Store.TH
import           Data.Store.TH.Internal
import           Data.Store.TypeHash
import           Data.StoreSpec.TH
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Time as Time
import qualified Data.Time.Clock.TAI as Time
import           Data.Typeable (Typeable)
import qualified Data.Vector as V
import qualified Data.Vector.Primitive as PV
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Unboxed as UV
import           Data.Word
import           Foreign.C.Types
import           Foreign.Ptr
import           Foreign.Storable (Storable, sizeOf)
import           GHC.Fingerprint.Type (Fingerprint(..))
import           GHC.Generics
import           GHC.Real (Ratio(..))
#if MIN_VERSION_base(4,15,0)
import           GHC.RTS.Flags (IoSubSystem(..))
#endif
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           Network.Socket
import           Numeric.Natural (Natural)
import           Prelude
import           System.Clock (TimeSpec(..))
import           System.Posix.Types
import           Test.Hspec hiding (runIO)
import           Test.SmallCheck.Series
import           TH.Utilities (unAppsT)

#if !MIN_VERSION_primitive(0,7,0)
import           Data.Primitive.Types (Addr)
#endif

#if MIN_VERSION_time(1,8,0)
import qualified Data.Time.Clock.System as Time
#endif
#if MIN_VERSION_time(1,9,0)
import qualified Data.Time.Format.ISO8601 as Time
#endif
#if MIN_VERSION_time(1,11,0)
import qualified Data.Time.Calendar.Quarter as Time
#endif

#if !MIN_VERSION_smallcheck(1,2,0)
import           Data.Void (Void)
#endif

------------------------------------------------------------------------
-- Instances for base types

addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]
addMinAndMaxBounds xs =
    (if (minBound :: a) `notElem` xs then [minBound] else []) ++
    (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs)

$(mkManyHasTypeHash [ [t| Int32 |] ])

-- Serial instances for (Num a, Bounded a) types. Only really
-- appropriate for the use here.

#if !MIN_VERSION_network(3,1,2)
instance Bounded PortNumber where
  minBound = 0
  maxBound = 65535
#endif

$(do let ns = [ ''PortNumber

#if !MIN_VERSION_smallcheck(1,2,0)
              , ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax
              , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong
              , ''CLong, ''CInt, ''CChar
#endif
              , ''CSsize, ''CPid
              , ''COff, ''CMode, ''CIno, ''CDev
#if !MIN_VERSION_smallcheck(1,1,4)
              , ''Word8, ''Word16, ''Word32, ''Word64
              , ''Int8, ''Int16, ''Int32, ''Int64
#endif
#if !MIN_VERSION_smallcheck(1,1,3)
              , ''Word
#endif
#if MIN_VERSION_base(4,10,0)
#if !MIN_VERSION_smallcheck(1,2,0)
              , ''CBool
#endif
              , ''CClockId, ''CKey, ''CId
              , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt
#endif
#if MIN_VERSION_base(4,14,0)
              , ''CSocklen, ''CNfds
#endif
#ifndef mingw32_HOST_OS
              , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid
#endif
              ]
         f n = [d| instance Monad m => Serial m $(conT n) where
                      series = generate (\_ -> addMinAndMaxBounds [0, 1]) |]
     concat <$> mapM f ns)

-- Serial instances for (Num a) types. Only really appropriate for the
-- use here.

$(do let ns =
#if !MIN_VERSION_smallcheck(1,2,0)
              [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic
              ,  ''CSUSeconds, ''CFloat, ''CDouble
              ] ++
#endif
#if !MIN_VERSION_smallcheck(1,1,3)
              [ ''Natural ] ++
#endif
#ifndef mingw32_HOST_OS
              [ ''CSpeed, ''CCc ] ++
#endif
              []
         f n = [d| instance Monad m => Serial m $(conT n) where
                      series = generate (\_ -> [0, 1]) |]
     concat <$> mapM f ns)

-- Serial instances for Primitive vectors

$(do tys <- getAllInstanceTypes1 ''PV.Prim
     let f ty = [d| instance (Serial m $(return ty), Monad m) => Serial m (PV.Vector $(return ty)) where
                      series = fmap PV.fromList series |]
     concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys))

$(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ]
         f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |]
     concat <$> mapM f ns)

instance Monad m => Serial m Any where
    series = fmap Any series

instance Monad m => Serial m All where
    series = fmap All series

instance Monad m => Serial m Fingerprint where
    series = generate (\_ -> [Fingerprint 0 0, Fingerprint maxBound maxBound])

instance Monad m => Serial m BS.ByteString where
    series = fmap BS.pack series

instance Monad m => Serial m LBS.ByteString where
    series = fmap LBS.pack series

instance Monad m => Serial m SBS.ShortByteString where
    series = fmap SBS.pack series

instance (Monad m, Serial m a, Storable a) => Serial m (SV.Vector a) where
    series = fmap SV.fromList series

instance (Monad m, Serial m a) => Serial m (V.Vector a) where
    series = fmap V.fromList series

instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where
    series = fmap mapFromList series

instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where
    series = fmap setFromList series

instance (Monad m, Serial m a) => Serial m (IntMap a) where
    series = fmap mapFromList series

instance Monad m => Serial m IntSet where
    series = fmap setFromList series

instance Monad m => Serial m Text where
    series = fmap fromList series

instance (Monad m, Serial m a) => Serial m (Seq a) where
    series = fmap fromList series

instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where
    series = fmap fromList series

instance (Monad m, Serial m k, Serial m a, Hashable k, Eq k) => Serial m (HashMap k a) where
    series = fmap mapFromList series

instance (Monad m, Serial m a, Hashable a, Eq a) => Serial m (HashSet a) where
    series = fmap setFromList series

instance (Monad m, A.Ix i, Serial m i, Serial m e) => Serial m (A.Array i e) where
    series = seriesArray

instance (Monad m, A.IArray A.UArray e, A.Ix i, Serial m i, Serial m e) => Serial m (A.UArray i e) where
    series = seriesArray

seriesArray :: (Monad m, A.Ix i, A.IArray a e, Serial m i, Serial m e) => Series m (a i e)
seriesArray = cons2 $ \bounds (NonEmpty xs) ->
    A.listArray bounds (take (A.rangeSize bounds) (cycle xs))

instance Monad m => Serial m Time.Day where
    series = Time.ModifiedJulianDay <$> series

instance Monad m => Serial m Time.DiffTime where
    series = Time.picosecondsToDiffTime <$> series

instance Monad m => Serial m Time.NominalDiffTime where
    series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series

instance Monad m => Serial m Time.UTCTime where
    series = uncurry Time.UTCTime <$> (series >< series)

instance (Monad m, Serial m a) => Serial m (Tagged a)

#if MIN_VERSION_base(4,15,0)
instance Monad m => Serial m IoSubSystem where
  series = cons0 IoPOSIX \/ cons0 IoNative
#endif

#if !MIN_VERSION_smallcheck(1,2,0)
instance (Monad m, Serial m a) => Serial m (Complex a) where
    series = uncurry (:+) <$> (series >< series)

instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a)

instance Monad m => Serial m Void where
    series = generate (\_ -> [])
#endif

instance Monad m => Serial m TimeSpec where
    series = uncurry TimeSpec <$> (series >< series)

-- We define our own Serial instance for 'Ratio' because of <https://github.com/feuerbach/smallcheck/pull/34>

newtype SerialRatio a = SerialRatio (Ratio a)
  deriving (Store, Eq, Show)

instance (Integral i, Serial m i) => Serial m (SerialRatio i) where
   series = pairToRatio <$> series
     where
      pairToRatio (n, Positive d) = SerialRatio (n :% d)

------------------------------------------------------------------------
-- Test datatypes for generics support

data Test
    = TestA Int64 Word32
    | TestB Bool
    | TestC
    | TestD BS.ByteString
    deriving (Eq, Show, Generic)
-- $(return . (:[]) =<< deriveStore [] (ConT ''Test) . dtCons =<< reifyDataType ''Test)
instance Store Test
instance Monad m => Serial m Test

data X = X
    deriving (Eq, Show, Generic)
instance Monad m => Serial m X
instance Store X

-- Datatypes with faulty instances
newtype BadIdea = BadIdea Int64
instance Store BadIdea where
    poke (BadIdea x) = poke x
    peek = BadIdea <$> peek
    size = ConstSize 1 -- too small

newtype BadIdea2 = BadIdea2 Int64
instance Store BadIdea2 where
    poke (BadIdea2 x) = poke x
    peek = BadIdea2 <$> peek
    size = ConstSize 12 -- too large

spec :: Spec
spec = do
    describe "Store on all monomorphic instances"
        $(do insts <- getAllInstanceTypes1 ''Store
             omitTys0 <- sequence $
#if !MIN_VERSION_primitive(0,7,0)
                 [t| Addr |] :
#endif
                 [ [t| CUIntPtr |]
                 , [t| CIntPtr |]
                 , [t| IntPtr |]
                 , [t| WordPtr |]
                 , [t| TypeHash |]
                 , [t| Fd |]
                 , [t| NameFlavour |]
#if MIN_VERSION_base(4,10,0)
                 , [t| CTimer |]
#endif

-- Assume the TH generated instances for Time work, to avoid defining
-- Serial instances. Also some lack Show / Eq.

                 , [t| Time.AbsoluteTime |]
                 , [t| Time.Day |]
                 , [t| Time.LocalTime |]
                 , [t| Time.TimeOfDay |]
                 , [t| Time.TimeZone |]
                 , [t| Time.UTCTime |]
                 , [t| Time.UniversalTime |]
                 , [t| Time.ZonedTime |]
                 , [t| Time.TimeLocale |]
#if MIN_VERSION_time(1,8,0)
                 , [t| Time.SystemTime |]
#endif
#if MIN_VERSION_time(1,9,0)
                 , [t| Time.FormatExtension |]
                 , [t| Time.CalendarDiffDays |]
                 , [t| Time.CalendarDiffTime |]
#endif
#if MIN_VERSION_time(1,11,0)
                 , [t| Time.DayOfWeek |]
                 , [t| Time.FirstWeekType |]
                 , [t| Time.Quarter |]
                 , [t| Time.QuarterOfYear |]
#endif

                 ]
             omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0
             let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty)
                 filtered = filter f insts
                 -- Roundtrip testing of TH instances is disabled - see issue #150
                 isThName n = nameModule n == Just "Language.Haskell.TH.Syntax"
             smallcheckManyStore verbose 2 $ map return filtered)
    it "Store on non-numeric Float/Double values" $ do
        let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m, MonadFail m) => Proxy a -> m ()
            testNonNumeric _proxy = do
                assertRoundtrip verbose ((1/0) :: a)
                assertRoundtrip verbose ((-1/0) :: a)
                -- -0 == 0, so we check if the infinity sign is the same
                case decode (encode ((-0) :: a)) of
                    Right (x :: a) -> unless (-1/0 == 1/x) (fail "Could not roundtrip negative 0")
                    _ -> fail "Could not roundtrip negative 0"
                assertRoundtrip verbose ((-0) :: a)
                -- 0/0 /= 0/0, so we check for NaN explicitly
                case decode (encode ((0/0) :: a)) of
                    Right (x :: a) -> unless (isNaN x) (fail "Could not roundtrip NaN")
                    _ -> fail "Could not roundtrip NaN"
        testNonNumeric (Proxy :: Proxy Double)
        testNonNumeric (Proxy :: Proxy Float)
        testNonNumeric (Proxy :: Proxy CDouble)
        testNonNumeric (Proxy :: Proxy CFloat)
        (return () :: IO ())
    describe "Store on all custom generic instances"
        $(smallcheckManyStore verbose 2
            [ [t| Test |]
            , [t| X |]
            ])
    describe "Manually listed polymorphic store instances"
        $(smallcheckManyStore verbose 4
            [ [t| SV.Vector Int8 |]
            , [t| V.Vector  Int8 |]
            , [t| SerialRatio     Int8 |]
            , [t| Complex   Int8 |]
            , [t| Dual      Int8 |]
            , [t| Sum       Int8 |]
            , [t| Product   Int8 |]
            , [t| First     Int8 |]
            , [t| Last      Int8 |]
            , [t| Maybe     Int8 |]
            , [t| Either    Int8 Int8 |]
            , [t| SV.Vector Int64 |]
            , [t| V.Vector  Int64 |]
            , [t| SerialRatio     Int64 |]
            , [t| Complex   Int64 |]
            , [t| Dual      Int64 |]
            , [t| Sum       Int64 |]
            , [t| Product   Int64 |]
            , [t| First     Int64 |]
            , [t| Last      Int64 |]
            , [t| Maybe     Int64 |]
            , [t| Either    Int64 Int64 |]
            , [t| (Int8, Int16) |]
            , [t| (Int8, Int16, Bool) |]
            , [t| (Bool, (), (), ()) |]
            , [t| (Bool, (), Int8, ()) |]
            -- Container-ey types
            , [t| [Int8] |]
            , [t| [Int64] |]
            , [t| Seq Int8 |]
            , [t| Seq Int64 |]
            , [t| Set Int8 |]
            , [t| Set Int64 |]
            , [t| IntMap Int8 |]
            , [t| IntMap Int64 |]
            , [t| Map Int8 Int8 |]
            , [t| Map Int64 Int64 |]
            , [t| HashMap Int8 Int8 |]
            , [t| HashMap Int64 Int64 |]
            , [t| HashSet Int8 |]
            , [t| HashSet Int64 |]
            , [t| NE.NonEmpty Int8 |]
            , [t| NE.NonEmpty Int64 |]
            , [t| Tagged Int32 |]
            , [t| A.Array (Int, Integer) Integer |]
            , [t| A.UArray Char Bool |]
            ])
    it "Slices roundtrip" $ do
        assertRoundtrip False $ T.drop 3 $ T.take 3 "Hello world!"
        assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!"
        assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32)
        assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8)
        (return () :: IO ())
    it "StaticSize roundtrips" $ do
        let x :: StaticSize 17 BS.ByteString
            x = toStaticSizeEx (BS.replicate 17 255)
        unless (checkRoundtrip False x) $
            (fail "Failed to roundtrip StaticSize ByteString" :: IO ())
    it "Size of generic instance for single fieldless constructor is 0" $ do
        case size :: Size X of
            ConstSize 0 -> (return () :: IO ())
            _ -> fail "Empty datatype takes up space"
    it "Printing out polymorphic store instances" $ do
        putStrLn ""
        putStrLn "Not really a test - printing out known polymorphic store instances (which should all be tested above)"
        putStrLn ""
        mapM_ putStrLn
              $(do insts <- getAllInstanceTypes1 ''Store
                   lift $ map pprint $ filter (not . isMonoType) insts)
    it "Faulty implementations of size lead to PokeExceptions" $ do
        evaluate (encode (BadIdea 0)) `shouldThrow` isPokeException
        evaluate (encode (BadIdea2 0)) `shouldThrow` isPokeException
    it "Avoids reading data with a negative size" $ do
        let bs = encode (SV.fromList [1..10::Int])
            bs' = BS.concat [encode (-1 :: Int)
                            , BS.drop (sizeOf (10 :: Int)) bs
                            ]
        evaluate (decodeEx bs' :: SV.Vector Int) `shouldThrow` isNegativeBytesException
    it "Avoids overflow in bounds checks" $ do
        let bs = encode ("some random bytestring" :: BS.ByteString)
            bs' = BS.concat [encode (maxBound :: Int)
                            , BS.drop (sizeOf (10 :: Int)) bs
                            ]
        evaluate (decodeEx bs' :: BS.ByteString) `shouldThrow` isTooManyBytesException
    it "Handles unaligned access" $ do
        assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32)
        assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double)
        (return () :: IO ())
    it "Expects the right marker when deserializing ordered maps (#97)" $ do
        let m = mapFromList [(1, ()), (2, ()), (3, ())] :: HashMap Int ()
            bs = encode m
        (decodeEx bs :: HashMap Int ()) `shouldBe` m
        evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException
        evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException
    it "Expects decode of negative integer as a natural to throw PeekException" $ do
        evaluate (decodeEx (encode ((-5) :: Integer)) :: Natural)
            `shouldThrow` isNegativeNaturalException

isPokeException :: Test.Hspec.Selector PokeException
isPokeException = const True

isNegativeBytesException :: Test.Hspec.Selector PeekException
isNegativeBytesException (PeekException _ t) = "Attempted to read negative number of bytes" `T.isPrefixOf` t

isTooManyBytesException :: Test.Hspec.Selector PeekException
isTooManyBytesException (PeekException _ t) = "Attempted to read too many bytes" `T.isPrefixOf` t

isUnexpectedMarkerException :: Test.Hspec.Selector PeekException
isUnexpectedMarkerException (PeekException _ t) =
    "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t

isNegativeNaturalException :: Test.Hspec.Selector PeekException
isNegativeNaturalException (PeekException _ t) =
    "Encountered negative integer when expecting a Natural" `T.isPrefixOf` t

max_stars_repo_name: sjakobi/store

max_issues_repo_name: sjakobi/store

max_forks_repo_name: sjakobi/store


text:
{-# LANGUAGE NamedFieldPuns, TemplateHaskell #-}

module School.Unit.Test.LogSoftMax
( logSoftMaxTest ) where

import Control.Monad.IO.Class (liftIO)
import Numeric.LinearAlgebra ((><), size, toLists)
import School.TestUtils (diffInput, matIndexes, randomMatrix, randomMatrixL)
import School.Types.FloatEq ((~=))
import School.Unit.LogSoftMax
import School.Unit.Unit (Unit(..))
import School.Unit.UnitActivation (UnitActivation(..))
import School.Unit.UnitGradient (UnitGradient(..))
import School.Unit.UnitParams (UnitParams(..))
import School.Utils.LinearAlgebra (compareDoubleMatrix, oneMatrix)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck hiding ((><), scale)
import Test.Tasty.TH
import Test.QuickCheck.Monadic (assert, monadicIO, pre)

eps :: Double
eps = 1e-5

prec :: Double
prec = 1e-3

prop_norm_size :: (Positive Int) -> (Positive Int) -> Property
prop_norm_size (Positive bSize) (Positive fSize) = monadicIO $ do
  input <- liftIO $ BatchActivation <$> randomMatrix bSize fSize
  let (BatchActivation result) = apply logSoftMax EmptyParams input
  assert $ and . (map (<= prec)) . concat . toLists $ result

prop_norm_sum :: (Positive Int) -> (Positive Int) -> Property
prop_norm_sum (Positive bSize) (Positive fSize) = monadicIO $ do
  input <- liftIO $ BatchActivation <$> randomMatrix bSize fSize
  let (BatchActivation result) = apply logSoftMax EmptyParams input
  assert $ and
         . (map (~= 1))
         . (map (sum . (map exp)))
         . toLists
         $ result

prop_gradient_dims :: (Positive Int) -> Positive Int -> Property
prop_gradient_dims (Positive bSize) (Positive fSize) = monadicIO $ do
  input <- liftIO $ fmap BatchActivation $ randomMatrix bSize fSize
  gradIn <- liftIO $ fmap BatchGradient $ randomMatrix bSize fSize
  let (BatchGradient gradOut, _) = deriv logSoftMax EmptyParams gradIn input
  assert $ (size gradOut == (bSize, fSize))

prop_numerical_gradient :: (Positive Int) -> Positive Int -> Property
prop_numerical_gradient (Positive bSize) (Positive fSize) = monadicIO $ do
  pre $ bSize < 25 && fSize < 25
  input <- liftIO $ fmap BatchActivation $ randomMatrixL 5 bSize fSize
  let params = EmptyParams
  let idxs = matIndexes bSize fSize
  let num = map (\idx -> diffInput logSoftMax params input eps idx)
                idxs
  let numGrad = (bSize >< fSize) num
  let inGrad = BatchGradient $ oneMatrix bSize fSize
  let (BatchGradient result, _) = deriv logSoftMax params inGrad input
  assert $ compareDoubleMatrix prec result numGrad

logSoftMaxTest :: TestTree
logSoftMaxTest = $(testGroupGenerator)

ext: hs

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


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

module Utils where

import Data.Complex
import Data.IntMap.Strict
import Expression
import Hash
import Prelude hiding ((*), (+), lookup)

-- | Auxiliary functions for operations
--
expressionNumType :: (NumType rc) => Expression d rc -> RC
expressionNumType (Expression n mp) =
    case lookup n mp of
        Just (_, node) -> nodeNumType node
        _ -> error "expression not in map"

expressionShape :: (DimensionType d) => Expression d rc -> Shape
expressionShape (Expression n mp) =
    case lookup n mp of
        Just (dim, _) -> dim
        _ -> error "expression not in map"

retrieveNode :: ExpressionMap -> Int -> Node
retrieveNode mp n =
    case lookup n mp of
        Just (_, node) -> node
        _ -> error "node not in map"

ensureSameShape :: (Ring d rc) => Expression d rc -> Expression d rc -> a -> a
ensureSameShape e1 e2 after =
    if expressionShape e1 == expressionShape e2
        then after
        else error "Ensure same shape failed"

fromReal :: Double -> Complex Double
fromReal x = x :+ 0

max_stars_repo_name: dandoh/NeatExpression

max_issues_repo_name: dandoh/NeatExpression

max_forks_repo_name: dandoh/NeatExpression


text:
module LeastSquares
    ( VarName
    , LinExpr(..)
    , LinContr(..)
    , QuadExpr(..)
    , minimize
    ) where

import Data.List (elemIndex, foldl1')
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust)
import qualified Data.Set as S
import Numeric.LinearAlgebra

type VarName = String

type CanonicalMap = M.Map VarName (Matrix R)

infix 4 :==:

data LinExpr = Var VarName Int
             | Coeff R
             | Vec (Vector R)
             | Mat (Matrix R)
             | Neg LinExpr
             | Sum LinExpr LinExpr
             | Prod LinExpr LinExpr
             deriving (Show, Eq)

instance Num LinExpr where
    (+) = Sum
    a - b = Sum a (Neg b)
    (*) = Prod
    negate = Neg
    signum = undefined
    abs = undefined
    fromInteger a = Coeff (fromInteger a)

data LinContr = LinExpr :==: LinExpr

data QuadExpr = SumSquares LinExpr
              | CoeffQuad R
              | ProdQuad QuadExpr QuadExpr
              | SumQuad QuadExpr QuadExpr

instance Num QuadExpr where
    (+) = SumQuad
    (*) = ProdQuad
    (-) = undefined
    negate = undefined
    signum = undefined
    abs = undefined
    fromInteger a = CoeffQuad (fromInteger a)

class CanonExpr e  where
    varSet :: e -> S.Set (VarName, Int)
    canonicalize :: e -> CanonicalMap

-- Canonicalize a generic expression
-- The vector is stored as a column matrix under the variable "".
instance CanonExpr LinExpr where
    varSet (Var v s) = S.singleton (v, s)
    varSet (Coeff _) = S.empty
    varSet (Vec _) = S.empty
    varSet (Mat _) = S.empty
    varSet (Neg e) = varSet e
    varSet (Prod _ e) = varSet e
    varSet (Sum e1 e2) = varSet e1 `S.union` varSet e2
    canonicalize (Var v s) = M.singleton v (ident s)
    canonicalize (Vec v) = M.singleton "" (asColumn v)
    canonicalize (Neg e) = M.map negate $ canonicalize e
    canonicalize (Prod (Coeff c) e) = M.map (scale c) $ canonicalize e
    canonicalize (Prod (Mat m) e) = M.map (m <>) $ canonicalize e
    canonicalize (Sum e1 e2) =
        M.unionWith (+) (canonicalize e1) (canonicalize e2)
    canonicalize _ = error "Expression is not well-formed"

-- Canonicalize an expression in the constraint
instance CanonExpr LinContr where
    varSet (e1 :==: e2) = varSet e1 `S.union` varSet e2
    canonicalize (e1 :==: e2) = canonicalize (e1 - e2)

-- Canonicalize an expression in the objective, which consists of SumSquares.
instance CanonExpr QuadExpr where
    varSet (SumSquares e) = varSet e
    varSet (CoeffQuad _) = S.empty
    varSet (ProdQuad _ e) = varSet e
    varSet (SumQuad e1 e2) = varSet e1 `S.union` varSet e2
    canonicalize (SumSquares e) = canonicalize e
    canonicalize (ProdQuad (CoeffQuad c) e) =
        M.map (scale (sqrt c)) $ canonicalize e
    canonicalize (SumQuad e1 e2) = canonicalize e1 `vstack` canonicalize e2
    canonicalize _ = error "Expression is not well-formed"

-- Combine two canonical maps by stacking one on top of another.
vstack :: CanonicalMap -> CanonicalMap -> CanonicalMap
vstack m1 m2 = M.fromSet combine (M.keysSet m1 `S.union` M.keysSet m2)
  where
    combine k = lookupDefault k m1 === lookupDefault k m2
    lookupDefault k m = M.findWithDefault (konst 0 (firstDim m, 1)) k m
    firstDim = rows . snd . fromJust . M.lookupGE "" :: CanonicalMap -> Int

minimize :: QuadExpr -> [LinContr] -> M.Map VarName (Vector R)
minimize obj [] = unpack vars $ a <\> (-b)
  where
    (a,b) = pack vars . canonicalize $ obj
    vars = varSet obj
minimize obj constraints = unpack vars $ mat <\> (-vec)
  where
    mat = fromBlocks [[2 * tr a <> a, tr c], [c, 0]]
    vec = vjoin [2 * tr a #> b, d]
    (a,b) = pack vars . canonicalize $ obj
    (c,d) = pack vars $ foldl1' vstack cds
    cds = map canonicalize constraints
    vars = varSet obj `S.union` S.unions (map varSet constraints)

pack :: S.Set (VarName, Int) -> CanonicalMap -> (Matrix R, Vector R)
pack vars m = (a, b)
  where
    a = fromBlocks [map getCoefficient (S.toAscList vars)]
    b = flatten $ M.findWithDefault (konst 0 (rows a, 1)) "" m
    getCoefficient (varName,s) = M.findWithDefault (konst 0 (s, s)) varName m

-- The vector given to unpack might be longer than the total size of the
-- variables. It might contain the dual variable values, for example.
unpack :: S.Set (VarName, Int) -> Vector R -> M.Map VarName (Vector R)
unpack vars result = M.fromList $ zip varNames coefficients
  where
    coefficients = map getCoefficient varList
    getCoefficient (varName,s) = subVector (startIndex varName) s result
    startIndex varName = cumsum !! fromJust (elemIndex varName varNames)
    cumsum = scanl (+) 0 varSizes
    (varNames,varSizes) = unzip varList
    varList = S.toAscList vars

max_stars_repo_name: tridao/leastsquares

max_issues_repo_name: tridao/leastsquares

max_forks_repo_name: tridao/leastsquares


text:
{-|
Module      : HABQTlib.UnsafeAPI

This module contains functions for performing and simulating HABQT in Haskell.

__Caution__: functions in this module perform no input validation and are partial. For a safe API refer to "HABQTlib".
-}
module HABQTlib.UnsafeAPI where

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Control.Monad.State.Lazy
import Data.Maybe (fromJust)
import qualified Data.Vector as V
import HABQTlib.Data
import HABQTlib.Data.Particle
import HABQTlib.MeasurementProcessing
import HABQTlib.RandomStates
import qualified Numeric.LinearAlgebra as LA
import Streaming
import qualified Streaming.Prelude as S
import qualified System.Random.MWC as MWC
import Text.Printf (printf)

-- | Tomography keeps track of the particle hierarchy and list of previous
-- measurement results, IO is used for verbose output and assorted random state
-- generation.
type TomState = StateT (ParticleHierarchy, [PureStateVector]) IO

-- | Tomography function takes a measurement result and returns state-dependent
-- Bayesian mean estimate of state and the optimal next POVM to perform.
type TomFun = PureStateVector -> TomState (DensityMatrix, PurePOVM)

-- | Given parameters such as output verbosity level and number of quantum
-- bits, set up the tomography function.
tomographyFun' ::
     QBitNum -- ^ Number of quantum bits under tomography
  -> MHMCiter -- ^ Number of MHMC iterations to perform when resampling
  -> OptIter -- ^ Number of POVM optimisation steps to perform
  -> OutputVerb -- ^ Verbosity of stdout output
  -> MWC.GenIO -- ^ IO generator for variates from "System.Random.MWC"
  -> TomFun
tomographyFun' nq mi oi outv gen nextResult = do
  (ph, ms) <- get
  let nextPH = updateParticleHierarchy nextResult ph
      dim = LA.rows . getStateVector $ nextResult
      effectiveSizes =
        V.map (liftA2 (/) effectiveSize (fromIntegral . ptsNumber)) nextPH
      ra = ResampleArgs outv gen dim mi
      resampleC es pts =
        if es < 0.5
          then resample ra (nextResult : ms) pts
          else return pts
  nextPH' <- lift $ V.zipWithM resampleC effectiveSizes nextPH
  sv0s <- liftIO $ replicateM nq (genPureSV 2)
  let nextEstimate = getMixedEstimate nextPH'
      nextPOVM = optimiseSingleQbPOVM oi sv0s nextPH'
  put (nextPH', nextResult : ms)
  return (nextEstimate, nextPOVM)

-- | Given a true state's density matrix and parameters, set up a simulation of
-- quantum tomography that outputs infidelity between mean estimates and true
-- state.
simulatedTomography' ::
     DensityMatrix -- ^ True state's density matrix
  -> QBitNum -- ^ Number of quantum bits under tomography
  -> MHMCiter -- ^ Number of MHMC iterations to perform when resampling
  -> OptIter -- ^ Number of POVM optimisation steps to perform
  -> OutputVerb -- ^ Verbosity of stdout output
  -> MWC.GenIO -- ^ IO generator for variates from "System.Random.MWC"
  -> StateT PurePOVM TomState Double
simulatedTomography' trueDM nq mi oi outv gen = do
  povm <- get
  nextResult <- liftIO $ simulateMeasuremet trueDM povm gen
  (nextEstimate, nextPOVM) <- lift $ tomographyFun' nq mi oi outv gen nextResult
  (nextPH, _) <- lift get
  put nextPOVM
  let fid = fidelityDM trueDM nextEstimate
  when (outv > NoOutput) . liftIO $ do
    let dim = 2 ^ nq
        rankFids =
          V.map
            (fidelityDM trueDM . snd . getWDM . reduceParticlesToMean)
            nextPH
        weightsAndFids =
          V.zip3 (V.enumFromN (1 :: Rank) dim) (V.map ptsWeight nextPH) rankFids
    putStrLn ""
    V.mapM_
      (\(a, b, c) ->
         printf "(Rank: %4d, Weight: %10.9f, Fidelity: %10.9f)\n" a b c)
      weightsAndFids
  return $ 1 - fid

-- | Stream simulated tomography results.
streamResults' ::
     QBitNum -- ^ Number of quantum bits under tomography
  -> Rank -- ^ Rank of true state
  -> NumberOfParticles -- ^ Number of particles (per rank) to use for tomography
  -> MHMCiter -- ^ Number of MHMC iterations to perform when resampling
  -> OptIter -- ^ Number of POVM optimisation steps to perform
  -> OutputVerb -- ^ Verbosity of stdout output
  -> Stream (Of Double) IO ()
streamResults' nq rank pn mi oi outv = do
  let dim = 2 ^ nq
  trueDM <- liftIO $ genDM dim rank
  ph <- liftIO $ initialiseParticleHierarchy dim pn
  gen <- liftIO MWC.createSystemRandom
  rPOVM <-
    liftIO $
    productPOVM <$>
    replicateM nq (mkAntipodalPOVM . fromJust . svToAngles <$> genPureSV 2)
  let tomS = S.repeatM (simulatedTomography' trueDM nq mi oi outv gen)
      tomS' = evalStateT (distribute tomS) rPOVM
      initInfid = 1 - fidelityDM trueDM (getMixedEstimate ph)
  S.yield initInfid
  evalStateT (distribute tomS') (ph, [])

max_stars_repo_name: Belinsky-L-V/HABQT

max_issues_repo_name: Belinsky-L-V/HABQT

max_forks_repo_name: Belinsky-L-V/HABQT


text:
module Statistics.Information.Mixed.TotalCorrelation where

import Data.Matrix
import qualified Statistics.Information.Continuous.Entropy as CE
import Statistics.Information.Continuous.MutualInfo
import qualified Statistics.Information.Continuous.TotalCorrelation as CTC
import qualified Statistics.Information.Discrete.Entropy as DE
import qualified Statistics.Information.Discrete.TotalCorrelation as DTC
import Statistics.Information.Mixed.Entropy
import Statistics.Information.Mixed.MutualInfo
import Statistics.Information.Utils.Matrix
import Statistics.Information.Utils.Random
import System.Random

ctcdc :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix a -> Matrix Double ->
         Double
ctcdc g k base xs ys = sum hxs - hx where
  hxs = [centropydc gcol k base col ys | (col, gcol) <- cols]
  hx = centropydc g2 k base xs ys
  (g1, g2) = split g
  cols = (map colVector (columns xs)) `zip` (splitN (ncols xs) g1)

ctccd :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix Double -> Matrix a ->
         Double
ctccd g k base xs ys = sum hxs - hx where
  hxs = [centropycd gcol k base col ys | (col, gcol) <- cols]
  hx = centropycd g2 k base xs ys
  (g1, g2) = split g
  cols = (map colVector (columns xs)) `zip` (splitN (ncols xs) g1)

corexcd_tcs :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix Double ->
               Matrix a -> Double
corexcd_tcs g k base xs ys = CTC.tc g1 k base xs - ctccd g2 k base xs ys where
  (g1, g2) = split g

corexcd_mis :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix Double ->
               Matrix a -> Double
corexcd_mis g k base xs ys = sum mixs - mi_all where
  mixs = [micd gcol k base col ys | (col, gcol) <- cols]
  mi_all = micd g2 k base xs ys
  (g1, g2) = split g
  cols = (map colVector (columns xs)) `zip` (splitN (ncols xs) g1)

corexdc_tcs :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix a ->
               Matrix Double -> Double
corexdc_tcs g k base xs ys = DTC.tc base xs - ctcdc g k base xs ys

corexdc_mis :: (RandomGen g, Eq a) => g -> Int -> Int -> Matrix a ->
               Matrix Double -> Double
corexdc_mis g k base xs ys = sum mixs - mi_all where
  mixs = [midc gcol k base col ys | (col, gcol) <- cols]
  mi_all = midc g2 k base xs ys
  (g1, g2) = split g
  cols = (map colVector (columns xs)) `zip` (splitN (ncols xs) g1)

max_stars_repo_name: eligottlieb/Shannon

max_issues_repo_name: eligottlieb/Shannon

max_forks_repo_name: eligottlieb/Shannon


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Marvin.API.Algorithms.LinearRegression (
  LinearRegression (..)
  , defaultLinearRegression

  , LinearRegressionModel
  , coefficients
  , intercept
) where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.HMatrix

import qualified Marvin.API.Algorithms.Internal.GradientDescent as GD
import Marvin.API.Algorithms.Internal.GradientDescent hiding (learningRate, lambda, addIntercept)

import Marvin.API.Meta.Model
import Marvin.API.Table.DataType
import Marvin.API.Table.Internal
import Marvin.API.Fallible

import Control.Arrow
import Control.Monad.Except
import qualified Data.Vector as Vec

-- * Parameters

-- | Parameters.
data LinearRegression = LinearRegression {
  learningRate :: Double -- ^ Coefficient of the gradient when updating the model.
  , numberOfIterations :: Int -- ^ Number of iterations.
  , lambda :: Double -- ^ Regularization coefficient.
  , addIntercept :: Bool -- ^ Whether to add a constant 1 column before training.
}

-- | Default parameters.
defaultLinearRegression = LinearRegression {
  learningRate = 0.001
  , numberOfIterations = 10
  , lambda = 0.1
  , addIntercept = True
}

toGradDesc :: LinearRegression -> GradientDescent
toGradDesc linReg = defaultGradientDescent {
  numIter = numberOfIterations linReg
  , GD.cost = linearRegressionCost
  , GD.learningRate = learningRate linReg
  , GD.addIntercept = addIntercept linReg
  , GD.lambda = lambda linReg
}

-- * Model

-- | Resulting model.
newtype LinearRegressionModel = LinRegModel LinearModel

-- | Retrieves a list of the coefficient.
coefficients :: LinearRegressionModel -> [Double]
coefficients (LinRegModel linearModel) = LA.toList $ coefs linearModel

-- | Retrieves the constant to be added.
intercept :: LinearRegressionModel -> Double
intercept (LinRegModel linearModel) = intercept_ linearModel

instance Show LinearRegressionModel where
  show (LinRegModel linear) = "Linear regression model:\n\n" ++ show linear

instance Estimator LinearRegression (NumericTable, NumericColumn) where
  type ResultingModel LinearRegression (NumericTable, NumericColumn) =
    LinearRegressionModel
  fit linReg (train, target) = do
    ensurePositive
      (InvalidAlgorithmParameter "LinearRegression" "numberOfIterations must be positive")
        $ numberOfIterations linReg
    ensurePositive
      (InvalidAlgorithmParameter "LinearRegression" "learning rate must be positive")
        $ learningRate linReg
    ensureNonNegative
      (InvalidAlgorithmParameter "LinearRegression" "lambda must be non-negative")
        $ lambda linReg
    ensureTableColSizeMatch "while training linear regression" train target
    let linearModel = fit' (toGradDesc linReg) (train, target)
    return $ LinRegModel linearModel

instance Predictor LinearRegressionModel where
  type Testing LinearRegressionModel = NumericTable
  type Prediction LinearRegressionModel = NumericColumn
  predict (LinRegModel model) = predict' model

unsafeFit :: LinearRegression -> FeatureMatrix -> TargetVariable -> ModelParameters
unsafeFit linReg = gradientDescent (toGradDesc linReg)

max_stars_repo_name: gaborhermann/marvin

max_issues_repo_name: gaborhermann/marvin

max_forks_repo_name: gaborhermann/marvin


text:
{-|
  Mapping of basic Matlab types to Haskell types.
-}
module Foreign.Matlab.Types (
    -- * Representations of Matlab types
    -- |Most types are simple aliases of Haskell types, given simply to identify them and provide a consistent naming scheme.

    MIO,

    MXClass(..),
    MChar,
    MLogical,
    MScalar,

    MNumeric,
    -- * Numeric types
    MDouble,
    MSingle,
    MInt8,
    MInt16,
    MInt32,
    MInt64,
    MUint8,
    MUint16,
    MUint32,
    MUint64,
    MComplex,

    -- * Array indexing
    MSize, MSubs,
    MIndex(..),
    mStart, mOffset,
    mSizeRange, mRangeSize,
    normMSize, realMSize,

    -- * Opaque types
    MXArray,
    MAny, MAnyArray,
    MCell(MCell), mCell,
    MStruct, mStruct,
    MFun
  ) where

import Data.Complex
import Data.Ix
import Foreign.Matlab.Internal

-- |The class of types which are simple Matlab scalars and can be array elements
class MScalar a
-- |The class of types which Matlab consisters \"numeric\"
class (MScalar a, Num a) => MNumeric a

instance MScalar MChar
instance MScalar MLogical
instance MScalar MDouble
instance MScalar MSingle
instance MScalar MInt8
instance MScalar MInt16
instance MScalar MInt32
instance MScalar MInt64
instance MScalar MUint8
instance MScalar MUint16
instance MScalar MUint32
instance MScalar MUint64
instance MNumeric a => MScalar (MComplex a)

instance MNumeric MDouble
instance MNumeric MSingle
instance MNumeric MInt8
instance MNumeric MInt16
instance MNumeric MInt32
instance MNumeric MInt64
instance MNumeric MUint8
instance MNumeric MUint16
instance MNumeric MUint32
instance MNumeric MUint64

-- |Complex numeric types.  Unfortunately, 'Complex' only applies to 'RealFloat' types, whereas Matlab allows any numeric type, so some types are (currently) unaccessable.
type MComplex = Complex

-- |The type of array sizes, which are the column-major lengths of each dimensions
type MSize = [Int]
-- |The type of array index subscripts, which are the column-major, 0-based indices in each dimension with normal Matlab semantics (flatten along last dimension)
type MSubs = [Int]
-- |Ways to index an array.  Using Matlab semantics, a singleton MSubs [n] is equivalent to a raw 0-based offset (MOffset n).
newtype MIndex = MSubs MSubs
    -- MOffset Int -- ^0-based offset from the beginning of the array (equivalent to singleton MSubs)

-- |First index in array
mStart :: MIndex
mStart = MSubs []

-- |Raw, 0-based array offset index
mOffset :: Int -> MIndex
mOffset i = MSubs [i]

instance Show MIndex where
  showsPrec _ (MSubs []) = id
  showsPrec _ (MSubs l) = showChar '(' . foldr1 (\s r -> s . showChar ',' . r) (map shows l) . showChar ')'
instance Eq MIndex where
  MSubs a == MSubs b = eq a b where
    eq [] [] = True
    eq (x:a) (y:b) = (x == y) && eq a b
    eq [] b = eq [0] b
    eq a [] = eq a [0]
instance Ord MIndex where
  compare (MSubs a) (MSubs b) = cmp a b where
    cmp [] [] = EQ
    cmp (x:a) (y:b) = case cmp a b of { EQ -> compare x y ; r -> r }
    cmp [] b = cmp [0] b
    cmp a [] = cmp a [0]
instance Ix MIndex where
  range (MSubs a, MSubs b) = map MSubs $ rng a b where
    rng [] [] = [[]]
    rng (x:a) (y:b) = concatMap (\l -> map (:l) [x..y]) $ rng a b
    rng [] b = rng [0] b
    rng _ _ = error "MIndex.range: length mismatch"
  index (MSubs a, MSubs b) (MSubs l) = idx a b l where
    idx _ _ [] = 0
    idx (x:a) (y:b) (i:l) = i-x+((y-x+1)*idx a b l)
    idx [] [] (0:l) = idx [] [] l
    idx [] b l = idx [0] b l
    idx _ _ _ = error "MIndex.index: length mismatch"
  inRange (MSubs a, MSubs b) (MSubs l) = inr a b l where
    inr _ _ [] = True
    inr a@(x:_) b@(_:_) [i] = i >= x && i-x < rangeSize (MSubs a, MSubs b)
    inr (x:a) (y:b) (i:l) = i >= x && i <= y && inr a b l
    inr [] [] (0:l) = inr [] [] l
    inr [] b l = inr [0] b l
    inr _ _ _ = error "MIndex.inRange: length mismatch"
  rangeSize (MSubs a, MSubs b) = rsz a b where
    rsz [] b = product $ map succ b
    rsz (x:a) (y:b) = (y-x+1)*rsz a b
    rsz _ _ = error "MIndex.rangeSize: length mismatch"

-- |Convert an array size to an index range, which will be of the form ((0,0,0...),(i-1,j-1,k-1,...))
mSizeRange :: MSize -> (MIndex,MIndex)
mSizeRange l = (MSubs [], MSubs $ map pred $ normMSize l)

-- |Convert an index range to an array size
mRangeSize :: (MIndex,MIndex) -> MSize
mRangeSize (MSubs [], MSubs l) = map succ l
mRangeSize _ = error "mRangeSize: invalid lower bound"

-- |Get the size form that Matlab likes (@length (realMSize s) >= 2@)
realMSize :: MSize -> MSize
realMSize [] = [1,1]
realMSize [n] = [n,1]
realMSize s = s

-- |Get a more useful size form (no trailing singletons)
normMSize :: MSize -> MSize
normMSize [] = []
normMSize (1:l) = case normMSize l of { [] -> [] ; l -> (1:l) }
normMSize (x:l) = x : normMSize l

max_stars_repo_name: CornellCAC/haskell-matlab

max_issues_repo_name: CornellCAC/haskell-matlab

max_forks_repo_name: CornellCAC/haskell-matlab


text:
-- |
-- Module      : BattleHack.Types
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Types where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import qualified Data.Set as S
import qualified Data.Map as M
import Sound.OpenAL

--------------------------------------------------------------------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
type Number = Double
type Vector = Complex Number
type Sample = Double

-- |
type Command = IO ()
type KeyMap  = M.Map String Command

-- |
data KeyLayout = KeyLeft | KeyRight | KeyBoth | KeyAccidental deriving (Show)

-- |
type Claviature = [(Source, Buffer)]

-- |
-- data Note = C Pitch | D Pitch | E Pitch | F Pitch | G Pitch | A Pitch | B Pitch deriving (Show)
-- data Pitch = Sharp | Flat | Natural                                             deriving (Show)

-- |
-- frame number, fps, etc.
data AnimationData = AnimationData { _frame :: Int,
                                     _fps   :: Int }

-- |
-- TODO: Slightly less confusing names (piano vs claviature)
data AppState = AppState { _piano      :: PianoSettings,
                          --  _claviature :: Claviature,
                          --  _source     :: Source,
                           _animation  :: AnimationData,
                           _bindings   :: KeyMap,
                           _inputstate :: InputState } -- deriving (Show)

-- |
-- TODO: Use custom key type or text (?)
data InputState =  InputState { _mouse    :: Vector,
                                _keyboard :: S.Set String }

-- |
data PianoSettings = PianoSettings { _origin  :: Vector,
                                     _keysize :: Vector,
                                     _indent  :: Number,
                                     _mid     :: Number,
                                     _active  :: Maybe Int,
                                     _keys    :: [Bool] } deriving (Show)


text:
-- {-# LANGUAGE AllowAmbiguousTypes                      #-}
{-# LANGUAGE BangPatterns                             #-}
{-# LANGUAGE DataKinds                                #-}
{-# LANGUAGE DeriveGeneric                            #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE FlexibleInstances                        #-}
{-# LANGUAGE GADTs                                    #-}
{-# LANGUAGE LambdaCase                               #-}
{-# LANGUAGE PartialTypeSignatures                    #-}
{-# LANGUAGE PatternSynonyms                          #-}
{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TupleSections                            #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeOperators                            #-}
{-# LANGUAGE ViewPatterns                             #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns              #-}
{-# OPTIONS_GHC -Wno-orphans                          #-}
{-# OPTIONS_GHC -Wno-unused-top-binds                 #-}
{-# OPTIONS_GHC -fno-warn-orphans                     #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures     #-}
{-# OPTIONS_GHC -fwarn-redundant-constraints          #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver    #-}
-- {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-- {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}

module Main where
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.State
import           Data.Bitraversable
import           Data.Foldable
import           Data.IDX
import           Data.List.Split
import           Data.Maybe
import           Data.Proxy
import           Data.Time.Clock
import           Data.Traversable
import           Data.Tuple
import           GHC.Generics                        (Generic)
import           GHC.TypeLits
import           GHC.TypeLits.Extra
import           Lens.Micro                          hiding ((&))
import           Mnist.Internal.Convolution
import           Numeric.Backprop                    hiding ((:&))
import           Numeric.LinearAlgebra.Static.Backprop                          -- hmatrix-backprop
import           Numeric.LinearAlgebra.Static.Vector (vecL, vecR, lVec, rVec)
import           Numeric.OneLiner
import           Text.Printf
import qualified Data.Vector                         as V
import qualified Data.Vector.Generic                 as VG
import qualified Data.Vector.Storable.Sized          as SVS
import qualified Data.Vector.Unboxed                 as VU
import qualified Numeric.LinearAlgebra               as HM  -- non-backprop hmatrix
import qualified Numeric.LinearAlgebra.Data          as HMD
import qualified Numeric.LinearAlgebra.Static        as HMS -- hmatrix with type-checked operations :D
import qualified System.Random.MWC                   as MWC
import qualified System.Random.MWC.Distributions     as MWC
import Debug.Trace

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

-- Custom data type for a tuple with strict values
data a :& b = !a :& !b
  deriving (Show, Generic)
infixr 2 :&

-- Do we actually need this? BVar already defines a similar instance
instance (NFData a, NFData b) => NFData (a :& b)
  where rnf (a :& b) = force a `seq` force b `seq` ()

instance (Num a, Num b) => Num (a :& b) where
    (+)         = gPlus
    (-)         = gMinus
    (*)         = gTimes
    negate      = gNegate
    abs         = gAbs
    signum      = gSignum
    fromInteger = gFromInteger

instance (Fractional a, Fractional b) => Fractional (a :& b) where
    (/) = gDivide
    recip = gRecip
    fromRational = gFromRational

instance (Backprop a, Backprop b) => Backprop (a :& b)

instance (MWC.Variate a, MWC.Variate b, Num a, Num b) => MWC.Variate (a :& b) where
    uniform g = (:&) <$> MWC.uniform g <*> MWC.uniform g
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

instance KnownNat n => MWC.Variate (R n) where
    uniform g = HMS.randomVector <$> MWC.uniform g <*> pure HMS.Uniform
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

instance (KnownNat m, KnownNat n) => MWC.Variate (L m n) where
    uniform g = HMS.uniformSample <$> MWC.uniform g <*> pure 0 <*> pure 1
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

-- So if we have a BVar z (a :& b) (a BVar containing a tuple), then matching on (x :&& y) will give us x :: BVar z a and y :: BVar z b.
pattern (:&&) :: (Backprop a, Backprop b, Reifies z W)
              => BVar z a -> BVar z b -> BVar z (a :& b)
pattern x :&& y <- (\xy -> (xy ^^. t1, xy ^^. t2)->(x, y))
  where
    (:&&) = isoVar2 (:&) (\case x :& y -> (x, y))
{-# COMPLETE (:&&) #-}

-- Just some lenses to help us get BVars out of the tuple
t1 :: Lens (a :& b) (a' :& b) a a'
t1 f (x :& y) = (:& y) <$> f x
{-# INLINE t1 #-}

t2 :: Lens (a :& b) (a :& b') b b'
t2 f (x :& y) = (x :&) <$> f y
{-# INLINE t2 #-}

feedForward
    :: (KnownNat i, KnownNat o)
    => Model (L o i :& R o) (R i) (R o)
feedForward (w :&& b) x = w #> x + b
{-# INLINE feedForward #-}

convolution
  :: ( KnownNat kernelSize
     , KnownNat filters
     , KnownNat stride
     , KnownNat inputRows
     , KnownNat inputCols
     , KnownNat (kernelSize * kernelSize * channels)
     , KnownNat (inputRows * channels)
     , KnownNat (((Div (inputRows - filters) stride) + 1) * filters)
     , KnownNat (((Div (inputCols - filters) stride) + 1))
     )
     -- | These proxies introduce type variables into the scope
     --   so GHC can do type level arithmetic to infer the Model types
     -- | Example: convolution (Proxy @3) (Proxy @12) (Proxy @1) (Proxy @28) (Proxy @28) (Proxy @1)
     --   will return a function of type Model (L 9 12) (L 28 28) (L 204 17)
     => Proxy kernelSize
     -> Proxy filters
     -> Proxy stride
     -> Proxy inputRows
     -> Proxy inputCols
     -> Proxy channels
     -> Model
        (L (kernelSize * kernelSize * channels) filters) -- TODO: Add bias
        (L (inputRows * channels) inputCols)
        (L (((Div (inputRows - filters) stride) + 1) * filters) ((Div (inputCols - filters) stride) + 1))
convolution k' fs' st' ix' iy' cs' =
  liftOp2 . op2 $ \kernel input ->

    -- natVal "reflects" the type level Nat into a term level Int.
    -- Example: for ix' (input rows) this works because we told the type checker that the function argument ix' is a Proxy of a type
    -- that has a KnownNat constraint. So the type level Nat is brought into scope when we pass Proxy @28 (which is sugar for Proxy :: Proxy 28)
    -- Hyperparameters as types. Neat.
    let ix = fromIntegral $ natVal ix'
        iy = fromIntegral $ natVal iy'
        kx = fromIntegral $ natVal k'
        ky = fromIntegral $ natVal k'
        sx = fromIntegral $ natVal st'
        sy = fromIntegral $ natVal st'
        ox = ((ix - (fromIntegral $ natVal fs')) `div` sx) + 1
        oy = ((iy - (fromIntegral $ natVal fs')) `div` sx) + 1
        ex = HMS.extract input
        ek = HMS.extract kernel

        -- Transform the 3D input matrix into a (W*H, K*K*D) matrix
        c  = vid2col kx ky sx sy ix iy ex
    in

    (
      -- FORWARD PASS
      -- This is the actual "convolution"
      let mt = c HM.<> ek
          -- Stretch the image back to the output dimensions
          r  = col2vid 1 1 1 1 ox oy mt
      in
          fromJust . HMS.create $ r

    , -- BACKWARD PASS (see backprop ops for more info)
      \dzdy ->
        let eo = HMS.extract dzdy

            -- what is this actually doing?
            -- should be taking output from forward pass and reshaping it
            -- so we can do convolutions via matrix mult
            vs = vid2col 1 1 1 1 ox oy eo

            -- TODO: Gradient for weights -- I cannot get this to work -- WHY?
            -- It currently only works when filters === kernelSize -- wat
            dW = HM.tr c HM.<> vs

            -- Gradient for input -- This seems to work fine
            -- convolve (via matrix mult) output with transposed weights matrix http://soumith.ch/ex/pages/2014/08/07/why-rotate-weights-convolution-gradient/
            dX' = vs HM.<> HM.tr ek
            dX = col2vid kx ky sx sy ix iy dX' -- stretch back into image dimensions
        in
            -- trace ("convolution backwards") (fromJust . HMS.create $ dW, fromJust . HMS.create $ dX)
            (fromJust . HMS.create $ dW, fromJust . HMS.create $ dX)
    )
{-# INLINE convolution #-}

flattenLayer :: (KnownNat o, KnownNat i, KnownNat (o * i), Reifies s W) => BVar s (L o i) -> BVar s (R (o * i))
flattenLayer = liftOp1 . op1 $ \input ->
  (
    let ex = HMS.extract input
        flattened = HMD.flatten ex
        result = fromJust . HMS.create $ flattened
      in
        -- trace "flatten forwards" result
        result
  ,
    \dzdy ->
      let ex = HMS.extract dzdy
          ei = HMS.extract input
        in
          -- trace ("flatten backwards") fromJust . HMS.create $ HMD.reshape (HMD.cols ei) ex
          fromJust . HMS.create $ HMD.reshape (HMD.cols ei) ex
  )
{-# INLINE flattenLayer #-}

-- TODO Add type annotation?
convLayer k fs st ix io cs p = vmap reLU . flattenLayer . convolution k fs st ix io cs p
{-# INLINE convLayer #-}

logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))
{-# INLINE logistic #-}

feedForwardLog
    :: (KnownNat i, KnownNat o)
    => Model (L o i :& R o) (R i) (R o)
feedForwardLog wb = logistic . feedForward wb
{-# INLINE feedForwardLog #-}

reLU :: (Num a, Ord a) => a -> a
reLU x | x < 0     = 0
       | otherwise = x
{-# INLINE reLU #-}

feedForwardReLU
    :: (KnownNat i, KnownNat o)
    => Model (L o i :& R o) (R i) (R o)
feedForwardReLU wb = vmap reLU . feedForward wb
{-# INLINE feedForwardReLU #-}

softMax :: (KnownNat n, Reifies s W) => BVar s (R n) -> BVar s (R n)
softMax x = konst (1 / sumElements expx) * expx
   where
      expx = exp x
{-# INLINE softMax #-}

feedForwardSoftMax
    :: (KnownNat i, KnownNat o)
    => Model (L o i :& R o) (R i) (R o)
feedForwardSoftMax wb = softMax . feedForward wb
{-# INLINE feedForwardSoftMax #-}

crossEntropy
   :: (KnownNat n, Reifies s W)
   => R n
   -> BVar s (R n)
   -> BVar s Double
crossEntropy !targ !res = -(log res <.> constVar targ)
{-# INLINE crossEntropy #-}

netErr
   :: forall m n o p s. (KnownNat o, Reifies s W)
   => Model p (L m n) (R o)
   -> L m n
   -> R o
   -> BVar s p
   -> BVar s Double
netErr f !x !targ !p = crossEntropy targ $ f p $ auto x
{-# INLINE netErr #-}

trainModel
   :: forall m n o p. (KnownNat o, Backprop p, Fractional p)
   => Double                -- ^ learning rate
   -> Model p (L m n) (R o)
   -> p                     -- ^ initial params
   -> [(L m n, R o)]        -- ^ input and target pairs
   -> p                     -- ^ trained params
trainModel r f = foldl' (\p (x,y) -> p - realToFrac r * gradBP (netErr f x y) p)
{-# INLINE trainModel #-}

testNet
   :: forall m n o p. (KnownNat o)
   => Model p (L m n) (R o)
   -> p
   -> [(L m n, R o)]
   -> Double
testNet f !p !xs = sum (map (uncurry test) xs) / fromIntegral (length xs)
   where
      test :: L m n -> R o -> Double -- test if the max index is correct
      -- second argument here is using ViewPatterns extension of GHC
      test x (HMS.extract->t)
         | HM.maxIndex t == HM.maxIndex (HMS.extract r) = 1
         | otherwise                                    = 0
         where
            r :: R o
            r = evalBP2 f p x

-- Given two Models, we can define the composition of them both
-- as long as their input/output shapes match
(<~)
    :: (Backprop p, Backprop q)
    => Model  p       b c
    -> Model       q  a b
    -> Model (p :& q) a c
(f <~ g) (p :&& q) = f p . g q
infixr 8 <~
{-# INLINE (<~) #-}

-- The type wildcard here means GHC should infer the type of the model params
-- We could define it but then we'd have to update it manually every time we add a new "layer" here
-- Each layer's parameters (weights + bias) are tupled together so we can pattern match on them (see <~ operator above)
model :: Model _ (L 28 28) (R 10)
model =
   feedForwardSoftMax @100 @10
   <~ feedForwardLog @500 @100
   <~ feedForwardLog @2028 @500
   <~ convLayer (Proxy @3) (Proxy @3) (Proxy @1) (Proxy @28) (Proxy @28) (Proxy @1)
{-# INLINE model #-}

main :: IO ()
main = MWC.withSystemRandom $ \g -> do
   Just train <- loadMNIST "data/train-images-idx3-ubyte" "data/train-labels-idx1-ubyte"
   Just test  <- loadMNIST "data/t10k-images-idx3-ubyte"  "data/t10k-labels-idx1-ubyte"
   putStrLn "Loaded data."

   p0 <- MWC.uniformR (-0.5, 0.5) g
   -- print (show $ take 10 train)

   flip evalStateT p0 . forM_ [1..] $ \e -> do
      train' <- liftIO . fmap V.toList $ MWC.uniformShuffle (V.fromList train) g
      liftIO $ printf "[Epoch %d]\n" (e :: Int)

      forM_ ([1..] `zip` chunksOf batch train') $ \(b, chnk) -> StateT $ \ps0 -> do
         printf "(Batch %d)\n" (b :: Int)

         t0 <- getCurrentTime
         newP <- evaluate . force $ trainModel (rate ^ fromIntegral e) model ps0 chnk
         t1 <- getCurrentTime
         printf "Trained on %d points in %s.\n" batch (show (t1 `diffUTCTime` t0))

         let trainScore = testNet model newP chnk
             testScore  = testNet model newP test
         printf "Training error:   %.2f%%\n" ((1 - trainScore) * 100)
         printf "Validation error: %.2f%%\n" ((1 - testScore ) * 100)

         -- TODO: Serialize trained params so we can save/load them

         -- Because we are in the StateT monad, the next iteration of the loop
         -- will be passed newP (the updated parameters for the model)
         return ((), newP)
   where
      rate = 0.01
      batch = 30

loadMNIST
   :: FilePath
   -> FilePath
   -> IO (Maybe [(L 28 28, R 10)])
loadMNIST fpI fpL = runMaybeT $ do
   i <- MaybeT          $ decodeIDXFile       fpI
   l <- MaybeT          $ decodeIDXLabelsFile fpL
   d <- MaybeT . return $ labeledIntData l i
   r <- MaybeT . return $ for d (bitraverse mkImage mkLabel . swap)
   liftIO . evaluate $ force r
      where
         mkImage :: VU.Vector Int -> Maybe (L 28 28)
         mkImage = HMS.create . HMD.reshape 28 . VG.convert . VG.map (\i -> fromIntegral i / 255)
         mkLabel :: Int -> Maybe (R 10)
         mkLabel n = HMS.create $ HM.build 10 (\i -> if round i == n then 1 else 0)

max_stars_repo_name: velveteer/mnist-backprop

max_issues_repo_name: velveteer/mnist-backprop

max_forks_repo_name: velveteer/mnist-backprop


text:
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
import           Control.Monad
import           Control.Monad.Random
import           Criterion.Main
import           Data.Default
import           Data.List                           (foldl')
import           Data.Singletons
import           Data.Singletons.Prelude.List
import           GHC.TypeLits
import qualified Numeric.LinearAlgebra.Static        as SA

import           Grenade

import           Grenade.Layers.Internal.Convolution
import           Grenade.Layers.Internal.Pooling

import           Numeric.LinearAlgebra

ff :: SpecNet
ff = specFullyConnected 2 40 |=> specTanh1D 40 |=> netSpecInner |=> specFullyConnected 20 30 |=> specRelu1D 30 |=> specFullyConnected 30 20 |=> specRelu1D 20 |=> specFullyConnected 20 10 |=> specRelu1D 10 |=> specFullyConnected 10 1 |=> specLogit1D 1 |=> specNil1D 1
  where netSpecInner = specFullyConnected 40 30 |=> specRelu1D 30 |=> specFullyConnected 30 20 |=> specNil1D 20

hugeFf :: SpecNet
hugeFf = specFullyConnected 2 4000 |=> specRelu1D 4000 |=> specFullyConnected 4000 1 |=> specLogit1D 1 |=> specNil1D 1

hugeBigFf :: SpecNet
hugeBigFf =
      specFullyConnected 2 4500
  |=> specTanh1D 4500
  |=> specFullyConnected 4500 750
  |=> specRelu1D 750
  |=> specFullyConnected 750 150
  |=> specRelu1D 150
  |=> specFullyConnected 150 150
  |=> specRelu1D 150
  |=> specFullyConnected 150 30
  |=> specRelu1D 30
  |=> specFullyConnected 30 20
  |=> specRelu1D 20
  |=> specFullyConnected 20 10
  |=> specRelu1D 10
  |=> specFullyConnected 10 1
  |=> specLogit1D 1
  |=> specNil1D 1

main :: IO ()
main = do
  putStrLn $ "Benchmarking with type: " ++ nameF
  x :: S ('D2 60 60) <- randomOfShape
  y :: S ('D3 60 60 1) <- randomOfShape
  SpecConcreteNetwork1D1D netFF <- networkFromSpecificationWith def ff
  SpecConcreteNetwork1D1D netHuge <- networkFromSpecificationWith def hugeFf
  SpecConcreteNetwork1D1D netHugeBig <- networkFromSpecificationWith def hugeBigFf
  SpecConcreteNetwork1D1D netHugeBlas <- networkFromSpecificationWith (NetworkInitSettings UniformInit BLAS Nothing) hugeFf
  SpecConcreteNetwork1D1D netHugeBigBlas <- networkFromSpecificationWith (NetworkInitSettings UniformInit BLAS Nothing) hugeBigFf
  defaultMain
    [ -- bgroup
    --     "im2col"
    --     [ bench "im2col 3x4" $ whnf (im2col 2 2 1 1) ((3 >< 4) [1 ..])
    --     , bench "im2col 28x28" $ whnf (im2col 5 5 1 1) ((28 >< 28) [1 ..])
    --     , bench "im2col 100x100" $ whnf (im2col 10 10 1 1) ((100 >< 100) [1 ..])
    --     ]
    -- , bgroup
    --     "col2im"
    --     [ bench "col2im 3x4" $ whnf (col2im 2 2 1 1 3 4) ((6 >< 4) [1 ..])
    --     , bench "col2im 28x28" $ whnf (col2im 5 5 1 1 28 28) ((576 >< 25) [1 ..])
    --     , bench "col2im 100x100" $ whnf (col2im 10 10 1 1 100 100) ((8281 >< 100) [1 ..])
    --     ]
    -- , bgroup
    --     "poolfw"
    --     [ bench "poolforwards 3x4" $ whnf (poolForward 1 3 4 2 2 1 1) ((3 >< 4) [1 ..])
    --     , bench "poolforwards 28x28" $ whnf (poolForward 1 28 28 5 5 1 1) ((28 >< 28) [1 ..])
    --     , bench "poolforwards 100x100" $ whnf (poolForward 1 100 100 10 10 1 1) ((100 >< 100) [1 ..])
    --     ]
    -- , bgroup
    --     "poolbw"
    --     [ bench "poolbackwards 3x4" $ whnf (poolBackward 1 3 4 2 2 1 1 ((3 >< 4) [1 ..])) ((2 >< 3) [1 ..])
    --     , bench "poolbackwards 28x28" $ whnf (poolBackward 1 28 28 5 5 1 1 ((28 >< 28) [1 ..])) ((24 >< 24) [1 ..])
    --     , bench "poolbackwards 100x100" $ whnf (poolBackward 1 100 100 10 10 1 1 ((100 >< 100) [1 ..])) ((91 >< 91) [1 ..])
    --     ]
    -- , bgroup
    --     "padcrop"
    --     [ bench "pad 2D 60x60" $ whnf (testRun2D Pad) x
    --     , bench "pad 3D 60x60" $ whnf (testRun3D Pad) y
    --     , bench "crop 2D 60x60" $ whnf (testRun2D' Crop) x
    --     , bench "crop 3D 60x60" $ whnf (testRun3D' Crop) y
    --     ]
    -- , bgroup
    --     "feedforward SGD"
    --     [ bench "ANN 1000 training steps" $ nfIO $ netTrain netFF defSGD 1000
    --     , bench "ANN 10000 training steps" $ nfIO $ netTrain netFF defSGD 10000
    --     , bench "ANN Huge 100 train steps" $ nfIO $ netTrain netHuge defSGD 100
    --     , bench "ANN Huge 1000 train steps" $ nfIO $ netTrain netHuge defSGD 1000
    --     ]
    -- ,
      bgroup
        "feedforward Adam"
        [ bench "ANN 100   train steps    Network: Huge          Backend: HMatrix" $ nfIO $ netTrain netHuge        defAdam 100
        , bench "ANN 100   train steps    Network: Huge          Backend: BLAS   " $ nfIO $ netTrain netHugeBlas    defAdam 100
        , bench "ANN 100   train steps    Network: Huge-Big      Backend: HMatrix" $ nfIO $ netTrain netHugeBig     defAdam 100
        , bench "ANN 100   train steps    Network: Huge-Big      Backend: BLAS   " $ nfIO $ netTrain netHugeBigBlas defAdam 100
        , bench "ANN 1000  train steps    Network: Huge          Backend: HMatrix" $ nfIO $ netTrain netHuge        defAdam 1000
        , bench "ANN 1000  train steps    Network: Huge          Backend: BLAS   " $ nfIO $ netTrain netHugeBlas    defAdam 1000
        , bench "ANN 1000  train steps    Network: Huge-Big      Backend: HMatrix" $ nfIO $ netTrain netHugeBig     defAdam 1000
        , bench "ANN 1000  train steps    Network: Huge-Big      Backend: BLAS   " $ nfIO $ netTrain netHugeBigBlas defAdam 1000
        , bench "ANN 1000  train steps    Network: Feedforward   Backend: HMatrix" $ nfIO $ netTrain netFF       defAdam 1000
        , bench "ANN 10000 train steps    Network: Feedforward   Backend: HMatrix" $ nfIO $ netTrain netFF       defAdam 10000
        ]
    ]
  putStrLn $ "Benchmarked with type: " ++ nameF

testRun2D :: Pad 1 1 1 1 -> S ('D2 60 60) -> S ('D2 62 62)
testRun2D = snd ... runForwards

testRun3D :: Pad 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 62 62 1)
testRun3D = snd ... runForwards

testRun2D' :: Crop 1 1 1 1 -> S ('D2 60 60) -> S ('D2 58 58)
testRun2D' = snd ... runForwards

testRun3D' :: Crop 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 58 58 1)
testRun3D' = snd ... runForwards

(...) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
(...) = (.) . (.)

netTrain ::
     (SingI (Last shapes), MonadRandom m, KnownNat len1, KnownNat len2, Head shapes ~ 'D1 len1, Last shapes ~ 'D1 len2)
  => Network layers shapes
  -> Optimizer o
  -> Int
  -> m (Network layers shapes)
netTrain net0 op n = do
  inps <-
    replicateM n $ do
      s <- getRandom
      return $ S1D $ SA.randomVector s SA.Uniform * 2 - 1
  let outs =
        flip map inps $ \(S1D v) ->
          if v `inCircle` (fromRational 0.50, 0.50) || v `inCircle` (fromRational (-0.50), 0.50)
            then S1D $ fromRational 1
            else S1D $ fromRational 0
  let trained = foldl' trainEach net0 (zip inps outs)
  return trained
  where
    trainEach !network (i, o) = train op network i o
    inCircle :: KnownNat n => SA.R n -> (SA.R n, RealNum) -> Bool
    v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Sound.StreamVector
(
    vfroml
    , vfromsl
    , vfromsrl
    , vgenerate
    , vmap
    , Vslice(..)
    , mkVslice
    , vsvec
    , vshead
    , vsUnsafeIndex
    , lfromv
    , rlfromrv
    , lvappend
    , rlvappend
    , vfromlist
    , vcfromlist
    , lcyclev
)
where

import qualified Data.Complex as Cp

import qualified Data.Vector.Generic as Vg
import qualified Data.Vector.Unboxed as Vu

import Sound.Class
import Sound.InfList
import Sound.Time

lcyclev :: (Vu.Unbox a) => Int -> a -> Vu.Vector a -> L a
lcyclev cylen z =
    lcycle cylen . lfromv z

vfroml :: (Vg.Vector v a) => Int -> L a -> v a
vfroml n s = Vg.fromList $ take n s

vfromsl :: (Vg.Vector v a) => SL Int a -> v a
vfromsl s = Vg.fromList (take (_slcount s) (_unslice s))

vfromsrl :: (Vg.Vector v a) => SRL Int a -> v a
vfromsrl = vfromsl . smap unrated

vgenerate :: (Vg.Vector v a) => Int -> (Int -> a) -> v a
vgenerate = Vg.generate

vmap :: (Vu.Unbox a, Vu.Unbox b) => (a -> b) -> Vu.Vector a -> Vu.Vector b
vmap = Vu.map

data Vslice a
    = MkVslice
    {
        _vsoffset :: !Int
        , _vsstride :: !Int
        , _vslength :: !Int
        , _vsvector :: Vu.Vector a
    }
    deriving (Read, Show)
mkVslice :: Int -> Int -> Vslice a -> Vslice a
mkVslice offset stride (MkVslice o s l v) =
    MkVslice (o + offset * s) (stride * s) (l `div` stride) v

vsvec :: (Vu.Unbox a) => Vu.Vector a -> Vslice a
vsvec x = MkVslice 0 1 (Vu.length x) x

vshead :: (Vu.Unbox a) => Vslice a -> a
vshead x = Vu.unsafeIndex (_vsvector x) (_vsoffset x)

vsUnsafeIndex :: (Vu.Unbox a) => Vslice a -> Int -> a
vsUnsafeIndex s k =
    Vu.unsafeIndex (_vsvector s) (_vsoffset s + _vsstride s * k)

{-# DEPRECATED lfromv "use 'lvappend' and 'point'" #-}
lfromv :: (Vu.Unbox a) => a -> Vu.Vector a -> L a
lfromv pad vec = lvappend vec (point pad)
{-
    loop vec
    where
        loop v =
            if Vu.null v
                then point pad
                else MkL (Vu.head v) (loop (Vu.tail v))
-}

rlfromrv :: (Vu.Unbox a) => a -> Rated (Vu.Vector a) -> Rated (L a)
rlfromrv pad = rmap (lfromv pad)

lvappend :: (Vu.Unbox a) => Vu.Vector a -> L a -> L a
lvappend vec rest =
    loop vec
    where
        loop v =
            if Vu.null v
                then rest
                else MkL (Vu.head v) (loop (Vu.tail v))

rlvappend :: (Vu.Unbox a) => Vu.Vector a -> RL a -> RL a
rlvappend vec = rmap (lvappend vec)

vfromlist :: (Vg.Vector v a) => [a] -> v a
vfromlist = Vg.fromList

vcfromlist :: (RealFloat a, Vu.Unbox a) => [a] -> Vu.Vector (Cp.Complex a)
vcfromlist = vfromlist . map (Cp.:+ 0)

max_stars_repo_name: edom/work

max_issues_repo_name: edom/work

max_forks_repo_name: edom/work


text:
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ViewPatterns        #-}

import           Control.Concurrent
import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Primitive
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.State
import           Data.Bifunctor
import           Data.Char
import           Data.Finite
import           Data.Foldable
import           Data.List
import           Data.Maybe
import           Data.Neural.Activation
import           Data.Neural.HMatrix.Recurrent
import           Data.Neural.HMatrix.Recurrent.Dropout
import           Data.Neural.HMatrix.Recurrent.Generate
import           Data.Neural.HMatrix.Recurrent.Train
import           Data.Ord
import           Data.Proxy
import           Data.Tuple
import           GHC.TypeLits
import           GHC.TypeLits.List
import           Numeric.LinearAlgebra.Static
import           Text.Printf
import qualified Data.Map.Strict                        as M
import qualified Data.Set                               as S
import qualified Data.Vector                            as VB
import qualified Data.Vector.Storable                   as V
import qualified Linear.V                               as L
import qualified System.Random.MWC                      as R
import qualified System.Random.MWC.Distributions        as R

genIx :: forall n. KnownNat n => Finite n -> R n
genIx (fromIntegral->i) = fromJust
                        . create
                        $ V.generate l (\i' -> if i' == i then 1 else 0)
  where
    l = fromInteger $ natVal (Proxy @n)

ixMax :: (Foldable t, Ord a) => t a -> Int
ixMax = fst . maximumBy (comparing snd) . zip [0..] . toList

ixSort :: (Foldable t, Ord a) => t a -> [Int]
ixSort = map fst . sortBy (flip (comparing snd)) . zip [0..] . toList

sanitize :: Char -> Char
sanitize c | isPrint c = c
           | otherwise = '#'

main :: IO ()
main = do
    g <- R.create
    holmes <- readFile "data/holmes.txt"
    let holmesVec :: VB.Vector Char
        holmesVec = VB.fromList holmes
    let allCharsV :: VB.Vector Char
        allCharsV = VB.fromList
                  . S.toList
                  . S.fromList
                  $ holmes

    L.reifyVectorNat allCharsV $ \(allChars :: L.V c Char) -> do
      let charMap :: M.Map Char (Finite c)
          charMap = M.fromList
                  . (`zip` [0..])
                  . toList
                  $ allChars
          c2v     :: Char -> R c
          c2v     = genIx . (charMap M.!)
          holmesSeries :: VB.Vector (L.V 15 Char, Char)
          holmesSeries = processSeries $ VB.zip holmesVec (VB.tail holmesVec)
          holmesSeries' :: VB.Vector ([R c], R c)
          holmesSeries' = bimap (map c2v . toList) c2v <$> holmesSeries
          ins :: VB.Vector [R c]
          ins = fst <$> holmesSeries'
          nextChar :: R c -> IO Int
          nextChar i = R.categorical (V.map ((**8) . max 0) (extract i)) g
          fb :: R c -> IO (R c)
          fb = fmap (genIx . fromIntegral) . nextChar
          cb :: Int -> Int -> Network c hs c -> IO ()
          cb e i n = when (i `mod` 1000 == 0) $ do
            let toCharList = map (sanitize . (allCharsV VB.!))
                           . take 50 . ixSort . V.toList . extract
                insTest   = ins VB.! 100
                insChars  = head . toCharList <$> insTest
                (last->lo, pp) = runNetStream naRLLog n (ins VB.! 100)
            lo' <- fb lo
            testOut   <- (lo:) <$> runNetFeedbackM_ naRLLog fb pp 75 lo'
            let testChars = toCharList <$> testOut
            threadDelay 250000
            printf "%d\t%d\n" e i
            mapM_ putStrLn (take 15 testChars)
            testCharsPick <- map (sanitize . (allCharsV VB.!)) <$> mapM nextChar testOut
            putStrLn $ insChars ++ "|" ++ testCharsPick

      print $ M.keys charMap
      print $ natVal (Proxy @c)
      print $ length holmes

      net0 <- randomNetMWC (-0.1,0.1) g :: IO (Network c '[100,75,50] c)
      net1 <- trainHistory 0.2 0.01 0.005 100 holmesSeries' net0 cb g
      return ()

trainHistory
    :: forall i m hs o. (PrimMonad m, KnownNats hs, KnownNat i, KnownNat o)
    => Double       -- ^ dropout
    -> Double       -- ^ step size (weights)
    -> Double       -- ^ step size (state)
    -> Int          -- ^ number of epochs
    -> VB.Vector ([R i], R o)
    -> Network i hs o
    -> (Int -> Int -> Network i hs o -> m ())  -- ^ callback
    -> R.Gen (PrimState m)
    -> m (Network i hs o)
trainHistory d sw ss e samps net0 cb g =
    flip execStateT net0
  . for_ [1 .. e] $ \i -> do
      samps' <- lift $ R.uniformShuffle samps g
      for_ (zip [1..] (VB.toList samps')) $ \(j, (h, t)) ->
        StateT $ \net -> do
          net' <- trainSeriesDOMWC naRLLog d sw ss t h net g
          cb i j net'
          net' `deepseq` return ((), net')

max_stars_repo_name: mstksg/neural-tests

max_issues_repo_name: mstksg/neural-tests

max_forks_repo_name: mstksg/neural-tests