packages feed

lr-acts (empty) → 0.0

raw patch · 14 files changed

+2180/−0 lines, 14 filesdep +QuickCheckdep +basedep +criterionsetup-changed

Dependencies added: QuickCheck, base, criterion, data-default, groups, hspec, lr-acts

Files

+ CHANGELOG.md view
@@ -0,0 +1,17 @@+# Changelog for `lr-acts`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.0 - 2025-05-22++### Added++- Left and right actions+- Semigroup, monoid and group actions+- Cyclic and generated actions+- Torsors+- Semidirect products
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2024, Alice Rixte++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,107 @@+# lr-acts++[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/lr-acts.svg)](https://hackage.haskell.org/package/lr-acts)  [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/AliceRixte/lr-acts/LICENSE)+++## Features++* Left and right actions of+  * sets+  * semigroup+  * monoids+  * groups+* Semidirect product+* Group torsors+* Cyclic actions+* Generated actions+++### Fine-grained class hierarchy++Left and right actions with a fine-grained class hierarchy for action properties. For left actions, here are the provided classes :++``` haskell+class LAct               -- Set action+ => LActSg               -- Semigroup action+     => LActMn           -- Monoid action+          => LTorsor     -- Torsor+ => LActDistrib          -- Distributive action+ => LActNeutral          -- Neutral preserving action+ => LActGen              -- Action generated by a set+     => LActCyclic       -- Cyclic action (generated by a single element)++```++### Derive most of you action instances++The acting type is always the second parameter. Use this with `DerivingVia` language extension to derive action instances :++``` haskell+import Data.Act+import Data.Semigroup++newtype Seconds = Seconds Float+newtype Duration = Duration Seconds+  deriving (Semigroup, Monoid) via (Sum Float)++  deriving (LAct Seconds, RAct Seconds) via (ActSelf' (Sum Float))+  -- derives LAct Second  Duration++  deriving (LAct [Seconds], RAct [Seconds]) via (ActMap (ActSelf' (Sum Float)))+   -- derives LAct [Second] Duration++newtype Durations = Durations [Duration]+  deriving (LAct Seconds, RAct Seconds) via (ActFold [Duration])+  -- derives LAct Second Durations++```++``` haskell+ghci> Duration 2 `lact` Seconds 3+Seconds 5.0++ghci> Duration 2 `lact` [Seconds 3, Seconds 4]+[Seconds 5.0,Seconds 6.0]++ghci> [Duration 2, Duration 3] `lact` Seconds 4+[Seconds 5.0,Seconds 6.0]++ghci> Durations [Duration 2, Duration 3] `lact` Seconds 4+Seconds 9.0+```++### Semidirect products++This fine-grained hierarchy allows to check for associativity and existence of neutral elements using _semidirect products_.++``` haskell+>>> import Data.Semigroup+>>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))+LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}+```++GHC will complain when using a semigroup action that is not distributive :++```haskell+>>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))+No instance for `LActDistrib (Sum Int) (Sum Int)'+  arising from a use of `<>'+```++## Comparison with other action libraries++Here is a list of action libraries on hackage :++- [monoid-extra](https://github.com/diagrams/monoid-extras)+- [acts](https://hackage.haskell.org/package/acts)+- [semigroup-actions](https://hackage.haskell.org/package/semigroups-actions)+- [raaz](https://hackage.haskell.org/package/raaz-0.0.1/docs/Raaz-Core-MonoidalAction.html)+++In comparison with these libraries, `lr-acts`is the only library that :+- Implements right actions+- Implements cyclic actions and generated actions+- Ensures the associativity and the neutrality of `mempty` in semidirect products+- Proposes several newtypes for deriving instances (note that [acts](https://hackage.haskell.org/package/acts) proposes a deriving mechanism, but centered around the actee type, not the actor type as in this library)++The main drawback of providing right actions and checking properties for semidirect products is that the number of instances can quickly be overwhelming. It can be a lot of boiler plate to declare them all, especially when the acting semigroup is commutative.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Main.hs view
@@ -0,0 +1,38 @@+module Main (main) where++import Criterion.Main++import Data.Semidirect.Lazy as L+import Data.Semidirect.Strict as S++import Data.Monoid+import Data.Semigroup++stimesLSemiLazy :: Int -> Sum Int+stimesLSemiLazy n =   L.lactee $ stimes n+    (L.LSemidirect (Sum 1) (Product 2) :: L.LSemidirect (Sum Int) (Product Int))++stimesLSemiStrict :: Int -> Sum Int+stimesLSemiStrict n =+  S.lactee $ stimes n+    (S.LSemidirect (Sum 1) (Product 2) :: S.LSemidirect (Sum Int) (Product Int))++sumProduct :: Int  -> (Sum Int, Product Int)+sumProduct n = stimes n (Sum 1, Product 2)++mkBench f n = bench (show n) $ nf f n++pow10list :: Int -> Int -> [Int]+pow10list a b = [10 ^n | n <- [a..b]]++nlist  :: [Int]+nlist = pow10list 1 4+++main :: IO ()+main =+    defaultMain [+        bgroup "Lazy pair (,)"      (fmap (mkBench sumProduct)      nlist)+      , bgroup "Lazy LSemidirect"   (fmap (mkBench stimesLSemiLazy) nlist)+      , bgroup "Strict LSemidirect" (fmap (mkBench stimesLSemiStrict) nlist)+    ]
+ lr-acts.cabal view
@@ -0,0 +1,87 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           lr-acts+version:        0.0+synopsis:       Left and right actions, semidirect products and torsors+description:    Please see the README on GitHub at <https://github.com/AliceRixte/lr-acts/blob/main/README.md>+category:       Algebra, Math, Data+homepage:       https://github.com/AliceRixte/lr-acts#readme+bug-reports:    https://github.com/AliceRixte/lr-acts/issues+author:         Alice Rixte+maintainer:     alice.rixte@u-bordeaux.fr+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.8.2+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/AliceRixte/lr-acts++library+  exposed-modules:+      Data.Act+      Data.Act.Act+      Data.Act.Cyclic+      Data.Act.Torsor+      Data.Semidirect+      Data.Semidirect.Lazy+      Data.Semidirect.Strict+  other-modules:+      Paths_lr_acts+  autogen-modules:+      Paths_lr_acts+  hs-source-dirs:+      src+  ghc-options: -Wall -threaded -fprint-potential-instances+  build-depends:+      base >=4.18 && <5+    , data-default >=0.7 && <0.9+    , groups ==0.5.*+  default-language: Haskell2010++test-suite lr-acts-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_lr_acts+  autogen-modules:+      Paths_lr_acts+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck >=2.14.3+    , base >=4.18 && <5+    , data-default >=0.7 && <0.9+    , groups ==0.5.*+    , hspec >=2.11+    , lr-acts+  default-language: Haskell2010++benchmark lr-acts-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_lr_acts+  autogen-modules:+      Paths_lr_acts+  hs-source-dirs:+      benchmark+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.18 && <5+    , criterion >=1.6+    , data-default >=0.7 && <0.9+    , groups ==0.5.*+    , lr-acts+  default-language: Haskell2010
+ src/Data/Act.hs view
@@ -0,0 +1,80 @@+++--------------------------------------------------------------------------------+-- |+--+-- Module      :  Data.Act+-- Description :  Actions of sets, semigroups, monoids or groups.+-- Copyright   :  (c) Alice Rixte 2024+-- License     :  BSD 3+-- Maintainer  :  alice.rixte@u-bordeaux.fr+-- Stability   :  unstable+-- Portability :  non-portable (GHC extensions)+--+-- == Presentation+--+-- An action lifts an element (the "/actor/") of some type @s@, the /acting/+-- type, into a function of another type @x@ which we call the "/actee/".+--+-- The class hierarchy for actions is fine-grained, which means it is flexible+-- but sometimes cumbersome to deal with. In particular, this allows to specify+-- specific properties on the action for a semidirect product to be a semigroup+-- or a monoid (see @'Data.Semidirect'@). Here is a tree summarizing the class+-- hierarchy and their laws:+--+-- @+-- 'LAct'                     /Set action/+--  => 'LActSg'               /Semigroup action/+--      => 'LActMn'           /Monoid action/+--           => 'LTorsor'     /Torsor/+--  => 'LActDistrib'          /Distributive action/+--  => 'LActNeutral'          /Neutral preserving action/+--  => 'LActGen'              /Action generated by a set/+--      => 'LActCyclic'       /Cyclic action (generated by a single element)/+-- @+--+--+-- == Instances driven by the acting type+--+-- The action classes do not have functional dependencies, which can make it+-- awkward to work with them. To avoid overlapping issues, this library chooses+-- to drive instances by the second parameter, i.e. to _never_ write instances+-- of the form+--+-- @+-- instance LAct SomeType s+-- instance RAct SomeType s+-- @+--+--+-- If you need such an instance, you should make a newtype. This library already+-- provides some, such as @'ActSelf'@,  @'ActTrivial'@, @'ActSelf''@, @'ActFold''@+-- and @'ActMap'@.+--+-- == Design choices compared to existing libraries+--+-- This library is inspired by the already existing action libraries.+--+-- * The deriving mechanism is inspired by the one from the @acts@ library. The+--   main difference between this library and the @acts@ library is that  @acts@+--   drives its instances by the actee parameter.+--+-- * The @monoid-extras@ library drives its instances by the acting type, but+--   does not provide a deriving mechanism. This library started as an extension+--   of @monoid-extras@, but the design choices made it diverge from it.+--+-- * The idea of specifying action properties using empty classes comes from the+--   @semigroups-actions@ library, which inspired some design of this library.+--   This library offers everything @semigroups-actions@ offers, and more.+--+--------------------------------------------------------------------------------++module Data.Act+  ( module Data.Act.Act+  , module Data.Act.Torsor+  , module Data.Act.Cyclic+  ) where++import Data.Act.Act+import Data.Act.Torsor+import Data.Act.Cyclic
+ src/Data/Act/Act.hs view
@@ -0,0 +1,773 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ConstraintKinds            #-}++--------------------------------------------------------------------------------+-- |+--+-- Module      :  Data.Act.Act+-- Description :  Actions of sets, semigroups, monoids and groups.+-- Copyright   :  (c) Alice Rixte 2024+-- License     :  BSD 3+-- Maintainer  :  alice.rixte@u-bordeaux.fr+-- Stability   :  unstable+-- Portability :  non-portable (GHC extensions)+--+-- = Usage+--+-- For both @'LAct'@ and @'RAct'@, the acting type is the second parameter. This+-- is a bit counter intuitive when using @'LAct'@, but it allows to use the+-- @DerivingVia@ mechanism to derive instances of @'LAct'@ and @'RAct'@ for+-- newtypes that wrap the acting type. For example, you can use @'ActSelf''@ as+-- follow to derive instances for @'LAct'@ and @'RAct'@ :+--+-- @+-- {-# LANGUAGE DerivingVia #-}+--+-- import Data.Act+-- import Data.Semigroup+--+-- newtype Seconds = Seconds Float+-- newtype Duration = Duration Seconds+--   deriving (Semigroup, Monoid) via (Sum Float)+--+--   deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActSelf'' (Sum Float))+--   -- derives LAct Second  Duration+--+--   deriving ('LAct' [Seconds], RAct [Seconds]) via ('ActMap' ('ActSelf'' (Sum Float)))+--    -- derives LAct [Second] Duration+--+-- newtype Durations = Durations [Duration]+--   deriving ('LAct' Seconds, 'RAct' Seconds) via ('ActFold' [Duration])+--   -- derives LAct Second Durations+-- @+-- >>> Duration (Seconds 1) <>$ (Seconds 2)+-- Seconds 3.0+-- >>> Duration 2 <>$ Seconds 3+-- Seconds 5.0+-- >>> Duration 2 <>$ [Seconds 3, Seconds 4]+-- [Seconds 5.0,Seconds 6.0]+-- >>> [Duration 2, Duration 3] <>$ Seconds 4+-- [Seconds 5.0,Seconds 6.0]+-- >>> Durations [Duration 2, Duration 3] <>$ Seconds 4+-- Seconds 9.0+--+--------------------------------------------------------------------------------++module Data.Act.Act+  ( -- * Left actions+    LAct (..)+  , LActSg+  , LActMn+  , LActGp+  , LActDistrib+  , LActSgMorph+  , LActNeutral+  , LActMnMorph+  -- * Right actions+  , RAct (..)+  , RActSg+  , RActMn+  , RActGp+  , RActDistrib+  , RActSgMorph+  , RActNeutral+  , RActMnMorph+  -- * Newtypes for instance derivation+  , ActSelf (..)+  , ActSelf' (..)+  , ActMap (..)+  , ActFold (..)+  , ActFold' (..)+  , ActTrivial (..)+) where++import Data.Semigroup as Sg+import Data.Monoid as Mn+import Data.Group+import Data.Functor.Identity+import Data.Foldable+import Data.Coerce+++-- | A left action of a set @s@ on another set @x@ is a function that maps+-- elements of @s@ to functions on @x@.+--+-- There are no additional laws for this class to satisfy.+--+-- The order @'LAct'@'s arguments is counter intuitive : even though we write+-- left actions as @s <>$ x@, we declare the constraint as @LAct x s@. The+-- reason for this is to be able to derive instances of @LAct@ while driving the+-- instances by the acting type.+--+-- Instances of @LAct@ are driven by the second parameter (the acting type).+-- Concretely, this means you should never write instances of the form+--+-- @instance LAct SomeType s@+--+-- where @s@ is a type variable.+--++--+class LAct x s where+  {-# MINIMAL lact | (<>$) #-}+  -- | Lifts an element of the set @s@ into a function on the set @x@+  lact :: s -> x -> x+  lact = (<>$)+  {-# INLINE lact #-}+  infixr 5 `lact`++  -- | Infix synonym or @'lact'@+  --+  -- The acting part is on the right of the operator (symbolized by @<>@) and+  -- the actee on the right (symbolized by @$@), hence the notation @<>$@+  (<>$) :: s -> x -> x+  (<>$) = lact+  {-# INLINE (<>$) #-}+  infixr 5 <>$++-- | A left semigroup action+--+-- Instances must satisfy the following law :+--+-- @ (s <> t) <>$ x == s <>$ (t <>$ x) @+--+class (LAct x s, Semigroup s) => LActSg x s++-- | A left monoid action, also called a left /unitary/ action.+--+-- In addition to the laws of @'LActSg'@, instances must satisfy the following+-- law :+--+-- @ 'mempty' <>$ x == x @+--+class (LActSg x s, Monoid s) => LActMn x s++-- | A left action of groups. No additional laws are needed.+--+type LActGp x s = (LActMn x s, Group s)+++-- | A left distributive action+--+-- Instances must satisfy the following law :+--+-- @ s <>$ (x <> y) == (s <>$ x) <> (s <>$ y) @+--+class (LAct x s, Semigroup x) => LActDistrib x s++-- | A left action by morphism of semigroups+--+-- Whenever the constaints @'LActSg' x s@ and @'LActDistrib' x s@ are satisfied,+-- @(s <>$)@ is a morphism of semigroups for any @s@.+--+type LActSgMorph x s =  (LActSg x s, LActDistrib x s)++++-- | A left action on a monoid that preserves its neutral element.+--+-- Instances must satisfy the following law :+--+-- @ s <>$ 'mempty' == 'mempty' @+--+class (LAct x s, Monoid x) => LActNeutral x s++++-- | A left action by morphism of monoids i.e. such that @(s <>$)@ is a morphism of monoids.+--+-- This is equivalent to satisfy the three following properties :+--+-- 1. left action by morphism of semigroups (i.e. @'LActSgMorph' x s@)+-- 2. left monoid action (i.e. @'LActMn' x s@)+-- 3. preseving neutral element (i.e. @'LActNeutral' x s@)+--+type LActMnMorph x s = (LActMn x s, LActSgMorph x s, LActNeutral x s)+++-- | A right action of a set @s@ on another set @x@.+--+-- There are no additional laws for this class to satisfy.+--+class RAct x s where+  {-# MINIMAL ract | ($<>) #-}+  -- | Act on the right of some element of @x@+  ract :: x -> s -> x+  ract = ($<>)+  {-# INLINE ract #-}+  infixl 5 `ract`++  -- | Infix synonym or @'ract'@+  --+  -- The acting part is on the right of the operator (symbolized by @<>@) and+  -- the actee on the left (symbolized by @$@), hence the notation @$<>@.+  --+  ($<>) :: x -> s -> x+  ($<>) = ract+  {-# INLINE ($<>) #-}+  infixl 5 $<>+++-- | A right semigroup action+--+-- Instances must satisfy the following law :+--+-- @ x $<> (s <> t) == (x $<> s) $<> t @+--+class (RAct x s, Semigroup s) => RActSg x s++-- | A right monoid action, also called a right /unitary/ action.+--+-- In addition to the laws of @'RActSg'@, instances must satisfy the following+-- law :+--+-- @ x $<> 'mempty' == x @+--+class (RActSg x s, Monoid s) => RActMn x s++-- | A left action of groups. No additional laws are needed.+--+type RActGp x s = (RActMn x s, Group s)++-- | A right distributive action+--+-- Instances must satisfy the following law :+--+-- @ (x <> y) $<> s == (x $<> s) <> (y $<> s) @+--+class (RAct x s, Semigroup x) => RActDistrib x s+++-- | A right action by morphism of semigroups+--+-- Whenever the constaints @'RActSg' x s@ and @'RActDistrib' x s@ are satisfied,+-- @($<> s)@ is a morphism of semigroups for any @s@.+--+type RActSgMorph x s =  (RActSg x s, RActDistrib x s)+++-- | A right action on a monoid that preserves its neutral element.+--+-- Instances must satisfy the following law :+--+-- @ x $<> mempty == x @+--+class (RAct x s, Monoid x) => RActNeutral x s++-- | A right action by morphism of monoids i.e. such that+--+-- @($<> s)@ is a morphism of monoids+--+type RActMnMorph x s = (RActMn x s, RActSgMorph x s, RActNeutral x s)+++++------------------------------- Newtype actions --------------------------------++-- | A semigroup always acts on itself by translation.+--+-- Notice that whenever there is an instance @LAct x s@ with @x@ different from+-- @s@, this action is lifted to an @ActSelf@ action.+--+-- >>> ActSelf "Hello" <>$ " World !"+-- "Hello World !"+--+newtype ActSelf s = ActSelf {unactSelf :: s}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | Semigroup action (monoid action when @Monoid s@)+instance Semigroup s => LAct s (ActSelf s) where+  ActSelf s <>$ x = s <> x+  {-# INLINE (<>$) #-}++instance Semigroup s => LActSg s (ActSelf s)+instance Monoid s => LActMn s (ActSelf s)++-- | Semigroup action (monoid action when @Monoid s@)+instance Semigroup s => RAct s (ActSelf s) where+  x $<> ActSelf s = x <> s+  {-# INLINE ($<>) #-}++instance Semigroup s => RActSg s (ActSelf s)+instance Monoid s => RActMn s (ActSelf s)++-- | Actions of @ActSelf'@ behave similarly to those of @'ActSelf'@, but first+-- try to coerce @x@ to @s@ before using the @Semigroup@ instance. If @x@ can be+-- coerced to @s@, then we use the @ActSelf@ action.+--+-- This is meant to be used in conjunction with the @deriving via@ strategy when+-- defining newtype wrappers. Here is a concrete example, where durations act on+-- time. Here, @Seconds@ is not a semigroup and @Duration@ is a group that acts+-- on time via the derived instance @LAct Seconds Duration@.+--+-- @+-- import Data.Semigroup+--+-- newtype Seconds = Seconds Float+--+-- newtype Duration = Duration Seconds+--   deriving ('Semigroup', 'Monoid', 'Group') via ('Sum' Float)+--   deriving ('LAct' Seconds) via ('ActSelf'' ('Sum' Float))+-- @+--+-- >>> Duration 2 <>$ Seconds 3+-- Seconds 5.0+--+newtype ActSelf' x = ActSelf' {unactCoerce :: x}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | Semigroup action (monoid action when @Monoid s@)+instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s)+  => LAct x (ActSelf' s) where+  ActSelf' s <>$ x = coerce $ s <> (coerce x :: s)+  {-# INLINE (<>$) #-}++instance (Coercible x s, Semigroup s) => LActSg x (ActSelf' s)+instance (Coercible x s, Monoid s) => LActMn x (ActSelf' s)++-- | Semigroup action (monoid action when @Monoid s@)+instance {-# OVERLAPPABLE #-} (Semigroup s, Coercible x s)+  => RAct x (ActSelf' s) where+  x $<> ActSelf' s = coerce $ (coerce x :: s) <> s+  {-# INLINE ($<>) #-}++instance (Coercible x s, Semigroup s) => RActSg x (ActSelf' s)+instance (Coercible x s, Monoid s) => RActMn x (ActSelf' s)++-- | The trivial action where any element of @s@ acts as the identity function+-- on @x@+--+-- >>> ActTrivial "Hello !" <>$ "Hi !"+-- " Hi !"++newtype ActTrivial x = ActTrivial  {unactId :: x}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@+instance LAct x (ActTrivial s) where+  (<>$) _ = id+  {-# INLINE (<>$) #-}++instance Semigroup s => LActSg x (ActTrivial s)+instance Monoid s => LActMn x (ActTrivial s)+instance Semigroup x => LActDistrib x (ActTrivial s)+instance Monoid x => LActNeutral x (ActTrivial s)++-- | Action by morphism of monoids when @'Monoid' s@ and @'Monoid' x@+instance RAct x (ActTrivial s) where+  x $<> _ = x+  {-# INLINE ($<>) #-}++instance Semigroup s => RActSg x (ActTrivial s)+instance Monoid s => RActMn x (ActTrivial s)+instance Semigroup x => RActDistrib x (ActTrivial s)+instance Monoid x => RActNeutral x (ActTrivial s)++-- | An action on any functor that uses the @fmap@ function. For example :+--+-- >>> ActMap (ActSelf "Hello") <>$ [" World !", " !"]+-- ["Hello World !","Hello !"]+--+newtype ActMap s = ActMap {unactMap :: s}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but+-- __not__ the morphism properties, which depend on potential @'Semigroup'@+-- (resp. @'Monoid'@) instances of @f x@+instance (LAct x s, Functor f) => LAct (f x) (ActMap s) where+  ActMap s <>$ x = fmap (s <>$) x+  {-# INLINE (<>$) #-}++instance (LActSg x s, Functor f) => LActSg (f x) (ActMap s)+instance (LActMn x s, Functor f) => LActMn (f x) (ActMap s)+instance LAct x s => LActDistrib [x] (ActMap s)+instance LAct x s => LActNeutral [x] (ActMap s)+++-- | Preserves the semigroup (resp. monoid) property of @'LAct' x s@, but+-- __not__ the morphism properties, which depend on potential @'Semigroup'@+-- (resp. @'Monoid'@) instances of @f x@. When $f = []@, this is an action by morphism of monoids.+instance (RAct x s, Functor f) => RAct (f x) (ActMap s) where+  x $<> ActMap s = fmap ($<> s) x+  {-# INLINE ($<>) #-}++instance (RActSg x s, Functor f) => RActSg (f x) (ActMap s)+instance (RActMn x s, Functor f) => RActMn (f x) (ActMap s)+instance RAct x s => RActDistrib [x] (ActMap s)+instance RAct x s => RActNeutral [x] (ActMap s)++-- | Lifting an a container as an action using @'foldr'@ (for /left/ actions) or+-- @'foldl'@ (for /right/ actions). For a strict version, use @'ActFold''@.+--+-- A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function,+-- and a allowing to lift any action to some @'Foldable'@ container.+--+-- >> ActFold [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int)+-- >  10+--+newtype ActFold s = ActFold {unactFold :: s}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | When used with lists @[]@, this is a monoid action+instance (Foldable f, LAct x s) => LAct x (ActFold (f s)) where+  ActFold f <>$ x = foldr (<>$) x f+  {-# INLINE (<>$) #-}++instance LAct x s => LActSg x (ActFold [s])++-- | When used with lists @[]@, this is a monoid action+instance (Foldable f, RAct x s) => RAct x (ActFold (f s)) where+  x $<> ActFold f = foldl ($<>) x f+  {-# INLINE ($<>) #-}++-- | Lifting an a container as an action using @'fold'r'@ (for /left/ actions)+-- or @'foldl''@ (for /right/ actions). For a lazy version, use @'ActFold'@.+--+-- A left action @(<>$)@ can be seen as an operator for the @'foldr'@ function,+-- and a allowing to lift any action to some @'Foldable'@ container.+--+-- >>> ActFold' [Sum (1 :: Int), Sum 2, Sum 3] <>$ (4 :: Int)+-- 10+--+newtype ActFold' s = ActFold' {unactFold' :: s}+  deriving stock (Show, Eq)+  deriving newtype (Semigroup, Monoid, Group)++-- | When used with lists @[]@, this is a monoid action+instance (Foldable f, LAct x s) => LAct x (ActFold' (f s)) where+  ActFold' f <>$ x = foldr' (<>$) x f+  {-# INLINE (<>$) #-}++instance LAct x s => LActSg x (ActFold' [s])++-- | When used with lists @[]@, this is a monoid action+instance (Foldable f, RAct x s) => RAct x (ActFold' (f s)) where+  x $<> ActFold' f = foldl' ($<>) x f+  {-# INLINE ($<>) #-}+++---------------------------------- Instances -----------------------------------++-- | Action by morphism of monoids+instance LAct x () where+  () <>$ x = x+  {-# INLINE (<>$) #-}++instance LActSg x ()+instance LActMn x ()+instance Semigroup x => LActDistrib x ()+instance Monoid x => LActNeutral x ()++-- | Monoid action+instance RAct x () where+  x $<> () = x+  {-# INLINE ($<>) #-}++instance RActSg x ()+instance RActMn x ()+instance Semigroup x => RActDistrib x ()+instance Monoid x => RActNeutral x ()++-- |  Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@+-- (resp. @'Monoid' s@)+instance {-# INCOHERENT #-} LAct () s where+  _ <>$ () = ()+  {-# INLINE (<>$) #-}++instance {-# INCOHERENT #-} Semigroup s =>LActSg () s+instance {-# INCOHERENT #-} Monoid s =>  LActMn () s+instance {-# INCOHERENT #-} LActDistrib () s+instance {-# INCOHERENT #-} LActNeutral () s++-- |  Action by morphism of semigroups (resp. monoids) when @'Semigroup' s@+-- (resp. @'Monoid' s@)+instance {-# INCOHERENT #-} RAct () s where+  () $<> _ = ()+  {-# INLINE ($<>) #-}++instance {-# INCOHERENT #-} Semigroup s => RActSg () s+instance {-# INCOHERENT #-} Monoid s => RActMn () s+instance {-# INCOHERENT #-} RActDistrib () s+instance {-# INCOHERENT #-} RActNeutral () s++-- | Monoid action when @'LAct' x s@ is a semigroup action.+instance LAct x s => LAct x (Maybe s) where+  Nothing <>$ x = x+  Just s <>$ x = s <>$ x++instance LActSg x s => LActSg x (Maybe s)+instance LActSg x s => LActMn x (Maybe s)++-- | Monoid action when @'LAct' x s@ is a semigroup action.+instance RAct x s => RAct x (Maybe s) where+  x $<> Nothing = x+  x $<> Just s = x $<> s++instance RActSg x s => RActSg x (Maybe s)+instance RActSg x s => RActMn x (Maybe s)++-- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2+-- s2)@+instance (LAct x1 s1, LAct x2 s2) => LAct (x1, x2) (s1, s2) where+  (s1, s2) <>$ (x1, x2) = (s1 <>$ x1, s2 <>$ x2)++instance (LActSg x1 s1, LActSg x2 s2) => LActSg (x1, x2) (s1, s2)+instance (LActMn x1 s1, LActMn x2 s2) => LActMn (x1, x2) (s1, s2)+instance (LActDistrib x1 s1, LActDistrib x2 s2) => LActDistrib (x1, x2) (s1, s2)+instance (LActNeutral x1 s1, LActNeutral x2 s2) => LActNeutral (x1, x2) (s1, s2)++-- | Same action propety as the weaker properties of @('LAct' x1 s1, 'LAct' x2+-- s2)@+instance (RAct x1 s1, RAct x2 s2) => RAct (x1, x2) (s1, s2) where+  (x1, x2) $<> (s1, s2) = (x1 $<> s1, x2 $<> s2)++instance (RActSg x1 s1, RActSg x2 s2) => RActSg (x1, x2) (s1, s2)+instance (RActMn x1 s1, RActMn x2 s2) => RActMn (x1, x2) (s1, s2)+instance (RActDistrib x1 s1, RActDistrib x2 s2) => RActDistrib (x1, x2) (s1, s2)+instance (RActNeutral x1 s1, RActNeutral x2 s2) => RActNeutral (x1, x2) (s1, s2)++-- | No additionnal properties. In particular this is _not_ a semigroup action.+instance (LAct x s, LAct x t) => LAct x (Either s t) where+  (Left  s) <>$ x = s <>$ x+  (Right s) <>$ x = s <>$ x++-- | No additionnal properties. In particular this is _not_ a semigroup action.+instance (RAct x s, RAct x t) => RAct x (Either s t) where+  x $<> (Left  s) = x $<> s+  x $<> (Right s) = x $<> s+++-------------------- Instances for base library functors ---------------------++-- | Preserves action properties of @'LAct' x s@.+instance LAct x s => LAct x (Identity s) where+  Identity s <>$ x = s <>$ x+  {-# INLINE (<>$) #-}++instance LActSg x s => LActSg x (Identity s)+instance LActMn x s => LActMn x (Identity s)+instance LActDistrib x s => LActDistrib x (Identity s)+instance LActNeutral x s => LActNeutral x (Identity s)+++-- | Preserves action properties of @'LAct' x s@.+instance {-# OVERLAPPING #-} LAct x s => LAct (Identity x) (Identity s) where+  Identity s <>$ Identity x = Identity (s <>$ x)++instance {-# OVERLAPPING #-} LActSg x s => LActSg (Identity x) (Identity s)+instance {-# OVERLAPPING #-} LActMn x s => LActMn (Identity x) (Identity s)+instance {-# OVERLAPPING #-} LActDistrib x s+  => LActDistrib (Identity x) (Identity s)+instance {-# OVERLAPPING #-} LActNeutral x s+  => LActNeutral (Identity x) (Identity s)++-- | Preserves action properties of @'RAct' x s@.+instance RAct x s => RAct x (Identity s) where+  x $<> Identity s = x $<> s+  {-# INLINE ($<>) #-}++instance RActSg x s => RActSg x (Identity s)+instance RActMn x s => RActMn x (Identity s)+instance RActDistrib x s => RActDistrib x (Identity s)+instance RActNeutral x s => RActNeutral x (Identity s)++-- | Preserves action properties of @'LAct' x s@.+instance {-# OVERLAPPING #-}  RAct x s => RAct (Identity x) (Identity s) where+  Identity x $<> Identity s = Identity (x $<> s)++instance {-# OVERLAPPING #-} RActSg x s => RActSg (Identity x) (Identity s)+instance {-# OVERLAPPING #-} RActMn x s => RActMn (Identity x) (Identity s)+instance {-# OVERLAPPING #-} RActDistrib x s+  => RActDistrib (Identity x) (Identity s)+instance {-# OVERLAPPING #-} RActNeutral x s+  => RActNeutral (Identity x) (Identity s)++------------------------- Instances for Data.Semigroup -------------------------++-- | Preserves action properties of @'LAct' x s@.+instance LAct x s => RAct x (Dual s) where+  x $<> Dual s = s <>$ x+  {-# INLINE ($<>) #-}++instance LActSg x s => RActSg x (Dual s)+instance LActMn x s => RActMn x (Dual s)+instance LActDistrib x s => RActDistrib x (Dual s)+instance LActNeutral x s => RActNeutral x (Dual s)++-- | Preserves action properties of @'LAct' x s@.+instance RAct x s => LAct x (Dual s) where+  Dual s <>$ x = x $<> s+  {-# INLINE (<>$) #-}++instance RActSg x s => LActSg x (Dual s)+instance RActMn x s => LActMn x (Dual s)+instance RActDistrib x s => LActDistrib x (Dual s)+instance RActNeutral x s => LActNeutral x (Dual s)++-- | Monoid action+instance LAct x (Endo x) where+  Endo f <>$ x = f x+  {-# INLINE (<>$) #-}++instance LActSg x (Endo x)+instance LActMn x (Endo x)++-- | Monoid action+instance Num x => LAct x (Sum x) where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance Num x => LActSg x (Sum x)+instance Num x => LActMn x (Sum x)+++-- | Monoid action+instance Num x => RAct x (Sum x) where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance Num x => RActSg x (Sum x)+instance Num x => RActMn x (Sum x)++-- | Monoid action+instance Num x => LAct x (Product x) where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance Num x => LActSg x (Product x)+instance Num x => LActMn x (Product x)++-- | Monoid action+instance Num x => RAct x (Product x) where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance Num x => RActSg x (Product x)+instance Num x => RActMn x (Product x)++-- | Monoid action+instance {-# OVERLAPPING #-} Num x => LAct (Sum x) (Sum x) where+  (<>$) = (<>)+  {-# INLINE (<>$) #-}++instance {-# OVERLAPPING #-} Num x => LActSg (Sum x) (Sum x)+instance {-# OVERLAPPING #-} Num x => LActMn (Sum x) (Sum x)++-- | Monoid action+instance {-# OVERLAPPING #-} Num x => RAct (Sum x) (Sum x) where+  ($<>) = (<>)+  {-# INLINE ($<>) #-}++instance {-# OVERLAPPING #-} Num x => RActSg (Sum x) (Sum x)+instance {-# OVERLAPPING #-} Num x => RActMn (Sum x) (Sum x)++-- | Monoid action+instance {-# OVERLAPPING #-}  Num x => LAct (Product x) (Product x) where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance {-# OVERLAPPING #-} Num x => LActSg (Product x) (Product x)+instance {-# OVERLAPPING #-} Num x => LActMn (Product x) (Product x)++-- | Monoid action+instance {-# OVERLAPPING #-} Num x => RAct (Product x) (Product x) where+  ($<>) = (<>)+  {-# INLINE ($<>) #-}++instance {-# OVERLAPPING #-} Num x => RActSg (Product x) (Product x)+instance {-# OVERLAPPING #-} Num x => RActMn (Product x) (Product x)++-- | Action by morphism of monoids+instance Num x => LAct (Sum x) (Product x) where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance Num x => LActSg (Sum x) (Product x)+instance Num x => LActMn (Sum x) (Product x)+instance Num x => LActDistrib (Sum x) (Product x)+instance Num x => LActNeutral (Sum x) (Product x)++-- | Action by morphism of monoids+instance Num x => RAct (Sum x) (Product x) where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance Num x => RActSg (Sum x) (Product x)+instance Num x => RActMn (Sum x) (Product x)+instance Num x => RActDistrib (Sum x) (Product x)+instance Num x => RActNeutral (Sum x) (Product x)++-- | Monoid action+instance LAct Bool Any where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance LActSg Bool Any+instance LActMn Bool Any++-- | Monoid action+instance RAct Bool Any where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance RActSg Bool Any+instance RActMn Bool Any++-- | Monoid action+instance LAct Bool All where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance LActSg Bool All+instance LActMn Bool All++-- | Monoid action+instance RAct Bool All where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance RActSg Bool All+instance RActMn Bool All++-- | Semigroup action+instance LAct x (Sg.First x) where+  (<>$) s = coerce (s <>)+  {-# INLINE (<>$) #-}++instance LActSg x (Sg.First x)++-- | Semigroup action+instance RAct x (Sg.Last x) where+  x $<> s = coerce $ coerce x <> s+  {-# INLINE ($<>) #-}++instance RActSg x (Sg.Last x)++-- | Monoid action+instance LAct x (Mn.First x) where+  Mn.First Nothing <>$ x = x+  Mn.First (Just s) <>$ _ = s+  {-# INLINE (<>$) #-}++instance LActSg x (Mn.First x)+instance LActMn x (Mn.First x)++-- | Monoid action+instance RAct x (Mn.Last x) where+  x $<> Mn.Last Nothing = x+  _ $<> Mn.Last (Just s) = s+  {-# INLINE ($<>) #-}++instance RActSg x (Mn.Last x)+instance RActMn x (Mn.Last x)
+ src/Data/Act/Cyclic.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies         #-}++--------------------------------------------------------------------------------+-- |+--+-- Module      :  Data.Act.Cyclic+-- Description :  Cyclic actions and actions generated by a subset of generators.+-- Copyright   :  (c) Alice Rixte 2024+-- License     :  BSD 3+-- Maintainer  :  alice.rixte@u-bordeaux.fr+-- Stability   :  unstable+-- Portability :  non-portable (GHC extensions)+--+-- = Presentation+--+-- === Cyclic actions+--+-- A cyclic action (see @'LActCyclic'@ or @'RActCyclic'@) is an action such that+-- every element of the actee set can be obtained by acting on some generator,+-- which we call here the /origin/ of the actee set.+--+-- For example, @'Sum' Integer@ acts cyclically on @'Integer'@ because for every+-- @n :: Integer@, we have @Sum n <>$ O == n@. In this example, @0@ is a+-- generator of the action @'LAct' Int (Sum Int)@ and in this library, we will+-- call it @'lorigin'@.+--+-- This gives us a way to lift any actee element into an action element. In this+-- library,  we call that lifting @'lshift'@  (resp. @'rshift'@). In the+-- previous example we get @'lshift' = Sum@.+--+-- === Actions generated by a subset of generators+--+-- In a more general setting, this library also provides @'LActGen'@ and+-- @'RActGen'@. In theory, they should be superclasses of @'LActCyclic'@ and+-- @'RActCyclic'@. In practice it is annoying to need @'Eq'@ instances for+-- defining @'lgenerators'@ and @'rgenerators'@. Please open an issue if you+-- actually need this.+--+--+-- = Usage+--+-- >>> {-# LANGUAGE TypeApplications #-}+-- >>> import Data.Act.Cyclic+-- >>> import Data.Semigroup+-- >>> lorigin @(Sum Int) :: Int+-- 0+-- >>> lshift (4 :: Int) :: Sum Int+-- Sum {getSum = 4}+--+-- = Formal algebraic definitions+--+-- In algebraic terms, a subset @u@ of the set @x@ is a /generating set/ of the+-- action @LAct x s@ if for every @x :: x@, there exists a pair @(u,s) :: (u,s)@+-- such that @s <>$ u = x@. When the set @u@ is finite, the action @LAct x s@ is+-- said to be finitely generated. When the set @u@ is a singleton, the action is+-- said to be /cyclic/.+--+-- When the previous decomposition is unique, the action is said to be /free/.+-- If it is both free and cyclic, it is /1-free/.+--+-- (See /Monoids, Acts and Categories/ by Mati+-- Kilp, Ulrich Knauer, Alexander V. Mikhalev, definition 1.5.1, p.63.)+--+-- Remark : Freeness could be represented with classes @LActFree@ and+-- @LActOneFree@ that have no methods. Feel free to open an issue if you need+-- them.+--------------------------------------------------------------------------------+++module Data.Act.Cyclic+  ( -- * Cyclic actions+    LActCyclic (..)+  , lorigin+  , RActCyclic (..)+  , rorigin+   -- * Action generated by a subset of generators+  , LActGen (..)+  , lgenerators+  , lgeneratorsList+  , lorigins+  , RActGen (..)+  , rgenerators+  , rgeneratorsList+  , rorigins+  )+  where++import Data.Bifunctor+import Data.Functor.Identity+import Data.Coerce+import Data.Semigroup as Sg+import Data.Monoid as Mn++import Data.Default++++import Data.Act.Act+++-- | A left action generated by a single generator.+--+-- Instances must satisfy the following law :+--+-- * 'lshift' x @ <>$ 'lorigin' == x@+--+-- In other words, 'lorigin' is a generator of the action @LAct x s@.+--+class LAct x s => LActCyclic x s where+  -- | The only generator of the action @LAct x s@.+  --+  -- >>> lorigin' @Int @(Sum Int)+  -- 0+  --+  -- To avoid having to use the redundant first type aplication, use+  -- @'lorigin'@.+  --+  lorigin' :: x++  --- | Shifts an element of @x@ into an action @lshift x@ such that+  -- @lshift x <>$ lorigin == x@.+  --+  lshift :: x -> s++-- | A version of @'lorigin''@ such that the first type application is @s@.+--+-- >>> lorigin @(Sum Int) :: Int+-- 0+--+lorigin :: forall s x. LActCyclic x s => x+lorigin = lorigin' @x @s+{-# INLINE lorigin #-}+++-- | A right action generated by a single generator.+--+-- Instances must satisfy the following law :+--+-- * 'rorigin' @ $<> 'rshift' x == x@+--+-- In other words, 'rorigin' is a generator of the action @RAct x s@.+--+class RAct x s => RActCyclic x s where+  -- | The only generator of the action @RAct x s@.+  --+  -- >>> rorigin' @Int @(Sum Int) :: Int+  -- 0+  --+  -- To avoid having to use the redundant first type aplication, use+  -- @'rorigin'@.+  rorigin' :: x++  -- | Shifts an element of @x@ into an action @rshift x@ such that+  -- @rshift x $<> rorigin == x@.+  rshift :: x -> s++-- | A version of @'rorigin''@ such that the first type application is @s@.+--+-- >>> rorigin @(Sum Int) :: Int+-- 0+--+rorigin :: forall s x. RActCyclic x s => x+rorigin = rorigin' @x @s+{-# INLINE rorigin #-}+++++-- | A left action generated by a subset of generators @'lgenerators'@.+--+-- Intuitively, by acting repeteadly on generators with actions+-- of @s@, we can reach any element of @x@.+--+-- Since the generating subset of @x@ maybe infinite, we give two alternative+-- ways to define it : one using a characteristic function @'lgenerators'@ and+-- the other using a list @'lgeneratorsList'@.+--+-- All the above is summarized by the following law that all instances must+-- satisfy :+--+-- 1. 'snd' @('lshiftFromGen' x) <>$ 'fst' ('lshiftFromGen' x) == x@+-- 2. 'lgenerators'@  ('fst' $ 'lshiftFromGen' x) == True@+-- 3. 'lgenerators' @ x == x `'elem'` 'lgeneratorsList' proxy@+--+class LAct x s => LActGen x s where+  -- | The set of origins of the action @'LAct' x s@.+  --+  -- This is a subset of @x@, represented as its characteristic function,+  -- meaning the function that returns @True@ for all elements of @x@ that are+  -- origins of the action and @False@ otherwise.+  --+  -- To use @'lgenerators'@, you need TypeApplications:+  --+  -- >>> lgenerators' @Int @(Sum Int) 4+  -- False+  --+  -- >>> lgenerators' @Int @(Sum Int) 0+  -- True+  --+  -- To avoid having to use the redundant first type aplication, use+  -- @'lgenerators'@.+  lgenerators' :: x -> Bool+  default lgenerators' :: Eq x => x -> Bool+  lgenerators' x = x `elem` lgeneratorsList' @x @s++  -- | The set of origins of the action @LAct x s@ seen as a list.+  --+  -- You can let this function undefined if the set of origins cannot be+  -- represented as a list.+  --+  -- >>> lgeneratorsList' @Int @(Sum Int)+  -- [0]+  --+  -- To avoid having to use the redundant first type aplication, use+  -- @'lgeneratorsList'@.+  --+  lgeneratorsList' :: [x]+  default lgeneratorsList' :: LActCyclic x s => [x]+  lgeneratorsList' = [lorigin @s]++  -- | Returns a point's associated genrator @u@ along with an action @s@ such+  -- that @s <>$ u == x@.+  lshiftFromGen:: x -> (x,s)+  default lshiftFromGen :: LActCyclic x s => x -> (x,s)+  lshiftFromGen x = (lorigin @s, lshift x)++-- | A version of @'lgenerators''@ such that the first type application is @s@.+--+-- >>> lgenerators @(Sum Int) (4 :: Int)+-- False+--+-- >>> lgenerators @(Sum Int) (0 :: Int)+-- True+--+lgenerators :: forall s x. LActGen x s => x -> Bool+lgenerators = lgenerators' @x @s+{-# INLINE lgenerators #-}++-- | A version of @'lgeneratorsList''@ such that the first type application is+-- @s@.+--+-- >>> lgeneratorsList @(Sum Int) :: [Int]+-- [0]+--+lgeneratorsList :: forall s x. LActGen x s => [x]+lgeneratorsList = lgeneratorsList' @x @s+{-# INLINE lgeneratorsList #-}++-- | An alias for @'lgeneratorsList'@.+lorigins :: forall s x. LActGen x s => [x]+lorigins = lgeneratorsList @s+{-# INLINE lorigins #-}++++------------------------------------------------------------------------------++-- | A right action generated by a subset of generators @'lgenerators'@.+--+-- Intuitively, by acting repeteadly on generators with actions+-- of @s@, we can reach any element of @x@.+--+--+-- Since the generating subset of @x@ maybe infinite, we give two alternative+-- ways to define it : one using a characteristic function @'rgenerators'@ and+-- the other using a list @'rgeneratorsList'@.+--+-- All the above is summarized by the following law that all instances must+-- satisfy :+--+-- 1. 'rgenerators'@  ('fst' $ 'rshiftFromGen' x) == True@+-- 2. 'fst' ('rshiftFromGen' x) $<> 'snd' @('rshiftFromGen' x) == x@+-- 3. 'rgenerators' @x == x `'elem'` 'rgeneratorsList' x@+--+class RAct x s => RActGen x s where+  -- | The set of origins of the action @'RAct' x s@.+  --+  -- This is a subset of @x@, represented as its characteristic function,+  -- meaning the function that returns @True@ for all elements of @x@ that are+  -- origins of the action and @False@ otherwise.+  --+  -- To use @'rgenerators'@, you need TypeApplications:+  --+  -- >>> rgenerators' @(Sum Int) (4 :: Int)+  -- False+  --+  -- >>> rgenerators' @(Sum Int) (0 :: Int)+  -- True+  --+  -- To avoid having to use the redundant first type aplication, use+  -- @'rgenerators'@.+  rgenerators' :: x -> Bool+  default rgenerators' :: Eq x => x -> Bool+  rgenerators' x = x `elem` rgeneratorsList' @x @s+  {-# INLINE rgenerators' #-}++  -- | The set of origins of the action @RAct x s@ seen as a list.+  --+  -- You can let this function undefined if the set of origins cannot be+  -- represented as a list.+  --+  -- >>> rgeneratorsList' @(Sum Int) :: [Int]+  -- [0]+  --+  rgeneratorsList' :: [x]+  default rgeneratorsList' :: RActCyclic x s => [x]+  rgeneratorsList' = [rorigin @s]+  {-# INLINE rgeneratorsList' #-}++  -- | Returns a point's associated generator @u@ along with an action @s@ such+  -- that @u $<> s == x@.+  rshiftFromGen :: x -> (x,s)+  default rshiftFromGen :: RActCyclic x s => x -> (x,s)+  rshiftFromGen x = (rorigin @s, rshift x)+  {-# INLINE rshiftFromGen #-}++-- | A version of @'rgenerators''@ such that the first type application is @s@.+--+-- >>> rgenerators @(Sum Int) (4 :: Int)+-- False+--+-- >>> rgenerators @(Sum Int) (0 :: Int)+-- True+--+rgenerators :: forall s x. RActGen x s => x -> Bool+rgenerators = rgenerators' @x @s+{-# INLINE rgenerators #-}++-- | A version of @'rgeneratorsList''@ such that the first type application is+-- @s@.+--+-- >>> rgeneratorsList @(Sum Int) :: [Int]+-- [0]+--+rgeneratorsList :: forall s x. RActGen x s => [x]+rgeneratorsList = rgeneratorsList' @x @s+{-# INLINE rgeneratorsList #-}++-- | An alias for @'rgeneratorsList'@.+--+rorigins :: forall s x. RActGen x s => [x]+rorigins = rgeneratorsList @s+{-# INLINE rorigins #-}++++---------------------------------- Instances -----------------------------------++-- Identity --++instance LActGen x s => LActGen (Identity x) (Identity s) where+  lgenerators' (Identity x) = lgenerators @s x+  {-# INLINE lgenerators' #-}+  lgeneratorsList' = Identity <$> lgeneratorsList @s+  {-# INLINE lgeneratorsList' #-}+  lshiftFromGen (Identity x) = bimap Identity Identity $ lshiftFromGen x+  {-# INLINE lshiftFromGen #-}++instance LActCyclic x s => LActCyclic (Identity x) (Identity s) where+  lorigin' = Identity (lorigin @s)+  {-# INLINE lorigin' #-}+  lshift (Identity x) = Identity (lshift x)+  {-# INLINE lshift #-}++instance RActGen x s => RActGen (Identity x) (Identity s) where+  rgenerators' (Identity x) = rgenerators @s x+  {-# INLINE rgenerators' #-}+  rgeneratorsList' = Identity <$> rgeneratorsList @s+  {-# INLINE rgeneratorsList' #-}+  rshiftFromGen (Identity x) = bimap Identity Identity $ rshiftFromGen x+  {-# INLINE rshiftFromGen #-}++instance RActCyclic x s => RActCyclic (Identity x) (Identity s) where+  rorigin' = Identity (rorigin @s)+  {-# INLINE rorigin' #-}+  rshift (Identity x) = Identity (rshift x)+  {-# INLINE rshift #-}++-- ActSelf --++instance (Eq s, Monoid s) => LActGen s (ActSelf s)++instance Monoid s => LActCyclic s (ActSelf s) where+  lorigin' = mempty+  {-# INLINE lorigin' #-}+  lshift = ActSelf+  {-# INLINE lshift #-}++instance (Eq s, Monoid s) => RActGen s (ActSelf s)++instance Monoid s => RActCyclic s (ActSelf s) where+  rorigin' = mempty+  {-# INLINE rorigin' #-}+  rshift = ActSelf+  {-# INLINE rshift #-}+++-- ActSelf' --++instance (Eq x, Coercible x s, Monoid s) => LActGen x (ActSelf' s)++instance (Coercible x s, Monoid s) => LActCyclic x (ActSelf' s) where+  lorigin' = coerce (mempty :: s)+  {-# INLINE lorigin' #-}+  lshift = coerce+  {-# INLINE lshift #-}++instance (Eq x, Coercible x s, Monoid s) => RActGen x (ActSelf' s)++instance (Coercible x s, Monoid s) => RActCyclic x (ActSelf' s) where+  rorigin' = coerce (mempty :: s)+  {-# INLINE rorigin' #-}+  rshift = coerce+  {-# INLINE rshift #-}++-- Sum --++instance (Eq x, Num x) => LActGen x (Sum x)++instance Num x => LActCyclic x (Sum x) where+  lorigin' = 0+  {-# INLINE lorigin' #-}+  lshift = Sum+  {-# INLINE lshift #-}++instance (Eq x, Num x) => RActGen x (Sum x)++instance Num x => RActCyclic x (Sum x) where+  rorigin' = 0+  {-# INLINE rorigin' #-}+  rshift = Sum+  {-# INLINE rshift #-}++-- Product --++instance (Eq x, Num x) => LActGen x (Product x)++instance Num x => LActCyclic x (Product x) where+  lorigin' = 1+  {-# INLINE lorigin' #-}+  lshift = Product+  {-# INLINE lshift #-}++instance (Eq x, Num x) => RActGen x (Product x)++instance Num x => RActCyclic x (Product x) where+  rorigin' = 1+  {-# INLINE rorigin' #-}+  rshift = Product+  {-# INLINE rshift #-}++-- Product on Sum --++instance (Eq x, Num x) => LActGen (Sum x) (Product x)++instance Num x => LActCyclic (Sum x) (Product x) where+  lorigin' = 1+  {-# INLINE lorigin' #-}+  lshift = coerce+  {-# INLINE lshift #-}++instance (Eq x, Num x) => RActGen (Sum x) (Product x)++instance Num x => RActCyclic (Sum x) (Product x) where+  rorigin' = 1+  {-# INLINE rorigin' #-}+  rshift = coerce+  {-# INLINE rshift #-}++-- First --++instance Default x => LActCyclic x (Sg.First x) where+  lorigin' = def+  lshift = Sg.First++instance Default x => LActCyclic x (Mn.First x) where+  lorigin' = def+  lshift = Mn.First . Just++instance Default x => RActCyclic x (Sg.Last x) where+  rorigin' = def+  rshift = Sg.Last++instance Default x => RActCyclic x (Mn.Last x) where+  rorigin' = def+  rshift = Mn.Last . Just+
+ src/Data/Act/Torsor.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE ScopedTypeVariables    #-}++--------------------------------------------------------------------------------+-- |+--+-- Module      :  Data.Act+-- Description :  Group torsors for left and right actions.+-- Copyright   :  (c) Alice Rixte 2025+-- License     :  BSD 3+-- Maintainer  :  alice.rixte@u-bordeaux.fr+-- Stability   :  unstable+-- Portability :  non-portable (GHC extensions)+--+-- == Presentation+--+--+--------------------------------------------------------------------------------++module Data.Act.Torsor+  ( LTorsor (..)+  , RTorsor (..)+  )+where++import Data.Coerce+import Data.Functor.Identity+import Data.Monoid++import Data.Group++import Data.Act.Act++-- | A left group torsor.+--+-- The most well known example of a torsor is the particular case of an affine+-- space where the group is the additive group of the vector space and the set+-- is a set of points. Torsors are more general than affine spaces since they+-- don't enforce linearity. Notice that 'LActDistrib' may correspond to a+-- linearity condition if you need one.+--+-- See this nLab article for more information :+-- https://ncatlab.org/nlab/show/torsor+--+-- [In algebraic terms : ]+--+-- A left group action is a torsor if and only if for every pair @(x,y) :: (x,+-- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@.+--+-- [In Haskell terms : ]+--+-- Instances must satisfy the following law :+--+-- * @ y .-. x <>$ x == @ @y@+-- * if @g <>$ x == y@ then @g == y .-. x@+--+class LActGp x g => LTorsor x g where+  {-# MINIMAL ldiff | (.-.) #-}+  -- | @ldiff y x@ is the only group element such that @'ldiff' y x <>$ x = y@.+  ldiff :: x -> x -> g+  ldiff y x = y .-. x+  infix 6 `ldiff`+  {-# INLINE ldiff #-}++  -- | Infix synonym for 'ldiff'.+  --+  -- This represents a point minus a point.+  --+  (.-.) :: LTorsor x g => x -> x -> g+  (.-.) = ldiff+  infix 6 .-.+  {-# INLINE (.-.) #-}+++instance LTorsor x () where+  ldiff _ _ = ()+  {-# INLINE ldiff #-}++instance LTorsor x g => LTorsor x (Identity g) where+  ldiff y x = Identity (ldiff y x)+  {-# INLINE ldiff #-}++instance (LTorsor x g, LTorsor y h) => LTorsor (x, y) (g,h) where+  ldiff (y1, y2) (x1, x2) = (ldiff y1 x1, ldiff y2 x2)+  {-# INLINE ldiff #-}++instance {-# OVERLAPPING #-} LTorsor x g+  => LTorsor (Identity x) (Identity g) where+  ldiff (Identity y) (Identity x) = Identity (ldiff y x)+  {-# INLINE ldiff #-}+++instance Group g => LTorsor g (ActSelf g) where+  ldiff y x = ActSelf (y ~~ x)+  {-# INLINE ldiff #-}++instance (Group g, Coercible x g) => LTorsor x (ActSelf' g) where+  ldiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g))+  {-# INLINE ldiff #-}+++instance RTorsor x g => LTorsor x (Dual g) where+  ldiff y x = Dual (rdiff y x)+  {-# INLINE ldiff #-}++instance Num x => LTorsor x (Sum x) where+  ldiff y x = Sum (y - x)+  {-# INLINE ldiff #-}++instance Fractional x => LTorsor x (Product x) where+  ldiff y x = Product (y / x)+  {-# INLINE ldiff #-}++++-- | A right group torsor.+--+-- [In algebraic terms : ]+--+-- A left group action is a torsor if and only if for every pair @(x,y) :: (x,+-- x)@, there exists a unique group element @g :: g@ such that @g <>$ x = y@.+--+-- [In Haskell terms : ]+--+-- Instances must satisfy the following law :+--+-- * @ x $<> y .~. x == @ @y@+-- * if @x $<> g == y@ then @g == y .~. x@+--+class RActGp x g => RTorsor x g where+  {-# MINIMAL rdiff | (.~.) #-}+  -- | @rdiff y x@ is the only group element such that @'rdiff' y x $<> x = y@.+  rdiff :: x -> x -> g+  rdiff y x = y .~. x+  infix 6 `rdiff`+  {-# INLINE rdiff #-}++  -- | Infix synonym for 'rdiff'.+  --+  -- This represents a point minus a point.+  --+  (.~.) :: RTorsor x g => x -> x -> g+  (.~.) = rdiff+  infix 6 .~.+  {-# INLINE (.~.) #-}++instance RTorsor x () where+  rdiff _ _ = ()+  {-# INLINE rdiff #-}++instance RTorsor x g => RTorsor x (Identity g) where+  rdiff y x = Identity (rdiff y x)+  {-# INLINE rdiff #-}++instance {-# OVERLAPPING #-} RTorsor x g+  => RTorsor (Identity x) (Identity g) where+  rdiff (Identity y) (Identity x) = Identity (rdiff y x)+  {-# INLINE rdiff #-}++instance (RTorsor x g, RTorsor y h) => RTorsor (x, y) (g,h) where+  rdiff (y1, y2) (x1, x2) = (rdiff y1 x1, rdiff y2 x2)+  {-# INLINE rdiff #-}++instance Group g => RTorsor g (ActSelf g) where+  rdiff y x = ActSelf (y ~~ x)+  {-# INLINE rdiff #-}++instance (Group g, Coercible x g) => RTorsor x (ActSelf' g) where+  rdiff y x = ActSelf' ((coerce y :: g) ~~ (coerce x :: g))+  {-# INLINE rdiff #-}++instance LTorsor x g => RTorsor x (Dual g) where+  rdiff y x = Dual (ldiff y x)+  {-# INLINE rdiff #-}++instance Num x => RTorsor x (Sum x) where+  rdiff y x = Sum (y - x)+  {-# INLINE rdiff #-}++instance Fractional x => RTorsor x (Product x) where+  rdiff y x = Product (y / x)+  {-# INLINE rdiff #-}+
+ src/Data/Semidirect.hs view
@@ -0,0 +1,16 @@+-----------------------------------------------------------------------------+-- |+--   Module      :  Data.Semigroup.Semidirect+--   Copyright   :  (c) Alice Rixte (2024)+--   License     :  BSD 3 (see LICENSE)+--   Maintainer  :  alice.rixte@u-bordeaux.fr+--+-- This is a re-export of "Data.Semigroup.Semidirect.Lazy". If you need a strict+-- version, please import "Data.Semigroup.Semidirect.Strict".+--+-----------------------------------------------------------------------------+module Data.Semidirect+    ( module Data.Semidirect.Lazy+    ) where++import Data.Semidirect.Lazy
+ src/Data/Semidirect/Lazy.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleInstances            #-}+{-# LANGUAGE MultiParamTypeClasses        #-}+{-# LANGUAGE InstanceSigs                 #-}+{-# LANGUAGE ScopedTypeVariables          #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Semidirect.Lazy+-- Description : Lazy semidirect products+-- Copyright   : (c) Alice Rixte 2025+-- License     : BSD 3+-- Maintainer  : alice.rixte@u-bordeaux.fr+-- Stability   : unstable+-- Portability : non-portable (GHC extensions)+--+-- Semidirect products for left and right actions.+--+-- For a strict version, see @'Data.Semidirect.Strict'@.+--+-- [Usage :]+--+-- >>> import Data.Semigroup+-- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))+-- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}+--+-- [Property checking :]+--+-- There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@)+-- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For+-- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism+-- and therefore the semidirect product is not associative :+--+-- >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))+-- No instance for `LActDistrib (Sum Int) (Sum Int)'+--   arising from a use of `<>'+--+-----------------------------------------------------------------------------++module Data.Semidirect.Lazy+       ( LSemidirect (..)+       , lerase+       , lforget+       , lembedActee+       , lembedActor+       , lfromPair+        , RSemidirect (..)+        , rerase+        , rforget+        , rembedActee+        , rembedActor+        , rfromPair+       ) where++import Data.Bifunctor+import Data.Act++-- | A semi-direct product for a left action, where @s@ acts on @x@+--+data LSemidirect x s = LSemidirect+  { lactee :: x -- ^ The value being acted on+  , lactor :: s -- ^ The acting element+  }+  deriving (Show, Read, Eq)++instance LActSgMorph x s+  => Semigroup (LSemidirect x s) where+  ~(LSemidirect x s) <> ~(LSemidirect x' s') =+    LSemidirect  (x <> (s <>$ x')) (s <> s')++instance LActMnMorph x s => Monoid (LSemidirect x s) where+  mempty = LSemidirect mempty mempty++instance Functor (LSemidirect x) where+  fmap f a = a {lactor = f (lactor a)}++instance Bifunctor LSemidirect where+  first f a = a {lactee = f (lactee a)}+  second = fmap++-- |  Erases the actee (i.e. replace it with @mempty@).+lerase :: Monoid x => LSemidirect x s -> LSemidirect x s+lerase a = a {lactee = mempty}++-- |  Forget the actor (i.e. replace it with @mempty@).+lforget :: Monoid s => LSemidirect x s -> LSemidirect x s+lforget a =a {lactor = mempty}++-- |  Make a semidirect pair whose actee is @mempty@.+lembedActor :: Monoid x => s -> LSemidirect x s+lembedActor s = LSemidirect mempty s++-- |  Make a semidirect pair whose actor is @mempty@.+lembedActee :: Monoid s => x -> LSemidirect x s+lembedActee x = LSemidirect x mempty++-- | Converts a pair into a semidirect product element.+lfromPair :: (x,s) -> LSemidirect x s+lfromPair (x,s) = LSemidirect x s+++------------------------------------------------------------------------------++-- |  A semidirect product for a right action, where @s@ acts on @x@+--+data RSemidirect x s = RSemidirect+  { ractee :: x -- ^ The value being acted on+  , ractor :: s -- ^ The acting element+  }+  deriving (Show, Read, Eq)++instance RActSgMorph x s+  => Semigroup (RSemidirect x s) where+  ~(RSemidirect x s) <> ~(RSemidirect x' s') =+    RSemidirect  (x <> (x' $<> s)) (s <> s')++instance RActMnMorph x s => Monoid (RSemidirect x s) where+  mempty = RSemidirect mempty mempty++instance Functor (RSemidirect x) where+  fmap f a = a {ractor = f (ractor a)}++instance Bifunctor RSemidirect where+  first f a = a {ractee = f (ractee a)}+  second = fmap++-- |  Erase the actee (i.e. replace it with @mempty@).+rerase :: Monoid x => RSemidirect x s -> RSemidirect x s+rerase a = a {ractee = mempty}++-- |  Forget the actor (i.e. replace it with @mempty@).+rforget :: Monoid s => RSemidirect x s -> RSemidirect x s+rforget a = a {ractor = mempty}++-- |  Make a semidirect pair whose actee is @mempty@.+rembedActor :: Monoid x => s -> RSemidirect x s+rembedActor s = RSemidirect mempty s++-- |  Make a semidirect pair whose actor element is @mempty@ .+rembedActee :: Monoid s => x -> RSemidirect x s+rembedActee x = RSemidirect x mempty++-- | Convert a pair into a semidirect product element+rfromPair :: (x,s) -> RSemidirect x s+rfromPair (x,s) = RSemidirect x s
+ src/Data/Semidirect/Strict.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleInstances            #-}+{-# LANGUAGE MultiParamTypeClasses        #-}+{-# LANGUAGE InstanceSigs                 #-}+{-# LANGUAGE ScopedTypeVariables          #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Semidirect.Strict+-- Description : Strict semidirect products+-- Copyright   : (c) Alice Rixte 2025+-- License     : BSD 3+-- Maintainer  : alice.rixte@u-bordeaux.fr+-- Stability   : unstable+-- Portability : non-portable (GHC extensions)+--+-- Semidirect products for left and right actions.+--+-- For a lazy version, see @'Data.Semidirect.Lazy'@.+--+-- [Usage :]+--+-- >>> import Data.Semigroup+-- >>> LSemidirect (Sum 1) (Product 2) <> LSemidirect (Sum (3 :: Int)) (Product (4 :: Int))+-- LSemidirect {lactee = Sum {getSum = 7}, lactor = Product {getProduct = 8}}+--+-- [Property checking :]+--+-- There is a @'Semigroup'@ instance for @'LSemidirect'@ (resp. @'RSemidirect'@)+-- only if there is a @'LActSgMorph'@ (resp. @'RActSgMorph'@) instance. For+-- example, @'Sum' Int@ acting on itself is not a semigroup action by morphism+-- and therefore the semidirect product is not associative :+--+-- >>> LSemidirect (Sum 1) (Sum 2) <> LSemidirect (Sum (3 :: Int)) (Sum (4 :: Int))+-- No instance for `LActDistrib (Sum Int) (Sum Int)'+--   arising from a use of `<>'+--+-----------------------------------------------------------------------------++module Data.Semidirect.Strict+       ( LSemidirect (..)+       , lerase+       , lforget+       , lembedActee+       , lembedActor+       , lfromPair+        , RSemidirect (..)+        , rerase+        , rforget+        , rembedActee+        , rembedActor+        , rfromPair+       ) where++import Data.Bifunctor+import Data.Act++-- | A semi-direct product for a left action, where @s@ acts on @x@+--+data LSemidirect x s = LSemidirect+  { lactee :: !x -- ^ The value being acted on+  , lactor :: !s -- ^ The acting element+  }+  deriving (Show, Read, Eq)++instance LActSgMorph x s+  => Semigroup (LSemidirect x s) where+  LSemidirect x s <> LSemidirect x' s' =+    LSemidirect  (x <> (s <>$ x')) (s <> s')++instance LActMnMorph x s => Monoid (LSemidirect x s) where+  mempty = LSemidirect mempty mempty++instance Functor (LSemidirect x) where+  fmap f a = a {lactor = f (lactor a)}++instance Bifunctor LSemidirect where+  first f a = a {lactee = f (lactee a)}+  second = fmap++-- |  Erase the actee (i.e. replace it with @mempty@).+lerase :: Monoid x => LSemidirect x s -> LSemidirect x s+lerase a = a {lactee = mempty}++-- |  Forget the actor (i.e. replace it with @mempty@).+lforget :: Monoid s => LSemidirect x s -> LSemidirect x s+lforget a =a {lactor = mempty}++-- |  Make a semidirect pair whose actee is @mempty@.+lembedActor :: Monoid x => s -> LSemidirect x s+lembedActor s = LSemidirect mempty s++-- |  Make a semidirect pair whose actor is @mempty@.+lembedActee :: Monoid s => x -> LSemidirect x s+lembedActee x = LSemidirect x mempty++-- | Convert a pair into a semidirect product element.+lfromPair :: (x,s) -> LSemidirect x s+lfromPair (x,s) = LSemidirect x s+++------------------------------------------------------------------------------++-- |  A semidirect product for a right action, where @s@ acts on @x@+--+data RSemidirect x s = RSemidirect+  { ractee :: !x -- ^ The value being acted on+  , ractor :: !s -- ^ The acting element+  }+  deriving (Show, Read, Eq)++instance RActSgMorph x s+  => Semigroup (RSemidirect x s) where+  RSemidirect x s <> RSemidirect x' s' =+    RSemidirect  (x <> (x' $<> s)) (s <> s')++instance RActMnMorph x s => Monoid (RSemidirect x s) where+  mempty = RSemidirect mempty mempty++instance Functor (RSemidirect x) where+  fmap f a = a {ractor = f (ractor a)}++instance Bifunctor RSemidirect where+  first f a = a {ractee = f (ractee a)}+  second = fmap++-- |  Erase the actee (i.e. replace it with @mempty@).+rerase :: Monoid x => RSemidirect x s -> RSemidirect x s+rerase a = a {ractee = mempty}++-- |  Forget the actor (i.e. replace it with @mempty@).+rforget :: Monoid s => RSemidirect x s -> RSemidirect x s+rforget a = a {ractor = mempty}++-- |  Make a semidirect pair whose actee is @mempty@.+rembedActor :: Monoid x => s -> RSemidirect x s+rembedActor s = RSemidirect mempty s++-- |  Make a semidirect pair whose actor element is @mempty@ .+rembedActee :: Monoid s => x -> RSemidirect x s+rembedActee x = RSemidirect x mempty++-- | Convert a pair into a semidirect product element+rfromPair :: (x,s) -> RSemidirect x s+rfromPair (x,s) = RSemidirect x s
+ test/Spec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeOperators  #-}+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE OverloadedLabels #-}++import Test.Hspec+import Test.QuickCheck++import Data.Monoid+import Data.Act++import qualified Data.Semidirect.Lazy as Lazy+import qualified Data.Semidirect.Strict as Strict++main :: IO ()+main = hspec $ do+  describe "Semidirect" $ do+    describe "LSemidirect" $ do+      describe "Lazy" $ do+        it "Product on Sum Semigroup" $ property $+          \x s y t ->+            Lazy.LSemidirect (Sum (x :: Int)) (Product (s :: Int))+            <> Lazy.LSemidirect (Sum y) (Product t)+            `shouldBe`+            Lazy.LSemidirect (Sum (x + s*y)) (Product (s*t))+        it "Product on Sum Monoid" $+          mempty `shouldBe`+            Lazy.LSemidirect (mempty :: Sum Int) (mempty :: Product Int)+      describe "Strict" $ do+        it "Product on Sum Semigroup" $ property $+          \x s y t ->+            Strict.LSemidirect (Sum (x :: Int)) (Product (s :: Int))+            <> Strict.LSemidirect (Sum y) (Product t)+            `shouldBe`+            Strict.LSemidirect (Sum (x + s*y)) (Product (s*t))+        it "Product on Sum Monoid" $+          mempty `shouldBe`+            Strict.LSemidirect (mempty :: Sum Int) (mempty :: Product Int)+    describe "RSemidirect" $ do+      describe "Lazy" $ do+        it "Product on Sum Semigroup" $ property $+          \x s y t ->+            Lazy.RSemidirect (Sum (x :: Int)) (Product (s :: Int))+            <> Lazy.RSemidirect (Sum y) (Product t)+            `shouldBe`+            Lazy.RSemidirect (Sum (x + s*y)) (Product (s*t))+        it "Product on Sum Monoid" $+          mempty `shouldBe`+            Lazy.RSemidirect (mempty :: Sum Int) (mempty :: Product Int)+      describe "Strict" $ do+        it "Product on Sum Semigroup" $ property $+          \x s y t ->+            Strict.RSemidirect (Sum (x :: Int)) (Product (s :: Int))+            <> Strict.RSemidirect (Sum y) (Product t)+            `shouldBe`+            Strict.RSemidirect (Sum (x + s*y)) (Product (s*t))+        it "Product on Sum Monoid" $+          mempty `shouldBe`+            Strict.RSemidirect (mempty :: Sum Int) (mempty :: Product Int)++  describe "Action" $ do+    describe "ActSelf" $ do+      it "Int acts on unit" $ property $+        \x -> (x :: Int) <>$ () `shouldBe` ()+      it "Unit acts on char" $ property $+        \x -> () <>$ (x :: Char) `shouldBe` x