text:
module Test.QuickCheck.Arbitrary
  (
  -- * Arbitrary and CoArbitrary classes
    Arbitrary(..)
  , CoArbitrary(..)

  -- ** Helper functions for implementing arbitrary
  , arbitrarySizedIntegral        -- :: Num a => Gen a
  , arbitraryBoundedIntegral      -- :: (Bounded a, Integral a) => Gen a
  , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a
  , arbitrarySizedFractional      -- :: Fractional a => Gen a
  , arbitraryBoundedRandom        -- :: (Bounded a, Random a) => Gen a
  -- ** Helper functions for implementing shrink
  , shrinkNothing            -- :: a -> [a]
  , shrinkList               -- :: (a -> [a]) -> [a] -> [[a]]
  , shrinkIntegral           -- :: Integral a => a -> [a]
  , shrinkRealFrac           -- :: RealFrac a => a -> [a]
  -- ** Helper functions for implementing coarbitrary
  , (><)
  , coarbitraryIntegral      -- :: Integral a => a -> Gen b -> Gen b
  , coarbitraryReal          -- :: Real a => a -> Gen b -> Gen b
  , coarbitraryShow          -- :: Show a => a -> Gen b -> Gen b

  -- ** Generators which use arbitrary
  , vector      -- :: Arbitrary a => Int -> Gen [a]
  , orderedList -- :: (Ord a, Arbitrary a) => Gen [a]
  )
 where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen

{-
import Data.Generics
  ( (:*:)(..)
  , (:+:)(..)
  , Unit(..)
  )
-}

import Data.Char
  ( chr
  , ord
  , isLower
  , isUpper
  , toLower
  , isDigit
  , isSpace
  )

import Data.Ratio
  ( Ratio
  , (%)
  , numerator
  , denominator
  )

import Data.Complex
  ( Complex((:+)) )

import System.Random
  ( Random
  )

import Data.List
  ( sort
  , nub
  )

import Control.Monad
  ( liftM
  , liftM2
  , liftM3
  , liftM4
  , liftM5
  )

import Data.Int(Int8, Int16, Int32, Int64)
import Data.Word(Word, Word8, Word16, Word32, Word64)

--------------------------------------------------------------------------
-- ** class Arbitrary

-- | Random generation and shrinking of values.
class Arbitrary a where
  -- | A generator for values of the given type.
  arbitrary :: Gen a
  arbitrary = error "no default generator"

  -- | Produces a (possibly) empty list of all the possible
  -- immediate shrinks of the given value.
  shrink :: a -> [a]
  shrink _ = []

-- instances

instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = promote (`coarbitrary` arbitrary)

instance Arbitrary () where
  arbitrary = return ()

instance Arbitrary Bool where
  arbitrary = choose (False,True)
  shrink True = [False]
  shrink False = []

instance Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)]

  shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ]
  shrink _        = []

instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary]

  shrink (Left x)  = [ Left  x' | x' <- shrink x ]
  shrink (Right y) = [ Right y' | y' <- shrink y ]

instance Arbitrary a => Arbitrary [a] where
  arbitrary = sized $ \n ->
    do k <- choose (0,n)
       sequence [ arbitrary | _ <- [1..k] ]

  shrink xs = shrinkList shrink xs

shrinkList :: (a -> [a]) -> [a] -> [[a]]
shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ]
                 ++ shrinkOne xs
 where
  n = length xs

  shrinkOne []     = []
  shrinkOne (x:xs) = [ x':xs | x'  <- shr x ]
                  ++ [ x:xs' | xs' <- shrinkOne xs ]

  removes k n xs
    | k > n     = []
    | null xs2  = [[]]
    | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2)
   where
    xs1 = take k xs
    xs2 = drop k xs

{-
  -- "standard" definition for lists:
  shrink []     = []
  shrink (x:xs) = [ xs ]
               ++ [ x:xs' | xs' <- shrink xs ]
               ++ [ x':xs | x'  <- shrink x ]
-}

instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where
  arbitrary = arbitrarySizedFractional
  shrink    = shrinkRealFrac

instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where
  arbitrary = liftM2 (:+) arbitrary arbitrary
  shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++
                    [ x :+ y' | y' <- shrink y ]

instance (Arbitrary a, Arbitrary b)
      => Arbitrary (a,b)
 where
  arbitrary = liftM2 (,) arbitrary arbitrary

  shrink (x,y) = [ (x',y) | x' <- shrink x ]
              ++ [ (x,y') | y' <- shrink y ]

instance (Arbitrary a, Arbitrary b, Arbitrary c)
      => Arbitrary (a,b,c)
 where
  arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary

  shrink (x,y,z) = [ (x',y,z) | x' <- shrink x ]
                ++ [ (x,y',z) | y' <- shrink y ]
                ++ [ (x,y,z') | z' <- shrink z ]

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
      => Arbitrary (a,b,c,d)
 where
  arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary

  shrink (w,x,y,z) = [ (w',x,y,z) | w' <- shrink w ]
                  ++ [ (w,x',y,z) | x' <- shrink x ]
                  ++ [ (w,x,y',z) | y' <- shrink y ]
                  ++ [ (w,x,y,z') | z' <- shrink z ]

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e)
      => Arbitrary (a,b,c,d,e)
 where
  arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary

  shrink (v,w,x,y,z) = [ (v',w,x,y,z) | v' <- shrink v ]
                    ++ [ (v,w',x,y,z) | w' <- shrink w ]
                    ++ [ (v,w,x',y,z) | x' <- shrink x ]
                    ++ [ (v,w,x,y',z) | y' <- shrink y ]
                    ++ [ (v,w,x,y,z') | z' <- shrink z ]

-- typical instance for primitive (numerical) types

instance Arbitrary Integer where
  arbitrary = arbitrarySizedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Int where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Int8 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Int16 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Int32 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Int64 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Word where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Word8 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Word16 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Word32 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Word64 where
  arbitrary = arbitrarySizedBoundedIntegral
  shrink    = shrinkIntegral

instance Arbitrary Char where
  arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]
  shrink c  = filter (<. c) $ nub
            $ ['a','b','c']
           ++ [ toLower c | isUpper c ]
           ++ ['A','B','C']
           ++ ['1','2','3']
           ++ [' ','\n']
   where
    a <. b  = stamp a < stamp b
    stamp a = ( (not (isLower a)
              , not (isUpper a)
              , not (isDigit a))
              , (not (a==' ')
              , not (isSpace a)
              , a)
              )

instance Arbitrary Float where
  arbitrary = arbitrarySizedFractional
  shrink    = shrinkRealFrac

instance Arbitrary Double where
  arbitrary = arbitrarySizedFractional
  shrink    = shrinkRealFrac

-- ** Helper functions for implementing arbitrary

-- | Generates an integral number. The number can be positive or negative
-- and its maximum absolute value depends on the size parameter.
arbitrarySizedIntegral :: Num a => Gen a
arbitrarySizedIntegral =
  sized $ \n ->
    let n' = toInteger n in
      fmap fromInteger (choose (-n', n'))

-- | Generates a fractional number. The number can be positive or negative
-- and its maximum absolute value depends on the size parameter.
arbitrarySizedFractional :: Fractional a => Gen a
arbitrarySizedFractional =
  sized $ \n ->
    let n' = toInteger n in
      do a <- choose ((-n') * precision, n' * precision)
         b <- choose (1, precision)
         return (fromRational (a % b))
 where
  precision = 9999999999999 :: Integer

-- | Generates an integral number. The number is chosen uniformly from
-- the entire range of the type. You may want to use
-- 'arbitrarySizedBoundedIntegral' instead.
arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a
arbitraryBoundedIntegral =
  do let mn = minBound
         mx = maxBound `asTypeOf` mn
     n <- choose (toInteger mn, toInteger mx)
     return (fromInteger n `asTypeOf` mn)

-- | Generates an element of a bounded type. The element is
-- chosen from the entire range of the type.
arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a
arbitraryBoundedRandom = choose (minBound,maxBound)

-- | Generates an integral number from a bounded domain. The number is
-- chosen from the entire range of the type, but small numbers are
-- generated more often than big numbers. Inspired by demands from
-- Phil Wadler.
arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a
arbitrarySizedBoundedIntegral =
  sized $ \s ->
    do let mn = minBound
           mx = maxBound `asTypeOf` mn
           bits n | n `quot` 2 == 0 = 0
                  | otherwise = 1 + bits (n `quot` 2)
           k  = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100)
       n <- choose (toInteger mn `max` (-k), toInteger mx `min` k)
       return (fromInteger n `asTypeOf` mn)

-- ** Helper functions for implementing shrink

-- | Returns no shrinking alternatives.
shrinkNothing :: a -> [a]
shrinkNothing _ = []

-- | Shrink an integral number.
shrinkIntegral :: Integral a => a -> [a]
shrinkIntegral x =
  nub $
  [ -x
  | x < 0, -x > x
  ] ++
  [ x'
  | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ])
  ]
 where
   -- a << b is "morally" abs a < abs b, but taking care of overflow.
   a << b = case (a >= 0, b >= 0) of
            (True,  True)  -> a < b
            (False, False) -> a > b
            (True,  False) -> a + b < 0
            (False, True)  -> a + b > 0

-- | Shrink a fraction.
shrinkRealFrac :: RealFrac a => a -> [a]
shrinkRealFrac x =
  nub $
  [ -x
  | x < 0
  ] ++
  [ x'
  | x' <- [fromInteger (truncate x)]
  , x' << x
  ]
 where
  a << b = abs a < abs b

--------------------------------------------------------------------------
-- ** CoArbitrary

-- | Used for random generation of functions.
class CoArbitrary a where
  -- | Used to generate a function of type @a -> c@. The implementation
  -- should use the first argument to perturb the random generator
  -- given as the second argument. the returned generator
  -- is then used to generate the function result.
  -- You can often use 'variant' and '><' to implement
  -- 'coarbitrary'.
  coarbitrary :: a -> Gen c -> Gen c

{-
  -- GHC definition:
  coarbitrary{| Unit |}    Unit      = id
  coarbitrary{| a :*: b |} (x :*: y) = coarbitrary x >< coarbitrary y
  coarbitrary{| a :+: b |} (Inl x)   = variant 0    . coarbitrary x
  coarbitrary{| a :+: b |} (Inr y)   = variant (-1) . coarbitrary y
-}

-- | Combine two generator perturbing functions, for example the
-- results of calls to 'variant' or 'coarbitrary'.
(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a)
(><) f g gen =
  do n <- arbitrary
     (g . variant (n :: Int) . f) gen

-- for the sake of non-GHC compilers, I have added definitions
-- for coarbitrary here.

instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
  coarbitrary f gen =
    do xs <- arbitrary
       coarbitrary (map f xs) gen

instance CoArbitrary () where
  coarbitrary _ = id

instance CoArbitrary Bool where
  coarbitrary False = variant 0
  coarbitrary True  = variant (-1)

instance CoArbitrary a => CoArbitrary (Maybe a) where
  coarbitrary Nothing  = variant 0
  coarbitrary (Just x) = variant (-1) . coarbitrary x

instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where
  coarbitrary (Left x)  = variant 0    . coarbitrary x
  coarbitrary (Right y) = variant (-1) . coarbitrary y

instance CoArbitrary a => CoArbitrary [a] where
  coarbitrary []     = variant 0
  coarbitrary (x:xs) = variant (-1) . coarbitrary (x,xs)

instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where
  coarbitrary r = coarbitrary (numerator r,denominator r)

instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where
  coarbitrary (x :+ y) = coarbitrary x >< coarbitrary y

instance (CoArbitrary a, CoArbitrary b)
      => CoArbitrary (a,b)
 where
  coarbitrary (x,y) = coarbitrary x
                   >< coarbitrary y

instance (CoArbitrary a, CoArbitrary b, CoArbitrary c)
      => CoArbitrary (a,b,c)
 where
  coarbitrary (x,y,z) = coarbitrary x
                     >< coarbitrary y
                     >< coarbitrary z

instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d)
      => CoArbitrary (a,b,c,d)
 where
  coarbitrary (x,y,z,v) = coarbitrary x
                       >< coarbitrary y
                       >< coarbitrary z
                       >< coarbitrary v

instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e)
      => CoArbitrary (a,b,c,d,e)
 where
  coarbitrary (x,y,z,v,w) = coarbitrary x
                         >< coarbitrary y
                         >< coarbitrary z
                         >< coarbitrary v
                         >< coarbitrary w

-- typical instance for primitive (numerical) types

instance CoArbitrary Integer where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Int where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Int8 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Int16 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Int32 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Int64 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Word where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Word8 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Word16 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Word32 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Word64 where
  coarbitrary = coarbitraryIntegral

instance CoArbitrary Char where
  coarbitrary = coarbitrary . ord

instance CoArbitrary Float where
  coarbitrary = coarbitraryReal

instance CoArbitrary Double where
  coarbitrary = coarbitraryReal

-- ** Helpers for implementing coarbitrary

-- | A 'coarbitrary' implementation for integral numbers.
coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b
coarbitraryIntegral = variant

-- | A 'coarbitrary' implementation for real numbers.
coarbitraryReal :: Real a => a -> Gen b -> Gen b
coarbitraryReal x = coarbitrary (toRational x)

-- | 'coarbitrary' helper for lazy people :-).
coarbitraryShow :: Show a => a -> Gen b -> Gen b
coarbitraryShow x = coarbitrary (show x)

--------------------------------------------------------------------------
-- ** arbitrary generators

-- these are here and not in Gen because of the Arbitrary class constraint

-- | Generates a list of a given length.
vector :: Arbitrary a => Int -> Gen [a]
vector k = vectorOf k arbitrary

-- | Generates an ordered list of a given length.
orderedList :: (Ord a, Arbitrary a) => Gen [a]
orderedList = sort `fmap` arbitrary

--------------------------------------------------------------------------
-- the end.


text:
-- tiers.hs -- prints tiers of values up to a certain point
--
-- Copyright (c) 2015-2018 Rudy Matela.
-- Distributed under the 3-Clause BSD licence (see the file LICENSE).
import Test.LeanCheck
import Test.LeanCheck.Utils.Types
import Test.LeanCheck.Function ()
import Test.LeanCheck.Function.Eq ()
import Test.LeanCheck.Tiers (showTiers, finite)
import System.Environment
import Data.List (intercalate, nub)
import Data.Ratio ((%))
import Data.Int
import Data.Word
import Data.Complex

dropEmptyTiersTail :: [[a]] -> [[a]]
dropEmptyTiersTail ([]:[]:[]: []:[]:[]: _) = []
dropEmptyTiersTail (xs:xss) = xs:dropEmptyTiersTail xss
dropEmptyTiersTail []     = []

lengthT :: [[a]] -> Maybe Int
lengthT xss | finite xss' = Just . length $ concat xss'
            | otherwise   = Nothing
  where xss' = dropEmptyTiersTail xss

allUnique :: Eq a => [a] -> Bool
allUnique [] = True
allUnique (x:xs) = x `notElem` xs
                && allUnique (filter (/= x) xs)

countRepetitions :: Eq a => [a] -> Int
countRepetitions xs = length xs - length (nub xs)

ratioRepetitions :: Eq a => [a] -> Rational
ratioRepetitions [] = 0
ratioRepetitions xs = fromIntegral (countRepetitions xs) % fromIntegral (length xs)

showLengthT :: [[a]] -> String
showLengthT xss = case lengthT xss of
                    Nothing -> "Infinity"
                    Just x  -> show x

showDotsLongerThan :: Show a => Int -> [a] -> String
showDotsLongerThan n xs = "["
                       ++ intercalate "," (dotsLongerThan n $ map show xs)
                       ++ "]"
  where
  dotsLongerThan n xs = take n xs ++ ["..." | not . null $ drop n xs]

printTiers :: Show a => Int -> [[a]] -> IO ()
printTiers n = putStrLn . init . unlines . map ("  " ++) . lines . showTiers n

put :: (Show a, Eq a, Listable a) => String -> Int -> a -> IO ()
put t n a = do
  putStrLn $ "map length (tiers :: [[ " ++ t ++ " ]])  =  "
          ++ showDotsLongerThan n (map length $ tiers `asTypeOf` [[a]])
  putStrLn $ ""
  putStrLn $ "length (list :: [ " ++ t ++ " ])  =  "
          ++ showLengthT (tiers `asTypeOf` [[a]])
  putStrLn $ ""
  putStrLn $ "allUnique (list :: [ " ++ t ++ " ])  =  "
          ++ show (allUnique . concat . take n $ tiers `asTypeOf` [[a]])
  putStrLn $ ""
  putStrLn $ "ratioRepetitions (list :: [ " ++ t ++ " ])  =  "
          ++ show (ratioRepetitions . concat . take n $ tiers `asTypeOf` [[a]])
  putStrLn $ ""
  putStrLn $ "tiers :: [" ++ t ++ "]  ="
  printTiers n $ tiers `asTypeOf` [[a]]

u :: a
u = undefined

main :: IO ()
main = do
  as <- getArgs
  let (t,n) = case as of
              []      -> ("Int", 12)
              [t]     -> (t,     12)
              (t:n:_) -> (t, read n)
  case t of
    -- simple types
    "()"               -> put t n (u :: ()                   )
    "Int"              -> put t n (u :: Int                  )
    "Nat"              -> put t n (u :: Nat                  )
    "Integer"          -> put t n (u :: Integer              )
    "Bool"             -> put t n (u :: Bool                 )
    "Char"             -> put t n (u :: Char                 )
    "Float"            -> put t n (u :: Float                )
    "Double"           -> put t n (u :: Double               )
    "Rational"         -> put t n (u :: Rational             )
    -- fixed width integer types
    "Nat2"             -> put t n (u :: Nat2                 )
    "Nat3"             -> put t n (u :: Nat3                 )
    "Nat4"             -> put t n (u :: Nat4                 )
    "Word2"            -> put t n (u :: Word2                )
    "Word3"            -> put t n (u :: Word3                )
    "Word4"            -> put t n (u :: Word4                )
    "Word8"            -> put t n (u :: Word8                )
    "Word16"           -> put t n (u :: Word16               )
    "Word32"           -> put t n (u :: Word32               )
    "Word64"           -> put t n (u :: Word64               )
    "Int2"             -> put t n (u :: Int2                 )
    "Int3"             -> put t n (u :: Int3                 )
    "Int4"             -> put t n (u :: Int4                 )
    "Int8"             -> put t n (u :: Int8                 )
    "Int16"            -> put t n (u :: Int16                )
    "Int32"            -> put t n (u :: Int32                )
    "Int64"            -> put t n (u :: Int64                )
    -- complex numbers
    "Complex Double"   -> put t n (u :: Complex Double       )
    -- lists
    "[()]"             -> put t n (u :: [()]                 )
    "[Int]"            -> put t n (u :: [Int]                )
    "[Nat]"            -> put t n (u :: [Nat]                )
    "[Integer]"        -> put t n (u :: [Integer]            )
    "[Bool]"           -> put t n (u :: [Bool]               )
    "[Char]"           -> put t n (u :: [Char]               )
    "String"           -> put t n (u :: String               )
    -- pairs
    "((),())"          -> put t n (u :: ((),())              )
    "(Int,Int)"        -> put t n (u :: (Int,Int)            )
    "(Nat,Nat)"        -> put t n (u :: (Nat,Nat)            )
    "(Bool,Bool)"      -> put t n (u :: (Bool,Bool)          )
    "(Bool,Int)"       -> put t n (u :: (Bool,Int)           )
    "(Int,Bool)"       -> put t n (u :: (Int,Bool)           )
    "(Int,Int,Int)"    -> put t n (u :: (Int,Int,Int)        )
    "(Nat,Nat,Nat)"    -> put t n (u :: (Nat,Nat,Nat)        )
    -- lists & pairs
    "[((),())]"        -> put t n (u :: [((),())]            )
    "([()],[()])"      -> put t n (u :: ([()],[()])          )
    "([Bool],[Bool])"  -> put t n (u :: ([Bool],[Bool])      )
    "([Int],[Int])"    -> put t n (u :: ([Int],[Int])        )
    -- lists of lists
    "[[Int]]"          -> put t n (u :: [[Int]]              )
    -- functions
    "()->()"           -> put t n (u :: () -> ()             )
    "()->Bool"         -> put t n (u :: () -> Bool           )
    "Bool->()"         -> put t n (u :: Bool -> ()           )
    "Bool->Bool"       -> put t n (u :: Bool -> Bool         )
    "Bool->Bool->Bool" -> put t n (u :: Bool -> Bool -> Bool )
    "Int->Int"         -> put t n (u :: Int -> Int           )
    "Int->Int->Int"    -> put t n (u :: Int -> Int -> Int    )
    "()->Nat"          -> put t n (u :: () -> Nat            )
    "Nat->()"          -> put t n (u :: Nat -> ()            )
    "Nat->Nat"         -> put t n (u :: Nat -> Nat           )
    "Nat->Nat->Nat"    -> put t n (u :: Nat -> Nat -> Nat    )
    "(Nat,Nat)->Nat"   -> put t n (u :: (Nat,Nat) -> Nat     )
    "Bool->Maybe Bool" -> put t n (u :: Bool -> Maybe Bool   )
    "Maybe Bool->Bool" -> put t n (u :: Maybe Bool -> Bool   )
    "Maybe Bool->Maybe Bool" -> put t n (u :: Maybe Bool -> Maybe Bool)
    -- functions with lists
    "[()]->[()]"       -> put t n (u :: [()] -> [()]         )
    "[Bool]->[Bool]"   -> put t n (u :: [Bool] -> [Bool]     )
    "[Int]->[Int]"     -> put t n (u :: [Int] -> [Int]       )
    "[Nat]->[Nat]"     -> put t n (u :: [Nat] -> [Nat]       )
    -- more functions
    "Nat2->()"         -> put t n (u :: Nat2 -> ()           )
    "()->Nat2"         -> put t n (u :: () -> Nat2           )
    "Nat2->Nat2"       -> put t n (u :: Nat2 -> Nat2         )
    "Nat2->Nat3"       -> put t n (u :: Nat2 -> Nat3         )
    "Nat3->Nat2"       -> put t n (u :: Nat3 -> Nat2         )
    "Nat3->Nat3"       -> put t n (u :: Nat3 -> Nat3         )
    -- functions with mixed arguments
    "Bool->Int->Bool"  -> put t n (u :: Bool -> Int -> Bool  )
    "Int->Bool->Bool"  -> put t n (u :: Int -> Bool -> Bool  )
    -- functions with 3 arguments
    "Int->Int->Int->Int"     -> put t n (u :: Int -> Int -> Int -> Int)
    "Bool->Bool->Bool->Bool" -> put t n (u :: Bool -> Bool -> Bool -> Bool)
    -- special lists
    "Set Bool"         -> put t n (u :: Set Bool             )
    "Set ()"           -> put t n (u :: Set ()               )
    "Set Nat"          -> put t n (u :: Set Nat              )
    "Set Nat2"         -> put t n (u :: Set Nat2             )
    "Set Nat3"         -> put t n (u :: Set Nat3             )
    "Bag Bool"         -> put t n (u :: Bag Bool             )
    "Bag ()"           -> put t n (u :: Bag ()               )
    "Bag Nat"          -> put t n (u :: Bag Nat              )
    "Bag Nat2"         -> put t n (u :: Bag Nat2             )
    "Bag Nat3"         -> put t n (u :: Bag Nat3             )
    "NoDup Bool"       -> put t n (u :: NoDup Bool           )
    "NoDup ()"         -> put t n (u :: NoDup ()             )
    "NoDup Nat"        -> put t n (u :: NoDup Nat            )
    "NoDup Nat2"       -> put t n (u :: NoDup Nat2           )
    "NoDup Nat3"       -> put t n (u :: NoDup Nat3           )
    "Map Bool Bool"    -> put t n (u :: Map Bool Bool        )
    "Map () ()"        -> put t n (u :: Map () ()            )
    "Map Nat Nat"      -> put t n (u :: Map Nat Nat          )
    "Map Nat2 Nat2"    -> put t n (u :: Map Nat2 Nat2        )
    "Map Nat3 Nat3"    -> put t n (u :: Map Nat3 Nat3        )
    -- extreme integers
--  "X Int"            -> put t n (u :: X Int   ) -- device dependent
--  "X Word"           -> put t n (u :: X Word  ) -- device dependent
    "X Int4"           -> put t n (u :: X Int4  )
    "X Word4"          -> put t n (u :: X Word4 )
    "X Nat7"           -> put t n (u :: X Nat7  )
--  "Xs Int"           -> put t n (u :: Xs Int  ) -- device dependent
--  "Xs Word"          -> put t n (u :: Xs Word ) -- device dependent
    "Xs Int4"          -> put t n (u :: Xs Int4 )
    "Xs Word4"         -> put t n (u :: Xs Word4)
    "Xs Nat7"          -> put t n (u :: Xs Nat7 )
    -- unhandled
    _                  -> putStrLn $ "unknown/unhandled type `" ++ t ++ "'"

ext: hs

max_stars_repo_name: jwaldmann/leancheck

max_issues_repo_name: jwaldmann/leancheck

max_forks_repo_name: jwaldmann/leancheck


text:
module COMPLEX11 where

import Data.Complex
import Numeric

x = 0 :+ 3
y = 1 + x

max_stars_repo_name: borgauf/omnimath

max_issues_repo_name: borgauf/omnimath

max_forks_repo_name: borgauf/omnimath


text:
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Evaluate where

import AlphaBeta
import Control.Monad
import Control.Parallel.Strategies (parMap, rpar)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Csv
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Vector (fromList)
import Debug.Trace
import Flow ((<|), (|>))
import GHC.Float (float2Double, int2Double)
import GHC.Generics (Generic)
import Game
import Helpers
import Minimax
import Statistics.Sample (mean, stdDev)
import System.IO (writeFile)
import System.Random (StdGen, mkStdGen, split)
import Text.Printf (printf)

evaluate =
  let results =
        map
          ( \(s1, ai1) ->
              map
                ( \(s2, ai2) ->
                    let (utilities, lengths) =
                          playOften
                            ( \a ->
                                case a of
                                  Gold -> ai1
                                  Silver -> ai2
                            )
                        vUtilities = utilities |> map float2Double |> fromList
                        vLengths = lengths |> map int2Double |> fromList
                     in ( \_ ->
                            ( s1,
                              s2,
                              vUtilities |> mean,
                              vUtilities |> stdDev,
                              vLengths |> mean,
                              vLengths |> stdDev
                            )
                        )
                )
                ais
          )
          ais
          |> concat
          |> parMap rpar (\a -> a ())
   in let path = "evaluation/results.csv"
       in do
            ( writeFile
                path
                ( "Gold,Silver,Utility,Utility (StdDev),Ply-Depth,Ply-Depth (StdDev)\n"
                    ++ (unpack (encode (results)))
                )
              )
            putStrLn ("Written evaluation to ./" ++ path)
            putStrLn "Run `cd evaluation && pipenv run python __main__.py` to create visualizations."

ais :: [(Text, (StdGen -> Ai))]
ais =
  [ ("a Random", random),
    ("b Minimax 1", minimax 1),
    --("c AlphaBeta 1", alphaBeta 1),
    ("c Minimax 2", minimax 2),
    --("e AlphaBeta 2", alphaBeta 2),
    ("d Minimax 3", minimax 3)
    --("g AlphaBeta 3", alphaBeta 3)
  ]

-- | Run multiple AIs against each other.
playOften :: (Player -> StdGen -> Ai) -> ([Float], [Int])
playOften ais =
  [10]
    |> parMap rpar (\i -> play (mkStdGen i) ais [] (initial breakthru))
    |> foldl
      ( \(us, ls) (Utility u, history) ->
          (u : us, length history : ls)
      )
      ([], [])

-- | Play a game to the end. Takes a random number generator, a specification of a (possibly random-number-generator dependent) AI for each player, the history of states, and the current states. Returns the utility of player Gold and the history of states.
play :: StdGen -> (Player -> StdGen -> Ai) -> [State] -> State -> (Utility, [State])
play g ai history state@State {player} =
  let Game {result, utility} = breakthru
   in case utility state of
        Just u -> (u, reverse history)
        Nothing ->
          let (g1, g2) = split g
           in play
                g2
                ai
                ((traceShowId state) : history)
                ( (ai player g1 state)
                    |> fmap
                      ( \a ->
                          let r = result state a
                           in (if r == Nothing then traceShow ("result error", state, a) else id) r
                      )
                    |> (\a -> (if a == Nothing then traceShow ("ai action error", state, a) else id) a)
                    |> join
                    |> fromMaybe initial_
                )

max_stars_repo_name: davidpomerenke/breakthru

max_issues_repo_name: davidpomerenke/breakthru

max_forks_repo_name: davidpomerenke/breakthru


text:
-- File created: 2009-08-06 20:47:49

module Haschoo.Evaluator.Standard.Vectors (procedures) where

import Control.Applicative ((<$>))
import Data.Array          (Array)
import Data.Array.IArray   ((!), bounds, elems)
import Data.Array.IO       (IOArray)
import Data.Array.MArray   ( readArray, writeArray
                           , newArray, newListArray
                           , getBounds, getElems)
import Data.Complex        (Complex((:+)))

import Haschoo.Types           (ScmValue(..), listToPair, pairToList)
import Haschoo.Utils           (ErrOr)
import Haschoo.Evaluator.Utils ( tooFewArgs, tooManyArgs, immutable
                               , notInt, notList)

procedures :: [(String, ScmValue)]
procedures = map (\(a,b) -> (a, ScmFunc a b))
   [ ("vector?", return . fmap ScmBool . scmIsVector)

   , ("make-vector", scmMakeVector)
   , ("vector",      scmVector)

   , ("vector-length", scmLength)

   , ("vector-ref",  scmRef)
   , ("vector-set!", scmSet)

   , ("vector->list", scmToList)
   , ("list->vector", scmFromList)

   , ("vector-fill!", scmFill)
   ]

scmIsVector :: [ScmValue] -> ErrOr Bool
scmIsVector [ScmMVector _] = Right True
scmIsVector [ScmVector  _] = Right True
scmIsVector [_]            = Right False
scmIsVector []             = tooFewArgs  "vector?"
scmIsVector _              = tooManyArgs "vector?"

scmMakeVector, scmVector :: [ScmValue] -> IO (ErrOr ScmValue)
scmMakeVector (ScmInt l : xs) =
   case xs of
        []  -> f (flip newArray (ScmComplex $ 0 :+ 42))
        [x] -> f (flip newArray x)
        _   -> return$ tooManyArgs "make-vector"
 where
   f mk = tryToLen "make-vector" l $ \i -> ScmMVector <$> mk (0, i-1)

scmMakeVector (_:_:_:_) = return$ tooManyArgs "make-vector"
scmMakeVector []        = return$ tooFewArgs  "make-vector"
scmMakeVector _         = return$ notInt      "make-vector"

scmVector xs = Right <$> toScmMVector xs

scmLength :: [ScmValue] -> IO (ErrOr ScmValue)
scmLength [x] = case x of
                     ScmVector  s -> Right . ScmInt . toInteger <$>  vLen s
                     ScmMVector s -> Right . ScmInt . toInteger <$> mvLen s
                     _            -> return$ notVector "vector-length"

scmLength [] = return$ tooFewArgs  "vector-length"
scmLength _  = return$ tooManyArgs "vector-length"

scmRef, scmSet :: [ScmValue] -> IO (ErrOr ScmValue)
scmRef [x, ScmInt i] = case x of
                            ScmVector  s -> f (vLen  s) (return . (s!))
                            ScmMVector s -> f (mvLen s) (readArray s)
                            _            -> return$ notVector "vector-ref"
 where
   f len = tryToIdx "vector-ref" len i

scmRef [_,_]   = return$ notInt      "vector-ref"
scmRef (_:_:_) = return$ tooManyArgs "vector-ref"
scmRef _       = return$ tooFewArgs  "vector-ref"

scmSet [v, ScmInt idx, x] =
   case v of
        ScmMVector v' -> do
           tryToIdx "vector-set!" (mvLen v') idx (\i -> writeArray v' i x)
           return (Right ScmVoid)

        ScmVector  _ -> return$ immutable "vector-set!"
        _            -> return$ notVector "vector-set!"

scmSet [_, _, ScmChar _] = return$ notInt      "vector-set!"
scmSet (_:_:_:_)         = return$ tooManyArgs "vector-set!"
scmSet _                 = return$ tooFewArgs  "vector-set!"

scmToList, scmFromList :: [ScmValue] -> IO (ErrOr ScmValue)
scmToList [x] = case x of
                     ScmVector  v -> f (elems v)
                     ScmMVector v -> f =<< getElems v
                     _            -> return$ notVector "vector->list"
 where
   f = fmap (Right . fst) . listToPair

scmToList [] = return$ tooFewArgs  "vector->list"
scmToList _  = return$ tooManyArgs "vector->list"

scmFromList [x] =
   case x of
        ScmList l       -> Right <$> toScmMVector l
        p@(ScmPair _ _) -> do
           l <- pairToList p
           case l of
                Left _             -> return$ notList "list->vector"
                Right (ScmList l') -> Right <$> toScmMVector l'

                _ -> error "list->vector :: the impossible happened"

        _ -> return$ notList "list->vector"

scmFromList [] = return$ tooFewArgs  "list->vector"
scmFromList _  = return$ tooManyArgs "list->vector"

scmFill :: [ScmValue] -> IO (ErrOr ScmValue)
scmFill [v, x] =
   case v of
        ScmMVector v' -> do
           (a,b) <- getBounds v'
           mapM_ (\i -> writeArray v' i x) [a..b]
           return (Right ScmVoid)

        ScmVector _ -> return$ immutable "vector-fill!"
        _           -> return$ notVector "vector-fill!"

scmFill (_:_:_) = return$ tooManyArgs "vector-fill!"
scmFill _       = return$ tooFewArgs  "vector-fill!"

------

notVector :: String -> ErrOr a
notVector = fail . ("Nonvector argument to " ++)

toScmMVector :: [ScmValue] -> IO ScmValue
toScmMVector v = ScmMVector <$> newListArray (0, length v - 1) v

tryToLen :: String -> Integer -> (Int -> IO a) -> IO (ErrOr a)
tryToLen = tryRange 0 (toInteger (maxBound :: Int))

tryToIdx :: String -> IO Int -> Integer -> (Int -> IO a) -> IO (ErrOr a)
tryToIdx s mlen i f = mlen >>= \len -> tryRange 0 (toInteger len - 1) s i f

tryRange :: Integer -> Integer -> String -> Integer -> (Int -> IO a)
         -> IO (ErrOr a)
tryRange a b s i f = if i >= a && i <= b
                        then Right <$> f (fromInteger i)
                        else return.Left $ "Out-of-range integer to " ++ s

vLen :: Array Int ScmValue -> IO Int
vLen = return . (+1) . snd . bounds

mvLen :: IOArray Int ScmValue -> IO Int
mvLen = fmap ((+1) . snd) . getBounds

max_stars_repo_name: Deewiant/haschoo

max_issues_repo_name: Deewiant/haschoo

max_forks_repo_name: Deewiant/haschoo


text:
{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE FlexibleContexts #-}

module Poisson1D
where

import qualified Basis
import           Data.List
import           Element               as E
import           Mesh
import           Numeric.LinearAlgebra
import           Quadrature            (integrate)
import qualified ShapeFcns

-- Synonym for numeric/fractional constraints
type FrElNuFi a = (Fractional a,Element a,Numeric a,Field a)

-- Element stiffness integrand
stiffnessIntegrand :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> [a] -> Matrix a
stiffnessIntegrand elem shpFcn xi = fromLists [[]]

-- Element mass integrand
massIntegrand :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> [a] -> Matrix a
massIntegrand elem shpFcn xi = fromLists [[]]

-- Element mass and stiffness matrices
-- Must multiply by the determinant of the Jacobian here!!!
elemMatrices :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> Int -> (Matrix a,Matrix a)
elemMatrices elem shpFcn ngpts = (stiffnessMat, massMat)
  where
    stiffnessMat = integrate 1 ngpts (stiffnessIntegrand elem shpFcn)
    massMat      = integrate 1 ngpts (massIntegrand elem shpFcn)

assembleSubMatrix :: FrElNuFi a =>

-- Function which assembles the global stiffness and mass matrices
assembleGlobalMatrices :: (E.Element e, ShapeFcns.ShapeFcn s,Basis.Basis b, FrElNuFi a) => Mesh e a -> s b -> Int -> a -> [[((Int,Int),a)]]
assembleGlobalMatrices grid shpFcn ngpts advSpd = [globalK, globalM, globalF]
  where
    globalK = []
    globalM = []
    globalF = []

-- Function for applying boundary conditions
applyBCs _ = []


text:
module Numeric.Sundials
  ( -- * The solving function
    solve
    -- * Problem specification
  , OdeRhsCType
  , OdeRhs(..)
  , odeRhsPure
  , OdeJacobianCType
  , OdeJacobian(..)
  , UserData
  , JacobianRepr(..)
  , SparsePattern(..)
  , OdeProblem(..)
    -- * Events
  , EventHandler
  , EventHandlerResult(..)
  , EventConditionCType
  , EventConditions(..)
  , eventConditionsPure
  , CrossingDirection(..)
  , TimeEventSpec(..)
    -- * Solution
  , SundialsDiagnostics(..)
  , ErrorDiagnostics(..)
  , SundialsSolution(..)
    -- * Solving options
  , ODEOpts(..)
  , OdeMethod(..)
  , ARK.ARKMethod(..)
  , CV.CVMethod(..)
  , allOdeMethods
  , IsMethod(..)
  , MethodType(..)
  , Tolerances(..)
    -- * Low-level types from sundials
  , SunVector(..)
  , SunMatrix(..)
  , SunIndexType
  , SunRealType
    -- * Offsets
    -- ** NVector
  , nvectorContentOffset
    -- ** NVector_SERIAL
  , nvectorContentSerialLengthOffset
  , nvectorContentSerialDataOffset
    -- ** SUNMatrix
  , sunmatrixContentOffset
    -- ** SUNMatrix_DENSE
  , sunmatrixContentDenseDataOffset
    -- ** SUNMatrix_SPARSE
  , sunmatrixContentSparseIndexvalsOffset
  , sunmatrixContentSparseIndexptrsOffset
  , sunmatrixContentSparseDataOffset
  , sunmatrixContentSparseNnzOffset
  ) where

import Numeric.Sundials.Common
import Numeric.Sundials.Foreign
import qualified Numeric.Sundials.CVode as CV
import qualified Numeric.Sundials.ARKode as ARK
import Katip

import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable (peek, poke)
import Numeric.Sundials.Foreign as T
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Maybe
import Data.Int
import Numeric.LinearAlgebra.HMatrix as H hiding (Vector)
import GHC.Prim
import GHC.Generics
import Control.Monad.IO.Class
import Control.Monad.Cont
import Control.Exception

-- | A supported ODE solving method, either by CVode or ARKode
data OdeMethod
  = CVMethod CV.CVMethod
  | ARKMethod ARK.ARKMethod
  deriving (Eq, Ord, Show, Read, Generic)

-- | List of all supported ODE methods
allOdeMethods :: [OdeMethod]
allOdeMethods =
  (CVMethod <$> [minBound .. maxBound]) ++
  (ARKMethod <$> [minBound .. maxBound])

instance IsMethod OdeMethod where
  methodToInt = \case
    ARKMethod m -> methodToInt m
    CVMethod m -> methodToInt m
  methodType = \case
    ARKMethod m -> methodType m
    CVMethod m -> methodType m

data ODEOpts = ODEOpts {
    maxNumSteps :: Int32
  , minStep     :: Double
  , fixedStep   :: Double
      -- ^ If this is greater than 0.0, then a fixed-size step is used.
      --
      -- This is only recommended for testing/debugging, not for production
      -- use.
      --
      -- Also, this only has effect for ARKode; using this with CVode will
      -- trigger an error.
  , maxFail     :: Int32
  , odeMethod   :: OdeMethod
  , initStep    :: Maybe Double
    -- ^ initial step size - by default, CVode
    -- estimates the initial step size to be the
    -- solution \(h\) of the equation
    -- \(\|\frac{h^2\ddot{y}}{2}\| = 1\), where
    -- \(\ddot{y}\) is an estimated value of the second
    -- derivative of the solution at \(t_0\)
  , jacobianRepr :: JacobianRepr
    -- ^ use a sparse matrix to represent the Jacobian
    -- and a sparse linear solver for Newton iterations
  } deriving (Show)

-- | Solve an ODE system using either ARKode or CVode (depending on what
-- @method@ is instantiated with).
solve
  :: forall m . Katip m
  => ODEOpts -- ^ solver options
  -> OdeProblem -- ^ the ODE system to solve
  -> m (Either ErrorDiagnostics SundialsSolution)
solve opts =
  let
    solveC =
      case odeMethod opts of
        CVMethod{} -> CV.solveC
        ARKMethod{} -> ARK.solveC
  in
    solveCommon solveC opts

-- | The common solving logic between ARKode and CVode
solveCommon
  :: (Katip m)
  => (CConsts -> CVars (VS.MVector RealWorld) -> LogEnv -> IO CInt)
      -- ^ the CVode/ARKode solving function; mostly inline-C code
  -> ODEOpts
  -> OdeProblem
  -> m (Either ErrorDiagnostics SundialsSolution)
solveCommon solve_c opts problem@(OdeProblem{..})

  | VS.null odeInitCond = -- 0-dimensional (empty) system

    return . Right $ SundialsSolution
      { actualTimeGrid = odeSolTimes
      , solutionMatrix = (VS.length odeSolTimes >< 0) []
      , diagnostics = mempty
      }

  | otherwise = do

    log_env <- getLogEnv
    liftIO $ do -- the rest is in the IO monad
    vars <- allocateCVars problem
    ret <- withCConsts opts problem $ \consts ->
      solve_c consts vars log_env
    frozenVars <- freezeCVars vars
    assembleSolverResult problem ret frozenVars

withCConsts
  :: ODEOpts
  -> OdeProblem
  -> (CConsts -> IO r)
  -> IO r
withCConsts ODEOpts{..} OdeProblem{..} = runContT $ do
  let
    dim = VS.length c_init_cond
    c_init_cond = coerce odeInitCond
    c_dim = fromIntegral dim
    c_n_sol_times = fromIntegral . VS.length $ odeSolTimes
    c_sol_time = coerce odeSolTimes
    c_rtol = relTolerance odeTolerances
    c_atol = either (VS.replicate dim) id $ absTolerances odeTolerances
    c_minstep = coerce minStep
    c_fixedstep = coerce fixedStep
    c_max_n_steps = fromIntegral maxNumSteps
    c_max_err_test_fails = fromIntegral maxFail
    c_init_step_size_set = fromIntegral . fromEnum $ isJust initStep
    c_init_step_size = coerce . fromMaybe 0 $ initStep
    c_n_event_specs = fromIntegral $ V.length odeEventDirections
    c_requested_event_direction = V.convert $ V.map directionToInt odeEventDirections
    c_apply_event n_events event_indices_ptr t y_ptr y'_ptr stop_solver_ptr record_event_ptr = do
      event_indices <- vecFromPtr event_indices_ptr (fromIntegral n_events)
      y_vec <- peek y_ptr
      EventHandlerResult{..} <-
        odeEventHandler
          (coerce t :: Double)
          (coerce $ sunVecVals y_vec :: VS.Vector Double)
          (VS.map fromIntegral event_indices :: VS.Vector Int)
      poke y'_ptr $ SunVector
        { sunVecN = sunVecN y_vec
        , sunVecVals = coerce eventNewState
        }
      poke stop_solver_ptr . fromIntegral $ fromEnum eventStopSolver
      poke record_event_ptr . fromIntegral $ fromEnum eventRecord
      return 0
    c_max_events = fromIntegral odeMaxEvents
    c_next_time_event = coerce odeTimeBasedEvents
    c_jac_set = fromIntegral . fromEnum $ isJust odeJacobian
    c_sparse_jac = case jacobianRepr of
      SparseJacobian (T.SparsePattern spat) ->
        VS.sum (VS.map fromIntegral spat) +
        -- additionally, add diagonal zeros, as they'll be allocated too
        sum [ if spat VS.! (i + i * dim) == 0 then 1 else 0 | i <- [0 .. dim-1] ]
      DenseJacobian -> 0
    c_method = methodToInt odeMethod

  (c_rhs, c_rhs_userdata) <-
    case odeRhs of
      OdeRhsC ptr u -> return (ptr, u)
      OdeRhsHaskell fun -> do
        let
          funIO :: OdeRhsCType
          funIO t y f _ptr = do
            sv <- peek y
            r <- fun t (sunVecVals sv)
            poke f $ SunVector { sunVecN = sunVecN sv
                               , sunVecVals = r
                               }
            return 0
        funptr <- ContT $ bracket (mkOdeRhsC funIO) freeHaskellFunPtr
        return (funptr, nullPtr)
  c_jac <-
    case odeJacobian of
      Nothing   -> return nullFunPtr
      Just (OdeJacobianC fptr) -> return fptr
      Just (OdeJacobianHaskell jac_fn) -> do
      let
        funIO :: OdeJacobianCType
        funIO t y_ptr _fy_ptr jac_ptr _userdata _tmp1 _tmp2 _tmp3 = do
          y <- peek y_ptr
          let jac = matrixToSunMatrix $
                jac_fn
                  (coerce t :: Double)
                  (coerce $ sunVecVals y :: VS.Vector Double)
          case jacobianRepr of
            DenseJacobian -> poke jac_ptr jac
            SparseJacobian spat -> poke (castPtr jac_ptr) (T.SparseMatrix spat jac)
          return 0
      funptr <- ContT $ bracket (mkOdeJacobianC funIO) freeHaskellFunPtr
      return funptr
  c_event_fn <-
    case odeEventConditions of
      EventConditionsC fptr -> return fptr
      EventConditionsHaskell f -> do
      let
        funIO :: EventConditionCType
        funIO t y_ptr out_ptr _ptr = do
              y <- sunVecVals <$> peek y_ptr
              -- FIXME: We should be able to use poke somehow
              T.vectorToC (coerce f t y) (fromIntegral c_n_event_specs) out_ptr
              return 0
      funptr <- ContT $ bracket (mkEventConditionsC funIO) freeHaskellFunPtr
      return funptr
  return CConsts{..}

max_stars_repo_name: novadiscovery/hmatrix-sundials

max_issues_repo_name: novadiscovery/hmatrix-sundials

max_forks_repo_name: novadiscovery/hmatrix-sundials


text:
{-# OPTIONS_GHC -Wall                   #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

{-# LANGUAGE DataKinds #-}

module HaddockExample ( main ) where

import           Numeric.LinearAlgebra.Static
                 ( R, vector, Sym,
                   headTail, matrix, sym
                 )
import           Data.Random.Distribution.MultiNormal
import           Numeric.Kalman
import           Numeric.LinearAlgebra.Static

import Graphics.Rendering.Chart hiding ( Vector )
import Graphics.Rendering.Chart.Backend.Diagrams
import Diagrams.Backend.Cairo.CmdLine
import Diagrams.Prelude hiding ( render, Renderable, sample )
import Diagrams.Backend.CmdLine

import Data.Csv
import System.IO hiding ( hGetContents )
import Data.ByteString.Lazy ( hGetContents )
import qualified Data.Vector as V

deltaT, g :: Double
deltaT = 0.01
g  = 9.81

bigQ :: Sym 2
bigQ = sym $ matrix bigQl

qc1 :: Double
qc1 = 0.01

bigQl :: [Double]
bigQl = [ qc1 * deltaT^3 / 3, qc1 * deltaT^2 / 2,
           qc1 * deltaT^2 / 2,       qc1 * deltaT
         ]

bigR :: Sym 1
bigR  = sym $ matrix [0.1]

observe :: R 2 -> R 1
observe a = vector [sin x] where x = fst $ headTail a

linearizedObserve :: R 2 -> L 1 2
linearizedObserve a = matrix [cos x, 0.0] where x = fst $ headTail a

stateUpdate :: R 2 -> R 2
stateUpdate u =  vector [x1 + x2 * deltaT, x2 - g * (sin x1) * deltaT]
  where
    (x1, w) = headTail u
    (x2, _) = headTail w

linearizedStateUpdate :: R 2 -> Sq 2
linearizedStateUpdate u = matrix [1.0,                    deltaT,
                                  -g * (cos x1) * deltaT,    1.0]
  where
    (x1, _) = headTail u

singleEKF :: MultiNormal (R 2) -> R 1 -> MultiNormal (R 2)
singleEKF = runEKF (const observe) (const linearizedObserve) (const bigR)
             (const stateUpdate) (const linearizedStateUpdate) (const bigQ)
             undefined

singleUKF :: MultiNormal (R 2) -> R 1 -> MultiNormal (R 2)
singleUKF = runUKF (const observe) (const bigR) (const stateUpdate) (const bigQ)
             undefined

initialDist :: MultiNormal (R 2)
initialDist = MultiNormal (vector [1.6, 0.0])
                          (sym $ matrix [0.1, 0.0,
                                         0.0, 0.1])

multiEKF :: [ℝ] -> [MultiNormal (R 2)]
multiEKF obs = scanl singleEKF initialDist (map (vector . pure) obs)

multiUKF :: [ℝ] -> [MultiNormal (R 2)]
multiUKF obs = scanl singleUKF initialDist (map (vector . pure) obs)

denv :: IO (DEnv Double)
denv = defaultEnv vectorAlignmentFns 600 500

diagEstimated :: String ->
                 [(Double, Double)] ->
                 [(Double, Double)] ->
                 [(Double, Double)] ->
                 IO (Diagram Cairo)
diagEstimated t l xs es = do
  env <- denv
  return $ fst $ runBackend env (render (chartEstimated t l xs es) (600, 500))

chartEstimated :: String ->
              [(Double, Double)] ->
              [(Double, Double)] ->
              [(Double, Double)] ->
              Renderable ()
chartEstimated title acts obs ests = toRenderable layout
  where

    actuals = plot_lines_values .~ [acts]
            $ plot_lines_style  . line_color .~ opaque red
            $ plot_lines_title .~ "Actual Trajectory"
            $ plot_lines_style  . line_width .~ 1.0
            $ def

    measurements = plot_points_values .~ obs
                 $ plot_points_style  . point_color .~ opaque blue
                 $ plot_points_title .~ "Measurements"
                 $ def

    estimas = plot_lines_values .~ [ests]
            $ plot_lines_style  . line_color .~ opaque black
            $ plot_lines_title .~ "Inferred Trajectory"
            $ plot_lines_style  . line_width .~ 1.0
            $ def

    layout = layout_title .~ title
           $ layout_plots .~ [toPlot actuals, toPlot measurements, toPlot estimas]
           $ layout_y_axis . laxis_title .~ "Angle / Horizontal Displacement"
           $ layout_y_axis . laxis_override .~ axisGridHide
           $ layout_x_axis . laxis_title .~ "Time"
           $ layout_x_axis . laxis_override .~ axisGridHide
           $ def

displayHeader :: FilePath -> Diagram B -> IO ()
displayHeader fn =
  mainRender ( DiagramOpts (Just 900) (Just 700) fn
             , DiagramLoopOpts False Nothing 0
             )

main :: IO ()
main = do
  h <- openFile "matlabRNGs.csv" ReadMode
  cs <- hGetContents h
  let df = (decode NoHeader cs) :: Either String (V.Vector (Double, Double))
  case df of
    Left _ -> error "Whatever"
    Right generatedSamples -> do
      let xs = take 500 (multiEKF $ V.toList $ V.map fst generatedSamples)
      let mus = map (fst . headTail . mu) xs
      let obs = V.toList $ V.map fst generatedSamples
      let acts = V.toList $ V.map snd generatedSamples
      de1 <- diagEstimated "Fitted Pendulum"
             (zip [0,1..] acts)
             (zip [0,1..] obs)
             (zip [0,1..] mus)
      displayHeader "diagrams/PendulumFittedEkf.png" de1
      let ys = take 500 (multiUKF $ V.toList $ V.map fst generatedSamples)
      let nus = map (fst . headTail . mu) ys
      de2 <- diagEstimated "Fitted Pendulum"
             (zip [0,1..] acts)
             (zip [0,1..] obs)
             (zip [0,1..] nus)
      displayHeader "diagrams/PendulumFittedUkf.png" de2

max_stars_repo_name: idontgetoutmuch/Kalman

max_issues_repo_name: f-o-a-m/Kalman

max_forks_repo_name: f-o-a-m/Kalman


text:
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleContexts      #-}

-- This is a simple generative adversarial network to make pictures
-- of numbers similar to those in MNIST.
--
-- It demonstrates a different usage of the library. Within about 15
-- minutes it was producing examples like this:
--
--               --.
--     .=-.--..#=###
--     -##==#########.
--     #############-
--   -###-.=..-.-==
--   ###-
--   .###-
--   .####...==-.
--   -####=--.=##=
--   -##=-     -##
--             =##
--           -##=
--           -###-
--         .####.
--         .#####.
-- ...---=#####-
-- .=#########.         .
--   .#######=.          .
--     . =-.
--
-- It's a 5!
--
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Random

import           Codec.Compression.GZip ( decompress )
import           Data.Serialize ( Get )
import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Lazy as B

import           Data.List ( foldl' )
import           Data.List.Split ( chunksOf )
import           Data.Maybe ( fromMaybe )
#if ! MIN_VERSION_base(4,13,0)
import           Data.Semigroup ( (<>) )
#endif

import           Data.Word ( Word32 , Word8 )
import qualified Data.Vector.Storable as V

import qualified Numeric.LinearAlgebra.Static as SA
import           Numeric.LinearAlgebra.Data ( toLists )

import           Options.Applicative
import           System.FilePath ( (</>) )

import           Grenade
import           Grenade.Utils.OneHot

type Discriminator =
  Network
    '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
     , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Relu
     , Reshape, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]
    '[ 'D2 28 28
     , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
     , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16
     , 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]

type Generator =
  Network
    '[ FullyConnected 80 256, Relu, Reshape
     , Deconvolution 16 10 5 5 2 2, Relu
     , Deconvolution 10 1 8 8 2 2, Logit]
    '[ 'D1 80
     , 'D1 256, 'D1 256, 'D3 4 4 16
     , 'D3 11 11 10, 'D3 11 11 10
     , 'D2 28 28, 'D2 28 28 ]

randomDiscriminator :: MonadRandom m => m Discriminator
randomDiscriminator = randomNetwork

randomGenerator :: MonadRandom m => m Generator
randomGenerator = randomNetwork

trainExample :: LearningParameters -> Discriminator -> Generator -> S ('D2 28 28) -> S ('D1 80) -> ( Discriminator, Generator )
trainExample rate discriminator generator realExample noiseSource
 = let (generatorTape, fakeExample)       = runNetwork generator noiseSource

       (discriminatorTapeReal, guessReal) = runNetwork discriminator realExample
       (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample

       (discriminator'real, _)            = runGradient discriminator discriminatorTapeReal ( guessReal - 1 )
       (discriminator'fake, _)            = runGradient discriminator discriminatorTapeFake guessFake
       (_, push)                          = runGradient discriminator discriminatorTapeFake ( guessFake - 1)

       (generator', _)                    = runGradient generator generatorTape push

       newDiscriminator                   = foldl' (applyUpdate rate { learningRegulariser = learningRegulariser rate * 10}) discriminator [ discriminator'real, discriminator'fake ]
       newGenerator                       = applyUpdate rate generator generator'
   in ( newDiscriminator, newGenerator )

ganTest :: (Discriminator, Generator) -> Int -> FilePath -> LearningParameters -> IO (Discriminator, Generator)
ganTest (discriminator0, generator0) iterations dataDir rate = do
  -- Note that for this example we use only the samples, and not the labels
  trainData      <- fmap fst <$> readMNIST (dataDir </> "train-images-idx3-ubyte.gz")
                                           (dataDir </> "train-labels-idx1-ubyte.gz")

  foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]

    where

  showShape' :: S ('D2 a b) -> IO ()
  showShape' (S2D mm) = putStrLn $
    let m  = SA.extract mm
        ms = toLists m
        render n'  | n' <= 0.2  = ' '
                   | n' <= 0.4  = '.'
                   | n' <= 0.6  = '-'
                   | n' <= 0.8  = '='
                   | otherwise =  '#'

        px = (fmap . fmap) render ms
    in unlines px

  runIteration :: [S ('D2 28 28)] -> (Discriminator, Generator) -> Int -> IO (Discriminator, Generator)
  runIteration trainData ( !discriminator, !generator ) _ = do
    trained'    <- foldM ( \(!discriminatorX, !generatorX ) realExample ->
                             trainExample rate discriminatorX generatorX realExample <$> randomOfShape )
                         ( discriminator, generator ) trainData

    showShape' . snd . runNetwork (snd trained') =<< randomOfShape

    return trained'

data GanOpts = GanOpts FilePath Int LearningParameters (Maybe FilePath) (Maybe FilePath)

mnist' :: Parser GanOpts
mnist' = GanOpts <$> argument str (metavar "DATADIR")
                 <*> option auto (long "iterations" <> short 'i' <> value 15)
                 <*> (LearningParameters
                       <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
                       <*> option auto (long "momentum" <> value 0.9)
                       <*> option auto (long "l2" <> value 0.0005)
                       )
                 <*> optional (strOption (long "load"))
                 <*> optional (strOption (long "save"))

main :: IO ()
main = do
  GanOpts mnist iter rate load save <- execParser (info (mnist' <**> helper) idm)
  putStrLn "Training stupidly simply GAN"
  nets0 <- case load of
    Just loadFile -> netLoad loadFile
    Nothing -> (,) <$> randomDiscriminator <*> randomGenerator

  nets1 <- ganTest nets0 iter mnist rate
  case save of
    Just saveFile -> B.writeFile saveFile $ Serialize.runPutLazy (Serialize.put nets1)
    Nothing -> return ()

-- Adapted from https://github.com/tensorflow/haskell/blob/master/tensorflow-mnist/src/TensorFlow/Examples/MNIST/Parse.hs
-- Could also have used Data.IDX, although that uses a different Vector variant from that need for fromStorable
readMNIST :: FilePath -> FilePath -> IO [(S ( 'D2 28 28), S ( 'D1 10))]
readMNIST iFP lFP = do
  labels  <- readMNISTLabels lFP
  samples <- readMNISTSamples iFP
  return $ zip
    (fmap (fromMaybe (error "bad samples") . fromStorable) samples)
    (fromMaybe (error "bad labels") . oneHot . fromIntegral <$> labels)

-- | Check's the file's endianess, throwing an error if it's not as expected.
checkEndian :: Get ()
checkEndian = do
  magic <- Serialize.getWord32be
  when (magic `notElem` ([2049, 2051] :: [Word32]))
    $ error "Expected big endian, but image file is little endian."

-- | Reads an MNIST file and returns a list of samples.
readMNISTSamples :: FilePath -> IO [V.Vector Double]
readMNISTSamples path = do
  raw <- decompress <$> B.readFile path
  either fail ( return . fmap (V.map normalize) ) $ Serialize.runGetLazy getMNIST raw
 where
  getMNIST :: Get [V.Vector Word8]
  getMNIST = do
    checkEndian
    -- Parse header data.
    cnt    <- fromIntegral <$> Serialize.getWord32be
    rows   <- fromIntegral <$> Serialize.getWord32be
    cols   <- fromIntegral <$> Serialize.getWord32be
    -- Read all of the data, then split into samples.
    pixels <- Serialize.getLazyByteString $ fromIntegral $ cnt * rows * cols
    return $ V.fromList <$> chunksOf (rows * cols) (B.unpack pixels)

  normalize :: Word8 -> Double
  normalize = (/ 255) . fromIntegral
  -- There are other normalization functions in the literature, such as
  -- normalize = (/ 0.3081) . (`subtract` 0.1307) . (/ 255) . fromIntegral
  -- but we need values in the range [0..1] for the showShape' pretty printer

-- | Reads a list of MNIST labels from a file and returns them.
readMNISTLabels :: FilePath -> IO [Word8]
readMNISTLabels path = do
  raw <- decompress <$> B.readFile path
  either fail return $ Serialize.runGetLazy getLabels raw
 where
  getLabels :: Get [Word8]
  getLabels = do
    checkEndian
    -- Parse header data.
    cnt <- fromIntegral <$> Serialize.getWord32be
    -- Read all of the labels.
    B.unpack <$> Serialize.getLazyByteString cnt

netLoad :: FilePath -> IO (Discriminator, Generator)
netLoad modelPath = do
  modelData <- B.readFile modelPath
  either fail return $
    Serialize.runGetLazy (Serialize.get :: Get (Discriminator, Generator)) modelData


text:
-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Debugging facilities, in particular to analyze the internal structure of
-- a 'SEXP' as structured JSON.
--
-- This module is intended to be imported qualified.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Language.R.Debug
  ( inspect )
  where

import Control.Memory.Region (V)
import qualified Data.Vector.SEXP as Vector
import qualified Foreign.R as R
import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE, SEXPInfo)
import Foreign.R.Type (IsVector)
import Foreign.Storable
import Language.R.Globals as H
import Language.R.HExp

import Data.Complex
import System.IO.Unsafe ( unsafePerformIO )

import Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy.Char8 as LBS

instance ToJSON SEXPTYPE where
  toJSON = A.String . T.pack . show

instance ToJSON SEXPInfo where
  toJSON x =
    object
      [ "type"  .= R.infoType x
      , "obj"   .= R.infoObj x
      , "named" .= R.infoNamed x
      , "gp"    .= R.infoGp x
      , "mark"  .= R.infoMark x
      , "debug" .= R.infoDebug x
      , "trace" .= R.infoTrace x
      , "spare" .= R.infoSpare x
      , "gcgen" .= R.infoGcGen x
      , "gccls" .= R.infoGcCls x
      ]

instance ToJSON a => ToJSON (Complex a) where
  toJSON (x :+ y) =
    object ["Re" .= x, "Im" .= y]

instance ToJSON (SEXP s a) where
  toJSON x =
      object
        [ "header" .= info
        , "attributes" .= if R.unsexp x == R.unsexp attr then "loop" else toJSON attr
        , tp .= go x
        ]
    where
      vector :: (IsVector a, ToJSON (Vector.ElemRep V a), Storable (Vector.ElemRep V a))
             => Vector.Vector a (Vector.ElemRep V a) -> V.Vector Value
      vector = V.fromList . map toJSON . Vector.toList -- XXX: do not use lists
      ub = R.unsexp H.unboundValue
      nil = R.unsexp H.nilValue
      miss = R.unsexp H.missingArg
      info = unsafePerformIO $ R.peekInfo x
      attr = unsafePerformIO $ R.getAttributes x
      tp = T.pack . show $ R.infoType info
      go :: SEXP s a -> Value
      go y | R.unsexp y == ub   = A.String "UnboundValue"
           | R.unsexp y == nil  = A.String "NilValue"
           | R.unsexp y == miss = A.String "MissingArg"
      go (hexp -> Nil) = A.String "NilValue"
      go (hexp -> Lang i j) =
          object [ "function" .= i
                 , "parameters" .= j
                 ]
      go h@(hexp -> Symbol i j k) =
          object [ "name" .= i
                 , "value" .= if R.unsexp j == R.unsexp h then "loop" else toJSON j
                 , "internal" .= k
                 ]
      go (hexp -> Special i) = object ["index" .= i]
      go (hexp -> Builtin i) = object ["index" .= i]
      go (hexp -> Char v) = A.String (T.pack (Vector.toString v))
      go (hexp -> Int v) = A.Array (vector v)
      go (hexp -> Real v) = A.Array (vector v)
      go (hexp -> Complex v) = A.Array (vector v)
      go (hexp -> Vector _ v) = A.Array (vector v)
--  String    :: {-# UNPACK #-} !(Vector.Vector (SEXP (R.Vector Word8)))
--            -> HExp (R.Vector (SEXP (R.Vector Word8)))
      go (hexp -> List i j k) =
          object [ "value" .= i
                 , "next"  .= j
                 , "tag"   .= k
                 ]
      go (hexp -> Env _ _ _) = A.String "Environment"
      go (hexp -> Closure f b e) =
         object [ "formals" .= f
                , "body" .= b
                , "environment" .= e
                ]
      go (hexp -> Promise vl ex en) =
          object [ "value" .= vl
                 , "expr" .= ex
                 , "environment" .= en
                 ]
      go (hexp -> DotDotDot v) =
          object [ "promises" .= v]
      go (hexp -> Expr _ v)   = A.Array (vector v)
      go (hexp -> Bytecode) = A.String "Bytecode"
      go (hexp -> ExtPtr _ a b) =
          object [ "ptr" .= A.String "<PTR>"
                 , "second" .= a
                 , "symbol" .= b
                 ]
      go (hexp -> WeakRef k v fn nxt) =
          object [ "key" .= k
                 , "value" .= v
                 , "finalizer" .= fn
                 , "next" .= nxt
                 ]
      go (hexp -> Raw _bs) = A.String "<data>"
      go (hexp -> S4 s) =
          object [ "tagval" .= s ]
      go _ = A.String "Unimplemented."

instance ToJSON (SomeSEXP s) where
  toJSON (R.SomeSEXP s) = toJSON s

inspect :: SEXP s a -> String
inspect = LBS.unpack . A.encode

max_stars_repo_name: reactormonk/HaskellR

max_issues_repo_name: reactormonk/HaskellR

max_forks_repo_name: reactormonk/HaskellR


text:
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Grenade.Recurrent.Layers.BasicRecurrent (
    BasicRecurrent (..)
  ) where

import           Data.Proxy
import           Data.Singletons.TypeLits     hiding (natVal)

#if MIN_VERSION_base(4,9,0)
import           Data.Kind                    (Type)
#endif

import           Numeric.LinearAlgebra.Static

import           GHC.TypeLits

import           Grenade.Core
import           Grenade.Recurrent.Core
import           Grenade.Utils.LinearAlgebra

data BasicRecurrent :: Nat -- Input layer size
                    -> Nat -- Output layer size
                    -> Type where
  BasicRecurrent :: ( KnownNat input
                    , KnownNat output
                    , KnownNat matrixCols
                    , matrixCols ~ (input + output))
                 => !(R output)   -- Bias neuron weights
                 -> !(R output)   -- Bias neuron momentum
                 -> !(L output matrixCols) -- Activation
                 -> !(L output matrixCols) -- Momentum
                 -> BasicRecurrent input output

data BasicRecurrent' :: Nat -- Input layer size
                     -> Nat -- Output layer size
                     -> Type where
  BasicRecurrent' :: ( KnownNat input
                     , KnownNat output
                     , KnownNat matrixCols
                     , matrixCols ~ (input + output))
                  => !(R output)   -- Bias neuron gradients
                  -> !(L output matrixCols)
                  -> BasicRecurrent' input output

instance Show (BasicRecurrent i o) where
  show BasicRecurrent {} = "BasicRecurrent"

instance FoldableGradient (BasicRecurrent' input output) where
  mapGradient f (BasicRecurrent' bias act) = BasicRecurrent' (dvmap f bias) (dmmap f act)
  squaredSums (BasicRecurrent' bias act) = [sumV . squareV $ bias, sumM . squareM $ act]

instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where
  type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

  runUpdate (OptSGD lRate lMomentum lRegulariser) (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
    let newBiasMomentum = konst lMomentum * oldBiasMomentum - konst lRate * biasGradient
        newBias         = oldBias + newBiasMomentum
        newMomentum     = konst lMomentum * oldMomentum - konst lRate * activationGradient
        regulariser     = konst (lRegulariser * lRate) * oldActivations
        newActivations  = oldActivations + newMomentum - regulariser
    in BasicRecurrent newBias newBiasMomentum newActivations newMomentum
  runUpdate _ l d = runUpdate defOptimizer l d
  reduceGradient = error "Attempt to reduce gradient of batch in BasicRecurrent instance"

instance (KnownNat i, KnownNat o, KnownNat x, KnownNat (x*o), x ~ (i+o)) => RandomLayer (BasicRecurrent i o) where
  createRandomWith m gen = do
    wB <- getRandomVector i o m gen
    wN <- getRandomMatrix i o m gen
    let bm = konst 0
        mm = konst 0
    return $ BasicRecurrent wB bm wN mm
      where i = natVal (Proxy :: Proxy i)
            o = natVal (Proxy :: Proxy o)

instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where
  type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

  type RecTape (BasicRecurrent i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))
  -- Do a matrix vector multiplication and return the result.
  runRecurrentForwards (BasicRecurrent wB _ wN _) (S1D lastOutput) (S1D thisInput) =
    let thisOutput = S1D $ wB + wN #> (thisInput # lastOutput)
    in ((S1D lastOutput, S1D thisInput), thisOutput, thisOutput)

  -- Run a backpropogation step for a full connected layer.
  runRecurrentBackwards (BasicRecurrent _ _ wN _) (S1D lastOutput, S1D thisInput) (S1D dRec) (S1D dEdy) =
    let biasGradient        = (dRec + dEdy)
        layerGrad           = (dRec + dEdy) `outer` (thisInput # lastOutput)
        -- calcluate derivatives for next step
        (backGrad, recGrad) = split $ tr wN #> (dRec + dEdy)
    in  (BasicRecurrent' biasGradient layerGrad, S1D recGrad, S1D backGrad)

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Test.Hedgehog.Hmatrix where

import           GHC.Stack                    (HasCallStack,
                                               withFrozenCallStack)

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

import           GHC.TypeLits

import           Hedgehog                     (Gen, MonadTest, diff)
import qualified Hedgehog.Gen                 as Gen
import qualified Hedgehog.Range               as Range

import           Numeric.LinearAlgebra        (norm_Inf)
import           Numeric.LinearAlgebra.Data   hiding ((===))
import qualified Numeric.LinearAlgebra.Static as H

import           Test.Hedgehog.Compat

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

randomPositiveVector :: forall n. ( KnownNat n ) =>  Gen (H.R n)
randomPositiveVector = (\s -> H.randomVector s H.Uniform) <$> Gen.int Range.linearBounded

randomVectorNormalised :: forall n. ( KnownNat n ) =>  Gen (H.R n)
randomVectorNormalised = (\s -> sigmoid ((H.randomVector s H.Uniform) * 2 - 1)) <$> Gen.int Range.linearBounded
  where
    sigmoid :: Floating a => a -> a
    sigmoid x = 1/(1 + exp (-x))

uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (H.L m n)
uniformSample = (\s -> H.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
    D4Sing n c h w ->
      withKnownNat n $ withKnownNat c $ withKnownNat h $ withKnownNat w $
        S4D <$> uniformSample

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

allClose :: SingI shape => S shape -> S shape -> Bool
allClose xs ys = case xs - ys of
  (S1D x) -> H.norm_Inf x < 0.0001
  (S2D x) -> H.norm_Inf x < 0.0001
  (S3D x) -> H.norm_Inf x < 0.0001
  (S4D x) -> H.norm_Inf x < 0.0001

allCloseP :: SingI shape => S shape -> S shape -> RealNum -> Bool
allCloseP xs ys p = case xs - ys of
  (S1D x) -> H.norm_Inf x < p
  (S2D x) -> H.norm_Inf x < p
  (S3D x) -> H.norm_Inf x < p
  (S4D x) -> H.norm_Inf x < p

allCloseV :: KnownNat n => H.R n -> H.R n -> Bool
allCloseV xs ys = H.norm_Inf (xs - ys) < 0.0001

-- | generate a 2D list with random elements
genLists :: Int -> Int -> Gen [[RealNum]]
genLists height width = Gen.list (Range.singleton height) $ Gen.list (Range.singleton width) (genRealNum (Range.constant (-2.0) 2.0))

genLists3D :: Int -> Int -> Int -> Gen [[[RealNum]]]
genLists3D depth height width
  = Gen.list (Range.singleton depth) $
      Gen.list (Range.singleton height) $
        Gen.list (Range.singleton width)
          (genRealNum (Range.constant (-2.0) 2.0))

extractVec :: KnownNat n => S ('D1 n) -> [RealNum]
extractVec (S1D vec) = toList $ H.extract vec

extractMat :: (KnownNat a, KnownNat b) => S ('D2 a b) -> [[RealNum]]
extractMat (S2D mat) = toLists $ H.extract mat

extractMat3D :: (KnownNat a, KnownNat b, KnownNat c) => S ('D3 a b c) -> [[RealNum]]
extractMat3D (S3D mat) = toLists $ H.extract mat

extractMat4D :: (KnownNat a, KnownNat b, KnownNat c, KnownNat d, KnownNat (a * b * c)) => S ('D4 a b c d) -> [[RealNum]]
extractMat4D (S4D mat) = toLists $ H.extract mat

elementsEqual :: SingI shape => S shape -> Bool
elementsEqual m = case m of
  S1D x -> listSameElements . toList $ H.extract x
  S2D x -> listSameElements . concat . toLists $ H.extract x
  S3D x -> listSameElements . concat . toLists $ H.extract x
  S4D x -> listSameElements . concat . toLists $ H.extract x

listSameElements :: Eq a => [a] -> Bool
listSameElements []  = True
listSameElements [_] = True
listSameElements (x:x':xs)
  | x == x'   = listSameElements (x':xs)
  | otherwise = False

maxVal :: S shape -> RealNum
maxVal ( S1D x ) = norm_Inf x
maxVal ( S2D x ) = norm_Inf x
maxVal ( S3D x ) = norm_Inf x
maxVal ( S4D x ) = norm_Inf x

isSimilarMatrixTo :: (MonadTest m, HasCallStack) => Matrix RealNum -> Matrix RealNum -> m ()
isSimilarMatrixTo x y =
  withFrozenCallStack $
    diff x (\a b -> norm_Inf (a - b) < precision) y

isSimilarVectorTo :: (MonadTest m, HasCallStack) => Vector RealNum -> Vector RealNum -> m ()
isSimilarVectorTo x y =
  withFrozenCallStack $
    diff x (\a b -> norm_Inf (a - b) < precision) y


text:
module Statistics.Dispersion where

import Statistics.Center

variance :: (Foldable t, Functor t, Fractional a) => t a -> a
variance vals = (sum $ fmap (\x -> x * x) deviations) / n
    where n = (fromIntegral $ length vals)
          mu = arithmeticMean vals
          deviations = fmap (\x -> x-mu) vals

stdev :: (Foldable t, Functor t, Floating a) => t a -> a
stdev vals = sqrt $ variance vals

max_stars_repo_name: ethansaxenian/RosettaDecode

max_issues_repo_name: ethansaxenian/RosettaDecode

max_forks_repo_name: ethansaxenian/RosettaDecode


text:
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import qualified Sound.Pulse.Simple as Pulse
import Control.Exception (bracket, finally)
import qualified Math.FFT as FFT
import Data.Array.IArray (amap, listArray)
import qualified Data.Array.IArray as IArray
import Data.Complex (Complex(..))
import Pipes
import qualified Pipes.Prelude as Pipes
import Graphics.Rendering.OpenGL (GLfloat)
import Graphics.DynamicGraph.FillLine
import Graphics.DynamicGraph.Line
import Graphics.DynamicGraph.Window
import Control.Monad (unless, guard, forever, when)
import Control.Error.Util (exceptT)
import Foreign.C.Types (CInt (..))
import Data.Foldable (for_)
import Data.Maybe (isJust)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.TH as Aeson.TH
import qualified Data.Yaml as Yaml
import qualified Data.Yaml.Pretty as Yaml.Pretty
import System.Environment (getArgs)
import Data.IORef
import qualified Data.ByteString.Char8 as BSC8

-- key presses
-- --------------------------------------------------------------------

foreign import ccall "fakekey_init"    fakeKeyInit    :: IO ()
foreign import ccall "fakekey_press"   fakeKeyPress   :: CInt -> IO ()
foreign import ccall "fakekey_release" fakeKeyRelease :: CInt -> IO ()

keyCodeToX11KeySym :: String -> Maybe CInt
keyCodeToX11KeySym code = case code of
  "KeyA" -> Just 0x0061
  "KeyB" -> Just 0x0062
  "KeyC" -> Just 0x0063
  "KeyD" -> Just 0x0064
  "KeyE" -> Just 0x0065
  "KeyF" -> Just 0x0066
  "KeyG" -> Just 0x0067
  "KeyH" -> Just 0x0068
  "KeyI" -> Just 0x0069
  "KeyJ" -> Just 0x006a
  "KeyK" -> Just 0x006b
  "KeyL" -> Just 0x006c
  "KeyM" -> Just 0x006d
  "KeyN" -> Just 0x006e
  "KeyO" -> Just 0x006f
  "KeyP" -> Just 0x0070
  "KeyQ" -> Just 0x0071
  "KeyR" -> Just 0x0072
  "KeyS" -> Just 0x0073
  "KeyT" -> Just 0x0074
  "KeyU" -> Just 0x0075
  "KeyV" -> Just 0x0076
  "KeyW" -> Just 0x0077
  "KeyX" -> Just 0x0078
  "KeyY" -> Just 0x0079
  "KeyZ" -> Just 0x007a
  "ArrowLeft" -> Just 0xff51
  "ArrowUp" -> Just 0xff52
  "ArrowRight" -> Just 0xff53
  "ArrowDown" -> Just 0xff54
  "Space" -> Just 0x0020
  _ -> Nothing

-- fft
-- --------------------------------------------------------------------

sampleRate :: Int
sampleRate = 16000

numSamples :: Int
numSamples = 512

fftFreqs :: [Float]
fftFreqs = 0 : (do
  let binWidth :: Float = fromIntegral sampleRate / fromIntegral numSamples
  ix <- fromIntegral <$> [1..numSamples]
  let freq = binWidth * ix
  -- filter frequencies above 2000, they're not very useful for what
  -- we're doing
  guard (freq < 2000)
  return freq)

fft :: [Float] -> [Float]
fft signal = IArray.elems $ amap
  (\(real :+ imag) -> sqrt (real ** 2 + imag ** 2))
  (FFT.dftRC (listArray (0, numSamples-1) signal))

-- reading audio
-- --------------------------------------------------------------------

data Graph = Audio | Frequency
  deriving (Show, Eq)
instance Aeson.FromJSON Graph where
  parseJSON = Aeson.withText "Graph" $ \case
    "Audio" -> return Audio
    "Frequency" -> return Frequency
    txt -> fail ("Invalid graph " ++ show txt)

data Params = Params
  { paramsAmplitudeCoefficient :: GLfloat
  , paramsAmplitudeLowTreshold :: GLfloat
  , paramsAmplitudeHighTreshold :: GLfloat
  -- ^ what the minimum scaled peak frequency should be to trigger high / low
  , paramsFrequncyTreshold :: GLfloat
  } deriving (Eq, Show)
Aeson.TH.deriveJSON
  Aeson.defaultOptions{ Aeson.fieldLabelModifier = drop (length ("params" :: String))}
  ''Params

data Options = Options
  { optionsPrintBestFreq :: Bool -- ^ wether to print what the chosen frequency
  , optionsControls :: Maybe (String, String) -- ^ what to press when low and high
  , optionsGraph :: Graph
  } deriving (Eq, Show)
Aeson.TH.deriveFromJSON
  Aeson.defaultOptions{ Aeson.fieldLabelModifier = drop (length ("options" :: String))}
  ''Options

data Frame = Frame
  { frameAudio :: [GLfloat]
  , frameFrequencies :: [GLfloat]
  -- ^ the frequencies amplitudes are scaled by paramsAmplitudeCoefficient
  }

-- returns the unscaled frame
readFrame :: Pulse.Simple -> IO Frame
readFrame spl = do
  frameAudio <- Pulse.simpleRead spl numSamples
  let frameFrequencies = take (length fftFreqs) (fft frameAudio)
  return Frame{..}

audioFreqs :: Pulse.Simple -> Params -> Producer Frame IO void
audioFreqs spl Params{..} = forever $ do
  frame <- lift (readFrame spl)
  yield frame{ frameFrequencies = map (* paramsAmplitudeCoefficient) (frameFrequencies frame) }

data LowHigh = Low | High
  deriving (Eq, Show)

computeLowHigh :: Options -> Params -> [GLfloat] -> IO (Maybe LowHigh)
computeLowHigh Options{..} Params{..} freqs = do
  let weightedAvg = sum (zipWith (*) fftFreqs freqs) / sum freqs
  let mbLowHigh = do
        let lowHigh = if weightedAvg < paramsFrequncyTreshold then Low else High
        guard $ case lowHigh of
          Low -> maximum freqs > paramsAmplitudeLowTreshold
          High -> maximum freqs > paramsAmplitudeHighTreshold
        return lowHigh
  when (optionsPrintBestFreq && isJust mbLowHigh) $ do
    putStrLn ("best freq: " ++ show weightedAvg)
  return mbLowHigh

control :: Options -> Params -> Pipe Frame Frame IO ()
control options@Options{..} params@Params{..} = go Nothing
  where
    go mbLowHigh = do
      frame@(Frame _ freqs) <- await
      newMbLowHigh <- lift (computeLowHigh options params freqs)
      lift $ case (mbLowHigh, newMbLowHigh) of
        (Nothing, Nothing) -> return ()
        (Nothing, Just newLowHigh) -> do
          putStrLn ("Going from idle to " ++ show newLowHigh)
          keyPress newLowHigh
        (Just lowHigh, Nothing) -> do
          putStrLn ("Going from " ++ show lowHigh ++ " to idle")
          keyRelease lowHigh
        (Just lowHigh, Just newLowHigh) | lowHigh == newLowHigh -> return ()
        (Just lowHigh, Just newLowHigh) -> do
          putStrLn ("Going from " ++ show lowHigh ++ " to " ++ show lowHigh)
          keyRelease lowHigh
          keyPress newLowHigh
      yield frame
      go newMbLowHigh

    keyPress lowHigh = for_ optionsControls $ \(lowKey, highKey) -> case lowHigh of
      Low -> do
        Just keyCode <- return (keyCodeToX11KeySym lowKey)
        fakeKeyPress keyCode
      High -> do
        Just keyCode <- return (keyCodeToX11KeySym highKey)
        fakeKeyPress keyCode

    keyRelease lowHigh = for_ optionsControls $ \(lowKey, highKey) -> case lowHigh of
      Low -> do
        Just keyCode <- return (keyCodeToX11KeySym lowKey)
        fakeKeyRelease keyCode
      High -> do
        Just keyCode <- return (keyCodeToX11KeySym highKey)
        fakeKeyRelease keyCode

calibrate :: Pulse.Simple -> IORef GLfloat -> Producer Frame IO void
calibrate spl maxFreqRef = forever $ do
  maxFreq <- lift (readIORef maxFreqRef)
  frame <- lift (readFrame spl)
  lift (writeIORef maxFreqRef (max maxFreq (maximum (frameFrequencies frame))))
  yield frame

main :: IO ()
main = do
  bracket
    (Pulse.simpleNew
      Nothing "pitch-control" Pulse.Record Nothing "Pitch controls for your keyboard"
      (Pulse.SampleSpec (Pulse.F32 Pulse.LittleEndian) sampleRate 1) Nothing Nothing)
    Pulse.simpleFree
    (\spl -> exceptT error return $ do
      res <- lift setupGLFW
      unless res (error "Unable to initilize GLFW")
      args <- lift getArgs
      case args of
        ["calibrate"] -> do
          maxFreqRef <- lift (newIORef 0)
          render <- window 1024 480 (fmap pipeify (renderFilledLine (length fftFreqs) jet_mod))
          let tranformFreqs = forever $ do
                frame <- await
                maxFreq <- lift (readIORef maxFreqRef)
                yield (map (/ maxFreq) (frameFrequencies frame))
          lift $ finally (runEffect (calibrate spl maxFreqRef >-> tranformFreqs >-> render)) $ do
            maxFreq <- readIORef maxFreqRef
            BSC8.putStrLn $ Yaml.Pretty.encodePretty Yaml.Pretty.defConfig Params
              { paramsAmplitudeCoefficient = 1 / maxFreq
              , paramsAmplitudeLowTreshold = 0.1
              , paramsAmplitudeHighTreshold = 0.2
              , paramsFrequncyTreshold = 700
              }
        ["run", paramsFile, optionsFile] -> do
          params <- lift (either (error . Yaml.prettyPrintParseException) id <$> Yaml.decodeFileEither paramsFile)
          options <- lift (either (error . Yaml.prettyPrintParseException) id <$> Yaml.decodeFileEither optionsFile)
          lift fakeKeyInit
          render <- window 1024 480 $ fmap pipeify $ case optionsGraph options of
            Frequency -> renderFilledLine (length fftFreqs) jet_mod
            Audio -> renderLine numSamples 1024
          let data_ = Pipes.map $ case optionsGraph options of
                Frequency -> frameFrequencies
                Audio -> map ((+ 0.5) . (/ 2)) . frameAudio
          lift (runEffect (audioFreqs spl params >-> control options params >-> data_ >-> render)))

max_stars_repo_name: bitonic/pitch-control

max_issues_repo_name: bitonic/pitch-control

max_forks_repo_name: bitonic/pitch-control


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators    #-}
module FokkerPlanck.Interpolation where

import           Data.Array.Repa as R
import           Data.Complex
import           Data.List       as L
import           Filter.Utils
import           Types

{-# INLINE radialCubicInterpolation #-}
radialCubicInterpolation ::
     (R.Source r1 Double, R.Source r2 (Complex Double), Shape sh)
  => R.Array r1 (sh :. Int) Double
  -> Double
  -> R.Array r2 (sh :. Int :. Int) (Complex Double)
  -> R.Array D (sh :. Int :. Int) (Complex Double)
radialCubicInterpolation radialArr scaleFactor inputArr =
  let (_ :. n) = extent radialArr
      (_ :. nx :. ny) = extent inputArr
   in if scaleFactor == 0
        then error "radialCubicInterpolation: scaleFactor = 0"
        else R.traverse2 inputArr radialArr const $ \fInput fRadial idx@(sh :. i :. j) ->
               let r =
                     (sqrt . fromIntegral $
                      (i - center nx) ^ 2 + (j - center ny) ^ 2) /
                     scaleFactor
                in if r < 0 || r > (fromIntegral $ n - 1) -- out of boundary. When r = 0, log r makes no sense, and therefore the information at r = 0 should not be used to interpoalte 0 < r <= 1.
                     then 0
                     else if r <= 1 -- linear interpolation
                            then fInput idx *
                                 ((fRadial (sh :. 1) +
                                   (r - 1) *
                                   (fRadial (sh :. 2) - fRadial (sh :. 1))) :+
                                  0)
                            else if r >= (fromIntegral $ n - 2) -- linear interpolation
                                   then fInput idx *
                                        ((fRadial (sh :. n - 2) +
                                          (r - (fromIntegral $ n - 2)) *
                                          (fRadial (sh :. n - 1) -
                                           fRadial (sh :. n - 2))) :+
                                         0)
                                   else let x0 = floor r -- cubic interpolation
                                            p0 = fRadial (sh :. x0 - 1)
                                            p1 = fRadial (sh :. x0)
                                            p2 = fRadial (sh :. x0 + 1)
                                            p3 = fRadial (sh :. x0 + 2)
                                            x = r - fromIntegral x0
                                         in fInput idx *
                                            (((-0.5 * p0 + 1.5 * p1 - 1.5 * p2 +
                                               0.5 * p3) *
                                              x ^ 3 +
                                              (p0 - 2.5 * p1 + 2 * p2 - 0.5 * p3) *
                                              x ^ 2 +
                                              (-0.5 * p0 + 0.5 * p2) * x +
                                              p1) :+
                                             0)

{-# INLINE cubicInterpolation #-}
cubicInterpolation ::
     (R.Source s Double)
  => R.Array s DIM5 Double
  -> Double
  -> R.Array D DIM4 Double
cubicInterpolation arr r =
  let (Z :. _ :. _ :. _ :. _ :. n) = extent arr
   in R.traverse arr (\(sh :. _) -> sh) $ \f sh@(Z :. tf :. sf :. t0f :. s0f) ->
        if r < 0 || r > (fromIntegral $ n - 1) -- out of boundary. When r = 0, log r makes no sense, and therefore the information at r = 0 should not be used to interpoalte 0 < r <= 1.
          then 0
          else if r <= 1 -- linear interpolation
                 then (f (sh :. 1) + (r - 1) * (f (sh :. 2) - f (sh :. 1)))
                 else if r >= (fromIntegral $ n - 2) -- linear interpolation
                        then (f (sh :. n - 2) +
                              (r - (fromIntegral $ n - 2)) *
                              (f (sh :. n - 1) - f (sh :. n - 2)))
                        else let x0 = floor r -- cubic interpolation
                                 p0 = f (sh :. x0 - 1)
                                 p1 = f (sh :. x0)
                                 p2 = f (sh :. x0 + 1)
                                 p3 = f (sh :. x0 + 2)
                                 x = r - fromIntegral x0
                              in ((-0.5 * p0 + 1.5 * p1 - 1.5 * p2 + 0.5 * p3) *
                                  x ^ 3 +
                                  (p0 - 2.5 * p1 + 2 * p2 - 0.5 * p3) * x ^ 2 +
                                  (-0.5 * p0 + 0.5 * p2) * x +
                                  p1)

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
module Tests.SpecFunctions where

import Test.QuickCheck  hiding (choose,within)
--import Test.Framework
--import Test.Framework.Providers.QuickCheck2
--import Numeric.SpecFunctions

max_stars_repo_name: aharol/datools

max_issues_repo_name: aharol/datools

max_forks_repo_name: aharol/datools


text:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}

module MLP.Types (
   Pattern(..),
   input,
   output,
   DataSet(..),
   trainSet,
   testSet,
   Parameters(..),
   topology,
   learningRate,
   decayLearningRate,
   normalise,
   epochs,
   minErrorRate,
   trainFile,
   testFile,
   verbose,
   Topology(..),
   numInputs,
   hiddenLayers,
   numOutputs,
   topoFold,
   dataSet,
   params,
   State(..),
   network,
   curEpoch,
   curError,
   App(..),
   zipWithPat,
   MonadFileSystem(..)
)  where

import Control.Lens (makeLenses, (^..), (^.), ix, folding, Fold)
import Data.Aeson (FromJSON(..), withObject, withArray, (.:), (.:?), (.!=))
import Numeric.LinearAlgebra.Data (Vector, Matrix, loadMatrix)
import Numeric.LinearAlgebra.Static (R, L, zipWithVector)
import Data.Aeson.Lens (key, values, _Integral)
import Data.Aeson.TH (deriveToJSON, defaultOptions, Options(..))
import Control.Monad (guard)
import Data.Maybe (fromMaybe)
import Control.Monad.State.Lazy (StateT(..), runStateT)
import Control.Monad.Writer.Lazy (Writer(..), runWriter)
import qualified Data.Text as T
import Data.Functor.Identity (Identity)
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.ByteString.Lazy as B
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.State.Class (MonadState(..))
import GHC.TypeLits ( KnownNat, Nat )
import MLP.Network (Net(..), AllCon, Learn(..), MLP(..))
import Data.Singletons (SingI(..))
import Numeric.Natural ( Natural )
import qualified Data.Text.IO as TIO (putStrLn)

data Pattern (i :: Nat) (o :: Nat) = Pattern {
   _input :: R i,
   _output :: R o
} deriving Show

-- rank 2 function
apply :: (forall n. R n -> R n -> R n) -> Pattern i o -> Pattern i o -> Pattern i o
apply f (Pattern in1 out1) (Pattern in2 out2) = Pattern (f in1 in2) (f out1 out2)

zipWithPat :: (KnownNat i, KnownNat o) => (Double -> Double -> Double) -> Pattern i o -> Pattern i o -> Pattern i o
zipWithPat f (Pattern i1 o1) (Pattern i2 o2) =
   Pattern (zipWithVector f i1 i2) (zipWithVector f o1 o2)

instance Num (Pattern i o) where
   (-) p1 p2 = apply (-) p1 p2
   (+) p1 p2 = apply (+) p1 p2
   (*) p1 p2 = apply (*) p1 p2
   abs (Pattern inp out) = Pattern (abs inp) (abs out)
   signum (Pattern inp out) = Pattern (signum inp) (signum out)
   fromInteger num = Pattern (fromInteger num) (fromInteger num)

instance Fractional (Pattern i o) where
   (/) p1 p2 = apply (/) p1 p2
   recip (Pattern inp out) = Pattern (recip inp) (recip out)
   fromRational rat = Pattern (fromRational rat) (fromRational rat)

data DataSet i o = DataSet {
   _trainSet :: [Pattern i o],
   _testSet :: [Pattern i o]
} deriving Show

data Topology = Topology {
   _numInputs :: Natural,
   _hiddenLayers :: [Natural],
   _numOutputs :: Natural
} deriving Show

data Parameters = Parameters {
   _topology :: Topology,
   _learningRate :: Double,
   _decayLearningRate :: Bool,
   _epochs :: Natural,
   _minErrorRate :: Double,
   _normalise :: Bool,
   _trainFile :: FilePath,
   _testFile :: FilePath,
   _verbose :: Bool
} deriving Show

data State i hs o = State {
   _dataSet :: DataSet i o,
   _params :: Parameters,
   _network :: !(Net i hs o),
   _curEpoch :: Natural,
   _curError :: Double
}

makeLenses ''Pattern
makeLenses ''DataSet
makeLenses ''Topology

topoFold :: Fold Topology Natural
topoFold = folding $ \s -> (s ^. numInputs) : (s ^. hiddenLayers) ++ (s ^.. numOutputs)

makeLenses ''Parameters
makeLenses ''State

type Log = [T.Text]

newtype App (i :: Nat) (hs :: [Nat]) (o :: Nat) (a :: *) = App {
   -- | this is an unpacked StateT (StateT i hs o) (Writer Log) a
   runApp :: State i hs o -> ((a, State i hs o), Log)
}

instance Functor (App i hs o) where
   fmap f (App app) =
      App $ \s ->
         let ((!a,!s'),!l) = app s
            in ((f a,s'),l)

instance Applicative (App i hs o) where
   pure a = App $ \s -> ((a,s), mempty)

   (App fab) <*> (App fa) =
      App $ \s ->
         let ((!ab,!s'),!l) = fab s
             ((a, s''), l') = fa s'
            in ((ab a, s''), l <> l')

instance Monad (App i hs o) where
   return = pure

   (App ma) >>= amb =
      App $ \s ->
         let ((!a, !s'), !l) = ma s
             ((b, s''), l') = runApp (amb a) s'
            in ((b, s''), l <> l')

instance MonadWriter Log (App i hs o) where
   writer (!a, !l) = App $ \s -> ((a,s),l)
   tell !l = App $ \s -> (((),s),l)
   listen (App app) =
      App $ \s ->
         let ((!a,!s''),!l) = app s
            in (((a,l),s''),l)

   pass (App app) =
      App $ \s ->
         let (((!a,!f),!s'),!l) = app s
            in ((a,s'),l)

instance MonadState (State i hs o) (App i hs o) where
   get = App $ \s -> ((s,s),mempty)
   put s = App . const $ (((), s), mempty)
   state app = App ((,mempty).app)

class (Monad m, MonadFail m) => MonadFileSystem m where
   readFileM :: FilePath -> m B.ByteString
   readMatrixM :: FilePath -> m (Matrix Double)
   printText :: T.Text -> m ()

instance MonadFileSystem IO where
   readFileM fl = B.readFile fl
   readMatrixM = loadMatrix
   printText = TIO.putStrLn

$(deriveToJSON defaultOptions{fieldLabelModifier=drop 1} ''Topology)
$(deriveToJSON defaultOptions{fieldLabelModifier=drop 1} ''Parameters)

instance FromJSON Topology where
   parseJSON = withObject "Topology" (\o -> do
      inputs <- o .: "numInputs"
      guard (inputs > 0)

      outputs <- o .: "numOutputs"
      guard (outputs > 0)

      let hidden =  o ^.. ix "hiddenLayers".values._Integral

      return $ Topology inputs hidden outputs)

instance FromJSON Parameters where
   parseJSON = withObject "Parameters" (\o -> do
      _topology <- o .: "topology"
      _learningRate <- o .:? "learningRate" .!= 0.6
      _decayLearningRate <- o .:? "decayLearningRate" .!= False
      _normalise <- o .:? "normalise" .!= False
      _epochs <- o .:? "epochs" .!= 1000
      _minErrorRate <- o .: "minErrorRate"
      _trainFile <- o .: "trainFile"
      _testFile <- o .: "testFile"

      _verbose <- o .:? "verbose" .!= False

      return $ Parameters {..})

max_stars_repo_name: ovanr/Typed-MLP

max_issues_repo_name: ovanr/Typed-MLP

max_forks_repo_name: ovanr/Typed-MLP