diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -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) + ] diff --git a/lr-acts.cabal b/lr-acts.cabal new file mode 100644 --- /dev/null +++ b/lr-acts.cabal @@ -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 +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 diff --git a/src/Data/Act.hs b/src/Data/Act.hs new file mode 100644 --- /dev/null +++ b/src/Data/Act.hs @@ -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 diff --git a/src/Data/Act/Act.hs b/src/Data/Act/Act.hs new file mode 100644 --- /dev/null +++ b/src/Data/Act/Act.hs @@ -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) diff --git a/src/Data/Act/Cyclic.hs b/src/Data/Act/Cyclic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Act/Cyclic.hs @@ -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 + diff --git a/src/Data/Act/Torsor.hs b/src/Data/Act/Torsor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Act/Torsor.hs @@ -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 #-} + diff --git a/src/Data/Semidirect.hs b/src/Data/Semidirect.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semidirect.hs @@ -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 diff --git a/src/Data/Semidirect/Lazy.hs b/src/Data/Semidirect/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semidirect/Lazy.hs @@ -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 diff --git a/src/Data/Semidirect/Strict.hs b/src/Data/Semidirect/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semidirect/Strict.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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