text:
-- |
-- Module      : Occlusion.Lenses
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 20 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Lenses where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Lens
import Data.Complex
import Data.Functor
import qualified Data.Set as S
import qualified Data.Map as M

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import qualified Southpaw.Picasso.Palette as Palette

import Occlusion.Types

--------------------------------------------------------------------------------------------------------------------------------------------
-- Lenses
--------------------------------------------------------------------------------------------------------------------------------------------
-- AppState --------------------------------------------------------------------------------------------------------------------------------

gui :: Lens AppState AppState GUI GUI
gui f s = (\new -> s { _gui=new }) <$> f (_gui s)

animation :: Lens AppState AppState AnimationData AnimationData
animation f s = (\new -> s { _animation=new }) <$> f (_animation s)

input :: Lens AppState AppState InputData InputData
input f s = (\new -> s { _input=new }) <$> f (_input s)

scene :: Lens AppState AppState Scene Scene
scene f s = (\new -> s { _scene=new }) <$> f (_scene s)

assets :: Lens AppState AppState Assets Assets
assets f s = (\new -> s { _assets=new }) <$> f (_assets s)

-- GUI -------------------------------------------------------------------------------------------------------------------------------------

window :: Lens GUI GUI Window Window
window f s = (\new -> s { _window=new }) <$> f (_window s)

canvas :: Lens GUI GUI DrawingArea DrawingArea
canvas f s = (\new -> s { _canvas=new }) <$> f (_canvas s)

-- InputData -------------------------------------------------------------------------------------------------------------------------------

mouse :: Lens InputData InputData (Complex Double) (Complex Double)
mouse f s = (\new -> s { _mouse=new }) <$> f (_mouse s)

click :: Lens InputData InputData (Maybe (Complex Double)) (Maybe (Complex Double))
click f s = (\new -> s { _click=new }) <$> f (_click s)

keyboard :: Lens InputData InputData (S.Set String) (S.Set String)
keyboard f s = (\new -> s { _keyboard=new }) <$> f (_keyboard s)

-- AnimationData ---------------------------------------------------------------------------------------------------------------------------

fps :: Lens AnimationData AnimationData Double Double
fps f s = (\new -> s { _fps=new }) <$> f (_fps s)

frame :: Lens AnimationData AnimationData Int Int
frame f s = (\new -> s { _frame=new }) <$> f (_frame s)

-- Scene -----------------------------------------------------------------------------------------------------------------------------------

player :: Lens Scene Scene Character Character
player f s = (\new -> s { _player=new }) <$> f (_player s)

npcs :: Lens Scene Scene [Character] [Character]
npcs f s = (\new -> s { _npcs=new }) <$> f (_npcs s)

obstacles :: Lens Scene Scene [Polygon Double] [Polygon Double]
obstacles f s = (\new -> s { _obstacles=new }) <$> f (_obstacles s)

-- Complex ---------------------------------------------------------------------------------------------------------------------------------

images :: Lens Assets Assets (M.Map String Cairo.Surface) (M.Map String Cairo.Surface)
images f s = (\new -> s { _images=new }) <$> f (_images s)

-- Character -------------------------------------------------------------------------------------------------------------------------------

position :: Lens Character Character (Complex Double) (Complex Double)
position f s = (\new -> s { _position=new }) <$> f (_position s)

velocity :: Lens Character Character (Complex Double) (Complex Double)
velocity f s = (\new -> s { _velocity=new }) <$> f (_velocity s)

name :: Lens Character Character String String
name f s = (\new -> s { _name=new }) <$> f (_name s)

colour :: Lens Character Character (Palette.Colour Double) (Palette.Colour Double)
colour f s = (\new -> s { _colour=new }) <$> f (_colour s)

behaviour :: Lens Character Character (Behaviour Character AppState Character) (Behaviour Character AppState Character)
behaviour f s = (\new -> s { _behaviour=new }) <$> f (_behaviour s)

-- Complex ---------------------------------------------------------------------------------------------------------------------------------

real :: Lens (Complex n) (Complex n) n n
real f (re:+im) = (:+im) <$> f re

imag :: Lens (Complex n) (Complex n) n n
imag f (re:+im) = (re:+) <$> f im

-- List ------------------------------------------------------------------------------------------------------------------------------------

-- nth :: Functor f => Int -> (Character -> f Character) -> [Character] -> f [Character]
nth :: Int -> Lens [a] [a] a a
nth i f s = assemble <$> f (s !! i)
  where
    assemble new = let (before, _:fter) = splitAt i s in before ++ [new] ++ fter

-- Lines -----------------------------------------------------------------------------------------------------------------------------------

linebegin :: Lens (Line a) (Line a) (Complex a) (Complex a)
linebegin f (Line fr to) = (`Line` to) <$> f fr

linestop :: Lens (Line a) (Line a) (Complex a) (Complex a)
linestop f (Line fr to) = (fr `Line`) <$> f to

max_stars_repo_name: SwiftsNamesake/Occlusion

max_issues_repo_name: SwiftsNamesake/Occlusion

max_forks_repo_name: SwiftsNamesake/Occlusion


text:
{-# LANGUAGE ScopedTypeVariables #-}

module Main (main) where

import Data.Complex
import Data.Monoid ((<>))
import Text.PrettyPrint.Mainland
import Control.Monad.IO.Class (liftIO)

import Spiral
import Spiral.Exp
import Spiral.FFT.CooleyTukey
import Spiral.SPL
import Spiral.Util.Pretty.Maple

main :: IO ()
main = defaultMain $ \args -> do
    n <- case args of
           [s] -> return (read s)
           _   -> return 4
    let dft_n :: SPL (Exp (Complex Double))
        dft_n = dit n
    --liftIO $ check dft_n
    liftIO $ putDocLn $ text "with(LinearAlgebra);"
    liftIO $ putDocLn $ text "A :=" <+> ppr (DFT n :: SPL (Exp (Complex Double))) <> semi
    liftIO $ putDocLn $ text "B :=" <+> ppr dft_n <> semi

ext: hs

max_stars_repo_name: mainland/hspiral

max_issues_repo_name: mainland/hspiral

max_forks_repo_name: mainland/hspiral


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

module Year2021.Day11 where

import Safe
import Numeric.LinearAlgebra
import System.FilePath

run :: Matrix Z -> Matrix Z
run grid = findJust ((<= 9) . maxElement) $ iterate f (grid + 1) where
  f grid = (grid + conv) * cond grid 0 1 0 1 * cond grid 9 1 1 0 where
    conv = conv2 (konst 1 (3, 3)) (cond grid 9 0 0 1)
      ?? (Drop 1, Drop 1) ?? (DropLast 1, DropLast 1)

part1, part2 :: [Matrix Z] -> Z
part1 = sum . map (sumElements . (1 -) . step) . take 100 . tail
part2 = fromIntegral . findIndexJust ((== 0) . sumElements)

main = readFile (replaceExtension __FILE__ ".in") >>=
  print . part2 . iterate run . fromLists . map (map (read . pure)) . lines


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# language RankNTypes #-}

-- | A \"confusing\" default implementation of a 'Traversable'-like class that
-- produces code very much like derived instances. It uses the same magic
-- behind @Control.Lens.Traversal.confusing@.
module Generics.Deriving.TraversableConf (
  -- * Generic Traversable class
    GTraversable(..)

  -- * Default method
  , gtraversedefault

  -- * Internal Traversable class
  , GTraversable'(..)

  ) where

import           Control.Applicative (Const, WrappedMonad(..), ZipList)
import qualified Data.Monoid as Monoid (First, Last, Product, Sum)
import           Data.Monoid (Dual)
import           Generics.Linear
import           Generics.Deriving.Foldable
import           Generics.Deriving.Functor
import           Data.Complex (Complex)
import           Data.Ord (Down)
import           Data.Proxy (Proxy)
import           Data.Functor.Identity (Identity)
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.Functor.Compose (Compose)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)

--------------------------------------------------------------------------------
-- Generic traverse
--------------------------------------------------------------------------------

class GTraversable' t where
  gtraverse' :: Applicative f => (a -> f b) -> t a -> CY f (t b)

instance GTraversable' V1 where
  gtraverse' _ x = pure $ case x of

instance GTraversable' U1 where
  gtraverse' _ U1 = pure U1

instance GTraversable' Par1 where
  gtraverse' f (Par1 a) = Par1 <$> liftCY (f a)

instance GTraversable' (K1 i c) where
  gtraverse' _ (K1 a) = pure (K1 a)

instance GTraversable' f => GTraversable' (M1 i c f) where
  gtraverse' f (M1 a) = M1 <$> gtraverse' f a

instance GTraversable' f => GTraversable' (MP1 m f) where
  gtraverse' f (MP1 a) = (\x -> MP1 x) <$> gtraverse' f a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where
  gtraverse' f (L1 a) = L1 <$> gtraverse' f a
  gtraverse' f (R1 a) = R1 <$> gtraverse' f a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where
  gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b

instance (GTraversable' f, GTraversable g) => GTraversable' (f :.: g) where
  gtraverse' f (Comp1 x) = Comp1 <$> gtraverse' (gtraverse f) x

instance GTraversable' UAddr where
  gtraverse' _ (UAddr a) = pure (UAddr a)

instance GTraversable' UChar where
  gtraverse' _ (UChar c) = pure (UChar c)

instance GTraversable' UDouble where
  gtraverse' _ (UDouble d) = pure (UDouble d)

instance GTraversable' UFloat where
  gtraverse' _ (UFloat f) = pure (UFloat f)

instance GTraversable' UInt where
  gtraverse' _ (UInt i) = pure (UInt i)

instance GTraversable' UWord where
  gtraverse' _ (UWord w) = pure (UWord w)

class (GFunctor t, GFoldable t) => GTraversable t where
  gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)
  default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                    => (a -> f b) -> t a -> f (t b)
  gtraverse = gtraversedefault

  gsequenceA :: Applicative f => t (f a) -> f (t a)
  gsequenceA = gtraverse id

  gmapM :: Monad m => (a -> m b) -> t a -> m (t b)
  gmapM f = unwrapMonad . gtraverse (WrapMonad . f)

  gsequence :: Monad m => t (m a) -> m (t a)
  gsequence = gmapM id

gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                 => (a -> f b) -> t a -> f (t b)
gtraversedefault f x = lowerCY $ to1 <$> gtraverse' f (from1 x)
{-# INLINE gtraversedefault #-}

-- Base types instances
instance GTraversable ((,) a)
instance GTraversable ((,,) a b)
instance GTraversable ((,,,) a b c)
instance GTraversable []
instance GTraversable (Arg a)
instance GTraversable Complex
instance GTraversable (Const m)
instance GTraversable Down
instance GTraversable Dual
instance GTraversable (Either a)
instance GTraversable Monoid.First
instance GTraversable (Semigroup.First)
instance GTraversable Identity
instance GTraversable Monoid.Last
instance GTraversable Semigroup.Last
instance GTraversable Max
instance GTraversable Maybe
instance GTraversable Min
instance GTraversable NonEmpty
instance GTraversable Monoid.Product
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g)
instance (GTraversable f, GTraversable g) => GTraversable (Compose f g)
instance GTraversable Proxy
instance GTraversable Monoid.Sum
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g)
instance GTraversable WrappedMonoid
instance GTraversable ZipList

-- The types below are stolen from kan-extensions, and used in the same way as
-- Control.Lens.Traversal.confusing. Note that this is *not* equivalent to
-- applying `confusing` itself to a plain traversal: the latter seems to make a
-- mess with types like
--
--   data Gramp f a = Gramp Int a (f a)

newtype Curried g h a = Curried (forall r. g (a -> r) -> h r)

instance Functor g => Functor (Curried g h) where
  fmap f (Curried g) = Curried (g . fmap (.f))
  {-# INLINE fmap #-}

instance (Functor g, g ~ h) => Applicative (Curried g h) where
  pure a = Curried (fmap ($ a))
  {-# INLINE pure #-}
  Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
  {-# INLINE (<*>) #-}

lowerCurried :: Applicative f => Curried f g a -> g a
lowerCurried (Curried f) = f (pure id)
{-# INLINE lowerCurried #-}

newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }

lowerYoneda :: Yoneda f a -> f a
lowerYoneda (Yoneda f) = f id
{-# INLINE lowerYoneda #-}

instance Functor (Yoneda f) where
  fmap f m = Yoneda (\k -> runYoneda m (k . f))
  {-# INLINE fmap #-}

instance Applicative f => Applicative (Yoneda f) where
  pure a = Yoneda (\f -> pure (f a))
  {-# INLINE pure #-}
  Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
  {-# INLINE (<*>) #-}

-- Lifted from the implementation of Control.Lens.Traversal.confusing
liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) (Yoneda f) a
liftCurriedYoneda fa = Curried (`yap` fa)
{-# INLINE liftCurriedYoneda #-}

yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
{-# INLINE yap #-}

-- This wrapper makes it easy to swap out implementations.
-- See, for example, https://github.com/glguy/generic-traverse,
-- which is essentially the same but uses a custom @Boggle@
-- type. I don't have a good sense of the tradeoffs between
-- the two.
newtype CY f a = CY { unCY :: Curried (Yoneda f) (Yoneda f) a }
  deriving newtype (Functor, Applicative)

liftCY :: Applicative f => f a -> CY f a
liftCY = CY . liftCurriedYoneda

lowerCY :: Applicative f => CY f a -> f a
lowerCY = lowerYoneda . lowerCurried . unCY

max_stars_repo_name: treeowl/linear-generics

max_issues_repo_name: treeowl/linear-generics

max_forks_repo_name: treeowl/linear-generics


text:
module Neural.MNIST where

import Control.Monad
import Data.Bits
import qualified Data.ByteString.Lazy as BSL
import Numeric.LinearAlgebra
import System.IO

readLittleEndian :: Handle -> IO (Int)
readLittleEndian hdl =
  (liftM BSL.reverse $ BSL.hGet hdl 4)
  >>= (\bytes -> return $
                foldl (\res (byte, i) -> res + (shift (fromIntegral byte) $ i * 8))
                0 $ zip (BSL.unpack bytes) [0..])

loadMNISTImages :: FilePath -> IO (Maybe [(Matrix Double)])
loadMNISTImages path =
  withBinaryFile path ReadMode readMNIST
  where readMNIST hdl =
          do test <- readLittleEndian hdl
             case test of
               2051 ->
                 (do imageCount <- readLittleEndian hdl
                     imageWidth <- readLittleEndian hdl
                     imageHeight <- readLittleEndian hdl

                     liftM Just $ readImages hdl imageWidth imageHeight)

               _ -> return Nothing

        readImages hdl w h = do
          img <- (readImage hdl w h)
          case img of
            Just img -> liftM2 (:) (return img) (readImages hdl w h)
            Nothing -> return []

        readImage hdl w h =
          (BSL.hGet hdl (w * h))
          >>= (\bytes ->
                if (fromIntegral $ BSL.length bytes) == (fromIntegral $ (w * h))
                then return $ Just $
                     (w><h) $ map (\pixel -> fromIntegral pixel / 255.0) $ BSL.unpack bytes
                else return Nothing)

loadMNISTLabels :: FilePath -> IO (Maybe [Int])
loadMNISTLabels path =
  withBinaryFile path ReadMode readMNIST
  where readMNIST hdl =
          do test <- readLittleEndian hdl
             case test of
               2049 -> (readLittleEndian hdl) >>= (readLabels hdl)
               _ -> return Nothing

        readLabels hdl labelCount =
          (BSL.hGet hdl labelCount)
          >>= (\bytes ->
                if (fromIntegral $ BSL.length bytes) == (fromIntegral labelCount)
                then return $ Just $ map fromIntegral $ BSL.unpack bytes
                else return Nothing)

loadMNISTDataSet :: FilePath -> FilePath -> IO (Maybe [((Matrix Double), Int)])
loadMNISTDataSet imagesPath labelsPath =
  do maybeImages <- loadMNISTImages imagesPath
     maybeLabels <- loadMNISTLabels labelsPath

     case (maybeImages,maybeLabels) of
       (Just images, Just labels) -> return $ Just $ zip images labels
       (_,_) -> return Nothing

printMNISTImage :: (Matrix Double) -> IO ()
printMNISTImage image = putStr $ foldl (++) "" $ map printRow (toLists image)
  where printRow row = (reverse $ foldl (\str e -> (if e > 0.5 then '#' else ' ') : str) [] row) ++ "\n"


text:
-- | An attempt at writing QuickHull in quintessential Haskell.
-- | I am just writing the simple 2D version for now.

module QuickHull (qhull2D) where

import           Control.Arrow
import           Control.Monad
import           Data.DList                   (DList)
import qualified Data.DList                   as D
import           Data.Foldable                (asum)
import qualified Data.List                    as L (splitAt)
import           Data.Maybe
import           Data.Ord
import qualified Data.Vector                  as V
import           Data.Vector.Algorithms.Intro as I
import qualified Data.Vector.Unboxed          as UV
import           Numeric.LinearAlgebra        (peps)

data Region2D
    = R021
    | R201
    | R012
    deriving (Show,Eq,Ord)

qhull2D
    :: V.Vector (UV.Vector Double)
    -> [UV.Vector Double]
qhull2D vecs
  | V.length vecs < 4 = V.toList vecs
  | otherwise =
      D.toList $ D.fromList [ax, bx, ay, by] `mappend`
                 qhull2DHelper ax by regU021 `mappend`
                 qhull2DHelper by bx regU201 `mappend`
                 qhull2DHelper bx ay regB201 `mappend`
                 qhull2DHelper ax ay regB021
  where
    ((regU021, regU201), (regB021, regB201)) =
      (assignTwoRegions *** assignTwoRegions) . splitValidQuad ax by bx ay $
        vecs
    [ax, bx, ay, by] = qhull2DInit vecs

qhull2DInit :: V.Vector (UV.Vector Double) -> [UV.Vector Double]
qhull2DInit points =
  [ V.unsafeIndex points ax
  , V.unsafeIndex points bx
  , V.unsafeIndex points ay
  , V.unsafeIndex points by
  ]
  where
    (ax, bx) = minMaxXIndexes points
    (ay, by) = minMaxYIndexes points

qhull2DHelper :: UV.Vector Double -> UV.Vector Double -> V.Vector (UV.Vector Double) -> DList (UV.Vector Double)
qhull2DHelper v w vecs
  | V.length vecs > 1 =
      D.cons maxP $
        qhull2DHelper w0 w1 r021 `mappend`
        qhull2DHelper w0 w2 r012 `mappend`
        qhull2DHelper w1 w2 r201
  | V.length vecs == 1 =
      D.singleton $
        V.unsafeHead vecs
  | otherwise = D.empty
  where
    (r021, r201, r012) = assignThreeRegions $ splitValidTri w0 w1 w2 testpts
    [w0, w1, w2] = V.toList . sortTriangle v w $ maxP
    testpts = V.ifilter (\i _ -> i /= maxInd) vecs
    (maxInd, maxP) = maxDistPt v w vecs

assignTwoRegions :: V.Vector (Region2D, UV.Vector Double)
                 -> (V.Vector (UV.Vector Double), V.Vector (UV.Vector Double))
assignTwoRegions = (,) <$> rMap R021 <*> rMap R201

assignThreeRegions
    :: V.Vector (Region2D, UV.Vector Double)
    -> (V.Vector (UV.Vector Double), V.Vector (UV.Vector Double), V.Vector (UV.Vector Double))
assignThreeRegions = (,,) <$> rMap R021 <*> rMap R201 <*> rMap R012

rMap
    :: Eq b
    => b -> V.Vector (b, UV.Vector Double) -> V.Vector (UV.Vector Double)
rMap r = V.map snd . V.filter ((== r) . fst)

-- Sorts points by their x-coordinates
sortTriangle
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> V.Vector (UV.Vector Double)
sortTriangle u v w = V.modify (I.sortBy (comparing UV.unsafeHead)) r
  where
    r = V.fromList [u, v, w]

inTriangleInterior
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> (Bool, Double, [Double])
inTriangleInterior a b c p = (,,) <$> same' . sum <*> signum . sum <*> id $ vv
  where
    vv = [test' ab aP, test' bc bp, test' ca cp]
    ab = diff b a
    bc = diff c b
    ca = diff a c
    aP = diff p a
    bp = diff p b
    cp = diff p c
    diff = UV.zipWith (-)
    same' = (||) <$> (== 3) <*> (== -3)
    test' u v = signum $ UV.foldl1' (-) $ UV.zipWith (*) u (UV.reverse v)

inQuadInterior
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> (Bool, Double, [Double])
inQuadInterior a b c d p = (,,) <$> same' . sum <*> signum . sum <*> id $ vv
  where
    vv = [test' ab aP, test' bc bp, test' cd cp, test' da dp]
    ab = diff b a
    bc = diff c b
    cd = diff d c
    da = diff a d
    aP = diff p a
    bp = diff p b
    cp = diff p c
    dp = diff p d
    diff = UV.zipWith (-)
    same' = (||) <$> (== 4) <*> (== (-4))
    test' u v = signum $ UV.foldl1' (-) $ UV.zipWith (*) u (UV.reverse v)

testInRegionQuad
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> (Maybe Region2D, Maybe Region2D)
testInRegionQuad v0 v1 v2 v3 p = reg
  where
    (inQuad,signSum,regs) = inQuadInterior v0 v1 v2 v3 p
    reg =
        if inQuad
            then (Nothing, Nothing)
            else (asum *** asum) . L.splitAt 2 . zipWith ($) regAssign $ regs
    regAssign =
        [ toMaybe R021 . (/= signSum)
        , toMaybe R201 . (/= signSum)
        , toMaybe R021 . (/= signSum)
        , toMaybe R201 . (/= signSum)]

splitValidQuad
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> V.Vector (UV.Vector Double)
    -> (V.Vector (Region2D, UV.Vector Double), V.Vector (Region2D, UV.Vector Double))
splitValidQuad u v w x =
    (V.map fromJust . V.filter isJust *** V.map fromJust . V.filter isJust) .
    V.unzip .
    V.map
        ((\v' (a,b) ->
               (flip (,) v' <$> a, flip (,) v' <$> b)) `ap`
         testInRegionQuad u v w x)

toMaybe :: a -> Bool -> Maybe a
toMaybe a pred' =
    if pred'
        then Just a
        else Nothing

testInRegionTri
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> Maybe Region2D
testInRegionTri v0 v1 v2 p = reg
  where
    (inTriangle,signSum,regs) = inTriangleInterior v0 v1 v2 p
    reg =
        if inTriangle
            then Nothing
            else asum . zipWith ($) regAssign $ regs
    regAssign =
        [ toMaybe R021 . (/= signSum)
        , toMaybe R201 . (/= signSum)
        , toMaybe R012 . (/= signSum)]

splitValidTri
    :: UV.Vector Double
    -> UV.Vector Double
    -> UV.Vector Double
    -> V.Vector (UV.Vector Double)
    -> V.Vector (Region2D, UV.Vector Double)
splitValidTri u v w =
    V.map fromJust .
    V.filter isJust . V.map ((fmap . flip (,)) `ap` testInRegionTri u v w)

minMaxXIndexes :: V.Vector (UV.Vector Double) -> (Int, Int)
minMaxXIndexes = minmax . sortOnFirst . vzip . V.map UV.unsafeHead
  where
    vzip v = V.zip v (V.enumFromN 0 $ V.length v)

minMaxYIndexes :: V.Vector (UV.Vector Double) -> (Int, Int)
minMaxYIndexes = minmax . sortOnFirst . vzip . V.map UV.unsafeLast
  where
    vzip v = V.zip v (V.enumFromN 0 $ V.length v)

minmax :: V.Vector (Double, Int) -> (Int, Int)
minmax = uncurry (,) . (snd . V.unsafeHead &&& snd . V.unsafeLast)

sortOnFirst
    :: Ord a
    => V.Vector (a, b) -> V.Vector (a, b)
sortOnFirst = V.modify (I.sortBy (comparing fst))

maxDistPt
    :: UV.Vector Double
    -> UV.Vector Double
    -> V.Vector (UV.Vector Double)
    -> (Int, UV.Vector Double)
maxDistPt mn mx =
    getMax . ap V.zip (V.map $ internalBisect mn mx . snd) . V.indexed
  where
    getMax = fst . V.maximumBy (comparing snd)

internalBisect :: UV.Vector Double
               -> UV.Vector Double
               -> UV.Vector Double
               -> Double
internalBisect u v w = 2 * sqrt (b * c * s * (b + c)) / (b + c + peps)
  where
    dist' x = sqrt . UV.sum . UV.map (join (*)) . UV.zipWith (-) x
    a = dist' u v
    b = dist' v w
    c = dist' u w
    s = a + b + c

max_stars_repo_name: emmanueldenloye/QuickHull

max_issues_repo_name: emmanueldenloye/QuickHull

max_forks_repo_name: emmanueldenloye/QuickHull


text:
{-# LANGUAGE Trustworthy #-}
-- |
-- Module      : Criterion.Monad
-- Copyright   : (c) 2009 Neil Brown
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- The environment in which most criterion code executes.
module Criterion.Monad
    (
      Criterion
    , withConfig
    , getGen
    , getOverhead
    ) where

import Control.Monad.Reader (asks, runReaderT)
import Control.Monad.Trans (liftIO)
import Control.Monad (when)
import Criterion.Measurement (measure, runBenchmark, secs)
import Criterion.Monad.Internal (Criterion(..), Crit(..))
import Criterion.Types hiding (measure)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Statistics.Regression (olsRegress)
import System.Random.MWC (GenIO, createSystemRandom)
import qualified Data.Vector.Generic as G

-- | Run a 'Criterion' action with the given 'Config'.
withConfig :: Config -> Criterion a -> IO a
withConfig cfg (Criterion act) = do
  g <- newIORef Nothing
  o <- newIORef Nothing
  runReaderT act (Crit cfg g o)

-- | Return a random number generator, creating one if necessary.
--
-- This is not currently thread-safe, but in a harmless way (we might
-- call 'createSystemRandom' more than once if multiple threads race).
getGen :: Criterion GenIO
getGen = memoise gen createSystemRandom

-- | Return an estimate of the measurement overhead.
getOverhead :: Criterion Double
getOverhead = do
  verbose <- asks ((== Verbose) . verbosity)
  memoise overhead $ do
    (meas,_) <- runBenchmark (whnfIO $ measure (whnfIO $ return ()) 1) 1
    let metric get = G.convert . G.map get $ meas
    let o = G.head . fst $
            olsRegress [metric (fromIntegral . measIters)] (metric measTime)
    when verbose . liftIO $
      putStrLn $ "measurement overhead " ++ secs o
    return o

-- | Memoise the result of an 'IO' action.
--
-- This is not currently thread-safe, but hopefully in a harmless way.
-- We might call the given action more than once if multiple threads
-- race, so our caller's job is to write actions that can be run
-- multiple times safely.
memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Criterion a
memoise ref generate = do
  r <- Criterion $ asks ref
  liftIO $ do
    mv <- readIORef r
    case mv of
      Just rv -> return rv
      Nothing -> do
        rv <- generate
        writeIORef r (Just rv)
        return rv

max_stars_repo_name: bgamari/criterion

max_issues_repo_name: bgamari/criterion

max_forks_repo_name: bgamari/criterion


text:
{-# LANGUAGE RecordWildCards #-}

module Elescore.Projection.DisruptionsPerDay
  ( DisruptionsPerDay
  , applyDisruptionPerDayEvent
  ) where

import           ClassyPrelude
import           Data.DateTime                     hiding (toGregorian)

import           Database.SimpleEventStore
import           Elescore.IdTypes
import           Elescore.Integration.Common.Types
import           Statistics.IQR

type Date = Text
type DisruptionsPerDay = (Set FacilityId, Map Date Sample)

applyDisruptionPerDayEvent :: PersistedEvent (DisruptionEvent a) -> DisruptionsPerDay -> DisruptionsPerDay
applyDisruptionPerDayEvent PersistedEvent {..} =
  case evPayload of
    FacilityDisrupted fid _ -> addSample (insertSet fid) (toDate evOccurredOn)
    FacilityRestored fid    -> addSample (deleteSet fid) (toDate evOccurredOn)
    _                       -> id

addSample :: (Set FacilityId -> Set FacilityId) -> Date -> DisruptionsPerDay -> DisruptionsPerDay
addSample f date (set, xs) =
  let newSet = f set
      numberOfDisruptions = fromIntegral (length newSet)
      xs' = insertWith (<>) date (singletonSample numberOfDisruptions) xs
  in (newSet, xs')

toDate :: DateTime -> Date
toDate dt =
  let (year, month, day) = toGregorian (utctDay dt)
  in mconcat [tshow year, "-", prependZero month, "-", prependZero day]

prependZero :: Int -> Text
prependZero a
  | a < 10 = "0" <> tshow a
  | otherwise = tshow a

max_stars_repo_name: Akii/elescore

max_issues_repo_name: Akii/elescore

max_forks_repo_name: Akii/elescore


text:
{-|
Module : GradientDescent
|-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module GradientDescent
  ( sigmoid
  , sigmoidPrime
  , matrixSigmoid
  , matrixSigmoidPrime
  , getOutcomes
  , gradientDescent
  ) where

import Numeric.LinearAlgebra
import qualified Data.List.Split as S
import System.Random
import Data.Array.IO
import Control.Monad
import GHC.Float
import Network

-- | Shuffle list
shuffle :: [a] -> IO [a]
shuffle xs = do
        ar <- newArray n xs
        forM [1..n] $ \i -> do
            j <- randomRIO (i,n)
            vi <- readArray ar i
            vj <- readArray ar j
            writeArray ar j vi
            return vj
  where
    n = length xs
    newArray :: Int -> [a] -> IO (IOArray Int a)
    newArray n = newListArray (1, n)

-- | Sigmoid Function
sigmoid :: Double -> Double
sigmoid x = 1.0 / (1.0 + exp (-x))

-- | Apply Sigmoid Function for every element of matrix
matrixSigmoid :: Matrix Double -> Matrix Double
matrixSigmoid = cmap sigmoid

-- | Sigmoid Prime Function
sigmoidPrime :: Double -> Double
sigmoidPrime x = sigmoid x * (1 - sigmoid x)

-- | Apply Sigmoid Prime Function for every element of matrix
matrixSigmoidPrime :: Matrix Double -> Matrix Double
matrixSigmoidPrime = cmap sigmoidPrime

-- | Cost function
costPrime :: Matrix Double -> Matrix Double  -> Matrix Double
costPrime outputActivations y = outputActivations - y

-- | Feed Forward algorithm
feedForward :: Net -- ^ Neural Network
            -> Matrix Double -- ^ Image Matrix
            -> Matrix Double
feedForward net x = foldl (\z (w,b)-> matrixSigmoid ((w <> z) + b)) x (zip (weights net) (biases net))

-- | Evaluate Neural Network predictions
evaluate :: Net -- ^ Neural Network for evaluation
         -> [(Matrix Double, Int)] -- ^ List of Test Images with their corresponding label
         -> Double -- ^ Returns Count of positive predictions
evaluate net testData = sum $ fmap (\(x,y) -> if x==y then 1.0 else 0.0) outcomes
  where
    testImages = map fst testData
    testLabels = map snd testData
    outcomes = zip (fmap (head . fmap maxIndex . toColumns . feedForward net) testImages) testLabels

-- | Get Neural Network predictions
getOutcomes :: Net -- ^ Neural Network
            -> [(Matrix Double, Int)] -- ^ List of Test Images with their corresponding labels
            -> [([Float], (Int, Int))] -- ^ Returns List of Test Images with their corresponding label and predictions
getOutcomes net testData = zip listImages outcomes
  where
    testImages = map fst testData
    testLabels = map snd testData
    listImages = head . toLists . tr . cmap double2Float <$> testImages
    outcomes = zip (fmap (head . fmap maxIndex . toColumns . feedForward net) testImages) testLabels

-- | Get List of neuron activations
neuronActivation :: [Matrix Double] -- ^ Weights of Neural Network
                 -> [Matrix Double] -- ^ Biases of Neural Network
                 -> Matrix Double   -- ^ Image Matrix
                 -> [Matrix Double]
neuronActivation [] [] x = []
neuronActivation (w:ws) (b:bs) x = z : neuronActivation ws bs (matrixSigmoid z)
  where
    z = (w <> x) + b

-- | Calculate deltas
calDelta :: Net -- ^ Neural Network
          -> [Matrix Double] -- ^ Weights of Neural Network
          -> [Matrix Double] -- ^ List of Neuron Activations
          -> Matrix Double   -- ^ delta
          -> Int -- ^ current layer
          -> [Matrix Double]
calDelta net w z delta l
  | l == numLayers net = [delta]
  | otherwise = calDelta net (tail w) (tail z) d (l + 1) ++ [delta]
    where
      sp = matrixSigmoidPrime (head z)
      d = tr (head w) <> delta * sp

-- | Back Propagation algorithm
backProp :: Net -- ^ Neural Network
         -> Matrix Double -- ^ Image Matrix
         -> Matrix Double -- ^ Image vectorized label
         -> ([Matrix Double],[Matrix Double])
backProp net x y = (nablaW, nablaB)
  where
    zs = neuronActivation (weights net) (biases net) x
    activations = x : (matrixSigmoid <$> zs)
    delta = (costPrime (last activations) y * matrixSigmoidPrime (last zs)) :: Matrix Double
    lDelta = calDelta net (reverse $ weights net) (tail $ reverse zs) delta 2
    nablaB = lDelta
    nablaW = (\ (x, y) -> x <> tr y) <$> zip lDelta activations

-- | Calculate Nabla for Weights and Biases
calNabla :: Net -- ^ Neural Network
         -> [(Matrix Double, Matrix Double)] -- ^ Batch of Images with their corresponding labels
         -> [Matrix Double] -- ^ List of Nabla Matrix's of Weights
         -> [Matrix Double] -- ^ List of Nabla Matrix's of Biases
         -> ([Matrix Double], [Matrix Double])
calNabla net [] nW nB = (nW, nB)
calNabla net (x:xs) nW nB = calNabla net xs nablaW nablaB
  where
    (deltaNablaW, deltaNablaB) = uncurry (backProp net) x
    nablaB = uncurry (+) <$> zip nB deltaNablaB
    nablaW = uncurry (+) <$> zip nW deltaNablaW

-- | Update network's weights and biases for each batch
updateMiniBatch :: Net -- ^ Neural Network
                -> [(Matrix Double, Matrix Double)] -- ^ Batch of Images with their corresponding labels
                -> Double -- ^ Alpha
                -> Net
updateMiniBatch net miniBatch alpha = newNet
  where
    nB = fmap (\x -> konst (0 :: Double) ((fst $ size x) :: Int, (snd $ size x) :: Int) :: Matrix Double) (biases net)
    nW = fmap (\x -> konst (0 :: Double) ((fst $ size x) :: Int, (snd $ size x) :: Int) :: Matrix Double) (weights net)
    (nablaW, nablaB) = calNabla net miniBatch nW nB
    newWeights = (\(x,y) -> x - cmap (\ p -> (alpha / fromIntegral (length miniBatch)) * p) y ) <$> zip (weights net) nablaW
    newBiases = (\(x,y) -> x - cmap (\ p -> (alpha / fromIntegral (length miniBatch)) * p) y ) <$> zip (biases net) nablaB
    newNet = Net (numLayers net) (sizes net) newBiases newWeights

-- | Train Neural Network
gradientDescent :: Net -- ^ Neural Network to train
                -> [(Matrix Double, Matrix Double)] -- ^ List of Training Images with column vectorized labels
                -> Int -- ^ Number of training iterations
                -> Int -- ^ Size of Image batches
                -> Double -- ^ Alpha
                -> [(Matrix Double, Int)] -- ^ List of Test Images with Labels
                -> IO Net
gradientDescent net trainingData epochs miniBatchSize alpha testData = loop net 0
  where
    nTest = fromIntegral (length testData)
    loop currentNet epoch = do
      let evaluation = 100.0 * evaluate currentNet testData / nTest
      let evaluationMsg = "Epoch: " ++ show epoch ++ " = " ++ show evaluation ++ "% Out Of " ++ show nTest ++ " Test Images"
      print evaluationMsg
      if epoch == epochs then return currentNet
      else do
        shuffledTrainingData <- shuffle trainingData
        let miniBatches = S.chunksOf miniBatchSize shuffledTrainingData
        let newNet = foldl (\z x-> updateMiniBatch z x alpha) currentNet miniBatches
        loop newNet (epoch + 1)

max_stars_repo_name: Malenczuk/HuskNet

max_issues_repo_name: Malenczuk/HuskNet

max_forks_repo_name: Malenczuk/HuskNet


text:
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances
           , FlexibleContexts, TypeSynonymInstances, GeneralizedNewtypeDeriving
           , UndecidableInstances, ScopedTypeVariables, DefaultSignatures
           , TypeOperators, CPP
  #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}

----------------------------------------------------------------------
-- |
-- Module      :  Test.QuickCheck.Checkers
-- Copyright   :  (c) Conal Elliott 2007,2008
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Some QuickCheck helpers
----------------------------------------------------------------------

module Test.QuickCheck.Checkers
  (
  -- * Misc
    Test, TestBatch, unbatch, checkBatch, quickBatch, verboseBatch
  -- , probablisticPureCheck
  , Unop, Binop, genR, involution, inverseL, inverse
  , FracT, NumT, OrdT, T
  -- * Generalized equality
  , EqProp(..), eq
  , BinRel, reflexive, transitive, symmetric, antiSymmetric
  , leftId, rightId, bothId, isAssoc, isCommut, commutes
  , MonoidD, monoidD, endoMonoidD, homomorphism
  , idempotent, idempotent2, idemElem
  -- , funEq, AsFun(..)
  -- * Model-based (semantics-based) testing
  , Model(..)
  , meq, meq1, meq2, meq3, meq4, meq5
  , eqModels, denotationFor
  , Model1(..)
  -- * Some handy testing types
  -- , Positive, NonZero(..), NonNegative(..)
  -- , suchThat, suchThatMaybe
  , arbs, gens
  , (.&.)
  , arbitrarySatisfying
  ) where

import Data.Function (on)
import Control.Applicative
import Control.Arrow ((***),first)
import qualified Control.Exception as Ex
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid hiding (First, Last)

import Data.Complex
import Data.Proxy
import Data.Ratio
import Data.Functor.Identity

#if __GLASGOW_HASKELL__ >= 800
import Data.Functor.Compose
import qualified Data.Functor.Product as F
import qualified Data.Functor.Sum as F
#endif
import Data.Semigroup
import GHC.Generics
import System.Random
import Test.QuickCheck hiding (generate)
import Test.QuickCheck.Random (QCGen, newQCGen)
-- import System.IO.Unsafe

import Test.QuickCheck.Gen      (Gen (..)) -- for rand
-- import Test.QuickCheck.Property (Prop(..)) -- for evaluate

import Test.QuickCheck.Utils

-- import Test.QuickCheck.Utils
-- import Test.QuickCheck.Instances.Num
-- import Control.Monad.Extensions

-- import qualified Data.Stream as S

{----------------------------------------------------------
    Misc
----------------------------------------------------------}

-- | Named test
type Test = (String,Property)

-- | Named batch of tests
type TestBatch = (String,[Test])

-- | Flatten a test batch for inclusion in another
unbatch :: TestBatch -> [Test]
unbatch (batchName,props) = map (first ((batchName ++ ": ")++)) props

-- TODO: consider a tree structure so that flattening is unnecessary.

type QuickCheckRunner = Args -> Property -> IO ()

-- | Run a batch of tests.  See 'quickBatch' and 'verboseBatch'.
checkBatch' :: QuickCheckRunner -> Args -> TestBatch -> IO ()
checkBatch' runner args (name,tests) =
  do putStrLn $ "\n" ++ name ++ ":"
     mapM_ pr tests
 where
   pr (s,p) = do putStr (padTo (width + 4) ("  "++s ++ ":"))
                 Ex.catch (runner args p)
                          (print :: Ex.SomeException -> IO ())
   width    = foldl' max 0 (map (length.fst) tests)

checkBatch :: Args -> TestBatch -> IO ()
checkBatch = checkBatch' quickCheckWith

padTo :: Int -> String -> String
padTo n = take n . (++ repeat ' ')

-- | Check a batch tersely.
quickBatch :: TestBatch -> IO ()
quickBatch = checkBatch quick'

-- | Check a batch verbosely.
verboseBatch :: TestBatch -> IO ()
verboseBatch = checkBatch' verboseCheckWith quick'

quick' :: Args
quick'   = stdArgs { maxSuccess = 500 }

{-

-- TODO: change TestBatch to be hierarchical/recursive, rather than
-- two-level.

data Batch n t = Test t | Batch [LBatch n t]
type LBatch n t = (n, Batch n t)

-- | Run a batch of tests.  See 'quickBatch' and 'verboseBatch'.
checkL :: Config -> LBatch -> IO ()
checkL config = checkL' 0
 where
   checkL' :: Int -> LBatch -> IO ()
   ...
-}

-- | Unary function, handy for type annotations
type Unop a = a -> a

-- | Binary function, handy for type annotations
type Binop a = a -> a -> a

-- Testing types

-- | Token 'Fractional' type for tests
type FracT = Float
-- | Token 'Num' type for tests
type NumT  = Int
-- | Token 'Ord' type for tests
type OrdT  = Int -- Char -- randomR is broken on Char
-- | Token uninteresting type for tests
type T     = Char

genR :: Random a => (a, a) -> Gen a
genR (lo,hi) = fmap (fst . randomR (lo,hi)) rand

-- | @f@ is its own inverse. See also 'inverse'.
involution :: (Show a, Arbitrary a, EqProp a) =>
              (a -> a) -> Property
involution f = f `inverseL` f

-- | @f@ is a left inverse of @g@.  See also 'inverse'.
inverseL :: (EqProp b, Arbitrary b, Show b) =>
            (a -> b) -> (b -> a) -> Property
f `inverseL` g = f . g =-= id

-- | @f@ is a left and right inverse of @g@.  See also 'inverseL'.
inverse :: ( EqProp a, Arbitrary a, Show a
           , EqProp b, Arbitrary b, Show b ) =>
           (a -> b) -> (b -> a) -> Property
f `inverse` g = f `inverseL` g .&. g `inverseL` f

{----------------------------------------------------------
    Generalized equality
----------------------------------------------------------}

infix  4 =-=

-- | Types of values that can be tested for equality, perhaps through
-- random sampling.
class EqProp a where
  (=-=) :: a -> a -> Property
  default (=-=) :: (Generic a, GEqProp (Rep a)) => a -> a -> Property
  (=-=) = geq `on` from
  {-# INLINEABLE (=-=) #-}

class GEqProp g where
  geq :: g x -> g x -> Property

instance GEqProp g => GEqProp (M1 _1 _2 g) where
  geq = geq `on` unM1
  {-# INLINEABLE geq #-}

instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :*: g2) where
  geq (g1a :*: g1b) (g2a :*: g2b) = geq g1a g2a .&&. geq g1b g2b
  {-# INLINEABLE geq #-}

instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :+: g2) where
  geq (L1 g1) (L1 g2) = geq g1 g2
  geq (R1 g1) (R1 g2) = geq g1 g2
  geq _ _             = property False
  {-# INLINEABLE geq #-}

instance EqProp a => GEqProp (K1 _1 a) where
  geq = (=-=) `on` unK1
  {-# INLINEABLE geq #-}

instance GEqProp U1 where
  geq U1 U1 = property True
  {-# INLINEABLE geq #-}

instance GEqProp V1 where
  geq _ _ = property True
  {-# INLINEABLE geq #-}

-- | For 'Eq' types as 'EqProp' types
eq :: Eq a => a -> a -> Property
a `eq` a' = property (a == a')

-- Template: fill in with Eq types for a
--   instance EqProp a where (=-=) = eq
-- E.g.,

instance EqProp ()
instance EqProp Bool
instance EqProp Char where (=-=) = eq
instance EqProp Ordering

-- Numeric
instance EqProp Int     where (=-=) = eq
instance EqProp Float   where (=-=) = eq
instance EqProp Double  where (=-=) = eq
instance EqProp Integer where (=-=) = eq
instance Eq a => EqProp (Complex a) where (=-=) = eq
instance Eq a => EqProp (Ratio a) where (=-=) = eq

-- Semigroups
instance EqProp a => EqProp (Min a)
instance EqProp a => EqProp (Max a)
instance EqProp a => EqProp (First a)
instance EqProp a => EqProp (Last a)

-- Monoids
instance EqProp a => EqProp (Dual a)
instance (Show a, Arbitrary a, EqProp a) => EqProp (Endo a)
instance EqProp All
instance EqProp Any
instance EqProp a => EqProp (Sum a)
instance EqProp a => EqProp (Product a)
instance EqProp (f a) => EqProp (Alt f a)
#if __GLASGOW_HASKELL__ >= 806
instance EqProp (f a) => EqProp (Ap f a)
#endif

-- Lists
instance EqProp a => EqProp [a]
instance EqProp a => EqProp (NonEmpty a)
instance EqProp a => EqProp (ZipList a)

-- Maybe
instance EqProp a => EqProp (Maybe a)

-- Pairing
instance (EqProp a, EqProp b) => EqProp (a,b)
instance (EqProp a, EqProp b, EqProp c) => EqProp (a,b,c)
instance (EqProp a, EqProp b, EqProp c, EqProp d) => EqProp (a,b,c,d)

-- Either
instance (EqProp a, EqProp b) => EqProp (Either a b)

-- Functors
#if __GLASGOW_HASKELL__ >= 800
instance EqProp (f (g a)) => EqProp (Compose f g a)
instance (EqProp (f a), EqProp (g a)) => EqProp (F.Sum f g a)
instance (EqProp (f a), EqProp (g a)) => EqProp (F.Product f g a)
#endif
instance EqProp a => EqProp (Identity a)
instance EqProp a => EqProp (Const a b)
instance EqProp (Proxy a)

-- Function equality
instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where
  f =-= f' = property (liftA2 (=-=) f f')
-- Alternative definition:
-- instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where
--   f =-= f' = property (probablisticPureCheck defaultConfig
--                                              (\x -> f x =-= g x))

eqModels :: (Model a b, EqProp b) => a -> a -> Property
eqModels = (=-=) `on` model

-- | @f `'denotationFor'` g@ proves that @f@ is a model for @g@, ie that
-- @'model' . g '=-=' f@.
denotationFor
    :: (Model b b', Arbitrary a, EqProp b', Show a)
    => (a -> b')
    -> (a -> b)
    -> TestBatch
denotationFor f g =
  ( "denotation"
  , [("eq", model . g =-= f)]
  )

-- Other types
-- instance EqProp a => EqProp (S.Stream a) where (=-=) = eqModels

-- Binary relation
type BinRel  a = a -> a -> Bool

-- | Reflexive property: @a `rel` a@
reflexive :: (Arbitrary a, Show a) =>
             BinRel a -> Property
reflexive rel = property $ \ a -> a `rel` a

-- | Transitive property: @a `rel` b && b `rel` c ==> a `rel` c@.
-- Generate @a@ randomly, but use @gen a@ to generate @b@ and @gen b@ to
-- generate @c@.  @gen@ ought to satisfy @rel@ fairly often.
transitive :: (Arbitrary a, Show a) =>
              BinRel a -> (a -> Gen a) -> Property
transitive rel gen =
  property $ \ a ->
    forAll (gen a) $ \ b ->
      forAll (gen b) $ \ c ->
        (a `rel` b) && (b `rel` c) ==> (a `rel` c)

-- | Symmetric property: @a `rel` b ==> b `rel` a@.  Generate @a@
-- randomly, but use @gen a@ to generate @b@.  @gen@ ought to satisfy
-- @rel@ fairly often.
symmetric :: (Arbitrary a, Show a) =>
             BinRel a -> (a -> Gen a) -> Property
symmetric rel gen =
  property $ \ a ->
    forAll (gen a) $ \ b ->
      (a `rel` b) ==> (b `rel` a)

-- | Antisymmetric property: @(a `rel` b) && (a /= b) ==> not (b `rel` a)@.
--
-- @since 0.5.0
antiSymmetric :: (Arbitrary a, Show a, Eq a) =>
                 BinRel a -> Property
antiSymmetric rel =
  property $ \ a b -> (a `rel` b) && (a /= b) ==> not (b `rel` a)

-- | Has a given left identity, according to '(=-=)'
leftId :: (Show a, Arbitrary a, EqProp a) => (i -> a -> a) -> i -> Property
leftId  op i = (i `op`) =-= id

-- | Has a given right identity, according to '(=-=)'
rightId :: (Show a, Arbitrary a, EqProp a) => (a -> i -> a) -> i -> Property
rightId op i = (`op` i) =-= id

-- | Has a given left and right identity, according to '(=-=)'
bothId :: (Show a, Arbitrary a, EqProp a) => (a -> a -> a) -> a -> Property
bothId = (liftA2.liftA2) (.&.) leftId rightId

-- bothId op i = leftId op i .&. rightId op i

-- | Associative, according to '(=-=)'
isAssoc :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property
isAssoc = isAssociativeBy (=-=) arbitrary

-- | Commutative, according to '(=-=)'
commutes :: EqProp z => (a -> a -> z) -> a -> a -> Property
commutes (#) a b = a # b =-= b # a

-- | Commutative, according to '(=-=)'
isCommut :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property
isCommut = isCommutableBy (=-=) arbitrary

-- | Explicit 'Monoid' dictionary.  Doesn't have to correspond to an
-- actual 'Monoid' instance, though see 'monoidD'.
data MonoidD a = MonoidD a (a -> a -> a)

-- | 'Monoid' dictionary built from the 'Monoid' methods.
monoidD :: Monoid a => MonoidD a
monoidD = MonoidD mempty mappend

-- | Monoid dictionary for an unwrapped endomorphism.  See also 'monoidD'
-- and 'Endo'.
endoMonoidD :: MonoidD (a -> a)
endoMonoidD = MonoidD id (.)

-- | Homomorphism properties with respect to given monoid dictionaries.
-- See also 'monoidMorphism'.
homomorphism :: (EqProp b, Show a, Arbitrary a) =>
                MonoidD a -> MonoidD b -> (a -> b) -> [(String,Property)]
homomorphism (MonoidD ida opa) (MonoidD idb opb) q =
  [ ("identity" , q ida =-= idb)
  , ("binop", property $ \ u v -> q (u `opa` v) =-= q u `opb` q v)
  ]

-- | The unary function @f@ is idempotent, i.e., @f . f == f@
idempotent :: (Show a, Arbitrary a, EqProp a) =>
               (a -> a) -> Property
idempotent f = idemElem (.) f

-- | A binary function @op@ is idempotent, i.e., @x `op` x == x@, for all @x@
idempotent2 :: (Show a, Arbitrary a, EqProp a) =>
               (a -> a -> a) -> Property
idempotent2 = property . idemElem

-- | A binary function @op@ is has an idempotent element @x@, i.e.,
-- @x `op` x == x@
idemElem :: EqProp a => (a -> a -> a) -> a -> Property
idemElem op x = x `op` x =-= x

{-
-- TODO: phase out AsFun, in favor of Model. withArray

-- | Types that can be modeled as functions.
class AsFun h a b | h -> a b where
  asFun :: h -> (a -> b)

instance AsFun (a->b) a b where asFun = id

-- | Equality of function-like types
funEq :: (AsFun h a b, EqProp (a -> b)) => h -> h -> Property
h `funEq` h' = asFun h =-= asFun h'
-}

{----------------------------------------------------------
    Model-based (semantics-based) testing
----------------------------------------------------------}

---- From bytestring

class Model a b | a -> b where
  model :: a -> b  -- get the model from a concrete value

-- note: bytestring doesn't make the fundep

---- Compare representation-level and model-level operations (commuting diagrams)

meq  :: (Model a b, EqProp b) => a -> b -> Property
meq1 :: (Model a b, Model a1 b1, EqProp b) =>
        (a1 -> a) -> (b1 -> b) -> a1 -> Property
meq2 :: (Model a b, Model a1 b1, Model a2 b2, EqProp b) =>
        (a1 -> a2 -> a) -> (b1 -> b2 -> b) -> a1 -> a2 -> Property
meq3 :: (Model a b, Model a1 b1, Model a2 b2, Model a3 b3, EqProp b) =>
        (a1 -> a2 -> a3 -> a)
     -> (b1 -> b2 -> b3 -> b)
     -> a1 -> a2 -> a3 -> Property
meq4 :: ( Model a b, Model a1 b1, Model a2 b2
        , Model a3 b3, Model a4 b4, EqProp b) =>
        (a1 -> a2 -> a3 -> a4 -> a)
     -> (b1 -> b2 -> b3 -> b4 -> b)
     -> a1 -> a2 -> a3 -> a4 -> Property
meq5 :: ( Model a b, Model a1 b1, Model a2 b2, Model a3 b3
        , Model a4 b4, Model a5 b5, EqProp b) =>
        (a1 -> a2 -> a3 -> a4 -> a5 -> a)
     -> (b1 -> b2 -> b3 -> b4 -> b5 -> b)
     -> a1 -> a2 -> a3 -> a4 -> a5 -> Property

meq  a b =
     model a             =-= b
meq1 f g = \a         ->
     model (f a)         =-= g (model a)
meq2 f g = \a b       ->
     model (f a b)       =-= g (model a) (model b)
meq3 f g = \a b c     ->
     model (f a b c)     =-= g (model a) (model b) (model c)
meq4 f g = \a b c d   ->
     model (f a b c d)   =-= g (model a) (model b) (model c) (model d)
meq5 f g = \a b c d e ->
     model (f a b c d e) =-= g (model a) (model b) (model c) (model d) (model e)

---- Some model instances

instance Model Bool   Bool   where model = id
instance Model Char   Char   where model = id
instance Model Int    Int    where model = id
instance Model Float  Float  where model = id
instance Model Double Double where model = id
instance Model String String where model = id

-- These next two require UndecidableInstances
instance (Model a b, Model a' b') => Model (a,a') (b,b') where
  model = model *** model

instance Model b b' => Model (a -> b) (a -> b') where
  model f = model . f

-- instance Model (S.Stream a) (NonNegative Int -> a) where
--   model s (NonNegative i) = s S.!! i

-- | Like 'Model' but for unary type constructors.
class Model1 f g | f -> g where
  model1 :: forall a. f a -> g a

{----------------------------------------------------------
    Some handy testing types
----------------------------------------------------------}

-- from QC2, plus tweaks

-- type Positive a = NonZero (NonNegative a)

arbitrarySatisfying :: Arbitrary a => (a -> Bool) -> Gen a
arbitrarySatisfying = (arbitrary `suchThat`)

-- -- | Generates a value that satisfies a predicate.
-- suchThat :: Gen a -> (a -> Bool) -> Gen a
-- gen `suchThat` p = satisfiesM p gen

-- -- | Tries to generate a value that satisfies a predicate.
-- suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
-- gen `suchThatMaybe` p = sized (try 0 . max 1)
--  where
--   try _ 0 = return Nothing
--   try k n = do x <- resize (2*k+n) gen
--                if p x then return (Just x) else try (k+1) (n-1)

-- | Generate n arbitrary values
arbs :: Arbitrary a => Int -> IO [a]

arbs n = fmap (\ rnd -> generate n rnd (vector n)) newQCGen

-- | Produce n values from a generator
gens :: Int -> Gen a -> IO [a]
gens n gen =
  fmap (\ rnd -> generate 1000 rnd (sequence (replicate n gen))) newQCGen

-- The next two are from twanvl:

instance Testable a => Testable [a] where
  property []    = property True
  property props = property $ \n -> props !! (n `mod` len)
    where len = length props

instance (Testable a, Testable b) => Testable (a,b) where
  property = uncurry (.&.)

{-
probablisticPureCheck :: Testable a => Args -> a -> Bool
probablisticPureCheck args a = unsafePerformIO $
  do rnd <- newStdGen
     probablisticPureTests args (evaluate a) rnd 0 0 []

probablisticPureTests :: Args
                      -> Gen Result
                      -> StdGen
                      -> Int
                      -> Int
                      -> [[String]]
                      -> IO Bool
probablisticPureTests args gen rnd0 ntest nfail stamps
  | ntest == maxSuccess args = return True
  | nfail == maxDiscard args = return True
  | otherwise                     =
      case ok result of
        Nothing    ->
          probablisticPureTests args gen rnd1 ntest (nfail+1) stamps
        Just True  ->
          probablisticPureTests args gen rnd1 (ntest+1) nfail
                                (stamp result:stamps)
        Just False ->
          return False
     where
      result      = generate (maxSize config ntest) rnd2 gen
      (rnd1,rnd2) = split rnd0

-}

-- TODO: resurrect probablistic stuff.  bob?

{--------------------------------------------------------------------
    Copied (& tweaked) from QC1
--------------------------------------------------------------------}

-- TODO: are there QC2 replacements for these QC1 operations?

rand :: Gen QCGen
rand = MkGen (\r _ -> r)

generate :: Int -> QCGen -> Gen a -> a
generate n rnd (MkGen m) = m rnd' size
 where
  (size, rnd') = randomR (0, n) rnd

-- evaluate :: Testable a => a -> Gen Result
-- evaluate a = gen where MkProp gen = property a

max_stars_repo_name: solomon-b/checkers

max_issues_repo_name: solomon-b/checkers

max_forks_repo_name: solomon-b/checkers


text:
module Main where

import Control.DeepSeq (NFData)
import Data.Complex (Complex((:+)))
import Data.Function (on)

test1 :: Int
test1 = undefined

test2 :: a -> a -> Complex a
test2 = (:+)

test25 :: NFData a => a
test25 = undefined

test3 :: (b -> b -> c) -> (a -> b) -> a -> a -> c
test3 = on

test4 :: IO ()
test4 = putStrLn "Bar"

test5 :: [t] -> ()
test5 (_:_) = ()
test5 _ = error "test5"

-- hlint
test6 :: [Integer] -> [Integer]
test6 = map ((+ 1) . (* 2))

max_stars_repo_name: betaveros/ghc-mod

max_issues_repo_name: phaazon/ghc-mod

max_forks_repo_name: phaazon/ghc-mod


text:
module Physics.Involutive
  ( Involutive(..)
  ) where

import Data.Complex hiding (conjugate)

class Involutive a where
  conjugate :: a -> a
  conjugate = id

instance Involutive Double
instance Involutive Float
instance (Involutive a, RealFloat a) => Involutive (Complex a) where
  {-# SPECIALIZE instance Involutive (Complex Float) #-}
  {-# SPECIALIZE instance Involutive (Complex Double) #-}
  conjugate (a :+ b) = conjugate a :+ negate b

max_stars_repo_name: ekmett/physics

max_issues_repo_name: ekmett/physics

max_forks_repo_name: ekmett/physics


text:
{- |
Description :  Random values, distributions, etc.
Copyright   :  (c) Dominik Schrempf 2017
License     :  GPLv3

Maintainer  :  dominik.schrempf@gmail.com
Stability   :  unstable
Portability :  non-portable (not tested)

Impure.

Some functions to work with random computations such as a definition of a
distribution, and convenience functions to draw from distributions.

* Changelog

-}

module Distribution where

-- I had problems with using =scanl= for vectors, a function provided by
-- Data.Vector. However, hmatrix reexports some definitions of vector which
-- results in errors. The qualified imports solve this problems.
import           Control.Monad.Random.Strict
import qualified Data.Vector.Generic         as V
import qualified Numeric.LinearAlgebra       as L

-- | A discrete distribution is a real vector.
type Distribution = L.Vector L.R

-- | Randomly sample an index from a discrete probability distribution.
drawFromDist :: (RandomGen g) => Distribution -> Rand g Int
drawFromDist dist = do
  p <- getRandomR (0.0 :: Double, 1.0 :: Double)
  return $ fromDist p dist

-- | A probability is just a double, an index is just an Int.
type Probability = Double

-- | For a given value, return the index of the sample according to a given
-- distribution. In Control.Monad.Trans.Random, this is implemented for lists,
-- but I happen to use vectors in this program, so I had to rewrite this
-- function.
fromDist :: Probability -> Distribution -> Int
fromDist p dist = V.length $ V.takeWhile (<p) cums
  -- The cumulative distribution.
  where cums = V.scanl1' (+) dist

-- | Get a uniform distribution with n categories.
uniformDist :: Int -> Distribution
uniformDist n = L.vector $ replicate n $ 1.0 / fromIntegral n

max_stars_repo_name: dschrempf/bmm-simulate

max_issues_repo_name: pomo-dev/bmm-simulate

max_forks_repo_name: pomo-dev/bmm-simulate


text:
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Cas.Misc where

import           PreludeCustom
import           Data.Function
import           Data.List hiding (intersect)
import           Debug.Trace
import           Data.Foldable
import           Data.Ratio
import           Data.Complex.Generic

foldlFst :: (a -> b -> a) -> a -> [(b,c)] -> (a,c)
foldlFst f a =  bimap (foldl f a) head . unzip

debug :: (Show a) => String -> a -> a
debug s = (\x -> trace (s <> " " <> show x ) x )

showQ = (==1) . denominator ?>>> show . numerator
                             ||> ((<>) <$> (<>"/") . show . numerator
                                       <*> show . denominator)

showImg y = bool "" (showQ y) (y/=1) <> "i"

showF (x':+y') = case (x',y') of
               (0,0) -> "0"
               (x,0) -> showQ x
               (0,y) -> showImg y
               (x,y) -> "(" <> showQ x <> "+" <> showImg y <> ")"

-- data QWrapperForShow = QWrapperForShow { unwrapQ :: Rational }

-- instance Show QWrapperForShow where
--     show (QWrapperForShow q) = showQ q

-- showF :: Complex Rational -> String
-- showF (x:+y)= show $ (QWrapperForShow x) :+ (QWrapperForShow y)
--

wrap :: String -> String
wrap s = "(" <> s <> ")"

wrapshow :: (Show a) => a -> String
wrapshow = wrap . show

stableGroupOn :: (Ord b) => (a -> b) -> [a] -> [[a]]
stableGroupOn f = fmap fromJust
                . (fmap . flip lookup
                    <$> fmap (f . head &&& id)
                      . groupBy ((==) `on` f)
                      . sortBy  (comparing f)
                    <*> nub
                      . fmap f )

stableGroup :: (Ord a) => [a] -> [[a]]
stableGroup = stableGroupOn id

max_stars_repo_name: vcanadi/cas

max_issues_repo_name: vcanadi/cas

max_forks_repo_name: vcanadi/cas


text:
-- | Hamiltonian Monte Carlo.  See, ex: Neal (2012)
--   http://arxiv.org/pdf/1206.1901.pdf.

module Strategy.Hamiltonian (hamiltonian) where

import Control.Monad.State.Strict
import Data.Maybe
import qualified Data.Vector.Storable as V
import Math.Probably.Sampler
import Math.Probably.Types
import Math.Probably.Utils
import Numeric.LinearAlgebra

-- | A Hamiltonian transition with step size and leapfrog increment tunables.
hamiltonian :: Maybe Double -> Maybe Int -> Transition (Double, Int)
hamiltonian e l = do
  Chain (ds, q0) target _ (te, tl) <- get
  let stepSize = fromMaybe te e
      nDisc    = fromMaybe tl l
      lTarget  = curry (logObjective target) ds
      glTarget = handleGradient $ gradient target

  r0 <- V.replicateM (dim q0) (lift unormal)
  zc <- lift unit
  let (q, r) = leapfrogIntegrator glTarget (q0, r0) stepSize nDisc
      next   = (ds, nextState lTarget (q0, q) (r0, r) zc)

  put $ Chain next target (logObjective target next) (stepSize, nDisc)
  return next

-- | The leapfrog or Stormer-Verlet integrator.
leapfrogIntegrator :: Gradient -> Particle -> Double -> Int -> Particle
leapfrogIntegrator glTarget (q0, r0) e = go q0 r0 where
  go q r 0 = (q, r)
  go q r n = let (q1, r1) = leapfrog glTarget (q, r) e
             in  go q1 r1 (pred n)

-- | The acceptance probability of a move.
acceptProb :: (Vector Double -> Double) -> Particle -> Particle -> Double
acceptProb lTarget (q0, q1) (r0, r1) = exp . min 0 $
  auxilliaryTarget lTarget (q1, r1) - auxilliaryTarget lTarget (q0, r0)

-- | The next state, given a proposal and random value from (0, 1).
nextState
  :: (Vector Double -> Double)
  -> Particle
  -> Particle
  -> Double
  -> ContinuousParams
nextState lTarget position momentum z
    | z < pAccept = snd position
    | otherwise   = fst position
  where
    pAccept = acceptProb lTarget position momentum

max_stars_repo_name: glutamate/probably-baysig

max_issues_repo_name: silky/probably-baysig

max_forks_repo_name: silky/probably-baysig


text:
-- | RVM regression model
module Numeric.BMML.RVMR
    ( fit
    , predict
    ) where

import Numeric.LinearAlgebra.Data (Matrix, Vector)
import qualified Numeric.LinearAlgebra.HMatrix as H

data RVMRModel = RVMRModel
    { mean :: Vector Double
    , covariance :: Matrix Double
    , optbeta :: Double
    }

initAlpha :: Int -> Vector Double
initAlpha m = H.konst 1.0e-3 m

initBeta :: Double
initBeta = 1.0e-3

fit :: Matrix Double -> Vector Double -> RVMRModel
fit x t =
    let (_,d) = H.size x
        alpha = initAlpha d
        beta = initBeta
        sigma = calcSigma alpha beta x
        m = calcMean beta sigma x t
    in go 10000 alpha beta sigma m
  where
    go 0 _ beta sigma m =
        RVMRModel
        { mean = m
        , covariance = sigma
        , optbeta = beta
        }
    go k alpha beta sigma m = if sNorm alpha na < 0.01
                                 then go 0 na nb ns nm
                                else go (k - 1) na nb ns nm
      where
        (n,d) = H.size x
        gamma :: Vector Double
        gamma = (H.konst 1 d) - (alpha * (H.takeDiag sigma))
        na :: Vector Double
        na =
            H.fromList
                (zipWith
                     (\gi mi ->
                           gi / (mi * mi))
                     (H.toList gamma)
                     (H.toList m))
        nb :: Double
        nb = normSq (t - x H.#> m) / (fromIntegral n - H.sumElements gamma)
        ns = calcSigma na nb x
        nm = calcMean nb ns x t

sNorm :: Vector Double -> Vector Double -> Double
sNorm x y =
    sqrt
        (foldr
             (\(xi,yi) res ->
                   res + (yi - xi) * (yi - xi))
             0
             (filter
                  (\(xi,yi) ->
                        xi < 10000 && yi < 10000)
                  (zip (H.toList x) (H.toList y))))
{-# INLINE sNorm #-}

calcSigma :: Vector Double -> Double -> Matrix Double -> Matrix Double
calcSigma a b x = H.inv (H.diag a + b `H.scale` (H.tr x H.<> x))
{-# INLINE calcSigma #-}

calcMean :: Double
         -> Matrix Double
         -> Matrix Double
         -> Vector Double
         -> Vector Double
calcMean b s x t = b `H.scale` ((s H.<> H.tr x) H.#> t)
{-# INLINE calcMean #-}

normSq :: Vector Double -> Double
normSq v = v `H.dot` v
{-# INLINE normSq #-}

predict :: RVMRModel -> Vector Double -> (Double, Double)
predict (RVMRModel m sigma ob) v =
    (m `H.dot` v, 1 / ob + v `H.dot` (sigma H.#> v))

max_stars_repo_name: DbIHbKA/BMML

max_issues_repo_name: DbIHbKA/BMML

max_forks_repo_name: DbIHbKA/BMML