text:
{-# LANGUAGE BangPatterns, CPP, DefaultSignatures, DerivingVia, LambdaCase #-}
{-# LANGUAGE OverloadedStrings, QuantifiedConstraints, StandaloneDeriving  #-}
{-# LANGUAGE TemplateHaskell, TypeOperators                                #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Control.Subcategory.Foldable
  ( CFoldable(..),
    ctoList,
    CTraversable(..),
    CFreeMonoid(..),
    cfromList,
    cfolded, cfolding,
    cctraverseFreeMonoid,
    cctraverseZipFreeMonoid
  ) where
import           Control.Applicative                  (ZipList, getZipList)
import           Control.Arrow                        (first, second, (***))
import qualified Control.Foldl                        as L
import           Control.Monad                        (forM)
import           Control.Subcategory.Applicative
import           Control.Subcategory.Functor
import           Control.Subcategory.Pointed
import           Control.Subcategory.Wrapper.Internal
import           Control.Subcategory.Zip
import           Data.Coerce
import           Data.Complex                         (Complex)
import           Data.Foldable
import           Data.Functor.Const                   (Const)
import           Data.Functor.Contravariant           (Contravariant, contramap,
                                                       phantom)
import           Data.Functor.Identity                (Identity)
import qualified Data.Functor.Product                 as SOP
import qualified Data.Functor.Sum                     as SOP
import qualified Data.HashMap.Strict                  as HM
import qualified Data.HashSet                         as HS
import qualified Data.IntMap.Strict                   as IM
import qualified Data.IntSet                          as IS
import           Data.Kind                            (Type)
import           Data.List                            (uncons)
import           Data.List                            (intersperse)
import           Data.List                            (nub)
import qualified Data.List                            as List
import           Data.List.NonEmpty                   (NonEmpty)
import qualified Data.List.NonEmpty                   as NE
import qualified Data.Map                             as M
import           Data.Maybe
import           Data.Monoid
import qualified Data.Monoid                          as Mon
import           Data.MonoTraversable                 hiding (WrappedMono,
                                                       unwrapMono)
import           Data.Ord                             (Down)
import qualified Data.Primitive.Array                 as A
import qualified Data.Primitive.PrimArray             as PA
import qualified Data.Primitive.SmallArray            as SA
import           Data.Proxy                           (Proxy)
import           Data.Semigroup                       (Arg, Max (..), Min (..),
                                                       Option)
import qualified Data.Semigroup                       as Sem
import qualified Data.Sequence                        as Seq
import           Data.Sequences                       (IsSequence (indexEx))
import qualified Data.Sequences                       as MT
import qualified Data.Set                             as Set
import qualified Data.Text                            as T
import qualified Data.Vector                          as V
import qualified Data.Vector.Algorithms.Intro         as AI
import qualified Data.Vector.Primitive                as P
import qualified Data.Vector.Storable                 as S
import qualified Data.Vector.Unboxed                  as U
import           Foreign.Ptr                          (Ptr)
import qualified GHC.Exts                             as GHC
import           GHC.Generics
import           Language.Haskell.TH                  hiding (Type)
import           Language.Haskell.TH.Syntax           hiding (Type)
import qualified VectorBuilder.Builder                as VB
import qualified VectorBuilder.Vector                 as VB

-- See Note [Function coercion]
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
(#.) _f = coerce
{-# INLINE (#.) #-}

ctoList :: (CFoldable f, Dom f a) => f a -> [a]
{-# INLINE [1] ctoList #-}
ctoList = cbasicToList

cfromList :: (CFreeMonoid f, Dom f a) => [a] -> f a
{-# INLINE [1] cfromList #-}
cfromList = cbasicFromList

-- | Fold-optic for 'CFoldable' instances.
--   In the terminology of lens, cfolded is a constrained
--   variant of @folded@ optic.
--
--  @
--    cfolded :: (CFoldable t, Dom t a) => Fold (t a) a
--  @
cfolded
  :: (CFoldable t, Dom t a)
  => forall f. (Contravariant f, Applicative f) => (a -> f a) -> t a -> f (t a)
{-# INLINE cfolded #-}
cfolded = (contramap (const ()) .) . ctraverse_

class Constrained f => CFoldable f where
  {-# MINIMAL cfoldMap | cfoldr #-}
  cfoldMap :: (Dom f a, Monoid w) => (a -> w) -> f a -> w
  {-# INLINE [1] cfoldMap #-}
  cfoldMap f = cfoldr (mappend . f) mempty

  cfoldMap' :: (Dom f a, Monoid m) => (a -> m) -> f a -> m
  {-# INLINE [1] cfoldMap' #-}
  cfoldMap' f = cfoldl' (\ acc a -> acc <> f a) mempty

  cfold :: (Dom f w, Monoid w) => f w -> w
  cfold = cfoldMap id

  {-# INLINE [1] cfold #-}
  cfoldr :: (Dom f a) => (a -> b -> b) -> b -> f a -> b
  {-# INLINE [1] cfoldr #-}
  cfoldr f z t = appEndo (cfoldMap (Endo #. f) t) z

  cfoldlM
    :: (Monad m, Dom f b)
    => (a -> b -> m a) -> a -> f b -> m a
  {-# INLINE [1] cfoldlM #-}
  cfoldlM f z0 xs = cfoldr f' return xs z0
    where f' x k z = f z x >>= k

  cfoldlM'
    :: (Monad m, Dom f b)
    => (a -> b -> m a) -> a -> f b -> m a
  {-# INLINE [1] cfoldlM' #-}
  cfoldlM' f z0 xs = cfoldr' f' return xs z0
    where f' !x k z = do
            !i <- f z x
            k i

  cfoldrM
    :: (Monad m, Dom f a)
    => (a -> b -> m b) -> b -> f a -> m b
  {-# INLINE [1] cfoldrM #-}
  cfoldrM f z0 xs = cfoldl c return xs z0
    where c k x z = f x z >>= k

  cfoldrM'
    :: (Monad m, Dom f a)
    => (a -> b -> m b) -> b -> f a -> m b
  {-# INLINE [1] cfoldrM' #-}
  cfoldrM' f z0 xs = cfoldl' c return xs z0
    where c k !x z = do
            !i <- f x z
            k i
  cfoldl
      :: (Dom f a)
      => (b -> a -> b) -> b -> f a -> b
  {-# INLINE [1] cfoldl #-}
  cfoldl f z t = appEndo (getDual (cfoldMap (Dual . Endo . flip f) t)) z

  cfoldr' :: (Dom f a) => (a -> b -> b) -> b -> f a -> b
  {-# INLINE [1] cfoldr' #-}
  cfoldr' f z0 xs = cfoldl f' id xs z0
      where f' k x z = k $! f x z

  cfoldl' :: Dom f a => (b -> a -> b) -> b -> f a -> b
  {-# INLINE [1] cfoldl' #-}
  cfoldl' f z0 xs = cfoldr f' id xs z0
    where f' x k z = k $! f z x

  cbasicToList :: Dom f a => f a -> [a]
  {-# INLINE cbasicToList #-}
  cbasicToList = cfoldr (:) []

  cfoldr1 :: Dom f a => (a -> a -> a) -> f a -> a
  {-# INLINE [1] cfoldr1 #-}
  cfoldr1 f xs = fromMaybe (errorWithoutStackTrace "cfoldr1: empty structure")
                    (cfoldr mf Nothing xs)
      where
        mf x m = Just $
          case m of
            Nothing -> x
            Just y  -> f x y

  cfoldl1 :: Dom f a => (a -> a -> a) -> f a -> a
  {-# INLINE [1] cfoldl1 #-}
  cfoldl1 f xs = fromMaybe (errorWithoutStackTrace "cfoldl1: empty structure")
                  (cfoldl mf Nothing xs)
    where
      mf m y = Just $
        case m of
          Nothing -> y
          Just x  -> f x y

  cindex :: Dom f a => f a -> Int -> a
  cindex xs n = case cfoldl' go (Left' 0) xs of
    Right' x -> x
    Left'{} -> errorWithoutStackTrace $ "cindex: index out of bound " ++ show n
    where
      go (Left' i) x
        | i == n = Right' x
        | otherwise = Left' (i + 1)
      go r@Right'{} _ = r

  cnull :: Dom f a => f a -> Bool
  cnull = cfoldr (const $ const False) True

  clength :: Dom f a => f a -> Int
  {-# INLINE [1] clength #-}
  clength = cfoldl' (\c _ -> c + 1) 0

  cany :: Dom f a => (a -> Bool) -> f a -> Bool
  {-# INLINE [1] cany #-}
  cany p = cfoldl' (\b -> (||) b . p) False

  call :: Dom f a => (a -> Bool) -> f a -> Bool
  {-# INLINE [1] call #-}
  call p = cfoldl' (\b -> (&&) b . p) True

  celem :: (Eq a, Dom f a) => a -> f a -> Bool
  {-# INLINE [1] celem #-}
  celem = cany . (==)

  cnotElem :: (Eq a, Dom f a) => a -> f a -> Bool
  {-# INLINE [1] cnotElem #-}
  cnotElem = call . (/=)

  cminimum :: (Ord a, Dom f a) => f a -> a
  {-# INLINE [1] cminimum #-}
  cminimum =
    getMin
    . fromMaybe (errorWithoutStackTrace "minimum: empty structure")
    . cfoldMap (Just . Min)

  cmaximum :: (Ord a, Dom f a) => f a -> a
  {-# INLINE [1] cmaximum #-}
  cmaximum =
    getMax
    . fromMaybe (errorWithoutStackTrace "cmaximum: empty structure")
    . cfoldMap (Just . Max)

  csum :: (Num a, Dom f a) => f a -> a
  {-# INLINE [1] csum #-}
  csum = getSum #. cfoldMap Sum

  cproduct :: (Num a, Dom f a) => f a -> a
  {-# INLINE [1] cproduct #-}
  cproduct = getProduct #. cfoldMap Product

  cctraverse_
    :: (CApplicative g, CPointed g, Dom g (), Dom f a, Dom g b)
    => (a -> g b)
    -> f a -> g ()
  {-# INLINE [1] cctraverse_ #-}
  cctraverse_ f = cfoldr c (cpure ())
    where
      {-# INLINE c #-}
      c x k = f x .> k

  ctraverse_
    :: (Applicative g, Dom f a)
    => (a -> g b)
    -> f a -> g ()
  {-# INLINE [1] ctraverse_ #-}
  ctraverse_ f = cfoldr c (pure ())
    where
      {-# INLINE c #-}
      c x k = f x *> k

  clast :: Dom f a => f a -> a
  {-# INLINE [1] clast #-}
  clast = fromJust . L.foldOver cfolded L.last

  chead :: Dom f a => f a -> a
  {-# INLINE [1] chead #-}
  chead = fromJust . L.foldOver cfolded L.head

  cfind :: Dom f a => (a -> Bool) -> f a -> Maybe a
  {-# INLINE [1] cfind #-}
  cfind = \p -> getFirst . cfoldMap (\x -> First $ if p x then Just x else Nothing)

  cfindIndex :: Dom f a => (a -> Bool) -> f a -> Maybe Int
  {-# INLINE [1] cfindIndex #-}
  cfindIndex = \p -> L.foldOver cfolded (L.findIndex p)

  cfindIndices :: Dom f a => (a -> Bool) -> f a -> [Int]
  {-# INLINE [1] cfindIndices #-}
  cfindIndices = \p -> List.findIndices p . ctoList

  celemIndex :: (Dom f a, Eq a) => a -> f a -> Maybe Int
  {-# INLINE [0] celemIndex #-}
  celemIndex = cfindIndex . (==)

  celemIndices :: (Dom f a, Eq a) => a -> f a -> [Int]
  {-# INLINE [0] celemIndices #-}
  celemIndices = cfindIndices . (==)

data Eith' a b = Left' !a | Right' !b

instance Traversable f => CTraversable (WrapFunctor f) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}

instance Foldable f => CFoldable (WrapFunctor f) where
  cfoldMap = foldMap
  {-# INLINE [1] cfoldMap #-}
#if MIN_VERSION_base(4,13,0)
  cfoldMap' = foldMap'
  {-# INLINE [1] cfoldMap' #-}
#endif
  cfold = fold
  {-# INLINE [1] cfold #-}
  cfoldr = foldr
  {-# INLINE [1] cfoldr #-}
  cfoldr' = foldr'
  {-# INLINE [1] cfoldr' #-}
  cfoldl = foldl
  {-# INLINE [1] cfoldl #-}
  cfoldl' = foldl'
  {-# INLINE [1] cfoldl' #-}
  cbasicToList = toList
  {-# INLINE [1] cbasicToList #-}
  cfoldr1 = foldr1
  {-# INLINE [1] cfoldr1 #-}
  cfoldl1 = foldl1
  {-# INLINE [1] cfoldl1 #-}
  cfoldlM = foldlM
  {-# INLINE [1] cfoldlM #-}
  cfoldrM = foldrM
  {-# INLINE [1] cfoldrM #-}
  cnull = null
  {-# INLINE [1] cnull #-}
  clength = length
  {-# INLINE [1] clength #-}
  cany = any
  {-# INLINE [1] cany #-}
  call = all
  {-# INLINE [1] call #-}
  celem = elem
  {-# INLINE [1] celem #-}
  cnotElem = notElem
  {-# INLINE [1] cnotElem #-}
  cminimum = minimum
  {-# INLINE [1] cminimum #-}
  cmaximum = maximum
  {-# INLINE [1] cmaximum #-}
  csum = sum
  {-# INLINE [1] csum #-}
  cproduct = product
  {-# INLINE [1] cproduct #-}
  ctraverse_ = traverse_
  {-# INLINE [1] ctraverse_ #-}
  cfind = find
  {-# INLINE [1] cfind #-}
  cfindIndex = L.fold . L.findIndex
  {-# INLINE [1] cfindIndex #-}
  celemIndex = L.fold . L.elemIndex
  {-# INLINE [1] celemIndex #-}

{-# RULES
"cfind/List"
  cfind = find @[]

"cfindIndex/List"
  cfindIndex = List.findIndex

"cfindIndices/List"
  cfindIndices = List.findIndices

"celemIndex/List"
  celemIndex = List.elemIndex

"celemIndices/List"
  celemIndices = List.elemIndices

"cfindIndex/List"
  cfindIndex = Seq.findIndexL

"cfindIndices/Seq"
  cfindIndices = Seq.findIndicesL

"celemIndex/Seq"
  celemIndex = Seq.elemIndexL

"celemIndices/Seq"
  celemIndices = Seq.elemIndicesL

  #-}

{-# RULES
"cctraverse_/traverse_"
  forall (f :: Applicative f => a -> f b) (tx :: Foldable t => t a).
  cctraverse_ f tx = traverse_ f tx
  #-}

{-# RULES
"cindex/List"
  cindex = (!!)
  #-}

class (CFunctor f, CFoldable f) => CTraversable f where
  -- | __N.B.__ If we require @g@ to be 'CApplicative'
  --   we cannot directly lift plain 'Traversable' to 'CTraversable'.
  --   This is rather annoying, so we require the strongest possible
  --   constraint to @g@ here.
  ctraverse
    :: (Dom f a, Dom f b, Applicative g)
    => (a -> g b) -> f a -> g (f b)

deriving via WrapFunctor []
  instance CFoldable []
{-# RULES
"ctoList/List"
  ctoList = id
"cfromList/List"
  cbasicFromList = id
"clast/List"
  clast = last
"chead/List"
  chead = head
  #-}

instance CTraversable [] where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Maybe
  instance CFoldable Maybe
instance CTraversable Maybe where
  ctraverse = traverse
deriving via WrapFunctor (Either e)
  instance CFoldable (Either e)
instance CTraversable (Either e) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor IM.IntMap
  instance CFoldable IM.IntMap
instance CTraversable IM.IntMap where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (M.Map k)
  instance CFoldable (M.Map k)
instance Ord k => CTraversable (M.Map k) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (HM.HashMap k)
  instance CFoldable (HM.HashMap k)
instance CTraversable (HM.HashMap k) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Seq.Seq
  instance CFoldable Seq.Seq
instance CTraversable Seq.Seq where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
{-# RULES
"cindex/Seq"
  cindex = Seq.index
  #-}

deriving via WrapFunctor Par1
  instance CFoldable Par1
instance CTraversable Par1 where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor NonEmpty
  instance CFoldable NonEmpty
instance CTraversable NonEmpty where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
{-# RULES
"cindex/NonEmpty"
  cindex = (NE.!!)
  #-}

deriving via WrapFunctor Down
  instance CFoldable Down
instance CTraversable Down where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Mon.Last
  instance CFoldable Mon.Last
instance CTraversable Mon.Last where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Mon.First
  instance CFoldable Mon.First
instance CTraversable Mon.First where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Sem.Last
  instance CFoldable Sem.Last
instance CTraversable Sem.Last where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Sem.First
  instance CFoldable Sem.First
instance CTraversable Sem.First where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Identity
  instance CFoldable Identity
instance CTraversable Identity where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor ZipList
  instance CFoldable ZipList
instance CTraversable ZipList where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
{-# RULES
"cindex/ZipList"
  cindex = (!!) . getZipList
  #-}

deriving via WrapFunctor Option
  instance CFoldable Option
instance CTraversable Option where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Min
  instance CFoldable Min
instance CTraversable Min where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Max
  instance CFoldable Max
instance CTraversable Max where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor Complex
  instance CFoldable Complex
instance CTraversable Complex where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (V1 :: Type -> Type)
  instance CFoldable (V1 :: Type -> Type)
instance CTraversable (V1 :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (U1 :: Type -> Type)
  instance CFoldable (U1 :: Type -> Type)
instance CTraversable (U1 :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor ((,) a)
  instance CFoldable ((,) a)
instance CTraversable ((,) a) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (Proxy :: Type -> Type)
  instance CFoldable (Proxy :: Type -> Type)
instance CTraversable (Proxy :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (Arg a)
  instance CFoldable (Arg a)
instance CTraversable (Arg a) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (Rec1 (f :: Type -> Type))
  instance Foldable f => CFoldable (Rec1 (f :: Type -> Type))
deriving via WrapFunctor (URec Char :: Type -> Type)
  instance CFoldable (URec Char :: Type -> Type)
instance CTraversable (URec Char :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (URec Double :: Type -> Type)
  instance CFoldable (URec Double :: Type -> Type)
instance CTraversable (URec Double :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (URec Float :: Type -> Type)
  instance CFoldable (URec Float :: Type -> Type)
instance CTraversable (URec Float :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (URec Int :: Type -> Type)
  instance CFoldable (URec Int :: Type -> Type)
instance CTraversable (URec Int :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (URec Word :: Type -> Type)
  instance CFoldable (URec Word :: Type -> Type)
instance CTraversable (URec Word :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (URec (Ptr ()) :: Type -> Type)
  instance CFoldable (URec (Ptr ()) :: Type -> Type)
instance CTraversable (URec (Ptr ()) :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving newtype
  instance CFoldable f => CFoldable (Alt f)
deriving newtype
  instance CFoldable f => CFoldable (Ap f)
deriving via WrapFunctor (Const m :: Type -> Type)
  instance CFoldable (Const m :: Type -> Type)
instance CTraversable (Const m :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}
deriving via WrapFunctor (K1 i c :: Type -> Type)
  instance CFoldable (K1 i c :: Type -> Type)
instance CTraversable (K1 i c :: Type -> Type) where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}

instance (CFoldable f, CFoldable g) => CFoldable (f :+: g) where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap f = \case
    L1 x -> cfoldMap f x
    R1 x -> cfoldMap f x

  {-# INLINE [1] cfoldr #-}
  cfoldr f z = \case
    L1 x -> cfoldr f z x
    R1 x -> cfoldr f z x

  cfoldMap' = \f -> \case
    L1 x -> cfoldMap' f x
    R1 x -> cfoldMap' f x
  {-# INLINE [1] cfoldMap' #-}
  cfold = \case
    L1 x -> cfold x
    R1 x -> cfold x
  {-# INLINE [1] cfold #-}
  cfoldr' = \f z -> \case
    L1 x -> cfoldr' f z x
    R1 x -> cfoldr' f z x
  {-# INLINE [1] cfoldr' #-}
  cfoldl = \f z -> \case
    L1 x -> cfoldl f z x
    R1 x -> cfoldl f z x
  {-# INLINE [1] cfoldl #-}
  cfoldl' = \f z -> \case
    L1 x -> cfoldl' f z x
    R1 x -> cfoldl' f z x
  {-# INLINE [1] cfoldl' #-}
  cbasicToList = \case
    L1 x -> ctoList x
    R1 x -> ctoList x
  {-# INLINE cbasicToList #-}
  cfoldr1 = \f -> \case
    L1 x -> cfoldr1 f x
    R1 x -> cfoldr1 f x
  {-# INLINE [1] cfoldr1 #-}
  cfoldl1 = \f -> \case
    L1 x -> cfoldl1 f x
    R1 x -> cfoldl1 f x
  {-# INLINE [1] cfoldl1 #-}
  cnull = \case
    L1 x -> cnull x
    R1 x -> cnull x
  {-# INLINE [1] cnull #-}
  clength = \case
    L1 x -> clength x
    R1 x -> clength x
  {-# INLINE [1] clength #-}
  cany = \f -> \case
    L1 x -> cany f x
    R1 x -> cany f x
  {-# INLINE [1] cany #-}
  call = \f -> \case
    L1 x -> call f x
    R1 x -> call f x
  {-# INLINE [1] call #-}
  celem = \x -> \case
    L1 xs -> celem x xs
    R1 xs -> celem x xs
  {-# INLINE [1] celem #-}
  cminimum = \case
    L1 xs -> cminimum xs
    R1 xs -> cminimum xs
  {-# INLINE [1] cminimum #-}
  cmaximum = \case
    L1 xs -> cmaximum xs
    R1 xs -> cmaximum xs
  {-# INLINE [1] cmaximum #-}
  csum = \case
    L1 xs -> csum xs
    R1 xs -> csum xs
  {-# INLINE [1] csum #-}
  cproduct = \case
    L1 xs -> cproduct xs
    R1 xs -> cproduct xs
  {-# INLINE [1] cproduct #-}
  ctraverse_ f = \case
    L1 xs -> ctraverse_ f xs
    R1 xs -> ctraverse_ f xs
  {-# INLINE [1] ctraverse_ #-}

instance (CTraversable f, CTraversable g) => CTraversable (f :+: g) where
  ctraverse f = \case
    L1 xs -> L1 <$> ctraverse f xs
    R1 xs -> R1 <$> ctraverse f xs
  {-# INLINE [1] ctraverse #-}

instance (CFoldable f, CFoldable g) => CFoldable (f :*: g) where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap f (l :*: r) = cfoldMap f l <> cfoldMap f r

  cfoldMap' f (l :*: r) = cfoldMap' f l <> cfoldMap' f r
  {-# INLINE [1] cfoldMap' #-}
  cfold (l :*: r) = cfold l <> cfold r
  {-# INLINE [1] cfold #-}
  cnull (l :*: r) = cnull l && cnull r
  {-# INLINE [1] cnull #-}
  clength (l :*: r) = clength l + clength r
  {-# INLINE [1] clength #-}
  cany f (l :*: r) = cany f l || cany f r
  {-# INLINE [1] cany #-}
  call f (l :*: r) = call f l && call f r
  {-# INLINE [1] call #-}
  celem x (l :*: r) = celem x l || celem x r
  {-# INLINE [1] celem #-}
  csum (l :*: r) = csum l + csum r
  {-# INLINE [1] csum #-}
  cproduct (l :*: r) = cproduct l * cproduct r
  {-# INLINE [1] cproduct #-}
  ctraverse_ f (l :*: r) = ctraverse_ f l *> ctraverse_ f r
  {-# INLINE [1] ctraverse_ #-}

instance (CTraversable f, CTraversable g) => CTraversable (f :*: g) where
  ctraverse f (l :*: r) =
    (:*:) <$> ctraverse f l <*> ctraverse f r

instance (CFoldable f, CFoldable g) => CFoldable (SOP.Sum f g) where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap f = \case
    SOP.InL x -> cfoldMap f x
    SOP.InR x -> cfoldMap f x

  {-# INLINE [1] cfoldr #-}
  cfoldr f z = \case
    SOP.InL x -> cfoldr f z x
    SOP.InR x -> cfoldr f z x

  cfoldMap' = \f -> \case
    SOP.InL x -> cfoldMap' f x
    SOP.InR x -> cfoldMap' f x
  {-# INLINE [1] cfoldMap' #-}
  cfold = \case
    SOP.InL x -> cfold x
    SOP.InR x -> cfold x
  {-# INLINE [1] cfold #-}
  cfoldr' = \f z -> \case
    SOP.InL x -> cfoldr' f z x
    SOP.InR x -> cfoldr' f z x
  {-# INLINE [1] cfoldr' #-}
  cfoldl = \f z -> \case
    SOP.InL x -> cfoldl f z x
    SOP.InR x -> cfoldl f z x
  {-# INLINE [1] cfoldl #-}
  cfoldl' = \f z -> \case
    SOP.InL x -> cfoldl' f z x
    SOP.InR x -> cfoldl' f z x
  {-# INLINE [1] cfoldl' #-}
  cbasicToList = \case
    SOP.InL x -> ctoList x
    SOP.InR x -> ctoList x
  {-# INLINE cbasicToList #-}
  cfoldr1 = \f -> \case
    SOP.InL x -> cfoldr1 f x
    SOP.InR x -> cfoldr1 f x
  {-# INLINE [1] cfoldr1 #-}
  cfoldl1 = \f -> \case
    SOP.InL x -> cfoldl1 f x
    SOP.InR x -> cfoldl1 f x
  {-# INLINE [1] cfoldl1 #-}
  cnull = \case
    SOP.InL x -> cnull x
    SOP.InR x -> cnull x
  {-# INLINE [1] cnull #-}
  clength = \case
    SOP.InL x -> clength x
    SOP.InR x -> clength x
  {-# INLINE [1] clength #-}
  cany = \f -> \case
    SOP.InL x -> cany f x
    SOP.InR x -> cany f x
  {-# INLINE [1] cany #-}
  call = \f -> \case
    SOP.InL x -> call f x
    SOP.InR x -> call f x
  {-# INLINE [1] call #-}
  celem = \x -> \case
    SOP.InL xs -> celem x xs
    SOP.InR xs -> celem x xs
  {-# INLINE [1] celem #-}
  cminimum = \case
    SOP.InL xs -> cminimum xs
    SOP.InR xs -> cminimum xs
  {-# INLINE [1] cminimum #-}
  cmaximum = \case
    SOP.InL xs -> cmaximum xs
    SOP.InR xs -> cmaximum xs
  {-# INLINE [1] cmaximum #-}
  csum = \case
    SOP.InL xs -> csum xs
    SOP.InR xs -> csum xs
  {-# INLINE [1] csum #-}
  cproduct = \case
    SOP.InL xs -> cproduct xs
    SOP.InR xs -> cproduct xs
  {-# INLINE [1] cproduct #-}
  ctraverse_ f = \case
    SOP.InL xs -> ctraverse_ f xs
    SOP.InR xs -> ctraverse_ f xs
  {-# INLINE [1] ctraverse_ #-}

instance (CTraversable f, CTraversable g) => CTraversable (SOP.Sum f g) where
  ctraverse f = \case
    SOP.InL xs -> SOP.InL <$> ctraverse f xs
    SOP.InR xs -> SOP.InR <$> ctraverse f xs
  {-# INLINE [1] ctraverse #-}

instance (CFoldable f, CFoldable g) => CFoldable (SOP.Product f g) where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap f (SOP.Pair l r) = cfoldMap f l <> cfoldMap f r

  cfoldMap' f (SOP.Pair l r) = cfoldMap' f l <> cfoldMap' f r
  {-# INLINE [1] cfoldMap' #-}
  cfold (SOP.Pair l r) = cfold l <> cfold r
  {-# INLINE [1] cfold #-}
  cnull (SOP.Pair l r) = cnull l && cnull r
  {-# INLINE [1] cnull #-}
  clength (SOP.Pair l r) = clength l + clength r
  {-# INLINE [1] clength #-}
  cany f (SOP.Pair l r) = cany f l || cany f r
  {-# INLINE [1] cany #-}
  call f (SOP.Pair l r) = call f l && call f r
  {-# INLINE [1] call #-}
  celem x (SOP.Pair l r) = celem x l || celem x r
  {-# INLINE [1] celem #-}
  csum (SOP.Pair l r) = csum l + csum r
  {-# INLINE [1] csum #-}
  cproduct (SOP.Pair l r) = cproduct l * cproduct r
  {-# INLINE [1] cproduct #-}
  ctraverse_ f (SOP.Pair l r) =
    ctraverse_ f l *> ctraverse_ f r
  {-# INLINE ctraverse_ #-}

deriving via WrapFunctor SA.SmallArray instance CFoldable SA.SmallArray
deriving via WrapFunctor A.Array instance CFoldable A.Array

instance CFoldable PA.PrimArray where
  cfoldr = PA.foldrPrimArray
  {-# INLINE [1] cfoldr #-}
  cfoldl' = PA.foldlPrimArray'
  {-# INLINE [1] cfoldl' #-}
  cfoldlM' = PA.foldlPrimArrayM'
  {-# INLINE [1] cfoldlM' #-}
  cfoldl = PA.foldlPrimArray
  {-# INLINE [1] cfoldl #-}
  clength = PA.sizeofPrimArray
  {-# INLINE [1] clength #-}
  csum = PA.foldlPrimArray' (+) 0
  {-# INLINE [1] csum #-}
  cproduct = PA.foldlPrimArray' (*) 1
  {-# INLINE [1] cproduct #-}
  ctraverse_ = PA.traversePrimArray_
  {-# INLINE [1] ctraverse_ #-}

instance CTraversable PA.PrimArray where
  ctraverse = PA.traversePrimArray
  {-# INLINE [1] ctraverse #-}

instance CTraversable SA.SmallArray where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}

instance CTraversable A.Array where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}

instance (CTraversable f, CTraversable g) => CTraversable (SOP.Product f g) where
  {-# INLINE [1] ctraverse #-}
  ctraverse f (SOP.Pair l r) =
    SOP.Pair <$> ctraverse f l <*> ctraverse f r

instance CFoldable Set.Set where
  cfoldMap = ofoldMap
  {-# INLINE [1] cfoldMap #-}
  cfoldr = Set.foldr
  {-# INLINE [1] cfoldr #-}
  cfoldl = Set.foldl
  {-# INLINE [1] cfoldl #-}
  cfoldr' = Set.foldr'
  {-# INLINE [1] cfoldr' #-}
  cfoldl' = Set.foldl'
  {-# INLINE [1] cfoldl' #-}
  cminimum = Set.findMin
  {-# INLINE [1] cminimum #-}
  cmaximum = Set.findMax
  {-# INLINE [1] cmaximum #-}
  celem = Set.member
  {-# INLINE [1] celem #-}
  cnotElem = Set.notMember
  {-# INLINE [1] cnotElem #-}
  cbasicToList = Set.toList
  {-# INLINE cbasicToList #-}
  celemIndex = Set.lookupIndex
  {-# INLINE [1] celemIndex #-}
  cindex = flip Set.elemAt
  {-# INLINE [1] cindex #-}

instance CTraversable Set.Set where
  -- TODO: more efficient implementation
  ctraverse f =
      fmap Set.fromList
    . traverse f
    . Set.toList
  {-# INLINE [1] ctraverse #-}

instance CFoldable HS.HashSet where
  cfoldMap = ofoldMap
  {-# INLINE [1] cfoldMap #-}
  cfoldr = HS.foldr
  {-# INLINE [1] cfoldr #-}
  cfoldl' = HS.foldl'
  {-# INLINE [1] cfoldl' #-}
  celem = HS.member
  {-# INLINE [1] celem #-}
  cbasicToList = HS.toList
  {-# INLINE cbasicToList #-}

instance CTraversable HS.HashSet where
  -- TODO: more efficient implementation
  ctraverse f =
      fmap HS.fromList
    . traverse f
    . HS.toList
  {-# INLINE [1] ctraverse #-}

{-# RULES
"celem/IntSet"
  celem = coerce
    @(Int -> IS.IntSet -> Bool)
    @(Int -> WrapMono IS.IntSet Int -> Bool)
    IS.member
"cnotElem/IntSet"
  cnotElem = coerce
    @(Int -> IS.IntSet -> Bool)
    @(Int -> WrapMono IS.IntSet Int -> Bool)
    IS.notMember
"cmaximum/IntSet"
  cmaximum = coerce @_ @(WrapMono IS.IntSet Int -> Int)
    IS.findMax
"cminimum/IntSet"
  cminimum = coerce @(IS.IntSet -> Int) @(WrapMono IS.IntSet Int -> Int)
    IS.findMin
  #-}

instance MonoFoldable mono => CFoldable (WrapMono mono) where
  cfoldMap = ofoldMap
  {-# INLINE [1] cfoldMap #-}
  cfold = ofold
  {-# INLINE [1] cfold #-}
  cfoldr = ofoldr
  {-# INLINE [1] cfoldr #-}
  cfoldl' = ofoldl'
  {-# INLINE [1] cfoldl' #-}
  cfoldlM = ofoldlM
  {-# INLINE [1] cfoldlM #-}
  cbasicToList = otoList
  {-# INLINE cbasicToList #-}
  cfoldr1 = ofoldr1Ex
  {-# INLINE [1] cfoldr1 #-}
  cnull = onull
  {-# INLINE [1] cnull #-}
  clength = olength
  {-# INLINE [1] clength #-}
  cany = oany
  {-# INLINE [1] cany #-}
  call = oall
  {-# INLINE [1] call #-}
  celem = oelem
  {-# INLINE [1] celem #-}
  cnotElem = onotElem
  {-# INLINE [1] cnotElem #-}
  cminimum = minimumEx
  {-# INLINE [1] cminimum #-}
  cmaximum = maximumEx
  {-# INLINE [1] cmaximum #-}
  csum = osum
  {-# INLINE [1] csum #-}
  cproduct = oproduct
  {-# INLINE [1] cproduct #-}
  ctraverse_ = otraverse_
  {-# INLINE [1] ctraverse_ #-}

instance MonoTraversable mono => CTraversable (WrapMono mono) where
  ctraverse = \f -> fmap WrapMono . otraverse f . unwrapMono

instance CFoldable V.Vector where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap = foldMap
  {-# INLINE [1] cfoldr #-}
  cfoldr = V.foldr
  {-# INLINE [1] cfoldr' #-}
  cfoldr' = V.foldr'
  {-# INLINE [1] cfoldl #-}
  cfoldl = V.foldl
  {-# INLINE [1] cfoldl' #-}
  cfoldl' = V.foldl'
  {-# INLINE cfoldlM #-}
  cfoldlM = V.foldM
  {-# INLINE cfoldlM' #-}
  cfoldlM' = V.foldM'
  {-# INLINE [1] cindex #-}
  cindex = (V.!)
  {-# INLINE [1] celem #-}
  celem = V.elem
  {-# INLINE [1] cnotElem #-}
  cnotElem = V.notElem
  {-# INLINE [1] cany #-}
  cany = V.any
  {-# INLINE [1] call #-}
  call = V.all
  {-# INLINE [1] cfoldl1 #-}
  cfoldl1 = V.foldl1
  {-# INLINE [1] cfoldr1 #-}
  cfoldr1 = V.foldr1
  {-# INLINE [1] csum #-}
  csum = V.sum
  {-# INLINE [1] cproduct #-}
  cproduct = V.product
  {-# INLINE [1] cmaximum #-}
  cmaximum = V.maximum
  {-# INLINE [1] cminimum #-}
  cminimum = V.minimum
  {-# INLINE cbasicToList #-}
  cbasicToList = V.toList
  {-# INLINE [1] clast #-}
  clast = V.last
  {-# INLINE [1] chead #-}
  chead = V.head
  {-# INLINE [1] cfind #-}
  cfind = V.find
  {-# INLINE [1] cfindIndex #-}
  cfindIndex = V.findIndex
  {-# INLINE [1] cfindIndices #-}
  cfindIndices = fmap V.toList . V.findIndices
  {-# INLINE [1] celemIndex #-}
  celemIndex = V.elemIndex
  {-# INLINE [1] celemIndices #-}
  celemIndices = fmap V.toList . V.elemIndices

instance CFoldable U.Vector where
  {-# INLINE [1] cfoldMap #-}
  cfoldMap = ofoldMap
  {-# INLINE [1] cfoldr #-}
  cfoldr = U.foldr
  {-# INLINE [1] cfoldr' #-}
  cfoldr' = U.foldr'
  {-# INLINE [1] cfoldl #-}
  cfoldl = U.foldl
  {-# INLINE [1] cfoldl' #-}
  cfoldl' = U.foldl'
  {-# INLINE cfoldlM #-}
  cfoldlM = U.foldM
  {-# INLINE cfoldlM' #-}
  cfoldlM' = U.foldM'
  {-# INLINE [1] cindex #-}
  cindex = (U.!)
  {-# INLINE [1] celem #-}
  celem = U.elem
  {-# INLINE [1] cnotElem #-}
  cnotElem = U.notElem
  {-# INLINE [1] cany #-}
  cany = U.any
  {-# INLINE [1] call #-}
  call = U.all
  {-# INLINE [1] cfoldl1 #-}
  cfoldl1 = U.foldl1
  {-# INLINE [1] cfoldr1 #-}
  cfoldr1 = U.foldr1
  {-# INLINE [1] csum #-}
  csum = U.sum
  {-# INLINE [1] cproduct #-}
  cproduct = U.product
  {-# INLINE [1] cmaximum #-}
  cmaximum = U.maximum
  {-# INLINE [1] cminimum #-}
  cminimum = U.minimum
  {-# INLINE cbasicToList #-}
  cbasicToList = U.toList
  {-# INLINE [1] clast #-}
  clast = U.last
  {-# INLINE [1] chead #-}
  chead = U.head
  {-# INLINE [1] cfind #-}
  cfind = U.find
  {-# INLINE [1] cfindIndex #-}
  cfindIndex = U.findIndex
  {-# INLINE [1] cfindIndices #-}
  cfindIndices = fmap U.toList . U.findIndices
  {-# INLINE [1] celemIndex #-}
  celemIndex = U.elemIndex
  {-# INLINE [1] celemIndices #-}
  celemIndices = fmap U.toList . U.elemIndices

instance CFoldable S.Vector where
  {-# INLINE [1] cfoldr #-}
  cfoldr = S.foldr
  {-# INLINE [1] cfoldr' #-}
  cfoldr' = S.foldr'
  {-# INLINE [1] cfoldl #-}
  cfoldl = S.foldl
  {-# INLINE [1] cfoldl' #-}
  cfoldl' = S.foldl'
  {-# INLINE cfoldlM #-}
  cfoldlM = S.foldM
  {-# INLINE cfoldlM' #-}
  cfoldlM' = S.foldM'
  {-# INLINE [1] cindex #-}
  cindex = (S.!)
  {-# INLINE [1] celem #-}
  celem = S.elem
  {-# INLINE [1] cnotElem #-}
  cnotElem = S.notElem
  {-# INLINE [1] cany #-}
  cany = S.any
  {-# INLINE [1] call #-}
  call = S.all
  {-# INLINE [1] cfoldl1 #-}
  cfoldl1 = S.foldl1
  {-# INLINE [1] cfoldr1 #-}
  cfoldr1 = S.foldr1
  {-# INLINE [1] csum #-}
  csum = S.sum
  {-# INLINE [1] cproduct #-}
  cproduct = S.product
  {-# INLINE [1] cmaximum #-}
  cmaximum = S.maximum
  {-# INLINE [1] cminimum #-}
  cminimum = S.minimum
  {-# INLINE cbasicToList #-}
  cbasicToList = S.toList
  {-# INLINE [1] clast #-}
  clast = S.last
  {-# INLINE [1] chead #-}
  chead = S.head
  {-# INLINE [1] cfind #-}
  cfind = S.find
  {-# INLINE [1] cfindIndex #-}
  cfindIndex = S.findIndex
  {-# INLINE [1] cfindIndices #-}
  cfindIndices = fmap S.toList . S.findIndices
  {-# INLINE [1] celemIndex #-}
  celemIndex = S.elemIndex
  {-# INLINE [1] celemIndices #-}
  celemIndices = fmap S.toList . S.elemIndices

instance CFoldable P.Vector where
  {-# INLINE [1] cfoldr #-}
  cfoldr = P.foldr
  {-# INLINE [1] cfoldr' #-}
  cfoldr' = P.foldr'
  {-# INLINE [1] cfoldl #-}
  cfoldl = P.foldl
  {-# INLINE [1] cfoldl' #-}
  cfoldl' = P.foldl'
  {-# INLINE cfoldlM #-}
  cfoldlM = P.foldM
  {-# INLINE cfoldlM' #-}
  cfoldlM' = P.foldM'
  {-# INLINE [1] cindex #-}
  cindex = (P.!)
  {-# INLINE [1] celem #-}
  celem = P.elem
  {-# INLINE [1] cnotElem #-}
  cnotElem = P.notElem
  {-# INLINE [1] cany #-}
  cany = P.any
  {-# INLINE [1] call #-}
  call = P.all
  {-# INLINE [1] cfoldl1 #-}
  cfoldl1 = P.foldl1
  {-# INLINE [1] cfoldr1 #-}
  cfoldr1 = P.foldr1
  {-# INLINE [1] csum #-}
  csum = P.sum
  {-# INLINE [1] cproduct #-}
  cproduct = P.product
  {-# INLINE [1] cmaximum #-}
  cmaximum = P.maximum
  {-# INLINE [1] cminimum #-}
  cminimum = P.minimum
  {-# INLINE cbasicToList #-}
  cbasicToList = P.toList
  {-# INLINE [1] clast #-}
  clast = P.last
  {-# INLINE [1] chead #-}
  chead = P.head
  {-# INLINE [1] cfind #-}
  cfind = P.find
  {-# INLINE [1] cfindIndex #-}
  cfindIndex = P.findIndex
  {-# INLINE [1] cfindIndices #-}
  cfindIndices = fmap P.toList . P.findIndices
  {-# INLINE [1] celemIndex #-}
  celemIndex = P.elemIndex
  {-# INLINE [1] celemIndices #-}
  celemIndices = fmap P.toList . P.elemIndices

instance CTraversable V.Vector where
  ctraverse = traverse
  {-# INLINE [1] ctraverse #-}

instance CTraversable U.Vector where
  ctraverse = \f -> fmap S.convert . traverse f . U.convert @_ @_ @V.Vector
  {-# INLINE [1] ctraverse #-}

instance CTraversable S.Vector where
  ctraverse = \f -> fmap S.convert . traverse f . U.convert @_ @_ @V.Vector
  {-# INLINE [1] ctraverse #-}

instance CTraversable P.Vector where
  ctraverse = \f -> fmap P.convert . traverse f . U.convert @_ @_ @V.Vector
  {-# INLINE [1] ctraverse #-}

{-# RULES
"cindex/IsSequence" forall (xs :: (MT.Index mono ~ Int, IsSequence mono) => WrapMono mono b).
  cindex xs = withMonoCoercible (coerce @(mono -> Int -> Element mono) indexEx xs)
  #-}

{-# RULES
"cfromList/ctoList" [~1]
  cfromList . ctoList = id
"cfromList/ctoList" [~1] forall xs.
  cfromList (ctoList xs) = xs
  #-}

{-# RULES
"ctoList/cfromList" [~1]
  ctoList . cfromList = id
"ctoList/cfromList" forall xs.
  ctoList (cfromList xs) = xs
  #-}
-- | Free monoid functor from fullsubcategory.
--   It must be a pointed foldable functor with the property
--   that for any 'Monoid' @w@ and @f :: a -> w@,
--   @'cfoldMap' f@ must be a monoid homomorphism and the following
--   must be hold:
--
--    @
--       'cfoldMap' f . 'cpure' == f
--    @
--
--   Hence, @'Set's@ cannot be a free monoid functor;
class (CFunctor f, forall x. Dom f x => Monoid (f x), CPointed f, CFoldable f)
  => CFreeMonoid f where
  cbasicFromList :: Dom f a => [a] -> f a
  cbasicFromList = foldr ((<>) . cpure) mempty
  {-# INLINE cbasicFromList #-}

  ccons :: Dom f a => a -> f a -> f a
  {-# INLINE [1] ccons #-}
  ccons = (<>) . cpure

  csnoc :: Dom f a => f a -> a -> f a
  {-# INLINE [1] csnoc #-}
  csnoc = (. cpure) . (<>)

  {- |
    The 'cfromListN' function takes the input list's length as a hint. Its behaviour should be equivalent to 'cfromList'. The hint can be used to construct the structure l more efficiently compared to 'cfromList'.
    If the given hint does not equal to the input list's length the behaviour of fromListN is not specified.
  -}
  cfromListN :: Dom f a => Int -> [a] -> f a
  cfromListN = const cfromList
  {-# INLINE [1] cfromListN #-}

  ctake :: Dom f a => Int -> f a -> f a
  {-# INLINE [1] ctake #-}
  ctake n = cfromList . take n . ctoList

  cdrop :: Dom f a => Int -> f a -> f a
  {-# INLINE [1] cdrop #-}
  cdrop n = cfromList . drop n . ctoList

  cinit :: Dom f a => f a -> f a
  {-# INLINE [1] cinit #-}
  cinit = cfromList . init . ctoList

  ctail :: Dom f a => f a -> f a
  ctail = cfromList . tail . ctoList

  csplitAt :: Dom f a => Int -> f a -> (f a, f a)
  {-# INLINE [1] csplitAt #-}
  csplitAt n = (\(a, b) -> (cfromList a, cfromList b)) . splitAt n . ctoList

  creplicate :: Dom f a => Int -> a -> f a
  {-# INLINE [1] creplicate #-}
  creplicate n = cfromList . replicate n

  cgenerate :: Dom f a => Int -> (Int -> a) -> f a
  {-# INLINE [1] cgenerate #-}
  cgenerate = \n f ->
    cfromList [f i | i <- [0.. n - 1]]

  cgenerateM :: (Dom f a, Monad m) => Int -> (Int -> m a) -> m (f a)
  {-# INLINE [1] cgenerateM #-}
  cgenerateM = \n f ->
    cfromList <$> mapM f [0..n-1]

  cgenerateA :: (Dom f a, Applicative g) => Int -> (Int -> g a) -> g (f a)
  {-# INLINE [1] cgenerateA #-}
  cgenerateA = \n f ->
    cfromList <$> traverse f [0..n-1]

  cuncons :: Dom f a => f a -> Maybe (a, f a)
  {-# INLINE [1] cuncons #-}
  cuncons = fmap (second cfromList) . uncons . ctoList

  cunsnoc :: Dom f a => f a -> Maybe (f a, a)
  {-# INLINE [1] cunsnoc #-}
  cunsnoc = fmap (first cfromList) . MT.unsnoc . ctoList

  creverse :: Dom f a => f a -> f a
  {-# INLINE [1] creverse #-}
  creverse = cfromList . reverse . ctoList

  cintersperse :: Dom f a => a -> f a -> f a
  cintersperse = \a -> cfromList . intersperse a . ctoList

  cnub :: (Dom f a, Eq a) => f a -> f a
  {-# INLINE [1] cnub #-}
  cnub = cfromList . nub . ctoList

  cnubOrd :: (Dom f a, Ord a) => f a -> f a
  {-# INLINE [1] cnubOrd #-}
  cnubOrd = cfromList . L.foldOver cfolded L.nub

  csort :: (Dom f a, Ord a) => f a -> f a
  {-# INLINE [1] csort #-}
  csort = cfromList . List.sort . ctoList

  csortBy :: (Dom f a) => (a -> a -> Ordering) -> f a -> f a
  {-# INLINE [1] csortBy #-}
  csortBy = \f -> cfromList . List.sortBy f . ctoList

  cinsert :: (Dom f a, Ord a) => a -> f a -> f a
  {-# INLINE [1] cinsert #-}
  cinsert = \a -> cfromList . List.insert a . ctoList

  cinsertBy :: (Dom f a) => (a -> a -> Ordering) -> a -> f a -> f a
  {-# INLINE [1] cinsertBy #-}
  cinsertBy = \f a -> cfromList . List.insertBy f a . ctoList

  ctakeWhile :: Dom f a => (a -> Bool) -> f a -> f a
  {-# INLINE [1] ctakeWhile #-}
  ctakeWhile = \f -> cfromList . takeWhile f . ctoList

  cdropWhile :: Dom f a => (a -> Bool) -> f a -> f a
  {-# INLINE [1] cdropWhile #-}
  cdropWhile = \f -> cfromList . dropWhile f . ctoList

  cspan :: Dom f a => (a -> Bool) -> f a -> (f a, f a)
  {-# INLINE [1] cspan #-}
  cspan = \f -> (cfromList *** cfromList) . span f . ctoList

  cbreak :: Dom f a => (a -> Bool) -> f a -> (f a, f a)
  {-# INLINE [1] cbreak #-}
  cbreak = \f -> (cfromList *** cfromList) . break f . ctoList

  cfilter :: Dom f a => (a -> Bool) -> f a -> f a
  {-# INLINE [1] cfilter #-}
  cfilter = \f -> cfromList . filter f . ctoList

  cpartition :: Dom f a => (a -> Bool) -> f a -> (f a, f a)
  {-# INLINE [1] cpartition #-}
  cpartition = \f -> (cfromList *** cfromList) . List.partition f . ctoList

  -- TODO: more ListLike equivalent functions here

instance CFreeMonoid [] where
  cbasicFromList = id
  {-# INLINE cbasicFromList #-}
  cfromListN = take
  {-# INLINE [1] cfromListN #-}
  ccons = (:)
  {-# INLINE [1] ccons #-}
  csnoc = \xs x -> xs ++ [x]
  {-# INLINE [1] csnoc #-}
  ctake = take
  {-# INLINE [1] ctake #-}
  cdrop = drop
  {-# INLINE [1] cdrop #-}
  cinit = init
  {-# INLINE [1] cinit #-}
  ctail = tail
  {-# INLINE [1] ctail #-}
  csplitAt = splitAt
  {-# INLINE [1] csplitAt #-}
  creplicate = replicate
  {-# INLINE [1] creplicate #-}
  cgenerateM = \n f -> mapM f [0..n-1]
  {-# INLINE [1] cgenerateM #-}
  cgenerateA = \n f -> traverse f [0..n-1]
  {-# INLINE [1] cgenerateA #-}
  cuncons = uncons
  {-# INLINE [1] cuncons #-}
  cunsnoc = MT.unsnoc
  {-# INLINE [1] cunsnoc #-}
  creverse = reverse
  {-# INLINE [1] creverse #-}
  cintersperse = intersperse
  {-# INLINE [1] cintersperse #-}
  cnub = cnub
  {-# INLINE [1] cnub #-}
  csort = List.sort
  {-# INLINE [1] csort #-}
  csortBy = List.sortBy
  {-# INLINE [1] csortBy #-}
  ctakeWhile = takeWhile
  {-# INLINE [1] ctakeWhile #-}
  cdropWhile = dropWhile
  {-# INLINE [1] cdropWhile #-}
  cspan = span
  {-# INLINE [1] cspan #-}
  cbreak = break
  {-# INLINE [1] cbreak #-}
  cfilter = filter
  {-# INLINE [1] cfilter #-}
  cpartition = List.partition
  {-# INLINE [1] cpartition #-}

fmap concat $ forM
  [''V.Vector, ''U.Vector, ''S.Vector, ''P.Vector]
  $ \vecTy@(Name _ (NameG _ pkg modl0@(ModName mn))) ->
    let modl = maybe modl0 (ModName . T.unpack)
          $ T.stripSuffix ".Base" $ T.pack mn
        modFun fun = varE $
          Name (OccName fun) (NameG VarName pkg modl)
    in [d|
    instance CFreeMonoid $(conT vecTy) where
      cbasicFromList = $(modFun "fromList")
      {-# INLINE cbasicFromList #-}
      cfromListN = $(modFun "fromListN")
      {-# INLINE [1] cfromListN #-}
      ccons = $(modFun "cons")
      {-# INLINE [1] ccons #-}
      csnoc = $(modFun "snoc")
      {-# INLINE [1] csnoc #-}
      ctake = $(modFun "take")
      {-# INLINE [1] ctake #-}
      cdrop = $(modFun "drop")
      {-# INLINE [1] cdrop #-}
      cinit = $(modFun "init")
      {-# INLINE [1] cinit #-}
      ctail = $(modFun "tail")
      {-# INLINE [1] ctail #-}
      csplitAt = $(modFun "splitAt")
      {-# INLINE [1] csplitAt #-}
      creplicate = $(modFun "replicate")
      {-# INLINE [1] creplicate #-}
      cgenerate = $(modFun "generate")
      {-# INLINE [1] cgenerate #-}
      cgenerateM = $(modFun "generateM")
      {-# INLINE [1] cgenerateM #-}
      cgenerateA = \n f ->
        fmap VB.build
        $ getAp $ foldMap (Ap . fmap VB.singleton . f) [0..n-1]
      {-# INLINE [1] cgenerateA #-}
      cuncons = \xs ->
        if $(modFun "null") xs
        then Nothing
        else Just ($(modFun "head") xs, $(modFun "tail") xs)
      {-# INLINE [1] cuncons #-}
      cunsnoc = \xs ->
        if $(modFun "null") xs
        then Nothing
        else Just ($(modFun "init") xs, $(modFun "last") xs)
      {-# INLINE [1] cunsnoc #-}
      creverse = $(modFun "reverse")
      {-# INLINE [1] creverse #-}
      cnubOrd = $(modFun "uniq") . $(modFun "modify") AI.sort
      {-# INLINE cnubOrd #-}
      csort = $(modFun "modify") AI.sort
      {-# INLINE [1] csort #-}
      csortBy = \f -> $(modFun "modify") $ AI.sortBy f
      {-# INLINE [1] csortBy #-}
      ctakeWhile = $(modFun "takeWhile")
      {-# INLINE [1] ctakeWhile #-}
      cdropWhile = $(modFun "dropWhile")
      {-# INLINE [1] cdropWhile #-}
      cspan = $(modFun "span")
      {-# INLINE [1] cspan #-}
      cbreak = $(modFun "break")
      {-# INLINE [1] cbreak #-}
      cfilter = $(modFun "filter")
      {-# INLINE [1] cfilter #-}
      cpartition = $(modFun "partition")
      {-# INLINE [1] cpartition #-}
    |]

instance CFreeMonoid PA.PrimArray where
  cbasicFromList = PA.primArrayFromList
  {-# INLINE cbasicFromList #-}
  cfromListN = PA.primArrayFromListN
  {-# INLINE [1] cfromListN #-}
  cgenerate = PA.generatePrimArray
  {-# INLINE [1] cgenerate #-}
  cgenerateM = PA.generatePrimArrayA
  {-# INLINE [1] cgenerateM #-}
  cgenerateA = PA.generatePrimArrayA
  {-# INLINE [1] cgenerateA #-}
  cfilter = PA.filterPrimArray
  {-# INLINE [1] cfilter #-}
  creplicate = PA.replicatePrimArray
  {-# INLINE [1] creplicate #-}

instance CFreeMonoid SA.SmallArray where
  cbasicFromList = SA.smallArrayFromList
  {-# INLINE cbasicFromList #-}
  cfromListN = SA.smallArrayFromListN
  {-# INLINE [1] cfromListN #-}

instance CFreeMonoid A.Array where
  cbasicFromList = A.fromList
  {-# INLINE cbasicFromList #-}
  cfromListN = A.fromListN
  {-# INLINE [1] cfromListN #-}
instance CFreeMonoid Seq.Seq where
  cbasicFromList = Seq.fromList
  {-# INLINE cbasicFromList #-}
  cfromListN = GHC.fromListN
  {-# INLINE [1] cfromListN #-}

instance MT.IsSequence mono
      => CFreeMonoid (WrapMono mono) where
  cbasicFromList = coerce $ MT.fromList @mono
  {-# INLINE cbasicFromList #-}
  cfromListN = \n -> coerce $ MT.take (fromIntegral n) . MT.fromList @mono
  {-# INLINE [1] cfromListN #-}
  ctake = coerce . MT.take @mono . fromIntegral
  {-# INLINE [1] ctake #-}
  cdrop = coerce . MT.drop @mono . fromIntegral
  {-# INLINE [1] cdrop #-}
  ccons = coerce $ MT.cons @mono
  {-# INLINE ccons #-}
  csnoc = coerce $ MT.snoc @mono
  {-# INLINE [1] csnoc #-}
  cuncons = coerce $ MT.uncons @mono
  {-# INLINE [1] cuncons #-}
  cunsnoc = coerce $ MT.unsnoc @mono
  {-# INLINE [1] cunsnoc #-}
  ctail = coerce $ MT.tailEx @mono
  {-# INLINE [1] ctail #-}
  cinit = coerce $ MT.initEx @mono
  {-# INLINE [1] cinit #-}
  csplitAt = coerce $ \(n :: Int) ->
      MT.splitAt @mono (fromIntegral n :: MT.Index mono)
  {-# INLINE [1] csplitAt #-}
  creplicate = coerce $ \(n :: Int) ->
      MT.replicate @mono (fromIntegral n :: MT.Index mono)
  {-# INLINE [1] creplicate #-}
  creverse = coerce $ MT.reverse @mono
  {-# INLINE [1] creverse #-}
  cintersperse = coerce $ MT.intersperse @mono
  {-# INLINE [1] cintersperse #-}
  csort = coerce $ MT.sort @mono
  {-# INLINE [1] csort #-}
  csortBy = coerce $ MT.sortBy @mono
  {-# INLINE [1] csortBy #-}
  ctakeWhile = coerce $ MT.takeWhile @mono
  {-# INLINE [1] ctakeWhile #-}
  cdropWhile = coerce $ MT.dropWhile @mono
  {-# INLINE [1] cdropWhile #-}
  cbreak = coerce $ MT.break @mono
  {-# INLINE [1] cbreak #-}
  cspan = coerce $ MT.span @mono
  {-# INLINE [1] cspan #-}
  cfilter = coerce $ MT.filter @mono
  {-# INLINE [1] cfilter #-}
  cpartition = coerce $ MT.partition @mono
  {-# INLINE [1] cpartition #-}

cctraverseFreeMonoid
  ::  ( CFreeMonoid t, CApplicative f, CPointed f,
        Dom t a, Dom f (t b), Dom f b, Dom t b,
        Dom f (t b, t b)
      )
  => (a -> f b) -> t a -> f (t b)
cctraverseFreeMonoid f =
  runCApp . cfoldMap (CApp . cmap cpure . f)

cctraverseZipFreeMonoid
  :: ( CFreeMonoid t, CRepeat f,
        Dom t a, Dom f (t b), Dom f b, Dom t b,
        Dom f (t b, t b)
      )
  => (a -> f b) -> t a -> f (t b)
cctraverseZipFreeMonoid f =
  runCZippy . cfoldMap (CZippy . cmap cpure . f)

-- | Lifts 'CFoldable' along given function.
--
--  @
--    cfolding :: (CFoldable t, Dom t a) => (s -> t a) -> Fold s a
--  @
cfolding
  :: (CFoldable t, Dom t a, Contravariant f, Applicative f)
  => (s -> t a)
  -> (a -> f a) -> s -> f s
{-# INLINE cfolding #-}
cfolding = \sfa agb -> phantom . ctraverse_ agb . sfa

max_stars_repo_name: konn/subcategories

max_issues_repo_name: konn/subcategories

max_forks_repo_name: konn/subcategories


text:
{-# LANGUAGE NamedFieldPuns #-}

module ZambiniSim where

import Data.Complex (Complex((:+)), phase, cis)

import Graphics.Gloss.Interface.Pure.Simulate

import Zambini
import Controller.PID

---------- MAIN LOOP STUFF ----------

data ZambiniSim = ZambiniSim { zambini :: Zambini
                             , xPID :: PID C
                             , thetaPID :: PID R
                             }

initial :: ZambiniSim
initial = ZambiniSim { zambini = Zambini { m = 0.1
                                         , i = 1
                                         , r = 1
                                         , fMax = 30
                                         , f1 = 0
                                         , f2 = 0
                                         , x = 0
                                         , v = 0
                                         , theta = 0
                                         , omega = 0
                                         }
                     , xPID = pidController (0.5, 0, 10) target noFilter noFilter 0
                     , thetaPID = pidController (5, 0, 8) 0 noFilter noFilter 0
                     }
  where
    target = (-100) :+ 100

validControl :: Zambini -> (R, R) -> (R, R)
validControl Zambini{r, fMax} (t, f) = (f1, f2)
  where
    t' = if t < 0 then -t else t
    f' = if f < fMax then 2*fMax - f else f

    validT' = fMax / (((f'-fMax)/t') + (1/r))
    validF' = -validT'/r + 2*fMax

    validT = if t < 0 then -validT' else validT'
    validF = if f < fMax then 2*fMax - validF' else validF'

    f1 = validT/(2*r*fMax) + validF/(2*fMax)
    f2 = -validT/(2*r*fMax) + validF/(2*fMax)

control :: Real t => t -> ZambiniSim -> ZambiniSim
control dt ZambiniSim{zambini, xPID, thetaPID} = ZambiniSim zambini' xPID' thetaPID'
  where
    dot :: C -> C -> R
    dot (r1 :+ i1) (r2 :+ i2) = r1*r2 + i1*i2

    (control, xPID') = getControl dt (x zambini) xPID
    targetForce = control `dot` cis (theta zambini)
    targetAngle = phase control
    (targetTorque, thetaPID') =  getControl dt (theta zambini) thetaPID{pidTarget=targetAngle}

    (f1, f2) = validControl zambini (targetTorque, targetForce)
    zambini' = zambini{f1=f1, f2=f2}

mainStep :: ViewPort -> Float -> ZambiniSim -> ZambiniSim
mainStep _ deltaFloat state = state'{zambini=zambini'}
  where
    dt = realToFrac deltaFloat
    state' = control dt state
    zambini' = step dt (zambini state')

renderSim :: ZambiniSim -> Picture
renderSim ZambiniSim{zambini, xPID=PID{pidTarget}} = pictures [render zambini, target]
  where
    target = move pidTarget $ color red $ circle 5
    move (x :+ y) = translate (realToFrac x) (realToFrac y)

zambiniMain :: IO ()
zambiniMain = simulate display background fps initial renderSim mainStep
  where
    display = InWindow "Control Systems" (1200, 800) (100, 100)
    background = black
    fps = 60

ext: hs

max_stars_repo_name: tyehle/control-systems

max_issues_repo_name: tyehle/control-systems

max_forks_repo_name: tyehle/control-systems


text:
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      : VectorSpace
-- Description : Particle Swarm Optimisation
-- Copyright   : (c) Tom Westerhout, 2017
-- License     : BSD3
-- Maintainer  : t.westerhout@student.ru.nl
-- Stability   : experimental

module PSO.VectorSpace
  ( Scalable(..)
  , VectorSpace(..)
  ) where

import           Data.Complex        (Complex (..))
import           Foreign.Storable
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Generic as GV

class Scalable a v where
  scale :: a -> v -> v

instance (Num a) => Scalable a a where
  scale = (*)

instance (Num a) => Scalable a (Complex a) where
  scale c (x :+ y) = (c * x) :+ (c * y)

instance (Num a, Storable a) => Scalable a (V.Vector a) where
  scale c = V.map (c*)

instance (RealFloat a, Storable a) => Scalable a (V.Vector (Complex a)) where
  scale c = scale (c :+ 0)

class (Num a, Num v, Scalable a v) => VectorSpace v a

instance (Num a, Num v, Scalable a v) => VectorSpace v a

max_stars_repo_name: twesterhout/tcm-swarm

max_issues_repo_name: twesterhout/tcm-swarm

max_forks_repo_name: twesterhout/tcm-swarm


text:
{-# LANGUAGE DataKinds, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-- | Vector-based (meaning that dual numbers for gradient computation
-- consider vectors, not scalars, as the primitive differentiable type)
-- implementation of fully connected neutral network for classification
-- of MNIST digits. Sports 2 hidden layers.
module HordeAd.Tool.MnistFcnnVector where

import Prelude

import           Control.Exception (assert)
import qualified Data.Array.DynamicS as OT
import qualified Data.Vector.Generic as V
import           GHC.Exts (inline)
import           Numeric.LinearAlgebra (Vector)

import HordeAd.Core.DualNumber
import HordeAd.Core.Engine
import HordeAd.Core.PairOfVectors (DualNumberVariables, var1)
import HordeAd.Tool.MnistData

sumTrainableInputsV
  :: IsScalar d r
  => DualNumber d (Vector r) -> Int -> DualNumberVariables d r -> DualNumber d r
sumTrainableInputsV x offset variables =
  let v = var1 variables offset
  in v <.>! x

sumTrainableInputsL
  :: forall d r. IsScalar d r
  => DualNumber d (Vector r) -> Int -> DualNumberVariables d r -> Int
  -> DualNumber d (Vector r)
sumTrainableInputsL x offset variables width =
  let f :: Int -> DualNumber d r
      f i = sumTrainableInputsV x (offset + i) variables
  in seq1 $ V.generate width f

sumConstantDataV
  :: IsScalar d r
  => Vector r -> Int -> DualNumberVariables d r -> DualNumber d r
sumConstantDataV x offset variables =
  let v = var1 variables offset
  in v <.>!! x

sumConstantDataL
  :: forall d r. IsScalar d r
  => Vector r -> Int -> DualNumberVariables d r -> Int
  -> DualNumber d (Vector r)
sumConstantDataL x offset variables width =
  let f :: Int -> DualNumber d r
      f i = sumConstantDataV x (offset + i) variables
  in seq1 $ V.generate width f

fcnnMnistLen1 :: Int -> Int -> (Int, [Int], [(Int, Int)], [OT.ShapeL])
fcnnMnistLen1 widthHidden widthHidden2 =
  ( 0
  , replicate widthHidden sizeMnistGlyph ++ [widthHidden]
    ++ replicate widthHidden2 widthHidden ++ [widthHidden2]
    ++ replicate sizeMnistLabel widthHidden2 ++ [sizeMnistLabel]
  , []
  , []
  )

-- | Fully connected neural network for the MNIST digit classification task.
-- There are two hidden layers and both use the same activation function.
-- The output layer uses a different activation function.
-- The widths of the hidden layers are @widthHidden@ and @widthHidden2@
-- and from these, the @len*@ functions compute the number and dimensions
-- of scalars (none in this case) and vectors of dual number parameters
-- (variables) to be given to the program.
fcnnMnist1 :: forall d r m. DualMonad d r m
           => (DualNumber d (Vector r) -> m (DualNumber d (Vector r)))
           -> (DualNumber d (Vector r) -> m (DualNumber d (Vector r)))
           -> Int
           -> Int
           -> Vector r
           -> DualNumberVariables d r
           -> m (DualNumber d (Vector r))
fcnnMnist1 factivationHidden factivationOutput widthHidden widthHidden2
          input variables = do
  let !_A = assert (sizeMnistGlyph == V.length input) ()
  let hiddenLayer1 = sumConstantDataL input 0 variables widthHidden
                     + var1 variables widthHidden  -- bias
  nonlinearLayer1 <- factivationHidden hiddenLayer1
  let offsetMiddle = widthHidden + 1
      hiddenLayer2 = sumTrainableInputsL nonlinearLayer1 offsetMiddle
                                         variables widthHidden2
                     + var1 variables (offsetMiddle + widthHidden2)  -- bias
  nonlinearLayer2 <- factivationHidden hiddenLayer2
  let offsetOutput = offsetMiddle + widthHidden2 + 1
      outputLayer = sumTrainableInputsL nonlinearLayer2 offsetOutput
                                        variables sizeMnistLabel
                    + var1 variables (offsetOutput + sizeMnistLabel)  -- bias
  factivationOutput outputLayer

-- | The neural network applied to concrete activation functions
-- and composed with the appropriate loss function.
fcnnMnistLoss1
  :: DualMonad d r m
  => Int -> Int -> MnistData r -> DualNumberVariables d r
  -> m (DualNumber d r)
fcnnMnistLoss1 widthHidden widthHidden2 (input, target) variables = do
  result <- inline fcnnMnist1 logisticAct softMaxActV
                              widthHidden widthHidden2 input variables
  lossCrossEntropyV target result

-- | A function testing the neural network given testing set of inputs
-- and the trained parameters.
fcnnMnistTest1
  :: forall r. IsScalar 'DModeGradient r
  => Int -> Int -> [MnistData r] -> (Domain0 r, Domain1 r) -> r
fcnnMnistTest1 widthHidden widthHidden2 inputs (params0, params1) =
  let matchesLabels :: MnistData r -> Bool
      matchesLabels (glyph, label) =
        let nn = inline fcnnMnist1 logisticAct softMaxActV
                                        widthHidden widthHidden2 glyph
            value = primalValue nn (params0, params1, V.empty, V.empty)
        in V.maxIndex value == V.maxIndex label
  in fromIntegral (length (filter matchesLabels inputs))
     / fromIntegral (length inputs)

max_stars_repo_name: Mikolaj/horde-ad

max_issues_repo_name: Mikolaj/horde-ad

max_forks_repo_name: Mikolaj/horde-ad


text:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module DFT.FFI where

import qualified Foreign.C.Types as C
import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Data.Complex (Complex)

#include <fftw3.h>

type FFTWFlag = C.CUInt

#{enum FFTWFlag,
 , c_measure         = FFTW_MEASURE
 , c_destroy_input   = FFTW_DESTROY_INPUT
 , c_unaligned       = FFTW_UNALIGNED
 , c_conserve_memory = FFTW_CONSERVE_MEMORY
 , c_exhaustive      = FFTW_EXHAUSTIVE
 , c_preserve_input  = FFTW_PRESERVE_INPUT
 , c_patient         = FFTW_PATIENT
 , c_estimate        = FFTW_ESTIMATE
 }

type FFTWSign = C.CInt

#{enum FFTWSign,
 , c_forward = FFTW_FORWARD
 , c_backward = FFTW_BACKWARD
 }

type FFTWKind = C.CInt

#{enum FFTWKind,
 , c_r2hc    = FFTW_R2HC
 , c_hc2r    = FFTW_HC2R
 , c_dht     = FFTW_DHT
 , c_redft00 = FFTW_REDFT00
 , c_redft10 = FFTW_REDFT10
 , c_redft01 = FFTW_REDFT01
 , c_redft11 = FFTW_REDFT11
 , c_rodft00 = FFTW_RODFT00
 , c_rodft10 = FFTW_RODFT10
 , c_rodft01 = FFTW_RODFT01
 , c_rodft11 = FFTW_RODFT11
 }

-- | A plan is an opaque foreign object.
type Plan = Ptr FFTWPlan

type FFTWPlan = ()

-- We use "safe" calls for anything which could take a while so that it won't block
-- other Haskell threads.

-- | Simple plan execution
foreign import ccall safe "fftw3.h fftw_execute" c_execute
    :: Plan -> IO ()

-- Execute a plan on different memory than the plan was created for.
-- Alignment /must/ be the same.  If we parallelize a transform of
-- multi-dimensional data by making separate calls within an un-transformed
-- dimension, it is possible that the alignment constraint would not be
-- fulfilled.  However, this only poses a problem for real transforms with odd
-- transform dimension.
foreign import ccall safe "fftw3.h fftw_execute_dft" c_execute_dft
    :: Plan -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_dft_r2c" c_execute_dft_r2c
    :: Plan -> Ptr Double -> Ptr (Complex Double) -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_dft_c2r" c_execute_dft_c2r
    :: Plan -> Ptr (Complex Double) -> Ptr Double -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_r2r" c_execute_r2r
    :: Plan -> Ptr Double -> Ptr Double -> IO ()

foreign import ccall safe "fftw3.h fftw_export_wisdom_to_string"
        c_export_wisdom_string :: IO CString

foreign import ccall safe "fftw3.h fftw_export_wisdom_to_filename"
        c_export_wisdom_filename :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_wisdom_from_string"
        c_import_wisdom_string :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_wisdom_from_filename"
        c_import_wisdom_filename :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_system_wisdom"
        c_import_wisdom_system :: IO C.CInt

-- | Frees memory allocated by 'fftw_malloc'.  Currently, we only need this to
-- free the wisdom string.
foreign import ccall safe "fftw3.h fftw_free" c_free :: Ptr a -> IO ()

foreign import ccall safe "fftw3.h fftw_destroy_plan" c_destroy_plan ::  Plan -> IO ()

foreign import ccall safe "fftw3.h fftw_cleanup" c_cleanup :: IO ()

foreign import ccall safe "fftw3.h fftw_plan_dft_2d" c_plan_dft_2d :: C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_1d" c_plan_dft_1d :: C.CInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_r2c_1d" c_plan_dft_r2c_1d :: C.CInt -> Ptr C.CDouble -> Ptr (Complex Double) -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_many_dft" c_plan_many_dft :: C.CInt -> Ptr C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr C.CInt -> C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr C.CInt -> C.CInt -> C.CInt -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_r2c_2d" c_plan_dft_r2c_2d :: C.CInt -> C.CInt -> Ptr C.CDouble -> Ptr (Complex Double) -> FFTWFlag -> IO Plan

ext: hsc

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:
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE EmptyCase                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

-- |
-- Module      : Numeric.Backprop.Class
-- Copyright   : (c) Justin Le 2018
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Provides the 'Backprop' typeclass, a class for values that can be used
-- for backpropagation.
--
-- This class replaces the old (version 0.1) API relying on 'Num'.
--
-- @since 0.2.0.0

module Numeric.Backprop.Class (
  -- * Backpropagatable types
    Backprop(..)
  -- * Derived methods
  , zeroNum, addNum, oneNum
  , zeroVec, addVec, oneVec, zeroVecNum, oneVecNum
  , zeroFunctor, addIsList, addAsList, oneFunctor
  , genericZero, genericAdd, genericOne
  -- * Newtype
  , ABP(..), NumBP(..), NumVec(..)
  -- * Generics
  , GZero, GAdd, GOne
  ) where

import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad
import           Data.Coerce
import           Data.Complex
import           Data.Data
import           Data.Foldable hiding  (toList)
import           Data.Functor.Compose
import           Data.Functor.Identity
import           Data.List.NonEmpty    (NonEmpty(..))
import           Data.Monoid
import           Data.Ratio
import           Data.Vinyl
import           Data.Vinyl.ARec
import           Data.Vinyl.TypeLevel
import           Data.Void
import           Data.Word
import           GHC.Exts
import           GHC.Generics
import           Numeric.Natural
import qualified Control.Arrow         as Arr
import qualified Data.Functor.Product  as DFP
import qualified Data.IntMap           as IM
import qualified Data.Map              as M
import qualified Data.Semigroup        as SG
import qualified Data.Sequence         as Seq
import qualified Data.Vector           as V
import qualified Data.Vector.Generic   as VG
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable  as VS
import qualified Data.Vector.Unboxed   as VU
import qualified Data.Vinyl.Functor    as V
import qualified Data.Vinyl.XRec       as V

-- | Class of values that can be backpropagated in general.
--
-- For instances of 'Num', these methods can be given by 'zeroNum',
-- 'addNum', and 'oneNum'.  There are also generic options given in
-- "Numeric.Backprop.Class" for functors, 'IsList' instances, and 'Generic'
-- instances.
--
-- @
-- instance 'Backprop' 'Double' where
--     'zero' = 'zeroNum'
--     'add' = 'addNum'
--     'one' = 'oneNum'
-- @
--
-- If you leave the body of an instance declaration blank, GHC Generics
-- will be used to derive instances if the type has a single constructor
-- and each field is an instance of 'Backprop'.
--
-- To ensure that backpropagation works in a sound way, should obey the
-- laws:
--
-- [/identity/]
--
--   * @'add' x ('zero' y) = x@
--
--   * @'add' ('zero' x) y = y@
--
-- Also implies preservation of information, making @'zipWith' ('+')@ an
-- illegal implementation for lists and vectors.
--
-- This is only expected to be true up to potential "extra zeroes" in @x@
-- and @y@ in the result.
--
-- [/commutativity/]
--
--   * @'add' x y = 'add' y x@
--
-- [/associativity/]
--
--   * @'add' x ('add' y z) = 'add' ('add' x y) z@
--
-- [/idempotence/]
--
--   * @'zero' '.' 'zero' = 'zero'@
--
--   * @'one' '.' 'one' = 'one'@
--
-- [/unital/]
--
--   * @'one' = 'gradBP' 'id'@
--
-- Note that not all values in the backpropagation process needs all of
-- these methods: Only the "final result" needs 'one', for example.  These
-- are all grouped under one typeclass for convenience in defining
-- instances, and also to talk about sensible laws.  For fine-grained
-- control, use the "explicit" versions of library functions (for example,
-- in "Numeric.Backprop.Explicit") instead of 'Backprop' based ones.
--
-- This typeclass replaces the reliance on 'Num' of the previous API
-- (v0.1).  'Num' is strictly more powerful than 'Backprop', and is
-- a stronger constraint on types than is necessary for proper
-- backpropagating.  In particular, 'fromInteger' is a problem for many
-- types, preventing useful backpropagation for lists, variable-length
-- vectors (like "Data.Vector") and variable-size matrices from linear
-- algebra libraries like /hmatrix/ and /accelerate/.
--
-- @since 0.2.0.0
class Backprop a where
    -- | "Zero out" all components of a value.  For scalar values, this
    -- should just be @'const' 0@.  For vectors and matrices, this should
    -- set all components to zero, the additive identity.
    --
    -- Should be idempotent:
    --
    --   * @'zero' '.' 'zero' = 'zero'@
    --
    -- Should be as /lazy/ as possible.  This behavior is observed for
    -- all instances provided by this library.
    --
    -- See 'zeroNum' for a pre-built definition for instances of 'Num' and
    -- 'zeroFunctor' for a definition for instances of 'Functor'.  If left
    -- blank, will automatically be 'genericZero', a pre-built definition
    -- for instances of 'GHC.Generic' whose fields are all themselves
    -- instances of 'Backprop'.
    zero :: a -> a
    -- | Add together two values of a type.  To combine contributions of
    -- gradients, so should be information-preserving:
    --
    --   * @'add' x ('zero' y) = x@
    --
    --   * @'add' ('zero' x) y = y@
    --
    -- Should be as /strict/ as possible.  This behavior is observed for
    -- all instances provided by this library.
    --
    -- See 'addNum' for a pre-built definition for instances of 'Num' and
    -- 'addIsList' for a definition for instances of 'IsList'.  If left
    -- blank, will automatically be 'genericAdd', a pre-built definition
    -- for instances of 'GHC.Generic' with one constructor whose fields are
    -- all themselves instances of 'Backprop'.
    add  :: a -> a -> a
    -- | "One" all components of a value.  For scalar values, this should
    -- just be @'const' 1@.  For vectors and matrices, this should set all
    -- components to one, the multiplicative identity.
    --
    -- As the library uses it, the most important law is:
    --
    --   * @'one' = 'gradBP' 'id'@
    --
    -- That is, @'one' x@ is the gradient of the identity function with
    -- respect to its input.
    --
    -- Ideally should be idempotent:
    --
    --   * @'one' '.' 'one' = 'one'@
    --
    -- Should be as /lazy/ as possible.  This behavior is observed for
    -- all instances provided by this library.
    --
    -- See 'oneNum' for a pre-built definition for instances of 'Num' and
    -- 'oneFunctor' for a definition for instances of 'Functor'.  If left
    -- blank, will automatically be 'genericOne', a pre-built definition
    -- for instances of 'GHC.Generic' whose fields are all themselves
    -- instances of 'Backprop'.
    one  :: a -> a

    default zero :: (Generic a, GZero (Rep a)) => a -> a
    zero = genericZero
    {-# INLINE zero #-}
    default add :: (Generic a, GAdd (Rep a)) => a -> a -> a
    add = genericAdd
    {-# INLINE add #-}
    default one :: (Generic a, GOne (Rep a)) => a -> a
    one = genericOne
    {-# INLINE one #-}

-- | 'zero' using GHC Generics; works if all fields are instances of
-- 'Backprop'.
genericZero :: (Generic a, GZero (Rep a)) => a -> a
genericZero = to . gzero . from
{-# INLINE genericZero #-}

-- | 'add' using GHC Generics; works if all fields are instances of
-- 'Backprop', but only for values with single constructors.
genericAdd :: (Generic a, GAdd (Rep a)) => a -> a -> a
genericAdd x y = to $ gadd (from x) (from y)
{-# INLINE genericAdd #-}

-- | 'one' using GHC Generics; works if all fields are instaces of
-- 'Backprop'.
genericOne :: (Generic a, GOne (Rep a)) => a -> a
genericOne = to . gone . from
{-# INLINE genericOne #-}

-- | 'zero' for instances of 'Num'.
--
-- Is lazy in its argument.
zeroNum :: Num a => a -> a
zeroNum _ = 0
{-# INLINE zeroNum #-}

-- | 'add' for instances of 'Num'.
addNum :: Num a => a -> a -> a
addNum = (+)
{-# INLINE addNum #-}

-- | 'one' for instances of 'Num'.
--
-- Is lazy in its argument.
oneNum :: Num a => a -> a
oneNum _ = 1
{-# INLINE oneNum #-}

-- | 'zero' for instances of 'VG.Vector'.
zeroVec :: (VG.Vector v a, Backprop a) => v a -> v a
zeroVec = VG.map zero
{-# INLINE zeroVec #-}

-- | 'add' for instances of 'VG.Vector'.  Automatically pads the end of the
-- shorter vector with zeroes.
addVec :: (VG.Vector v a, Backprop a) => v a -> v a -> v a
addVec x y = case compare lX lY of
    LT -> let (y1,y2) = VG.splitAt (lY - lX) y
          in  VG.zipWith add x y1 VG.++ y2
    EQ -> VG.zipWith add x y
    GT -> let (x1,x2) = VG.splitAt (lX - lY) x
          in  VG.zipWith add x1 y VG.++ x2
  where
    lX = VG.length x
    lY = VG.length y

-- | 'one' for instances of 'VG.Vector'.
oneVec :: (VG.Vector v a, Backprop a) => v a -> v a
oneVec = VG.map one
{-# INLINE oneVec #-}

-- | 'zero' for instances of 'VG.Vector' when the contained type is an
-- instance of 'Num'.  Is potentially more performant than 'zeroVec' when
-- the vectors are larger.
--
-- See 'NumVec' for a 'Backprop' instance for 'VG.Vector' instances that
-- uses this for 'zero'.
--
-- @since 0.2.4.0
zeroVecNum :: (VG.Vector v a, Num a) => v a -> v a
zeroVecNum = flip VG.replicate 0 . VG.length
{-# INLINE zeroVecNum #-}

-- | 'one' for instances of 'VG.Vector' when the contained type is an
-- instance of 'Num'.  Is potentially more performant than 'oneVec' when
-- the vectors are larger.
--
-- See 'NumVec' for a 'Backprop' instance for 'VG.Vector' instances that
-- uses this for 'one'.
--
-- @since 0.2.4.0
oneVecNum :: (VG.Vector v a, Num a) => v a -> v a
oneVecNum = flip VG.replicate 1 . VG.length
{-# INLINE oneVecNum #-}

-- | 'zero' for 'Functor' instances.
zeroFunctor :: (Functor f, Backprop a) => f a -> f a
zeroFunctor = fmap zero
{-# INLINE zeroFunctor #-}

-- | 'add' for instances of 'IsList'.  Automatically pads the end of the
-- "shorter" value with zeroes.
addIsList :: (IsList a, Backprop (Item a)) => a -> a -> a
addIsList = addAsList toList fromList
{-# INLINE addIsList #-}

-- | 'add' for types that are isomorphic to a list.
-- Automatically pads the end of the "shorter" value with zeroes.
addAsList
    :: Backprop b
    => (a -> [b])       -- ^ convert to list (should form isomorphism)
    -> ([b] -> a)       -- ^ convert from list (should form isomorphism)
    -> a
    -> a
    -> a
addAsList f g x y = g $ go (f x) (f y)
  where
    go = \case
      [] -> id
      o@(x':xs) -> \case
        []    -> o
        y':ys -> add x' y' : go xs ys

-- | 'one' for instances of 'Functor'.
oneFunctor :: (Functor f, Backprop a) => f a -> f a
oneFunctor = fmap one
{-# INLINE oneFunctor #-}

-- | A newtype wrapper over an instance of 'Num' that gives a free
-- 'Backprop' instance.
--
-- Useful for things like /DerivingVia/, or for avoiding orphan instances.
--
-- @since 0.2.1.0
newtype NumBP a = NumBP { runNumBP :: a }
  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic, Functor, Foldable, Traversable, Num, Fractional, Floating)

instance NFData a => NFData (NumBP a)

instance Applicative NumBP where
    pure    = NumBP
    {-# INLINE pure #-}
    f <*> x = NumBP $ (runNumBP f) (runNumBP x)
    {-# INLINE (<*>) #-}

instance Monad NumBP where
    return = NumBP
    {-# INLINE return #-}
    x >>= f = f (runNumBP x)
    {-# INLINE (>>=) #-}

instance Num a => Backprop (NumBP a) where
    zero = coerce (zeroNum :: a -> a)
    {-# INLINE zero #-}
    add = coerce (addNum :: a -> a -> a)
    {-# INLINE add #-}
    one = coerce (oneNum :: a -> a)
    {-# INLINE one #-}

-- | Newtype wrapper around a @v a@ for @'VG.Vector' v a@, that gives
-- a more efficient 'Backprop' instance for /long/ vectors when @a@ is an
-- instance of 'Num'.  The normal 'Backprop' instance for vectors will map
-- 'zero' or 'one' over all items; this instance will completely ignore the
-- contents of the original vector and instead produce a new vector of the
-- same length, with all @0@ or @1@ using the 'Num' instance of @a@
-- (essentially using 'zeroVecNum' and 'oneVecNum' instead of 'zeroVec' and
-- 'oneVec').
--
-- 'add' is essentially the same as normal, but using '+' instead of the
-- type's 'add'.
--
-- @since 0.2.4.0
newtype NumVec v a = NumVec { runNumVec :: v a }
  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic, Functor, Applicative, Monad, Alternative, MonadPlus, Foldable, Traversable)

instance NFData (v a) => NFData (NumVec v a)

instance (VG.Vector v a, Num a) => Backprop (NumVec v a) where
    zero = coerce $ zeroVecNum @v @a
    add (NumVec x) (NumVec y) = NumVec $ case compare lX lY of
        LT -> let (y1,y2) = VG.splitAt (lY - lX) y
              in  VG.zipWith (+) x y1 VG.++ y2
        EQ -> VG.zipWith (+) x y
        GT -> let (x1,x2) = VG.splitAt (lX - lY) x
              in  VG.zipWith (+) x1 y VG.++ x2
      where
        lX = VG.length x
        lY = VG.length y
    one = coerce $ oneVecNum @v @a

-- | A newtype wrapper over an @f a@ for @'Applicative' f@ that gives
-- a free 'Backprop' instance (as well as 'Num' etc. instances).
--
-- Useful for performing backpropagation over functions that require some
-- monadic context (like 'IO') to perform.
--
-- @since 0.2.1.0
newtype ABP f a = ABP { runABP :: f a }
  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic, Functor, Applicative, Monad, Alternative, MonadPlus, Foldable, Traversable)

instance NFData (f a) => NFData (ABP f a)

instance (Applicative f, Backprop a) => Backprop (ABP f a) where
    zero = fmap zero
    {-# INLINE zero #-}
    add  = liftA2 add
    {-# INLINE add #-}
    one  = fmap one
    {-# INLINE one #-}

instance (Applicative f, Num a) => Num (ABP f a) where
    (+) = liftA2 (+)
    {-# INLINE (+) #-}
    (-) = liftA2 (-)
    {-# INLINE (-) #-}
    (*) = liftA2 (*)
    {-# INLINE (*) #-}
    negate = fmap negate
    {-# INLINE negate #-}
    abs = fmap abs
    {-# INLINE abs #-}
    signum = fmap signum
    {-# INLINE signum #-}
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

instance (Applicative f, Fractional a) => Fractional (ABP f a) where
    (/) = liftA2 (/)
    {-# INLINE (/) #-}
    recip = fmap recip
    {-# INLINE recip #-}
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

instance (Applicative f, Floating a) => Floating (ABP f a) where
    pi  = pure pi
    {-# INLINE pi #-}
    exp = fmap exp
    {-# INLINE exp #-}
    log = fmap log
    {-# INLINE log #-}
    sqrt = fmap sqrt
    {-# INLINE sqrt #-}
    (**) = liftA2 (**)
    {-# INLINE (**) #-}
    logBase = liftA2 logBase
    {-# INLINE logBase #-}
    sin = fmap sin
    {-# INLINE sin #-}
    cos = fmap cos
    {-# INLINE cos #-}
    tan = fmap tan
    {-# INLINE tan #-}
    asin = fmap asin
    {-# INLINE asin #-}
    acos = fmap acos
    {-# INLINE acos #-}
    atan = fmap atan
    {-# INLINE atan #-}
    sinh = fmap sinh
    {-# INLINE sinh #-}
    cosh = fmap cosh
    {-# INLINE cosh #-}
    tanh = fmap tanh
    {-# INLINE tanh #-}
    asinh = fmap asinh
    {-# INLINE asinh #-}
    acosh = fmap acosh
    {-# INLINE acosh #-}
    atanh = fmap atanh
    {-# INLINE atanh #-}

-- | Helper class for automatically deriving 'zero' using GHC Generics.
class GZero f where
    gzero :: f t -> f t

instance Backprop a => GZero (K1 i a) where
    gzero (K1 x) = K1 (zero x)
    {-# INLINE gzero #-}

instance (GZero f, GZero g) => GZero (f :*: g) where
    gzero (x :*: y) = gzero x :*: gzero y
    {-# INLINE gzero #-}

instance (GZero f, GZero g) => GZero (f :+: g) where
    gzero (L1 x) = L1 (gzero x)
    gzero (R1 x) = R1 (gzero x)
    {-# INLINE gzero #-}

instance GZero V1 where
    gzero = \case {}
    {-# INLINE gzero #-}

instance GZero U1 where
    gzero _ = U1
    {-# INLINE gzero #-}

instance GZero f => GZero (M1 i c f) where
    gzero (M1 x) = M1 (gzero x)
    {-# INLINE gzero #-}

instance GZero f => GZero (f :.: g) where
    gzero (Comp1 x) = Comp1 (gzero x)
    {-# INLINE gzero #-}

-- | Helper class for automatically deriving 'add' using GHC Generics.
class GAdd f where
    gadd :: f t -> f t -> f t

instance Backprop a => GAdd (K1 i a) where
    gadd (K1 x) (K1 y) = K1 (add x y)
    {-# INLINE gadd #-}

instance (GAdd f, GAdd g) => GAdd (f :*: g) where
    gadd (x1 :*: y1) (x2 :*: y2) = x3 :*: y3
      where
        !x3 = gadd x1 x2
        !y3 = gadd y1 y2
    {-# INLINE gadd #-}

instance GAdd V1 where
    gadd = \case {}
    {-# INLINE gadd #-}

instance GAdd U1 where
    gadd _ _ = U1
    {-# INLINE gadd #-}

instance GAdd f => GAdd (M1 i c f) where
    gadd (M1 x) (M1 y) = M1 (gadd x y)
    {-# INLINE gadd #-}

instance GAdd f => GAdd (f :.: g) where
    gadd (Comp1 x) (Comp1 y) = Comp1 (gadd x y)
    {-# INLINE gadd #-}

-- | Helper class for automatically deriving 'one' using GHC Generics.
class GOne f where
    gone :: f t -> f t

instance Backprop a => GOne (K1 i a) where
    gone (K1 x) = K1 (one x)
    {-# INLINE gone #-}

instance (GOne f, GOne g) => GOne (f :*: g) where
    gone (x :*: y) = gone x :*: gone y
    {-# INLINE gone #-}

instance (GOne f, GOne g) => GOne (f :+: g) where
    gone (L1 x) = L1 (gone x)
    gone (R1 x) = R1 (gone x)
    {-# INLINE gone #-}

instance GOne V1 where
    gone = \case {}
    {-# INLINE gone #-}

instance GOne U1 where
    gone _ = U1
    {-# INLINE gone #-}

instance GOne f => GOne (M1 i c f) where
    gone (M1 x) = M1 (gone x)
    {-# INLINE gone #-}

instance GOne f => GOne (f :.: g) where
    gone (Comp1 x) = Comp1 (gone x)
    {-# INLINE gone #-}

instance Backprop Int where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance Backprop Integer where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.1.0
instance Backprop Natural where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop Word8 where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop Word where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop Word16 where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop Word32 where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop Word64 where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance Integral a => Backprop (Ratio a) where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance RealFloat a => Backprop (Complex a) where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance Backprop Float where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance Backprop Double where
    zero = zeroNum
    {-# INLINE zero #-}
    add  = addNum
    {-# INLINE add #-}
    one  = oneNum
    {-# INLINE one #-}

instance Backprop a => Backprop (V.Vector a) where
    zero = zeroVec
    {-# INLINE zero #-}
    add  = addVec
    {-# INLINE add #-}
    one  = oneVec
    {-# INLINE one #-}

instance (VU.Unbox a, Backprop a) => Backprop (VU.Vector a) where
    zero = zeroVec
    {-# INLINE zero #-}
    add  = addVec
    {-# INLINE add #-}
    one  = oneVec
    {-# INLINE one #-}

instance (VS.Storable a, Backprop a) => Backprop (VS.Vector a) where
    zero = zeroVec
    {-# INLINE zero #-}
    add  = addVec
    {-# INLINE add #-}
    one  = oneVec
    {-# INLINE one #-}

instance (VP.Prim a, Backprop a) => Backprop (VP.Vector a) where
    zero = zeroVec
    {-# INLINE zero #-}
    add  = addVec
    {-# INLINE add #-}
    one  = oneVec
    {-# INLINE one #-}

-- | 'add' assumes the shorter list has trailing zeroes, and the result has
-- the length of the longest input.
instance Backprop a => Backprop [a] where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = addIsList
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | 'add' assumes the shorter list has trailing zeroes, and the result has
-- the length of the longest input.
instance Backprop a => Backprop (NonEmpty a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = addIsList
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | 'add' assumes the shorter sequence has trailing zeroes, and the result
-- has the length of the longest input.
instance Backprop a => Backprop (Seq.Seq a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = addIsList
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | 'Nothing' is treated the same as @'Just' 0@.  However, 'zero', 'add',
-- and 'one' preserve 'Nothing' if all inputs are also 'Nothing'.
instance Backprop a => Backprop (Maybe a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add x y = asum [ add <$> x <*> y
                   , x
                   , y
                   ]
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | 'add' is strict, but 'zero' and 'one' are lazy in their arguments.
instance Backprop () where
    zero _ = ()
    add () () = ()
    one _ = ()

-- | 'add' is strict
instance (Backprop a, Backprop b) => Backprop (a, b) where
    zero (x, y) = (zero x, zero y)
    {-# INLINE zero #-}
    add (x1, y1) (x2, y2) = (x3, y3)
      where
        !x3 = add x1 x2
        !y3 = add y1 y2
    {-# INLINE add #-}
    one (x, y) = (one x, one y)
    {-# INLINE one #-}

-- | 'add' is strict
instance (Backprop a, Backprop b, Backprop c) => Backprop (a, b, c) where
    zero (x, y, z) = (zero x, zero y, zero z)
    {-# INLINE zero #-}
    add (x1, y1, z1) (x2, y2, z2) = (x3, y3, z3)
      where
        !x3 = add x1 x2
        !y3 = add y1 y2
        !z3 = add z1 z2
    {-# INLINE add #-}
    one (x, y, z) = (one x, one y, one z)
    {-# INLINE one #-}

-- | 'add' is strict
instance (Backprop a, Backprop b, Backprop c, Backprop d) => Backprop (a, b, c, d) where
    zero (x, y, z, w) = (zero x, zero y, zero z, zero w)
    {-# INLINE zero #-}
    add (x1, y1, z1, w1) (x2, y2, z2, w2) = (x3, y3, z3, w3)
      where
        !x3 = add x1 x2
        !y3 = add y1 y2
        !z3 = add z1 z2
        !w3 = add w1 w2
    {-# INLINE add #-}
    one (x, y, z, w) = (one x, one y, one z, one w)
    {-# INLINE one #-}

-- | 'add' is strict
instance (Backprop a, Backprop b, Backprop c, Backprop d, Backprop e) => Backprop (a, b, c, d, e) where
    zero (x, y, z, w, v) = (zero x, zero y, zero z, zero w, zero v)
    {-# INLINE zero #-}
    add (x1, y1, z1, w1, v1) (x2, y2, z2, w2, v2) = (x3, y3, z3, w3, v3)
      where
        !x3 = add x1 x2
        !y3 = add y1 y2
        !z3 = add z1 z2
        !w3 = add w1 w2
        !v3 = add v1 v2
    {-# INLINE add #-}
    one (x, y, z, w, v) = (one x, one y, one z, one w, one v)
    {-# INLINE one #-}

instance Backprop a => Backprop (Identity a) where
    zero = coerce (zero @a)
    add = coerce (add @a)
    one = coerce (one @a)

instance Backprop (Proxy a) where
    zero _ = Proxy
    {-# INLINE zero #-}
    add _ _ = Proxy
    {-# INLINE add #-}
    one _ = Proxy
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop w => Backprop (Const w a) where
    zero = coerce (zero @w)
    add = coerce (add @w)
    one = coerce (one @w)

instance Backprop Void where
    zero = \case {}
    {-# INLINE zero #-}
    add = \case {}
    {-# INLINE add #-}
    one = \case {}
    {-# INLINE one #-}

-- | 'zero' and 'one' replace all current values, and 'add' merges keys
-- from both maps, adding in the case of double-occurrences.
instance (Backprop a, Ord k) => Backprop (M.Map k a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = M.unionWith add
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | 'zero' and 'one' replace all current values, and 'add' merges keys
-- from both maps, adding in the case of double-occurrences.
instance (Backprop a) => Backprop (IM.IntMap a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = IM.unionWith add
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance Backprop a => Backprop (K1 i a p) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance Backprop (f p) => Backprop (M1 i c f p) where
    zero = coerce (zero @(f p))
    add  = coerce (add @(f p))
    one  = coerce (one @(f p))

-- | @since 0.2.2.0
instance (Backprop (f p), Backprop (g p)) => Backprop ((f :*: g) p)

-- | @since 0.2.6.3
instance (Backprop (f (g a))) => Backprop ((f :.: g) a) where
    zero = coerce (zero @(f (g a)))
    add  = coerce (add @(f (g a)))
    one  = coerce (one @(f (g a)))

-- | @since 0.2.2.0
instance Backprop (V1 p)

-- | @since 0.2.2.0
instance Backprop (U1 p)

-- | @since 0.2.2.0
instance Backprop a => Backprop (Sum a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance Backprop a => Backprop (Product a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance Backprop a => Backprop (SG.Option a) where
    zero = coerce (zero @(Maybe a))
    add  = coerce (add @(Maybe a))
    one  = coerce (one @(Maybe a))

-- | @since 0.2.2.0
instance Backprop a => Backprop (SG.First a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance Backprop a => Backprop (SG.Last a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance Backprop a => Backprop (First a) where
    zero = coerce (zero @(Maybe a))
    add  = coerce (add @(Maybe a))
    one  = coerce (one @(Maybe a))

-- | @since 0.2.2.0
instance Backprop a => Backprop (Data.Monoid.Last a) where
    zero = coerce (zero @(Maybe a))
    add  = coerce (add @(Maybe a))
    one  = coerce (one @(Maybe a))

-- | @since 0.2.2.0
instance Backprop a => Backprop (Dual a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.2.0
instance (Backprop a, Backprop b) => Backprop (SG.Arg a b)

-- | @since 0.2.2.0
instance (Backprop (f a), Backprop (g a)) => Backprop (DFP.Product f g a)

-- | @since 0.2.2.0
instance Backprop (f (g a)) => Backprop (Compose f g a) where
    zero = coerce (zero @(f (g a)))
    add  = coerce (add @(f (g a)))
    one  = coerce (one @(f (g a)))

-- | 'add' adds together results; 'zero' and 'one' act on results.
--
-- @since 0.2.2.0
instance Backprop a => Backprop (r -> a) where
    zero = zeroFunctor
    {-# INLINE zero #-}
    add  = liftA2 add
    {-# INLINE add #-}
    one  = oneFunctor
    {-# INLINE one #-}

-- | @since 0.2.2.0
instance (Backprop a, Applicative m) => Backprop (Arr.Kleisli m r a) where
    zero (Arr.Kleisli f) = Arr.Kleisli ((fmap . fmap) zero f)
    {-# INLINE zero #-}
    add (Arr.Kleisli f) (Arr.Kleisli g) = Arr.Kleisli $ \x ->
        add <$> f x <*> g x
    {-# INLINE add #-}
    one (Arr.Kleisli f) = Arr.Kleisli ((fmap . fmap) one f)
    {-# INLINE one #-}

-- | @since 0.2.6.3
instance (ReifyConstraint Backprop f rs, RMap rs, RApply rs) => Backprop (Rec f rs) where
    zero = rmap (\case V.Compose (Dict x) -> zero x)
         . reifyConstraint @Backprop
    {-# INLINE zero #-}
    add xs = rzipWith (\x -> \case V.Compose (Dict y) -> add x y) xs
           . reifyConstraint @Backprop
    {-# INLINE add #-}
    one  = rmap (\case V.Compose (Dict x) -> one x)
         . reifyConstraint @Backprop
    {-# INLINE one #-}

-- | @since 0.2.6.3
instance (ReifyConstraint Backprop f rs, RMap rs, RApply rs, RecApplicative rs, NatToInt (RLength rs), RPureConstrained (IndexableField rs) rs)
      => Backprop (ARec f rs) where
    zero = toARec . zero . fromARec
    {-# INLINE zero #-}
    add xs ys = toARec $ add (fromARec xs) (fromARec ys)
    {-# INLINE add #-}
    one  = toARec . zero . fromARec
    {-# INLINE one #-}

-- | @since 0.2.6.3
instance (ReifyConstraint Backprop f rs, RMap rs, RApply rs, VS.Storable (Rec f rs))
      => Backprop (SRec f rs) where
    zero = toSRec . zero . fromSRec
    {-# INLINE zero #-}
    add xs ys = toSRec $ add (fromSRec xs) (fromSRec ys)
    {-# INLINE add #-}
    one  = toSRec . zero . fromSRec
    {-# INLINE one #-}

-- | @since 0.2.6.3
instance (ReifyConstraint Backprop f rs, RMap rs, RApply rs, IsoXRec f rs)
      => Backprop (XRec f rs) where
    zero = toXRec . zero . fromXRec
    {-# INLINE zero #-}
    add xs ys = toXRec $ add (fromXRec xs) (fromXRec ys)
    {-# INLINE add #-}
    one  = toXRec . zero . fromXRec
    {-# INLINE one #-}

-- | @since 0.2.6.3
instance Backprop a => Backprop (V.Identity a) where
    zero = coerce (zero @a)
    add  = coerce (add @a)
    one  = coerce (one @a)

-- | @since 0.2.6.3
instance Backprop a => Backprop (V.Thunk a) where
    zero (V.Thunk x) = V.Thunk (zero x)
    add (V.Thunk x) (V.Thunk y) = V.Thunk (add x y)
    one (V.Thunk x) = V.Thunk (one x)

-- | @since 0.2.6.3
instance Backprop (op (f a) (g a)) => Backprop (V.Lift op f g a) where
    zero = coerce (zero @(op (f a) (g a)))
    add  = coerce (add @(op (f a) (g a)))
    one  = coerce (one @(op (f a) (g a)))

-- | @since 0.2.6.3
instance Backprop t => Backprop (V.ElField '(s, t)) where
    zero (V.Field x) = V.Field (zero x)
    add (V.Field x) (V.Field y) = V.Field (add x y)
    one (V.Field x) = V.Field (one x)

-- | @since 0.2.6.3
instance Backprop (f (g a)) => Backprop (V.Compose f g a) where
    zero = coerce (zero @(f (g a)))
    add  = coerce (add @(f (g a)))
    one  = coerce (one @(f (g a)))

-- | @since 0.2.6.3
instance Backprop w => Backprop (V.Const w a) where
    zero = coerce (zero @w)
    add  = coerce (add @w)
    one  = coerce (one @w)

-- | @since 0.2.6.3
instance Backprop (V.HKD t a) => Backprop (V.XData t a) where
    zero = coerce (zero @(V.HKD t a))
    add  = coerce (add @(V.HKD t a))
    one  = coerce (one @(V.HKD t a))

-- | @since 0.2.6.3
instance Backprop (SField field) where
    zero _ = SField
    add _ _ = SField
    one _  = SField

-- | @since 0.2.6.3
instance Backprop (Label field) where
    zero _ = Label
    add _ _ = Label
    one _  = Label