module Quox.Semiring

import Quox.Context
import public Quox.NatExtra
import Data.Bool.Decidable
import Quox.No

%hide Nat.isZero

export infixl 8 +.
export infixl 9 *., *:, :*
export infixr 10 ^.

public export
interface AddMonoid a where
  zero   : a
  isZero : a -> Bool
  (+.)   : a -> a -> a

public export
interface TimesMonoid a where
  one : a
  (*.) : a -> a -> a

public export
0 Semiring : Type -> Type
Semiring a = (AddMonoid a, TimesMonoid a)

public export
interface (Semiring base, AddMonoid vec) => VecSpace base vec | vec where
  (*:) : base -> vec -> vec
  (:*) : vec -> base -> vec

  x  *: xs = xs :* x
  xs :* x  = x  *: xs


namespace Foldable
  public export %inline %tcinline
  ssum : AddMonoid a => Foldable t => {default zero init : a} -> t a -> a
  ssum = foldl (+.) init

  public export %inline %tcinline
  sproduct : TimesMonoid a => Foldable t => {default one init : a} -> t a -> a
  sproduct = foldl (*.) init

namespace Context
  public export %inline %tcinline
  ssum : AddMonoid a => {default zero init : a} ->
         Telescope' a from to -> a
  ssum = foldl_ (+.) zero

  public export %inline %tcinline
  sproduct : TimesMonoid a => {default one init : a} ->
             Telescope' a from to -> a
  sproduct = foldl_ (*.) one


public export
(^.) : TimesMonoid a => a -> Nat -> a
x ^. 0   = one
x ^. S k = x *. x^.k


export %inline
[NumAdd] Eq a => Num a => AddMonoid a where
  zero = 0; (+.) = (+); isZero = (== 0)

export %inline
[NumTimes] Num a => TimesMonoid a where
  one = 1; (*.) = (*)


export %inline %hint
NatAM : AddMonoid Nat
NatAM = NumAdd

export %inline %hint
NatTM : TimesMonoid Nat
NatTM = NumTimes

export %inline %hint
IntegerAM : AddMonoid Integer
IntegerAM = NumAdd

export %inline %hint
IntegerTM : TimesMonoid Integer
IntegerTM = NumTimes

export %inline %hint
IntAM : AddMonoid Int
IntAM = NumAdd

export %inline %hint
IntTM : TimesMonoid Int
IntTM = NumTimes


export %inline
(from `LTE'` to, AddMonoid a) => AddMonoid (Telescope' a from to) where
  zero   = replicateLTE zero
  (+.)   = zipWith (+.)
  isZero = all isZero

export %inline
(from `LTE'` to, Semiring a) => VecSpace a (Telescope' a from to) where
  x *: xs = map (x *.) xs


public export
interface AddMonoid a => MonoAddMonoid a where
  0 zeroPlus : (x, y : a) ->
               No (isZero x) -> No (isZero y) -> No (isZero (x +. y))

export
MonoAddMonoid Nat where
  zeroPlus (S _) (S _) Ah Ah = Ah


public export
0 MonoAddSemiring : Type -> Type
MonoAddSemiring a = (MonoAddMonoid a, TimesMonoid a)