{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}

{-|
Module: Data.Semiring
Description: Haskell semirings
License: MIT
Maintainer: mail@doisinkidney.com
Stability: experimental
-}
module Data.Semiring
  (
   -- * Semiring classes
   Semiring(..)
  ,StarSemiring(..)
  ,mulFoldable
  ,addFoldable
  ,
   -- * Helper classes
   HasPositiveInfinity(..)
  ,HasNegativeInfinity(..)
  ,DetectableZero(..)
  ,
   -- * Monoidal wrappers
   Add(..)
  ,Mul(..)
  ,
   -- * Ordering wrappers
   Max(..)
  ,Min(..)
  ,
   -- * Matrix wrapper
   Matrix(..)
  ,transpose
  ,mulMatrix
  ,rows
  ,cols)
  where

import           Data.Complex                (Complex)
import           Data.Fixed                  (Fixed, HasResolution)
import           Data.Functor.Identity       (Identity (..))
import           Data.Int                    (Int16, Int32, Int64, Int8)
import           Data.Ratio                  (Ratio)
import           Data.Scientific             (Scientific)
import           Data.Time.Clock             (DiffTime, NominalDiffTime)
import           Data.Word                   (Word16, Word32, Word64, Word8)
import           Foreign.C.Types             (CChar, CClock, CDouble, CFloat,
                                              CInt, CIntMax, CIntPtr, CLLong,
                                              CLong, CPtrdiff, CSChar,
                                              CSUSeconds, CShort, CSigAtomic,
                                              CSize, CTime, CUChar, CUInt,
                                              CUIntMax, CUIntPtr, CULLong,
                                              CULong, CUSeconds, CUShort,
                                              CWchar)
import           Foreign.Ptr                 (IntPtr, WordPtr)
import           Numeric.Natural             (Natural)
import           System.Posix.Types          (CCc, CDev, CGid, CIno, CMode,
                                              CNlink, COff, CPid, CRLim, CSpeed,
                                              CSsize, CTcflag, CUid, Fd)

import           Data.Semigroup              hiding (Max (..), Min (..))

import           Data.Coerce
import           Data.Typeable               (Typeable)
import           Foreign.Storable            (Storable)
import           GHC.Generics                (Generic, Generic1)

import           Data.Functor.Classes
import           Data.Semiring.TH

import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map

import           Data.Set                    (Set)
import qualified Data.Set                    as Set

import           Data.Hashable
import qualified Data.HashMap.Strict         as HashMap
import qualified Data.HashSet                as HashSet

import qualified Data.Vector                 as Vector
import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Storable        as StorableVector
import qualified Data.Vector.Unboxed         as UnboxedVector
import qualified Data.Vector.Unboxed.Base    as U

import           Control.DeepSeq

import           Numeric.Log                 hiding (sum)
import qualified Numeric.Log
import           Numeric.Log.Signed

import           Control.Applicative
import           Data.Foldable
import           Data.Traversable

import           Data.Semiring.Newtype
import           GHC.Base                    (build)

-- $setup
-- >>> import Data.Function

-- | A <https://en.wikipedia.org/wiki/Semiring Semiring> is like the
-- the combination of two 'Data.Monoid.Monoid's. The first
-- is called '<+>'; it has the identity element 'zero', and it is
-- commutative. The second is called '<.>'; it has identity element 'one',
-- and it must distribute over '<+>'.
--
-- = Laws
-- == Normal 'Monoid' laws
--
-- @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c)
--'zero' '<+>' a = a '<+>' 'zero' = a
--(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c)
--'one' '<.>' a = a '<.>' 'one' = a@
--
-- == Commutativity of '<+>'
-- @a '<+>' b = b '<+>' a@
--
-- == Distribution of '<.>' over '<+>'
-- @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c)
--(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@
--
-- == Annihilation
-- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@
--
-- An ordered semiring follows the laws:
--
-- @x '<=' y => x '<+>' z '<=' y '<+>' z
--x '<=' y => x '<+>' z '<=' y '<+>' z
--'zero' '<=' z '&&' x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@
class Semiring a  where
    {-# MINIMAL zero , one , (<.>) , (<+>) #-}
    -- | The identity of '<+>'.
    zero
        :: a
    -- | The identity of '<.>'.
    one
        :: a
    -- | An associative binary operation, which distributes over '<+>'.
    infixl 7 <.>
    (<.>) :: a -> a -> a
    -- | An associative, commutative binary operation.
    infixl 6 <+>
    (<+>) :: a -> a -> a
    -- | Takes the sum of the elements of a list. Analogous to 'sum'
    -- on numbers, or 'or' on 'Bool's.
    --
    -- >>> add [1..5]
    -- 15
    -- >>> add [False, False]
    -- False
    -- >>> add [False, True]
    -- True
    -- >>> add [True, undefined]
    -- True
    add
        :: [a] -> a
    add = foldl' (<+>) zero
    {-# INLINE add #-}
    -- | Takes the product of the elements of a list. Analogous to
    -- 'product' on numbers, or 'and' on 'Bool's.
    --
    -- >>> mul [1..5]
    -- 120
    -- >>> mul [True, True]
    -- True
    -- >>> mul [True, False]
    -- False
    -- >>> mul [False, undefined]
    -- False
    mul
        :: [a] -> a
    mul = foldl' (<.>) one
    {-# INLINE mul #-}

-- | The product of the contents of a 'Foldable'.
mulFoldable :: (Foldable f, Semiring a) => f a -> a
mulFoldable = mul . toList
{-# INLINE mulFoldable #-}

-- | The sum of the contents of a 'Foldable'.
addFoldable :: (Foldable f, Semiring a) => f a -> a
addFoldable = add . toList
{-# INLINE addFoldable #-}

-- | A <https://en.wikipedia.org/wiki/Semiring#Star_semirings Star semiring>
-- adds one operation, 'star' to a 'Semiring', such that it follows the
-- law:
--
-- @'star' x = 'one' '<+>' x '<.>' 'star' x = 'one' '<+>' 'star' x '<.>' x@
--
-- For the semiring of types, this is equivalent to a list. When looking
-- at the 'Applicative' and 'Control.Applicative.Alternative' classes as
-- (near-) semirings, this is equivalent to the
-- 'Control.Applicative.many' operation.
--
-- Another operation, 'plus', can be defined in relation to 'star':
--
-- @'plus' x = x '<.>' 'star' x@
--
-- This should be recognizable as a non-empty list on types, or the
-- 'Control.Applicative.some' operation in
-- 'Control.Applicative.Alternative'.
class Semiring a =>
      StarSemiring a  where
    star :: a -> a
    plus :: a -> a
    star x = one <+> plus x
    {-# INLINE star #-}
    plus x = x <.> star x
    {-# INLINE plus #-}

-- | Useful for operations where zeroes may need to be discarded: for instance
-- in sparse matrix calculations.
class Semiring a =>
      DetectableZero a  where
    -- | 'True' if x is 'zero'.
    isZero
        :: a -> Bool

isZeroEq
    :: (Semiring a, Eq a)
    => a -> Bool
isZeroEq = (zero ==)
{-# INLINE isZeroEq #-}

--------------------------------------------------------------------------------
-- Infinites
--------------------------------------------------------------------------------
-- | A class for semirings with a concept of "infinity". It's important that
-- this isn't regarded as the same as "bounded":
-- @x '<+>' 'positiveInfinity'@ should probably equal 'positiveInfinity'.
class HasPositiveInfinity a  where
    -- | A positive infinite value
    positiveInfinity
        :: a
    -- | Test if a value is positive infinity.
    isPositiveInfinity
        :: a -> Bool

defaultPositiveInfinity
    :: RealFloat a
    => a
defaultPositiveInfinity = 1 / 0
{-# INLINE defaultPositiveInfinity #-}

defaultIsPositiveInfinity
    :: RealFloat a
    => a -> Bool
defaultIsPositiveInfinity x = isInfinite x && x > 0
{-# INLINE defaultIsPositiveInfinity #-}

-- | A class for semirings with a concept of "negative infinity". It's important\
-- that this isn't regarded as the same as "bounded":
-- @x '<+>' 'negativeInfinity'@ should probably equal 'negativeInfinity'.
class HasNegativeInfinity a  where
    -- | A negative infinite value
    negativeInfinity
        :: a
    -- | Test if a value is negative infinity.
    isNegativeInfinity
        :: a -> Bool

defaultIsNegativeInfinity
    :: RealFloat a
    => a -> Bool
defaultIsNegativeInfinity x = isInfinite x && x < 0
{-# INLINE defaultIsNegativeInfinity #-}

defaultNegativeInfinity
    :: RealFloat a
    => a
defaultNegativeInfinity = negate (1 / 0)
{-# INLINE defaultNegativeInfinity #-}

instance HasPositiveInfinity Double where
    positiveInfinity = defaultPositiveInfinity
    isPositiveInfinity = defaultIsPositiveInfinity
    {-# INLINE positiveInfinity #-}
    {-# INLINE isPositiveInfinity #-}

instance HasNegativeInfinity Double where
    negativeInfinity = defaultNegativeInfinity
    isNegativeInfinity = defaultIsNegativeInfinity
    {-# INLINE negativeInfinity #-}
    {-# INLINE isNegativeInfinity #-}

instance HasPositiveInfinity Float where
    positiveInfinity = defaultPositiveInfinity
    isPositiveInfinity = defaultIsPositiveInfinity
    {-# INLINE positiveInfinity #-}
    {-# INLINE isPositiveInfinity #-}

instance HasNegativeInfinity Float where
    negativeInfinity = defaultNegativeInfinity
    isNegativeInfinity = defaultIsNegativeInfinity
    {-# INLINE negativeInfinity #-}
    {-# INLINE isNegativeInfinity #-}

instance HasPositiveInfinity CDouble where
    positiveInfinity = defaultPositiveInfinity
    isPositiveInfinity = defaultIsPositiveInfinity
    {-# INLINE positiveInfinity #-}
    {-# INLINE isPositiveInfinity #-}

instance HasNegativeInfinity CDouble where
    negativeInfinity = defaultNegativeInfinity
    isNegativeInfinity = defaultIsNegativeInfinity
    {-# INLINE negativeInfinity #-}
    {-# INLINE isNegativeInfinity #-}

instance HasPositiveInfinity CFloat where
    positiveInfinity = defaultPositiveInfinity
    isPositiveInfinity = defaultIsPositiveInfinity
    {-# INLINE positiveInfinity #-}
    {-# INLINE isPositiveInfinity #-}

instance HasNegativeInfinity CFloat where
    negativeInfinity = defaultNegativeInfinity
    isNegativeInfinity = defaultIsNegativeInfinity
    {-# INLINE negativeInfinity #-}
    {-# INLINE isNegativeInfinity #-}

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
instance Semiring Bool where
    one = True
    zero = False
    (<+>) = (||)
    (<.>) = (&&)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance StarSemiring Bool where
    star _ = True
    plus = id
    {-# INLINE star #-}
    {-# INLINE plus #-}

instance DetectableZero Bool where
    isZero = not
    {-# INLINE isZero #-}

instance Semiring () where
    one = ()
    zero = ()
    _ <+> _ = ()
    _ <.> _ = ()
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance DetectableZero () where
    isZero _ = True
    {-# INLINE isZero #-}

instance StarSemiring () where
    star _ = ()
    plus _ = ()
    {-# INLINE star #-}
    {-# INLINE plus #-}

-- | A polynomial in /x/ can be defined as a list of its coefficients,
-- where the /i/th element is the coefficient of /x^i/. This is the
-- semiring for such a list. Adapted from
-- <https://pdfs.semanticscholar.org/702d/348c32133997e992db362a19697d5607ab32.pdf here>.
--
-- Effort is made to allow some of these functions to fuse. The reference
-- implementation is:
--
-- @
-- 'one' = ['one']
-- 'zero' = []
-- [] '<+>' ys = ys
-- xs '<+>' [] = xs
-- (x:xs) '<+>' (y:ys) = x '<+>' y : (xs '<+>' ys)
-- _ '<.>' [] = []
-- xs '<.>' ys = 'foldr' f [] xs where
--   f x zs = 'map' (x '<.>') ys '<+>' ('zero' : zs)
-- @
instance Semiring a =>
         Semiring [a] where
    one = [one]
    zero = []
    (<+>) = listAdd
    xs <.> ys
      | null ys = []
      | otherwise = foldr f [] xs
      where
        f x zs = foldr (g x) id ys (zero : zs)
        g x y a (z:zs) = x <.> y <+> z : a zs
        g x y a []     = x <.> y : a []
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}
    {-# INLINE one #-}
    {-# INLINE zero #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped [] Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped [] Double #-}

listAdd :: Semiring a => [a] -> [a] -> [a]
listAdd [] ys         = ys
listAdd xs []         = xs
listAdd (x:xs) (y:ys) = (x <+> y) : listAdd xs ys
{-# NOINLINE [0] listAdd #-}
{-# SPECIALISE listAdd :: BinaryWrapped [] Int #-}
{-# SPECIALISE listAdd :: BinaryWrapped [] Word #-}
{-# SPECIALISE listAdd :: BinaryWrapped [] Double #-}

-- a definition of addition which can be fused on its left argument
listAddFBL :: Semiring a => ListBuilder a -> [a] -> [a]
listAddFBL xf = xf f id  where
  f x xs (y:ys) = x <+> y : xs ys
  f x xs []     = x : xs []

type FBL a = ListBuilder a -> [a] -> [a]
{-# SPECIALISE listAddFBL :: FBL Int #-}
{-# SPECIALISE listAddFBL :: FBL Word #-}
{-# SPECIALISE listAddFBL :: FBL Double #-}

-- a definition of addition which can be fused on its right argument
listAddFBR :: Semiring a => [a] -> ListBuilder a -> [a]
listAddFBR xs' yf = yf f id xs' where
  f y ys (x:xs) = x <+> y : ys xs
  f y ys []     = y : ys []

type FBR a = [a] -> ListBuilder a -> [a]
{-# SPECIALISE listAddFBR :: FBR Int #-}
{-# SPECIALISE listAddFBR :: FBR Word #-}
{-# SPECIALISE listAddFBR :: FBR Double #-}

type ListBuilder a = forall b. (a -> b -> b) -> b -> b

{-# RULES
"listAddFB/left"  forall (g :: ListBuilder a). listAdd (build g) = listAddFBL g
"listAddFB/right" forall xs (g :: ListBuilder a). listAdd xs (build g) = listAddFBR xs g
  #-}

instance StarSemiring a => StarSemiring [a] where
    star [] = one
    star (x:xs) = r where
      r = xst : map (xst <.>) (xs <.> r)
      xst = star x
    {-# SPECIALISE star :: [Bool] -> [Bool] #-}
    {-# SPECIALISE star :: [Min Double]  -> [Min Double] #-}
    {-# SPECIALISE star :: [Max Double]  -> [Max Double] #-}

instance DetectableZero a =>
         DetectableZero [a] where
    isZero = all isZero
    {-# INLINE isZero #-}

instance Semiring a =>
         Semiring (Vector.Vector a) where
    one = Vector.singleton one
    zero = Vector.empty
    xs <+> ys =
        case compare (Vector.length xs) (Vector.length ys) of
            EQ -> Vector.zipWith (<+>) xs ys
            LT -> Vector.unsafeAccumulate (<+>) ys (Vector.indexed xs)
            GT -> Vector.unsafeAccumulate (<+>) xs (Vector.indexed ys)
    signal <.> kernel
      | Vector.null signal = Vector.empty
      | Vector.null kernel = Vector.empty
      | otherwise = Vector.generate (slen + klen - 1) f
      where
        f n =
            foldl'
                (\a k ->
                      a <+>
                      Vector.unsafeIndex signal k <.>
                      Vector.unsafeIndex kernel (n - k))
                zero
                [kmin .. kmax]
          where
            !kmin = max 0 (n - (klen - 1))
            !kmax = min n (slen - 1)
        !slen = Vector.length signal
        !klen = Vector.length kernel
    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Double #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word #-}

instance DetectableZero a => DetectableZero (Vector.Vector a) where
    isZero = Vector.all isZero

instance (UnboxedVector.Unbox a, Semiring a) =>
         Semiring (UnboxedVector.Vector a) where
    one = UnboxedVector.singleton one
    zero = UnboxedVector.empty
    xs <+> ys =
        case compare (UnboxedVector.length xs) (UnboxedVector.length ys) of
            EQ -> UnboxedVector.zipWith (<+>) xs ys
            LT -> UnboxedVector.unsafeAccumulate (<+>) ys (UnboxedVector.indexed xs)
            GT -> UnboxedVector.unsafeAccumulate (<+>) xs (UnboxedVector.indexed ys)
    signal <.> kernel
      | UnboxedVector.null signal = UnboxedVector.empty
      | UnboxedVector.null kernel = UnboxedVector.empty
      | otherwise = UnboxedVector.generate (slen + klen - 1) f
      where
        f n =
            foldl'
                (\a k ->
                      a <+>
                      UnboxedVector.unsafeIndex signal k <.>
                      UnboxedVector.unsafeIndex kernel (n - k))
                zero
                [kmin .. kmax]
          where
            kmin = max 0 (n - (klen - 1))
            kmax = min n (slen - 1)
        slen = UnboxedVector.length signal
        klen = UnboxedVector.length kernel
    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Double #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word #-}

instance (UnboxedVector.Unbox a, DetectableZero a) => DetectableZero (UnboxedVector.Vector a) where
    isZero = UnboxedVector.all isZero

instance (StorableVector.Storable a, Semiring a) =>
         Semiring (StorableVector.Vector a) where
    one = StorableVector.singleton one
    zero = StorableVector.empty
    xs <+> ys =
        case compare lxs lys of
            EQ -> StorableVector.zipWith (<+>) xs ys
            LT -> StorableVector.unsafeAccumulate_ (<+>) ys (StorableVector.enumFromN 0 lxs) xs
            GT -> StorableVector.unsafeAccumulate_ (<+>) xs (StorableVector.enumFromN 0 lys) ys
      where
        lxs = StorableVector.length xs
        lys = StorableVector.length ys
    signal <.> kernel
      | StorableVector.null signal = StorableVector.empty
      | StorableVector.null kernel = StorableVector.empty
      | otherwise = StorableVector.generate (slen + klen - 1) f
      where
        f n =
            foldl'
                (\a k ->
                      a <+>
                      StorableVector.unsafeIndex signal k <.>
                      StorableVector.unsafeIndex kernel (n - k))
                zero
                [kmin .. kmax]
          where
            kmin = max 0 (n - (klen - 1))
            kmax = min n (slen - 1)
        slen = StorableVector.length signal
        klen = StorableVector.length kernel
    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Double #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word #-}

instance (StorableVector.Storable a, DetectableZero a) =>
         DetectableZero (StorableVector.Vector a) where
    isZero = StorableVector.all isZero

instance (Monoid a, Ord a) =>
         Semiring (Set a) where
    (<+>) = Set.union
    zero = Set.empty
    one = Set.singleton mempty
    xs <.> ys = foldMap (flip Set.map ys . mappend) xs
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}
    {-# INLINE zero #-}
    {-# INLINE one #-}

instance (Monoid a, Hashable a, Eq a) => Semiring (HashSet.HashSet a) where
    (<+>) = HashSet.union
    zero = HashSet.empty
    one = HashSet.singleton mempty
    xs <.> ys = foldMap (flip HashSet.map ys . mappend) xs
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}
    {-# INLINE zero #-}
    {-# INLINE one #-}

instance (Ord a, Monoid a, Semiring b) =>
         Semiring (Map a b) where
    one = Map.singleton mempty one
    {-# INLINE one #-}
    zero = Map.empty
    {-# INLINE zero #-}
    (<+>) = Map.unionWith (<+>)
    {-# INLINE (<+>) #-}
    xs <.> ys =
        Map.fromListWith
            (<+>)
            [ (mappend k l, v <.> u)
            | (k,v) <- Map.toList xs
            , (l,u) <- Map.toList ys ]
    {-# INLINE (<.>) #-}

instance (Hashable a, Monoid a, Semiring b, Eq a) =>
         Semiring (HashMap.HashMap a b) where
    one = HashMap.singleton mempty one
    {-# INLINE one #-}
    zero = HashMap.empty
    {-# INLINE zero #-}
    (<+>) = HashMap.unionWith (<+>)
    {-# INLINE (<+>) #-}
    xs <.> ys =
        HashMap.fromListWith
            (<+>)
            [ (mappend k l, v <.> u)
            | (k,v) <- HashMap.toList xs
            , (l,u) <- HashMap.toList ys ]
    {-# INLINE (<.>) #-}

instance (Monoid a, Ord a) =>
         DetectableZero (Set a) where
    isZero = Set.null
    {-# INLINE isZero #-}

instance (Monoid a, Hashable a, Eq a) =>
         DetectableZero (HashSet.HashSet a) where
    isZero = HashSet.null

instance (Precise a, RealFloat a) => Semiring (Log a) where
    (<.>) = (*)
    {-# INLINE (<.>) #-}
    (<+>) = (+)
    {-# INLINE (<+>) #-}
    one = Exp 0
    {-# INLINE one #-}
    zero = Exp (-(1/0))
    {-# INLINE zero #-}
    add = Numeric.Log.sum
    {-# INLINE add #-}

    {-# SPECIALISE (<.>) :: BinaryWrapped Log Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped Log Double #-}

instance (Precise a, RealFloat a) => DetectableZero (Log a) where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance (Precise a, RealFloat a) => Semiring (SignedLog a) where
    (<.>) = (*)
    {-# INLINE (<.>) #-}
    (<+>) = (+)
    {-# INLINE (<+>) #-}
    one = SLExp True 0
    {-# INLINE one #-}
    zero = SLExp False (-(1/0))
    {-# INLINE zero #-}

    {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Double #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Double #-}

instance (Precise a, RealFloat a) => DetectableZero (SignedLog a) where
    isZero = isZeroEq
    {-# INLINE isZero #-}
--------------------------------------------------------------------------------
-- Addition and multiplication newtypes
--------------------------------------------------------------------------------

-- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the
-- 'Semiring' constraint, rather than 'Num'.
newtype Add a = Add
    { getAdd :: a
    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
               ,Semiring,DetectableZero,StarSemiring)

instance Eq1 Add where
    liftEq = coerce
    {-# INLINE liftEq #-}

instance Ord1 Add where
    liftCompare = coerce
    {-# INLINE liftCompare #-}

instance Show1 Add where
    liftShowsPrec = showsNewtype "Add" "getAdd"
    {-# INLINE liftShowsPrec #-}

instance Read1 Add where
    liftReadsPrec = readsNewtype "Add" "getAdd"
    {-# INLINE liftReadsPrec #-}

-- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the
-- 'Semiring' constraint, rather than 'Num'.
newtype Mul a = Mul
    { getMul :: a
    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
               ,Semiring,DetectableZero,StarSemiring)

instance Eq1 Mul where
    liftEq = coerce
    {-# INLINE liftEq #-}

instance Ord1 Mul where
    liftCompare = coerce
    {-# INLINE liftCompare #-}

instance Show1 Mul where
    liftShowsPrec = showsNewtype "Mul" "getMul"
    {-# INLINE liftShowsPrec #-}

instance Read1 Mul where
    liftReadsPrec = readsNewtype "Mul" "getMul"
    {-# INLINE liftReadsPrec #-}

instance Semiring a =>
         Semigroup (Add a) where
    (<>) = (coerce :: WrapBinary Add a) (<+>)
    {-# INLINE (<>) #-}

instance Semiring a =>
         Semigroup (Mul a) where
    (<>) = (coerce :: WrapBinary Mul a) (<.>)
    {-# INLINE (<>) #-}

instance Semiring a =>
         Monoid (Add a) where
    mempty = Add zero
    {-# INLINE mempty #-}
    mappend = (<>)
    {-# INLINE mappend #-}
    mconcat = (coerce :: ([a] -> a) -> [Add a] -> Add a) add
    {-# INLINE mconcat #-}

instance Semiring a =>
         Monoid (Mul a) where
    mempty = Mul one
    {-# INLINE mempty #-}
    mappend = (<>)
    {-# INLINE mappend #-}
    mconcat = (coerce :: ([a] -> a) -> [Mul a] -> Mul a) mul
    {-# INLINE mconcat #-}

--------------------------------------------------------------------------------
-- Traversable newtype
--------------------------------------------------------------------------------
-- | A suitable definition of a square matrix for certain types which are both
-- 'Applicative' and 'Traversable'. For instance, given a type like so:
--
-- >>> :{
-- data Quad a = Quad a a a a deriving Show
-- instance Functor Quad where
--     fmap f (Quad w x y z) = Quad (f w) (f x) (f y) (f z)
-- instance Applicative Quad where
--     pure x = Quad x x x x
--     Quad fw fx fy fz <*> Quad xw xx xy xz =
--         Quad (fw xw) (fx xx) (fy xy) (fz xz)
-- instance Foldable Quad where
--     foldr f b (Quad w x y z) = f w (f x (f y (f z b)))
-- instance Traversable Quad where
--     traverse f (Quad w x y z) = Quad <$> f w <*> f x <*> f y <*> f z
-- :}
--
-- The newtype performs as you would expect:
--
-- >>> getMatrix one :: Quad (Quad Integer)
-- Quad (Quad 1 0 0 0) (Quad 0 1 0 0) (Quad 0 0 1 0) (Quad 0 0 0 1)
--
-- 'ZipList's are another type which works with this newtype:
--
-- >>> :{
-- let xs = (Matrix . ZipList . map ZipList) [[1,2],[3,4]]
--     ys = (Matrix . ZipList . map ZipList) [[5,6],[7,8]]
-- in (map getZipList . getZipList . getMatrix) (xs <.> ys)
-- :}
-- [[19,22],[43,50]]
newtype Matrix f g a = Matrix
    { getMatrix :: f (g a)
    } deriving (Generic,Generic1,Typeable,Functor,Foldable,Traversable)

instance (Applicative f, Applicative g) =>
         Applicative (Matrix f g) where
    pure = Matrix #. pure . pure
    (<*>) =
        (coerce :: (f (g (a -> b)) -> f (g a) -> f (g b)) -> Matrix f g (a -> b) -> Matrix f g a -> Matrix f g b)
            (liftA2 (<*>))

instance (Traversable f, Applicative f, Semiring a, f ~ g) =>
         Semiring (Matrix f g a) where
    (<.>) = (coerce :: Binary (f (g a)) -> Binary (Matrix f g a)) mulMatrix
    (<+>) = liftA2 (<+>)
    zero = pure zero
    one =
        (coerce :: (f (g a) -> f (g a)) -> Matrix f g a -> Matrix f g a)
            (imap (\i -> imap (\j z -> if i == j then o else z))) zero
      where
        imap f = snd . mapAccumL (\ !i x -> (i + 1, f i x)) (0 :: Int)
        o :: a
        o = one

instance (Traversable f, Applicative f, DetectableZero a, f ~ g) =>
         DetectableZero (Matrix f g a) where
    isZero = all isZero

-- | Transpose the matrix.
transpose :: (Applicative g, Traversable f) => Matrix f g a -> Matrix g f a
transpose (Matrix xs) = Matrix (sequenceA xs)

-- | Multiply two matrices.
mulMatrix
    :: (Applicative n, Traversable m, Applicative m, Applicative p, Semiring a)
    => n (m a) -> m (p a) -> n (p a)
mulMatrix xs ys = fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) cs) xs
  where
    cs = sequenceA ys

-- | Convert the matrix to a nested list, in row-major form.
rows :: (Foldable f, Foldable g) => Matrix f g a -> [[a]]
rows = foldr ((:) . toList) [] . getMatrix

-- | Convert the matrix to a nested list, in column-major form.
cols :: (Foldable f, Foldable g) => Matrix f g a -> [[a]]
cols = foldr (foldr f (const [])) (repeat []) . getMatrix where
  f e a (x:xs) = (e:x) : a xs
  f _ _ []     = []

instance (Show1 f, Show1 g) =>
         Show1 (Matrix f g) where
    liftShowsPrec (sp :: Int -> a -> ShowS) sl =
        showsNewtype "Matrix" "getMatrix" liftedTwiceSP liftedTwiceSL
      where
        liftedOnceSP :: Int -> g a -> ShowS
        liftedOnceSP = liftShowsPrec sp sl
        liftedOnceSL :: [g a] -> ShowS
        liftedOnceSL = liftShowList sp sl
        liftedTwiceSP :: Int -> f (g a) -> ShowS
        liftedTwiceSP = liftShowsPrec liftedOnceSP liftedOnceSL
        liftedTwiceSL :: [f (g a)] -> ShowS
        liftedTwiceSL = liftShowList liftedOnceSP liftedOnceSL

instance (Read1 f, Read1 g) =>
         Read1 (Matrix f g) where
    liftReadsPrec (rp :: Int -> ReadS a) rl =
        readsNewtype "Matrix" "getMatrix" liftedTwiceRP liftedTwiceRL
      where
        liftedOnceRP :: Int -> ReadS (g a)
        liftedOnceRP = liftReadsPrec rp rl
        liftedOnceRL :: ReadS [g a]
        liftedOnceRL = liftReadList rp rl
        liftedTwiceRP :: Int -> ReadS (f (g a))
        liftedTwiceRP = liftReadsPrec liftedOnceRP liftedOnceRL
        liftedTwiceRL :: ReadS [f (g a)]
        liftedTwiceRL = liftReadList liftedOnceRP liftedOnceRL

instance (Eq1 f, Eq1 g) =>
         Eq1 (Matrix f g) where
    liftEq (eq :: a -> b -> Bool) =
        coerce (liftEq (liftEq eq) :: f (g a) -> f (g b) -> Bool)

instance (Ord1 f, Ord1 g) => Ord1 (Matrix f g) where
    liftCompare (cmp :: a -> b -> Ordering) =
        coerce (liftCompare (liftCompare cmp) :: f (g a) -> f (g b) -> Ordering)

instance (Show1 f, Show1 g, Show a) => Show (Matrix f g a) where
    showsPrec = showsPrec1

instance (Read1 f, Read1 g, Read a) => Read (Matrix f g a) where
    readsPrec = readsPrec1

instance (Eq1 f, Eq1 g, Eq a) => Eq (Matrix f g a) where
    (==) = eq1

instance (Ord1 f, Ord1 g, Ord a) => Ord (Matrix f g a) where
    compare = compare1

--------------------------------------------------------------------------------
-- Ord wrappers
--------------------------------------------------------------------------------
-- | The "<https://ncatlab.org/nlab/show/tropical+semiring Tropical>" or
-- min-plus semiring. It is a semiring where:
--
-- @'<+>'  = 'min'
--'zero' = ∞
--'<.>'  = '<+>'
--'one'  = 'zero'@
--
-- Note that we can't use 'Data.Semigroup.Min' from 'Data.Semigroup'
-- because annihilation needs to hold:
--
-- @∞ '<+>' x = x '<+>' ∞ = ∞@
--
-- Taking ∞ to be 'maxBound' would break the above law. Using 'positiveInfinity'
-- to represent it follows the law.
newtype Min a = Min
    { getMin :: a
    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
               ,NFData)

-- | The "<https://ncatlab.org/nlab/show/max-plus+algebra Arctic>"
-- or max-plus semiring. It is a semiring where:
--
-- @'<+>'  = 'max'
--'zero' = -∞
--'<.>'  = '<+>'
--'one'  = 'zero'@
--
-- Note that we can't use 'Data.Semigroup.Max' from 'Data.Semigroup'
-- because annihilation needs to hold:
--
-- @-∞ '<+>' x = x '<+>' -∞ = -∞@
--
-- Taking -∞ to be 'minBound' would break the above law. Using
-- 'negativeInfinity' to represent it follows the law.
newtype Max a = Max
    { getMax :: a
    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable
               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable
               ,NFData)

instance Eq1 Max where
    liftEq = coerce
    {-# INLINE liftEq #-}

instance Ord1 Max where
    liftCompare = coerce
    {-# INLINE liftCompare #-}

instance Show1 Max where
    liftShowsPrec = showsNewtype "Max" "getMax"
    {-# INLINE liftShowsPrec #-}

instance Read1 Max where
    liftReadsPrec = readsNewtype "Max" "getMax"
    {-# INLINE liftReadsPrec #-}

instance Eq1 Min where
    liftEq = coerce
    {-# INLINE liftEq #-}

instance Ord1 Min where
    liftCompare = coerce
    {-# INLINE liftCompare #-}

instance Show1 Min where
    liftShowsPrec = showsNewtype "Min" "getMin"
    {-# INLINE liftShowsPrec #-}

instance Read1 Min where
    liftReadsPrec = readsNewtype "Min" "getMin"
    {-# INLINE liftReadsPrec #-}

instance Ord a =>
         Semigroup (Max a) where
    (<>) = (coerce :: WrapBinary Max a) max
    {-# INLINE (<>) #-}
    stimes = stimesIdempotent
    {-# SPECIALISE (<>) :: BinaryWrapped Max Double #-}

instance Ord a =>
         Semigroup (Min a) where
    (<>) = (coerce :: WrapBinary Min a) min
    {-# INLINE (<>) #-}
    stimes = stimesIdempotent
    {-# SPECIALISE (<>) :: BinaryWrapped Min Double #-}

-- | >>> (getMax . foldMap Max) [1..10]
-- 10.0
instance (Ord a, HasNegativeInfinity a) =>
         Monoid (Max a) where
    mempty = Max negativeInfinity
    mappend = (coerce :: WrapBinary Max a) max
    {-# INLINE mempty #-}
    {-# INLINE mappend #-}
    {-# SPECIALISE mappend :: BinaryWrapped Max Double #-}

-- | >>> (getMin . foldMap Min) [1..10]
-- 1.0
instance (Ord a, HasPositiveInfinity a) =>
         Monoid (Min a) where
    mempty = Min positiveInfinity
    mappend = (coerce :: WrapBinary Min a) min
    {-# INLINE mempty #-}
    {-# INLINE mappend #-}
    {-# SPECIALISE mappend :: BinaryWrapped Min Double #-}

instance (Semiring a, Ord a, HasNegativeInfinity a) =>
         Semiring (Max a) where
    (<+>) = (coerce :: WrapBinary Max a) max
    zero = Max negativeInfinity
    (<.>) = (coerce :: WrapBinary Max a) (<+>)
    one = Max zero
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

    {-# SPECIALISE (<+>) :: BinaryWrapped Max Double #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped Max Double #-}

instance (Semiring a, Ord a, HasPositiveInfinity a) =>
         Semiring (Min a) where
    (<+>) = (coerce :: WrapBinary Min a) min
    zero = Min positiveInfinity
    (<.>) = (coerce :: WrapBinary Min a) (<+>)
    one = Min zero
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}
    {-# SPECIALISE (<+>) :: BinaryWrapped Min Double #-}
    {-# SPECIALISE (<.>) :: BinaryWrapped Min Double #-}

instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>
         StarSemiring (Max a) where
    star (Max x)
      | x > zero = Max positiveInfinity
      | otherwise = Max zero
    {-# SPECIALISE star :: Max Double  -> Max Double  #-}

instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>
         StarSemiring (Min a) where
    star (Min x)
      | x < zero = Min negativeInfinity
      | otherwise = Min zero
    {-# SPECIALISE star :: Min Double  -> Min Double  #-}

instance (Semiring a, Ord a, HasPositiveInfinity a) =>
         DetectableZero (Min a) where
    isZero (Min x) = isPositiveInfinity x
    {-# INLINE isZero #-}

instance (Semiring a, Ord a, HasNegativeInfinity a) =>
         DetectableZero (Max a) where
    isZero (Max x) = isNegativeInfinity x
    {-# INLINE isZero #-}

newtype instance U.Vector (Min a) = V_Min (U.Vector a)
newtype instance U.MVector s (Min a) = MV_Min (U.MVector s a)

instance U.Unbox a =>
         M.MVector U.MVector (Min a) where
    {-# INLINE basicLength #-}
    {-# INLINE basicUnsafeSlice #-}
    {-# INLINE basicOverlaps #-}
    {-# INLINE basicUnsafeNew #-}
    {-# INLINE basicUnsafeRead #-}
    {-# INLINE basicUnsafeWrite #-}
    basicLength =
        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Min a) -> Int)
            M.basicLength
    basicUnsafeSlice =
        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Min a) -> U.MVector s (Min a))
            M.basicUnsafeSlice
    basicOverlaps =
        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Min a) -> U.MVector s (Min a) -> Bool)
            M.basicOverlaps
    basicUnsafeNew n =
        fmap
            (coerce :: U.MVector s a -> U.MVector s (Min a))
            (M.basicUnsafeNew n)
    basicUnsafeRead (MV_Min xs) i =
        fmap (coerce :: a -> Min a) (M.basicUnsafeRead xs i)
    basicUnsafeWrite =
        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Min a) -> Int -> Min a -> m ())
            M.basicUnsafeWrite
    basicInitialize =
        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Min a) -> m ())
            M.basicInitialize

instance U.Unbox a =>
         G.Vector U.Vector (Min a) where
    {-# INLINE basicUnsafeFreeze #-}
    {-# INLINE basicUnsafeThaw #-}
    {-# INLINE basicLength #-}
    {-# INLINE basicUnsafeSlice #-}
    {-# INLINE basicUnsafeIndexM #-}
    basicUnsafeFreeze (MV_Min xs) =
        fmap
            (coerce :: U.Vector a -> U.Vector (Min a))
            (G.basicUnsafeFreeze xs)
    basicUnsafeThaw (V_Min xs) =
        fmap
            (coerce :: U.MVector s a -> U.MVector s (Min a))
            (G.basicUnsafeThaw xs)
    basicLength =
        (coerce :: (U.Vector a -> Int) -> U.Vector (Min a) -> Int)
            G.basicLength
    basicUnsafeSlice =
        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Min a) -> U.Vector (Min a))
            G.basicUnsafeSlice
    basicUnsafeIndexM (V_Min xs) i =
        fmap (coerce :: a -> Min a) (G.basicUnsafeIndexM xs i)

newtype instance U.Vector (Max a) = V_Max (U.Vector a)
newtype instance U.MVector s (Max a) = MV_Max (U.MVector s a)

instance U.Unbox a =>
         M.MVector U.MVector (Max a) where
    {-# INLINE basicLength #-}
    {-# INLINE basicUnsafeSlice #-}
    {-# INLINE basicOverlaps #-}
    {-# INLINE basicUnsafeNew #-}
    {-# INLINE basicUnsafeRead #-}
    {-# INLINE basicUnsafeWrite #-}
    basicLength =
        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Max a) -> Int)
            M.basicLength
    basicUnsafeSlice =
        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Max a) -> U.MVector s (Max a))
            M.basicUnsafeSlice
    basicOverlaps =
        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Max a) -> U.MVector s (Max a) -> Bool)
            M.basicOverlaps
    basicUnsafeNew n =
        fmap
            (coerce :: U.MVector s a -> U.MVector s (Max a))
            (M.basicUnsafeNew n)
    basicUnsafeRead (MV_Max xs) i =
        fmap (coerce :: a -> Max a) (M.basicUnsafeRead xs i)
    basicUnsafeWrite =
        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Max a) -> Int -> Max a -> m ())
            M.basicUnsafeWrite
    basicInitialize =
        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Max a) -> m ())
            M.basicInitialize

instance U.Unbox a =>
         G.Vector U.Vector (Max a) where
    {-# INLINE basicUnsafeFreeze #-}
    {-# INLINE basicUnsafeThaw #-}
    {-# INLINE basicLength #-}
    {-# INLINE basicUnsafeSlice #-}
    {-# INLINE basicUnsafeIndexM #-}
    basicUnsafeFreeze (MV_Max xs) =
        fmap
            (coerce :: U.Vector a -> U.Vector (Max a))
            (G.basicUnsafeFreeze xs)
    basicUnsafeThaw (V_Max xs) =
        fmap
            (coerce :: U.MVector s a -> U.MVector s (Max a))
            (G.basicUnsafeThaw xs)
    basicLength =
        (coerce :: (U.Vector a -> Int) -> U.Vector (Max a) -> Int)
            G.basicLength
    basicUnsafeSlice =
        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Max a) -> U.Vector (Max a))
            G.basicUnsafeSlice
    basicUnsafeIndexM (V_Max xs) i =
        fmap (coerce :: a -> Max a) (G.basicUnsafeIndexM xs i)
--------------------------------------------------------------------------------
-- (->) instance
--------------------------------------------------------------------------------
-- | The @(->)@ instance is analogous to the one for 'Monoid'.
instance Semiring b =>
         Semiring (a -> b) where
    zero = const zero
    {-# INLINE zero #-}
    one = const one
    {-# INLINE one #-}
    (f <+> g) x = f x <+> g x
    {-# INLINE (<+>) #-}
    (f <.> g) x = f x <.> g x
    {-# INLINE (<.>) #-}

instance StarSemiring b =>
         StarSemiring (a -> b) where
    star = (.) star
    {-# INLINE star #-}
    plus = (.) plus
    {-# INLINE plus #-}

--------------------------------------------------------------------------------
-- Endo instance
--------------------------------------------------------------------------------
-- | This is /not/ a true semiring. In particular, it requires the
-- underlying monoid to be commutative, and even then, it is only a near
-- semiring. It is, however, extremely useful. For instance, this type:
--
-- @forall a. 'Endo' ('Endo' a)@
--
-- Is a valid encoding of church numerals, with addition and
-- multiplication being their semiring variants.
instance Monoid a =>
         Semiring (Endo a) where
    zero = Endo mempty
    Endo f <+> Endo g = Endo (f `mappend` g)
    one = mempty
    (<.>) = mappend
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance (Monoid a, Eq a) =>
         StarSemiring (Endo a) where
    star (Endo f) = Endo converge
      where
        converge x = go x
          where
            go inp =
                mappend
                    x
                    (if inp == next
                         then inp
                         else go next)
              where
                next = mappend x (f inp)

instance (Enum a, Bounded a, Eq a, Monoid a) =>
         DetectableZero (Endo a) where
    isZero (Endo f) = all (mempty ==) (map f [minBound .. maxBound])

--------------------------------------------------------------------------------
-- Instances for Bool wrappers
--------------------------------------------------------------------------------
instance Semiring Any where
    (<+>) = coerce (||)
    zero = Any False
    (<.>) = coerce (&&)
    one = Any True
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance StarSemiring Any where
    star _ = Any True
    plus = id
    {-# INLINE star #-}
    {-# INLINE plus #-}

instance Semiring All where
    (<+>) = coerce (||)
    zero = All False
    (<.>) = coerce (&&)
    one = All True
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance StarSemiring All where
    star _ = All True
    plus = id
    {-# INLINE star #-}
    {-# INLINE plus #-}

instance DetectableZero Any where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero All where
    isZero = isZeroEq
    {-# INLINE isZero #-}

--------------------------------------------------------------------------------
-- Boring instances
--------------------------------------------------------------------------------

instance Semiring Int where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Int8 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Int16 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Int32 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Int64 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Integer where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Word where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Word8 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Word16 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Word32 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Word64 where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Float where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Double where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Scientific where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring DiffTime where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring NominalDiffTime where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUIntMax where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CIntMax where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUIntPtr where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CIntPtr where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSUSeconds where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUSeconds where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CTime where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CClock where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSigAtomic where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CWchar where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSize where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CPtrdiff where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CDouble where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CFloat where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CULLong where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CLLong where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CULong where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CLong where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUInt where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CInt where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUShort where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CShort where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUChar where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSChar where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CChar where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring IntPtr where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring WordPtr where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Fd where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CRLim where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CTcflag where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSpeed where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CCc where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CUid where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CNlink where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CGid where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CSsize where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CPid where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring COff where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CMode where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CIno where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring CDev where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring Natural where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Integral a =>
         Semiring (Ratio a) where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring a => Semiring (Product a) where
    one = Product one
    {-# INLINE one #-}
    zero = Product zero
    {-# INLINE zero #-}
    (<+>) = (coerce :: WrapBinary Product a) (<+>)
    {-# INLINE (<+>) #-}
    (<.>) = (coerce :: WrapBinary Product a) (<.>)
    {-# INLINE (<.>) #-}

instance Semiring a => Semiring (Sum a) where
    one = Sum one
    {-# INLINE one #-}
    zero = Sum zero
    {-# INLINE zero #-}
    (<+>) = (coerce :: WrapBinary Sum a) (<+>)
    {-# INLINE (<+>) #-}
    (<.>) = (coerce :: WrapBinary Sum a) (<.>)
    {-# INLINE (<.>) #-}

instance RealFloat a =>
         Semiring (Complex a) where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance HasResolution a =>
         Semiring (Fixed a) where
    one = 1
    zero = 0
    (<+>) = (+)
    (<.>) = (*)
    {-# INLINE zero #-}
    {-# INLINE one #-}
    {-# INLINE (<+>) #-}
    {-# INLINE (<.>) #-}

instance Semiring a => Semiring (Identity a) where
    one = Identity one
    {-# INLINE one #-}
    zero = Identity zero
    {-# INLINE zero #-}
    (<+>) = (coerce :: WrapBinary Identity a) (<+>)
    {-# INLINE (<+>) #-}
    (<.>) = (coerce :: WrapBinary Identity a) (<.>)
    {-# INLINE (<.>) #-}

instance DetectableZero Int where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Int8 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Int16 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Int32 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Int64 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Integer where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Word where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Word8 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Word16 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Word32 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Word64 where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Float where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Double where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Scientific where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero DiffTime where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero NominalDiffTime where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUIntMax where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CIntMax where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUIntPtr where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CIntPtr where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSUSeconds where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUSeconds where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CTime where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CClock where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSigAtomic where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CWchar where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSize where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CPtrdiff where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CDouble where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CFloat where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CULLong where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CLLong where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CULong where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CLong where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUInt where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CInt where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUShort where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CShort where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUChar where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSChar where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CChar where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero IntPtr where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero WordPtr where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Fd where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CRLim where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CTcflag where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSpeed where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CCc where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CUid where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CNlink where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CGid where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CSsize where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CPid where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero COff where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CMode where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CIno where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero CDev where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance DetectableZero Natural where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance Integral a =>
         DetectableZero (Ratio a) where
    isZero = isZeroEq
    {-# INLINE isZero #-}

deriving instance DetectableZero a => DetectableZero (Product a)

deriving instance DetectableZero a => DetectableZero (Sum a)

instance RealFloat a =>
         DetectableZero (Complex a) where
    isZero = isZeroEq
    {-# INLINE isZero #-}

instance HasResolution a =>
         DetectableZero (Fixed a) where
    isZero = isZeroEq
    {-# INLINE isZero #-}

deriving instance DetectableZero a => DetectableZero (Identity a)

--------------------------------------------------------------------------------
-- Very boring instances
--------------------------------------------------------------------------------
$(traverse semiringIns [2 .. 15])

$(traverse starIns [2 .. 15])

$(traverse zeroIns [2 .. 15])


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeFamilies        #-}

--
-- Note: Input files can be downloaded at https://www.kaggle.com/scolianni/mnistasjpg
--
--
-- This is a simple generative adversarial network to make pictures
-- of numbers similar to those in MNIST.
--
-- It demonstrates a different usage of the library. Within about 15
-- minutes it was producing examples like this:
--
--               --.
--     .=-.--..#=###
--     -##==#########.
--     #############-
--   -###-.=..-.-==
--   ###-
--   .###-
--   .####...==-.
--   -####=--.=##=
--   -##=-     -##
--             =##
--           -##=
--           -###-
--         .####.
--         .#####.
-- ...---=#####-
-- .=#########.         .
--   .#######=.          .
--     . =-.
--
-- It's a 5!
--
import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Random
import           Control.Monad.Trans.Except

import qualified Data.Attoparsec.Text         as A
import qualified Data.ByteString              as B
import           Data.List                    (foldl')
import           Data.Serialize
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import qualified Data.Vector.Storable         as V

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

import           Options.Applicative

import           Grenade
import           Grenade.Utils.OneHot

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

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

randomDiscriminator :: IO Discriminator
randomDiscriminator = randomNetwork

randomGenerator :: IO Generator
randomGenerator = randomNetwork

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

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

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

       (generator', _)                    = runGradient generator generatorTape push

       !newDiscriminator                   = force $ foldl' (applyUpdate $ sgdUpdateLearningParamters opt) discriminator [ discriminator'real, discriminator'fake ]
       !newGenerator                       = force $ applyUpdate opt generator generator'
   in ( newDiscriminator, newGenerator )
  where sgdUpdateLearningParamters :: Optimizer opt -> Optimizer opt
        sgdUpdateLearningParamters (OptSGD rate mom reg) = OptSGD rate mom (reg * 10)
        sgdUpdateLearningParamters o                     = o

ganTest :: (Discriminator, Generator) -> Int -> FilePath -> Optimizer opt -> ExceptT String IO (Discriminator, Generator)
ganTest (discriminator0, generator0) iterations trainFile opt = do
  !trainData      <- fmap fst <$> readMNIST trainFile

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

    where

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

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

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

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

    return trained'

data GanOpts = GanOpts FilePath Int Bool (Optimizer 'SGD) (Optimizer 'Adam) (Maybe FilePath) (Maybe FilePath)

mnist' :: Parser GanOpts
mnist' = GanOpts <$> argument str (metavar "TRAIN")
                 <*> option auto (long "iterations" <> short 'i' <> value 15)
                 <*> flag False True (long "use-adam" <> short 'a')
                 <*> (OptSGD
                       <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
                       <*> option auto (long "momentum" <> value 0.9)
                       <*> option auto (long "l2" <> value 0.0005)
                       )
                 <*> (OptAdam
                       <$> option auto (long "alpha" <> short 'r' <> value 0.001)
                       <*> option auto (long "beta1" <> value 0.9)
                       <*> option auto (long "beta2" <> value 0.999)
                       <*> option auto (long "epsilon" <> value 1e-4)
                       <*> option auto (long "lambda" <> value 1e-3)
                      )
                 <*> optional (strOption (long "load"))
                 <*> optional (strOption (long "save"))

main :: IO ()
main = do
  GanOpts mnist iter useAdam sgd adam load save <- execParser (info (mnist' <**> helper) idm)
  putStrLn "Training stupidly simply GAN"
  nets0 <-
    case load of
      Just loadFile -> netLoad loadFile
      Nothing       -> (,) <$> randomDiscriminator <*> randomGenerator
  res <-
    if useAdam
      then runExceptT $ ganTest nets0 iter mnist adam
      else runExceptT $ ganTest nets0 iter mnist sgd
  case res of
    Right nets1 ->
      case save of
        Just saveFile -> B.writeFile saveFile $ runPut (put nets1)
        Nothing       -> return ()
    Left err -> putStrLn err

readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]
readMNIST mnist = ExceptT $ do
  mnistdata <- T.readFile mnist
  return $ traverse (A.parseOnly parseMNIST) (tail $ T.lines mnistdata)

parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
parseMNIST = do
  Just lab <- oneHot <$> A.decimal
  pixels   <- many (A.char ',' >> A.double)
  image    <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ fmap realToFrac pixels)
  return (image, lab)

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


{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Data.AEq
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- A type class for approximate and exact equalilty comparisons and instances
-- for common data types.
module Data.AEq (
    AEq(..),
    ) where

import Foreign
import Foreign.C.Types
import Data.Complex
import Numeric.IEEE

infix 4 ===, ~==

-- | Types with approximate and exact equality comparisons.
class Eq a => AEq a where
    -- | An exact equality comparison.
    --
    -- For real 'IEEE' types, two values are equivalent in the
    -- following cases:
    --
    --   * both values are @+0@;
    --
    --   * both values are @-0@;
    --
    --   * both values are nonzero and equal to each other
    --     (according to '==');
    --
    --   * both values are @NaN@ with the same payload and sign.
    --
    -- For complex 'IEEE' types, two values are equivalent if their
    -- real and imaginary parts are equivalent.
    --
    (===) :: a -> a -> Bool
    (===) = (==)
    {-# INLINE (===) #-}

    -- | An approximate equality comparison operator.
    --
    -- For real 'IEEE' types, two values are approximately equal in the
    -- following cases:
    --
    --   * at least half of their significand bits agree;
    --
    --   * both values are less than 'epsilon';
    --
    --   * both values are @NaN@.
    --
    -- For complex 'IEEE' types, two values are approximately equal in the
    -- followiing cases:
    --
    --   * their magnitudes are approximately equal and the angle between
    --     them is less than @32*'epsilon'@;
    --
    --   * both magnitudes are less than 'epsilon';
    --
    --   * both have a @NaN@ real or imaginary part.
    --
    -- Admitedly, the @32@ is a bit of a hack.  Future versions of the
    -- library may switch to a more principled test of the angle.
    --
    (~==) :: a -> a -> Bool
    (~==) = (==)
    {-# INLINE (~==) #-}

approxEqIEEE :: (IEEE a) => a -> a -> Bool
approxEqIEEE x y =
    ( sameSignificandBits x y >= d
    || (abs x < epsilon && abs y < epsilon)
    || (isNaN x && isNaN y)
    )
  where
    d = (floatDigits x + 1) `div` 2
{-# INLINE approxEqIEEE #-}

identicalComplexIEEE :: (IEEE a) => Complex a -> Complex a -> Bool
identicalComplexIEEE (x1 :+ y1) (x2 :+ y2) =
    (identicalIEEE x1 x2) && (identicalIEEE y1 y2)
{-# INLINE identicalComplexIEEE #-}

approxEqComplexIEEE :: (IEEE a) => Complex a -> Complex a -> Bool
approxEqComplexIEEE z1 z2 = let
    (r1,c1) = polar z1
    (r2,c2) = polar z2
    angle = abs (c1 - c2)
    in ( ( approxEqIEEE r1 r2
         && (angle < 32*epsilon || angle > 2*(pi - 16*epsilon) || isNaN angle)
         )
       || (r1 < epsilon && r2 < epsilon)
       )
{-# INLINE approxEqComplexIEEE #-}

instance AEq Float where
    (===) = identicalIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqIEEE
    {-# INLINE (~==) #-}

instance AEq Double where
    (===) = identicalIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqIEEE
    {-# INLINE (~==) #-}

instance AEq (Complex Float) where
    (===) = identicalComplexIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqComplexIEEE
    {-# INLINE (~==) #-}

instance AEq (Complex Double) where
    (===) = identicalComplexIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqComplexIEEE
    {-# INLINE (~==) #-}

instance AEq CFloat where
    (===) = identicalIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqIEEE
    {-# INLINE (~==) #-}

instance AEq CDouble where
    (===) = identicalIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqIEEE
    {-# INLINE (~==) #-}

instance AEq (Complex CFloat) where
    (===) = identicalComplexIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqComplexIEEE
    {-# INLINE (~==) #-}

instance AEq (Complex CDouble) where
    (===) = identicalComplexIEEE
    {-# INLINE (===) #-}
    (~==) = approxEqComplexIEEE
    {-# INLINE (~==) #-}

instance AEq Bool
instance AEq Char
instance AEq Int
instance AEq Int8
instance AEq Int16
instance AEq Int32
instance AEq Int64
instance AEq Integer
instance AEq Ordering
instance AEq Word
instance AEq Word8
instance AEq Word16
instance AEq Word32
instance AEq Word64
instance AEq ()
instance AEq WordPtr
instance AEq IntPtr
instance AEq (StablePtr a)
instance AEq (Ptr a)
instance AEq (FunPtr a)
instance AEq (ForeignPtr a)
instance AEq CChar
instance AEq CSChar
instance AEq CUChar
instance AEq CShort
instance AEq CUShort
instance AEq CInt
instance AEq CUInt
instance AEq CLong
instance AEq CULong
instance AEq CPtrdiff
instance AEq CSize
instance AEq CWchar
instance AEq CSigAtomic
instance AEq CLLong
instance AEq CULLong
instance AEq CIntPtr
instance AEq CUIntPtr
instance AEq CIntMax
instance AEq CUIntMax
instance AEq CClock
instance AEq CTime

eqListsWith :: (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListsWith f (x:xs) (y:ys) = f x y && eqListsWith f xs ys
eqListsWith _ [] [] = True
eqListsWith _ _  _  = False
{-# INLINE eqListsWith #-}

instance (AEq a) => AEq [a] where
    (===) = eqListsWith (===)
    {-# INLINE (===) #-}
    (~==) = eqListsWith (~==)
    {-# INLINE (~==) #-}

instance (AEq a) => AEq (Maybe a) where
    (===) Nothing  Nothing  = True
    (===) (Just x) (Just y) = (===) x y
    (===) _ _ = False
    {-# INLINE (===) #-}

    (~==) Nothing  Nothing  = True
    (~==) (Just x) (Just y) = (~==) x y
    (~==) _ _ = False
    {-# INLINE (~==) #-}

instance (AEq a, AEq b) => AEq (Either a b) where
    (===) (Left a1)  (Left a2)  = (===) a1 a2
    (===) (Right b1) (Right b2) = (===) b1 b2
    (===) _ _ = False
    {-# INLINE (===) #-}

    (~==) (Left a1)  (Left a2)  = (~==) a1 a2
    (~==) (Right b1) (Right b2) = (~==) b1 b2
    (~==) _ _ = False
    {-# INLINE (~==) #-}

instance (AEq a, AEq b) => AEq (a,b) where
    (===) (a1,b1) (a2,b2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1) (a2,b2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c) => AEq (a,b,c) where
    (===) (a1,b1,c1) (a2,b2,c2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1) (a2,b2,c2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d) => AEq (a,b,c,d) where
    (===) (a1,b1,c1,d1) (a2,b2,c2,d2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1) (a2,b2,c2,d2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e) => AEq (a,b,c,d,e) where
    (===) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f) => AEq (a,b,c,d,e,f) where
    (===) (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g) => AEq (a,b,c,d,e,f,g) where
    (===) (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h) => AEq (a,b,c,d,e,f,g,h) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i) => AEq (a,b,c,d,e,f,g,h,i) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1) (a2,b2,c2,d2,e2,f2,g2,h2,i2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1) (a2,b2,c2,d2,e2,f2,g2,h2,i2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j) => AEq (a,b,c,d,e,f,g,h,i,j) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k) => AEq (a,b,c,d,e,f,g,h,i,j,k) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        && ((===) k1 k2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        && ((~==) k1 k2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l) => AEq (a,b,c,d,e,f,g,h,i,j,k,l) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        && ((===) k1 k2)
        && ((===) l1 l2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        && ((~==) k1 k2)
        && ((~==) l1 l2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        && ((===) k1 k2)
        && ((===) l1 l2)
        && ((===) m1 m2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        && ((~==) k1 k2)
        && ((~==) l1 l2)
        && ((~==) m1 m2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m, AEq n) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        && ((===) k1 k2)
        && ((===) l1 l2)
        && ((===) m1 m2)
        && ((===) n1 n2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        && ((~==) k1 k2)
        && ((~==) l1 l2)
        && ((~==) m1 m2)
        && ((~==) n1 n2)
        )
    {-# INLINE (~==) #-}

instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m, AEq n, AEq o) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
    (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) =
        (  ((===) a1 a2)
        && ((===) b1 b2)
        && ((===) c1 c2)
        && ((===) d1 d2)
        && ((===) e1 e2)
        && ((===) f1 f2)
        && ((===) g1 g2)
        && ((===) h1 h2)
        && ((===) i1 i2)
        && ((===) j1 j2)
        && ((===) k1 k2)
        && ((===) l1 l2)
        && ((===) m1 m2)
        && ((===) n1 n2)
        && ((===) o1 o2)
        )
    {-# INLINE (===) #-}

    (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) =
        (  ((~==) a1 a2)
        && ((~==) b1 b2)
        && ((~==) c1 c2)
        && ((~==) d1 d2)
        && ((~==) e1 e2)
        && ((~==) f1 f2)
        && ((~==) g1 g2)
        && ((~==) h1 h2)
        && ((~==) i1 i2)
        && ((~==) j1 j2)
        && ((~==) k1 k2)
        && ((~==) l1 l2)
        && ((~==) m1 m2)
        && ((~==) n1 n2)
        && ((~==) o1 o2)
        )
    {-# INLINE (~==) #-}


module NeuralNetwork.Types where

import Numeric.LinearAlgebra.Data (R, Vector)
import Numeric.Natural (Natural)

newtype Layer = Layer
  { numUnits :: Natural
  } deriving (Eq, Show)

data Network = Network
  { inputLayer :: Layer
  , hiddenLayer :: [Layer]
  , outputLayer :: Layer
  } deriving (Eq, Show)


module Main where

import Softbody
import qualified Data.Array.Accelerate as A
import Data.Array.Accelerate.LLVM.Native as CPU
import Data.Complex
import Graphics.Gloss
import Graphics.Gloss.Data.ViewPort
import Graphics.Gloss.Data.Color

hs_new_v = CPU.runN new_v

update_v :: C -> V -> Double -> Double -> V
update_v c v t d = hs_new_v c v (A.fromList A.Z $ [t :+ 0]) (A.fromList A.Z $ [d :+ 0])

---

display_v :: (V, C) -> Picture
display_v (v, c) = pictures [nodePictures, edgePictures]
  where
    complexToFloatTuple (real :+ imag) = (realToFrac real, realToFrac imag)
    nodeList = A.toList v

    rectangleAt x y = translate x y $ rectangleSolid 10 10
    nodePictures = pictures (map (\(pi, delta, alpha, rho) -> uncurry rectangleAt $ complexToFloatTuple pi) nodeList)

    nodePairsWithDistance = zip [(pi1, pi2) | (pi1, _, _, _) <- nodeList, (pi2, _, _, _) <- nodeList] (A.toList c)
    edgeColor n = mixColors 10 n black red
    edgePicture ((pi1, pi2), d) = color (edgeColor . realToFrac . abs $ (magnitude $ pi2 - pi1) - d) (line $ complexToFloatTuple <$> [pi1, pi2])
    edgePictures = pictures (edgePicture <$> nodePairsWithDistance)

tick_v :: ViewPort -> Float -> (V, C) -> (V, C)
tick_v _ t (v, c) = (update_v c v (realToFrac t * 8) 1, c)

main :: IO ()
main = simulate
  (InWindow "https://aearnus.github.io/" (800, 600) (0, 0))
  (greyN 0.5)
  120
  (my_v, my_c)
  display_v
  tick_v


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-}

module Vectors where

import Feldspar
import Feldspar.Array.Vector
import Feldspar.Array.Buffered

import Feldspar.Software
import Feldspar.Software as Soft (icompile)
import Feldspar.Software.Compile
import Feldspar.Software.Marshal

import Feldspar.Hardware hiding (Arr, IArr, Ref)
import Feldspar.Hardware as Hard (icompile, icompileSig, icompileAXILite)

import Control.Monad (void)
import Data.Complex (Complex)

-- language-c-quote
import Language.C.Quote.GCC
import qualified Language.C.Syntax as C

-- imperative-edsl
import qualified Language.Embedded.Backend.C  as Imp

import Prelude hiding (take, drop, reverse, length, zip, zipWith, sum, tail, map)

--------------------------------------------------------------------------------
-- * ...
--------------------------------------------------------------------------------

sumLast5 :: SPull (SExp Word32) -> SExp Word32
sumLast5 = sum . take 5 . reverse

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

test1 :: IO ()
test1 = Soft.icompile $ printf "%d" $ sumLast5 inp
  where
    inp :: SPull (SExp Word32)
    inp = 0 ... 10

--------------------------------------------------------------------------------
-- * ...
--------------------------------------------------------------------------------

dot :: (Vector exp, Pully exp vec a, Num a, Syntax exp a) => vec -> vec -> a
dot a b = sum $ zipWith (*) a b

dotArr :: IArr (SExp Int32) -> IArr (SExp Int32) -> SExp Int32
dotArr = dot

dotProg :: Software ()
dotProg = connectStdIO $ return . uncurry dotArr

dotIO :: IO ()
dotIO = Soft.icompile dotProg

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

fir :: (Vector exp, Num a, Syntax exp a) => Pull exp a -> Pull exp a -> Pull exp a
fir coeff = map (dot coeff . reverse) . tail . inits

firArr :: IArr (SExp Int32) -> IArr (SExp Int32) -> Pull SExp (SExp Int32)
firArr a b = fir (toPull a) (toPull b)

firProg :: Software ()
firProg = connectStdIO $ manifestFresh . uncurry firArr

firIO :: IO ()
firIO = Soft.icompile firProg

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

type SStore  a = Store  Software a

printTime_def = [cedecl|
void printTime(typename clock_t start, typename clock_t end)
{
  printf("CPU time (sec): %f\n", (double)(end-start) / CLOCKS_PER_SEC);
}
|]

sizeOf_double_complex :: SExp Length
sizeOf_double_complex = 16

-- | Measure the time for 100 runs of 'fftCore' (excluding initialization) for
-- arrays of the given size
benchmark :: SExp Length -> Software ()
benchmark n = do
  addInclude "<stdio.h>"
  addInclude "<string.h>"
  addInclude "<time.h>"
  addDefinition printTime_def
  start <- newObject "clock_t" False
  end   <- newObject "clock_t" False
  st1 :: SStore (SExp (Complex Double)) <- newStore n
  inp1 <- unsafeFreezeStore n st1
  callProc "memset"
      [ iarrArg (manifest inp1)
      , valArg (0 :: SExp Index)
      , valArg (n*sizeOf_double_complex)
      ]
  st2 :: SStore (SExp (Complex Double)) <- newStore n
  inp2 <- unsafeFreezeStore n st2
  callProc "memset"
      [ iarrArg (manifest inp1)
      , valArg (0 :: SExp Index)
      , valArg (n*sizeOf_double_complex)
      ]
  callProcAssign start "clock" []

  for 0 1 99 $ \(_ :: SExp Index) ->
    void $ manifestFresh (fir (toPull inp1) (toPull inp2))

  callProcAssign end "clock" []
  callProc "printTime" [objArg start, objArg end]

runBenchmark n = runCompiled'
  (Imp.def :: CompilerOpts)
  (Imp.def {Imp.externalFlagsPre = ["-O3"], Imp.externalFlagsPost = ["-lm"]})
  (benchmark n)

printBenchmark n = Soft.icompile (benchmark n)

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

dot_sig :: HSig (SArr Word32 -> SArr Word32 -> Signal Word32 -> ())
dot_sig =
  inputIArr 1 $ \a ->
  inputIArr 1 $ \b ->
  ret $ pure $ dot a b
  -- `dot` is pure, so we lift its result.

test3 :: IO ()
test3 = Hard.icompileSig $ dot_sig
  -- Seems the optimizer isn't happy, might be just my installation tho.

test4 :: IO ()
test4 = Hard.icompileAXILite $ dot_sig

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

dot_mmap :: Software ()
dot_mmap =
  do dot <- mmap "0x43C00000" dot_sig
     a :: Arr (SExp Word32) <- initArr [1]
     b :: Arr (SExp Word32) <- initArr [1]
     c :: Ref (SExp Word32) <- newRef
     --
     call dot (a >>: b >>: c >: nil)
     --
     result <- getRef c
     printf "dot: %d\n" result

test5 :: IO ()
test5 = Soft.icompile dot_mmap

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


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE TypeApplications    #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.LRN where

import           Data.Singletons              ()
import           GHC.TypeLits
import           Hedgehog
import           Data.Proxy
import           Data.Kind (Type)
import           Test.Hedgehog.Hmatrix
import           Test.Grenade.Layers.Internal.Reference
import qualified System.Random.MWC as MWC
import           Control.DeepSeq
import           Control.Exception (evaluate)
import           Test.Hedgehog.Compat
import           Data.Serialize
import           Data.Either

import           Grenade.Core
import           Grenade.Layers.LRN
import           Grenade.Types
import           Numeric.LinearAlgebra.Data   as NLD hiding ((===))
import           Numeric.LinearAlgebra.Static as H hiding ((===))

expectedDepth1
  = [
      [0.99992500, 1.99940020, 2.99797659],
      [3.99520671, 4.99064546, 5.98385086],
      [6.97438480, 7.96181378, 8.94570965],
      [1.09990018, 2.09930569, 3.09776755],
      [4.09483851, 5.09007376, 6.08303166],
      [7.07327453, 8.06036937, 9.04388861],
      [1.19987041, 2.19920173, 3.19754459],
      [4.19445196, 5.18947928, 6.18218531],
      [7.17213277, 8.15888920, 9.14202759]
    ]

expectedDepth2
  = [
      [0.99992500, 1.99940020, 2.99797659],
      [3.99520671, 4.99064546, 5.98385086],
      [6.97438480, 7.96181378, 8.94570965],

      [1.09981771, 2.09867639, 3.09568020],
      [4.08993980, 5.08057535, 6.06671955],
      [7.04752047, 8.02214440, 8.98977845],

      [1.19976155, 2.19847498, 3.19524425],
      [4.18918085, 5.17940607, 6.16505399],
      [7.14527441, 8.11923556, 9.08612680]
    ]

expectedDepth3
  = [
      [0.99983428, 1.99873942, 2.99581955],
      [3.99018517, 4.98095623, 5.96726513],
      [6.94825962, 7.92310558, 8.89098967],

      [1.09969897, 2.09791554, 3.09330926],
      [4.08455479, 5.07034831, 6.04941408],
      [7.02051070, 7.98243693, 8.93403711],

      [1.19976155, 2.19847498, 3.19524425],
      [4.18918085, 5.17940607, 6.16505399],
      [7.14527441, 8.11923556, 9.08612680]
    ]

prop_lrn_forwards_fixed :: Property
prop_lrn_forwards_fixed = property $ do
  let ch1 = [[1, 2, 3], [4, 5, 6], [7, 8, 9]]
      ch2 = map (map (0.1 +)) ch1
      ch3 = map (map (0.1 +)) ch2
      dat = concat [ch1, ch2, ch3]
      mat = (NLD.fromLists dat) :: NLD.Matrix RealNum

      lrn   = LRN :: (LRN "0.0001" "0.75" "1" 1)
      lrn'  = LRN :: (LRN "0.0001" "0.75" "1" 2)
      lrn'' = LRN :: (LRN "0.0001" "0.75" "1" 3)

      Just inp = (H.create mat) :: Maybe (H.L 9 3)
      (out,   expMat)   = getOutput lrn   expectedDepth1 inp
      (out',  expMat')  = getOutput lrn'  expectedDepth2 inp
      (out'', expMat'') = getOutput lrn'' expectedDepth3 inp

  out   `isSimilarMatrixTo` expMat
  out'  `isSimilarMatrixTo` expMat'
  out'' `isSimilarMatrixTo` expMat''
  where
    -- Helper function to
    getOutput :: (KnownSymbol a, KnownSymbol b, KnownSymbol k, KnownNat n) => LRN a b k n -> [[RealNum]] -> H.L 9 3 -> (Matrix RealNum, Matrix RealNum)
    getOutput l e inp = (H.extract o, NLD.fromLists e)
      where
      (_, S3D o :: (S ('D3 3 3 3))) = runForwards l ((S3D inp) :: (S ('D3 3 3 3)))

data OpaqueLRN :: Type where
  OpaqueLRN :: (KnownNat i) => LRN "0.0001" "0.75" "1" i -> OpaqueLRN

genOpaqueLRN :: Gen OpaqueLRN
genOpaqueLRN = do
  s :: Integer <- choose 1 7
  let Just s' = someNatVal s
  case s' of
      SomeNat (Proxy :: Proxy i') ->
          return . OpaqueLRN $ (LRN :: LRN "0.0001" "0.75" "1" i')

prop_lrn_forwards :: Property
prop_lrn_forwards = property $ do
  OpaqueLRN (lrn :: LRN "0.0001" "0.75" "1" n) <- blindForAll genOpaqueLRN
  let n' = natVal (Proxy :: Proxy n)
  source <- forAll $ genLists3D 5 11 7 -- 5 channels, 11 rows, 7 columns
  let inp = S3D (H.fromList $ (concat . concat) source) :: S ('D3 11 7 5)
      (_, o :: (S ('D3 11 7 5))) = runForwards lrn inp
      out = naiveLRNForwards 0.0001 0.75 1 (fromIntegral n') source

  assert $ allClose o (S3D (H.fromList $ (concat . concat) out))

prop_lrn_backwards :: Property
prop_lrn_backwards = property $ do
  OpaqueLRN (lrn :: LRN "0.0001" "0.75" "1" n) <- blindForAll genOpaqueLRN
  let n' = natVal (Proxy :: Proxy n)
  source <- forAll $ genLists3D 5 11 7 -- 5 channels, 11 rows, 7 columns
  let inp = S3D (H.fromList $ (concat . concat) source) :: S ('D3 11 7 5)
      (tape, o :: (S ('D3 11 7 5))) = runForwards lrn inp
      ((),    d :: (S ('D3 11 7 5))) = runBackwards lrn tape o
      out = naiveLRNForwards 0.0001 0.75 1 (fromIntegral n') source
      back = naiveLRNBackwards 0.0001 0.75 1 (fromIntegral n') source out

  assert $ allClose d (S3D (H.fromList $ (concat . concat) back))

prop_lrn_show :: Property
prop_lrn_show = withTests 1 $ property $ do
  let lrn = LRN :: (LRN "0.0001" "0.75" "1" 1)
  (show lrn) `seq` success

prop_lrn_rnf :: Property
prop_lrn_rnf = withTests 1 $ property $ do
  let lrn = LRN :: (LRN "0.0001" "0.75" "1" 1)
  (r :: ()) <- evalIO $ evaluate $ rnf lrn
  r `seq` success

prop_lrn_run_update :: Property
prop_lrn_run_update = withTests 1 $ property $ do
  source <- forAll $ genLists 12 17
  gen <- evalIO MWC.create
  (lrn :: LRN "0.0001" "0.75" "1" 1) <- evalIO $ createRandomWith UniformInit gen
  let mat = (NLD.fromLists source) :: NLD.Matrix RealNum
      Just inp = (H.create mat) :: Maybe (H.L 12 17)
      (tape, o :: (S ('D3 3 17 4))) = runForwards lrn ((S3D inp) :: (S ('D3 3 17 4)))
      (grad, _ :: (S ('D3 3 17 4))) = runBackwards lrn tape o
  (runUpdate defSGD lrn grad) `seq` (runUpdate defAdam lrn grad) `seq` success
  (reduceGradient @(LRN "0.0001" "0.75" "1" 1) [grad]) `seq` success

prop_lrn_serializable :: Property
prop_lrn_serializable = withTests 1 $ property $ do
  gen <- evalIO MWC.create
  (lrn :: LRN "0.0001" "0.75" "1" 1) <- evalIO $ createRandomWith UniformInit gen
  let bs  = encode lrn
      dec = decode bs :: Either String (LRN "0.0001" "0.75" "1" 1)
  assert $ isRight dec
  (put lrn) `seq` success

tests :: IO Bool
tests = checkParallel $$(discover)