diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for group-theory + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Emily Pillmore + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Emily Pillmore nor the names of other + 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 +OWNER 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,15 @@ +group-theory +========== + +[![Hackage](https://img.shields.io/hackage/v/group-theory.svg)](https://hackage.haskell.org/package/group-theory) ![Build Status](https://github.com/emilypi/group-theory/workflows/ci/badge.svg) + +This is a package for exploring constructive group theory in Haskell. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Co-maintained by Emily Pillmore (@topos) and Reed Mullanix (@totbwf). Please feel free to contact either myself, or Reed through github or on the #haskell IRC channel on irc.freenode.net. + +\- Emily diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/group-theory.cabal b/group-theory.cabal new file mode 100644 --- /dev/null +++ b/group-theory.cabal @@ -0,0 +1,67 @@ +cabal-version: 2.0 +name: group-theory +version: 0.1.0.0 +synopsis: The theory of groups +description: + This package includes definitions for Groups (monoids with invertibility), including + finite, fre, simple, cyclic, and permutation groups. Additionally, we add the concept + of 'Cancelative' functors, building upon 'Alternative' applicative functors. + +homepage: https://github.com/emilypi/group-theory +bug-reports: https://github.com/emilypi/group-theory/issues +license: BSD3 +license-file: LICENSE +author: Emily Pillmore +maintainer: emilypi@cohomolo.gy +copyright: (c) 2020 Emily Pillmore +category: Algebra, Math, Permutations, Groups +build-type: Custom +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 + +source-repository head + type: git + location: https://github.com/emilypi/group-theory.git + +custom-setup + setup-depends: + base >=4.11 && <5 + , Cabal + , cabal-doctest + +library + exposed-modules: + Control.Applicative.Cancelative + Data.Group + Data.Group.Additive + Data.Group.Cyclic + Data.Group.Finite + Data.Group.Foldable + Data.Group.Free + Data.Group.Free.Church + Data.Group.Multiplicative + Data.Group.Permutation + + build-depends: + base >=4.11 && <5 + , containers >=0.5 && <0.7 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: + base >=4.11 && <5 + , doctest + , group-theory + + hs-source-dirs: test + ghc-options: -Wall -threaded + x-doctest-options: --fast diff --git a/src/Control/Applicative/Cancelative.hs b/src/Control/Applicative/Cancelative.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Cancelative.hs @@ -0,0 +1,107 @@ +{-# language DefaultSignatures #-} +{-# language Safe #-} +-- | +-- Module : Control.Applicative.Cancelative +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'Cancelative' functors +-- along with the relevant combinators. +-- +module Control.Applicative.Cancelative +( -- * Cancelative + Cancelative(..) + -- ** Cancelative combinators +, cancel1 +, annihalate +) where + + +import Control.Applicative +import Data.Group +import Data.Group.Free +import Data.Group.Free.Church +import Data.Proxy + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> import Data.Word +-- >>> import Data.Group.Free +-- >>> import Data.Group.Foldable +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts + +-- -------------------------------------------------------------------- -- +-- Cancelative functors + +-- | A group on 'Applicative' functors. +-- +-- 'Cancelative' functors have the following laws: +-- +-- [Left Cancelation] @ 'cancel' a '<|>' a = 'empty' @ +-- [Rigth Cancelation] @ a '<|>' 'cancel' a = 'empty' @ +-- +-- This is analogous to a group operation on applicative functors, +-- in the sense that 'Alternative' forms a monoid. A straight- +-- forward implementation exists whenever @f a@ forms a 'Group' +-- for all @a@, in which case, @cancel == invert@. +-- +class Alternative f => Cancelative f where + -- | Invert (or 'cancel') a 'Cancelative' functor, such that, if the + -- functor is also a 'Data.Group.Foldable.GroupFoldable', then @'Data.Group.Foldable.gold' '.' 'cancel'@ + -- amounts to evaluating the inverse of a word in the functor. + -- + -- === __Examples:__ + -- + -- >>> let x = FreeGroup [Left (Sum (2 :: Word8)), Right (Sum 3)] + -- >>> cancel x + -- FreeGroup {runFreeGroup = [Right (Sum {getSum = 2}),Left (Sum {getSum = 3})]} + -- + cancel :: f a -> f a + default cancel :: Group (f a) => f a -> f a + cancel = invert + {-# minimal cancel #-} + +instance Cancelative FG where + cancel = invert + +instance Cancelative FA where + cancel = invert + +instance Cancelative FreeGroup where + cancel = invert + +instance Cancelative Proxy where + cancel _ = Proxy + +-- -------------------------------------------------------------------- -- +-- Cancelative functor combinators + +-- | Cancel a single element in a 'Cancelative' functor. +-- +-- === __Examples:__ +-- +-- >>> let x = FreeGroup [Left (Sum (2 :: Word8)), Right (Sum 3)] +-- >>> gold x +-- Sum {getSum = 1} +-- >>> gold $ cancel1 (Sum 1) x +-- Sum {getSum = 0} +-- +cancel1 :: (Group a, Cancelative f) => a -> f a -> f a +cancel1 a f = cancel (pure a) <|> f + +-- | Annihalate a 'Traversable''s worth of elements in a 'Cancelative' +-- functor. +-- +annihalate :: (Cancelative f, Traversable t) => (a -> f a) -> t a -> f (t a) +annihalate f = traverse (cancel . f) diff --git a/src/Data/Group.hs b/src/Data/Group.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group.hs @@ -0,0 +1,630 @@ +{-# language BangPatterns #-} +{-# language CPP #-} +{-# language DerivingStrategies #-} +{-# language FlexibleInstances #-} +{-# language PatternSynonyms #-} +{-# language Safe #-} +#if MIN_VERSION_base(4,12,0) +{-# language TypeOperators #-} +#endif +{-# language ViewPatterns #-} +-- | +-- Module : Data.Group +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'Group' and 'AbelianGroup', +-- along with the relevant combinators. +-- +module Data.Group +( -- * Groups + Group(..) + -- * Group combinators +, (><) + -- ** Conjugation +, conjugate +, unconjugate +, pattern Conjugate + -- ** Order +, Order(..) +, pattern Infinitary +, pattern Finitary +, order + -- ** Abelianization +, Abelianizer(..) +, abelianize +, commutate +, pattern Abelianized +, pattern Quotiented + -- * Abelian groups +, AbelianGroup +) where + + +import Data.Bool +import Data.Functor.Const +#if __GLASGOW_HASKELL__ > 804 +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity +import Data.Semigroup (stimes) +import Data.Int +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.Word + +import Numeric.Natural + +#if MIN_VERSION_base(4,12,0) +import GHC.Generics +#endif + +import Prelude hiding (negate, exponent) +import qualified Prelude + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts + +infixr 6 >< + +-- -------------------------------------------------------------------- -- +-- Groups + +-- | The typeclass of groups (types with an associative binary operation that +-- has an identity, and all inverses, i.e. a 'Monoid' with all inverses), +-- representing the structural symmetries of a mathematical object. +-- +-- Instances should satisfy the following: +-- +-- [Right identity] @ x '<>' 'mempty' = x@ +-- [Left identity] @'mempty' '<>' x = x@ +-- [Associativity] @ x '<>' (y '<>' z) = (x '<>' y) '<>' z@ +-- [Concatenation] @ 'mconcat' = 'foldr' ('<>') 'mempty'@ +-- [Right inverses] @ x '<>' 'invert' x = 'mempty' @ +-- [Left inverses] @ 'invert' x '<>' x = 'mempty' @ +-- +-- Some types can be viewed as a group in more than one way, +-- e.g. both addition and multiplication on numbers. +-- In such cases we often define @newtype@s and make those instances +-- of 'Group', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'. +-- Often in practice such differences between addition and +-- multiplication-like operations matter (e.g. when defining rings), and +-- so, classes "additive" (the underlying operation is addition-like) and +-- "multiplicative" group classes are provided in vis 'Data.Group.Additive.AdditiveGroup' and +-- 'Data.Group.Multiplicative.MultiplicativeGroup'. +-- +-- Categorically, 'Group's may be viewed single-object groupoids. +-- +class Monoid a => Group a where + invert :: a -> a + invert a = mempty `minus` a + {-# inline invert #-} + + -- | Similar to 'stimes' from 'Data.Semigroup', but handles + -- negative powers by using 'invert' appropriately. + -- + -- === __Examples:__ + -- + -- >>> gtimes 2 (Sum 3) + -- Sum {getSum = 6} + -- >>> gtimes (-3) (Sum 3) + -- Sum {getSum = -9} + -- + gtimes :: (Integral n) => n -> a -> a + gtimes n a + | n == 0 = mempty + | n > 0 = stimes n a + | otherwise = stimes (abs n) (invert a) + {-# inline gtimes #-} + + -- | 'Group' subtraction. + -- + -- This function denotes principled 'Group' subtraction, where + -- @a `minus` b@ translates into @a <> (invert b)@. This is because + -- subtraction as an operator is non-associative, but the operation + -- described in terms of addition and inversion is. + -- + minus :: a -> a -> a + minus a b = a <> invert b + {-# inline minus #-} + {-# minimal invert | minus #-} + + +instance Group () where + invert = id + {-# inline invert #-} + +instance Group b => Group (a -> b) where + invert f = invert . f + {-# inline invert #-} + +instance Group a => Group (Dual a) where + invert (Dual a) = Dual (invert a) + {-# inline invert #-} + +instance Group a => Group (Down a) where + invert (Down a) = Down (invert a) + {-# inline invert #-} + +instance Group a => Group (Endo a) where + invert (Endo a) = Endo (invert . a) + {-# inline invert #-} + +#if __GLASGOW_HASKELL__ > 804 +instance Group (Equivalence a) where + invert (Equivalence p) = Equivalence $ \a b -> not (p a b) + {-# inline invert #-} + +instance Group (Comparison a) where + invert (Comparison p) = Comparison $ \a b -> invert (p a b) + {-# inline invert #-} + +instance Group (Predicate a) where + invert (Predicate p) = Predicate $ \a -> not (p a) + {-# inline invert #-} + +instance Group a => Group (Op a b) where + invert (Op f) = Op $ invert . f + {-# inline invert #-} +#endif + +instance Group Any where + invert (Any b) = Any $ bool True False b + {-# inline invert #-} + +instance Group All where + invert (All b) = All $ bool True False b + {-# inline invert #-} + +instance Group (Sum Integer) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Rational) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Int) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Int8) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Int16) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Int32) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Int64) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Word) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Word8) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Word16) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Word32) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum Word64) where + invert = Prelude.negate + {-# inline invert #-} + +instance Group (Sum (Ratio Int)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Int8)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Int16)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Int32)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Int64)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Word)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Word8)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Word16)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Word32)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Sum (Ratio Word64)) where + invert = Sum . Prelude.negate . getSum + {-# inline invert #-} + +instance Group (Product Rational) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Natural)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Int)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Int8)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Int16)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Int32)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Int64)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Word)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Word8)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Word16)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Word32)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group (Product (Ratio Word64)) where + invert = Product . Prelude.recip . getProduct + {-# inline invert #-} + +instance Group a => Group (Const a b) where + invert = Const . invert . getConst + {-# inline invert #-} + +instance Group a => Group (Identity a) where + invert = Identity . invert . runIdentity + {-# inline invert #-} + +instance Group Ordering where + invert LT = GT + invert EQ = EQ + invert GT = LT + {-# inline invert #-} + +instance (Group a, Group b) => Group (a,b) where + invert ~(a,b) = (invert a, invert b) + {-# inline invert #-} + +instance Group a => Group (Proxy a) where + invert _ = Proxy + +instance (Group a, Group b, Group c) => Group (a,b,c) where + invert ~(a,b,c) = (invert a, invert b, invert c) + {-# inline invert #-} + +instance (Group a, Group b, Group c, Group d) => Group (a,b,c,d) where + invert ~(a,b,c,d) = (invert a, invert b, invert c, invert d) + {-# inline invert #-} + +instance (Group a, Group b, Group c, Group d, Group e) => Group (a,b,c,d,e) where + invert ~(a,b,c,d,e) = (invert a, invert b, invert c, invert d, invert e) + {-# inline invert #-} + +#if MIN_VERSION_base(4,12,0) +instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where + invert (f :*: g) = invert f :*: invert g + +instance Group (f (g a)) => Group ((f :.: g) a) where + invert (Comp1 fg) = invert (Comp1 fg) +#endif + +-- -------------------------------------------------------------------- -- +-- Group combinators + +-- | Apply @('<>')@, commuting its arguments. When the group is abelian, +-- @a <> b@ is identically @b <> a@. +-- +(><) :: Group a => a -> a -> a +a >< b = b <> a +{-# inline (><) #-} + +-- | Conjugate an element of a group by another element. +-- When the group is abelian, conjugation is the identity. +-- +-- Symbolically, this is \( (g,a) \mapsto gag^{-1} \). +-- +-- === __Examples__: +-- +-- >>> let x = Sum (3 :: Int) +-- >>> conjugate x x +-- Sum {getSum = 3} +-- +-- >>> let x = All True +-- >>> conjugate (All False) x +-- All {getAll = False} +-- +conjugate :: Group a => a -> a -> a +conjugate g a = (g <> a) `minus` g +{-# inline conjugate #-} + +-- | Apply an inverse conjugate to a conjugated element. +-- +-- @ +-- unconjugate . conjugate = id +-- conjugate . unconjugate = id +-- @ +-- +-- === __Examples__: +-- +-- >>> let x = Sum (3 :: Int) +-- >>> unconjugate x (conjugate x x) +-- Sum {getSum = 3} +-- +unconjugate :: Group a => a -> a -> a +unconjugate g a = invert g <> a <> g + +-- | Bidirectional pattern for conjugation by a group element +-- +-- __Note:__ When the underlying 'Group' is abelian, this +-- pattern is the identity. +-- +pattern Conjugate :: Group a => (a,a) -> (a,a) +pattern Conjugate t <- (\(g,a) -> (g, conjugate g a) -> t) where + Conjugate (g,a) = (g, unconjugate g a) +{-# complete Conjugate #-} + +-- -------------------------------------------------------------------- -- +-- Group order + +-- | The order of a group element. +-- +-- The order of a group element can either be infinite, +-- as in the case of @All False@, or finite, as in the +-- case of @All True@. +-- +data Order = Infinite | Finite !Natural + deriving (Eq, Show) + +-- | Unidirectional pattern synonym for the infinite order of a +-- group element. +-- +pattern Infinitary :: (Eq g, Group g) => g +pattern Infinitary <- (order -> Infinite) + +-- | Unidirectional pattern synonym for the finite order of a +-- group element. +-- +pattern Finitary :: (Eq g, Group g) => Natural -> g +pattern Finitary n <- (order -> Finite n) + +-- | Calculate the exponent of a particular element in a group. +-- +-- __Warning:__ If 'order' expects a 'Data.Group.FiniteGroup', this is gauranteed +-- to terminate. However, this is not true of groups in general. This will +-- spin forever if you give it something like non-zero @Sum Integer@. +-- +-- === __Examples__: +-- +-- >>> order @(Sum Word8) 3 +-- Finite 255 +-- +-- >>> order (Any False) +-- Finite 1 +-- +-- >>> order (All False) +-- Infinite +-- +order :: (Eq g, Group g) => g -> Order +order a = go 0 a where + go !n g + -- guard against (). + | g == mempty, n > 0 = Finite n + -- guard against infinite cases like @All False@. + | g == a, n > 0 = Infinite + | otherwise = go (succ n) (g <> a) +{-# inline order #-} + +-- -------------------------------------------------------------------- -- +-- Abelianization + +-- | Quotient a pair of group elements by their commutator. +-- +-- The of the quotient \( G / [G,G] \) forms an abelian group, and 'Abelianizer' +-- forms a functor from the category of groups to the category of Abelian groups. +-- This functor is left adjoint to the inclusion functor \( Ab \rightarrow Grp \), +-- forming a monad in \( Grp \). +-- +data Abelianizer a = Quot | Commuted a + deriving stock (Eq, Show) + +instance Functor Abelianizer where + fmap _ Quot = Quot + fmap f (Commuted a) = Commuted (f a) + +instance Applicative Abelianizer where + pure = Commuted + + Quot <*> _ = Quot + _ <*> Quot = Quot + Commuted f <*> Commuted a = Commuted (f a) + +instance Monad Abelianizer where + return = pure + (>>) = (*>) + + Quot >>= _ = Quot + Commuted a >>= f = f a + +instance Foldable Abelianizer where + foldMap _ Quot = mempty + foldMap f (Commuted a) = f a + +instance Traversable Abelianizer where + traverse _ Quot = pure Quot + traverse f (Commuted a) = Commuted <$> f a + +instance Semigroup g => Semigroup (Abelianizer g) where + Quot <> t = t + t <> Quot = t + Commuted a <> Commuted b = Commuted (a <> b) + +instance Monoid g => Monoid (Abelianizer g) where + -- Normally we'd say 'Quot' but these are the same. + mempty = Commuted mempty + +instance (Eq g, Group g) => Group (Abelianizer g) where + invert Quot = Quot + invert (Commuted a) = Commuted (invert a) + +-- | Take the commutator of two elements of a group. +-- +commutate :: Group g => g -> g -> g +commutate g g' = g <> g' <> invert g <> invert g' +{-# inline commutate #-} + +-- | Quotient a pair of group elements by their commutator. +-- +-- Ranging over the entire group, this operation constructs +-- the quotient of the group by its commutator sub-group +-- \( G / [G,G] \). +-- +abelianize :: (Eq g, Group g) => g -> g -> Abelianizer g +abelianize g g' + | x == mempty = Quot + | otherwise = Commuted x + where + x = commutate g g' +{-# inline abelianize #-} + +-- | A unidirectional pattern synonym for elements of a group +-- modulo commutators which are __not__ the identity. +-- +pattern Abelianized :: (Eq g, Group g) => g -> (g,g) +pattern Abelianized x <- (uncurry abelianize -> Commuted x) + +-- | A unidirectional pattern synonym for elements of a group +-- modulo commutators which are the identity. +-- +pattern Quotiented :: (Eq g, Group g) => (g,g) +pattern Quotiented <- (uncurry abelianize -> Quot) + +-- -------------------------------------------------------------------- -- +-- Abelian (commutative) groups + +-- | Commutative 'Group's. +-- +-- Instances of 'AbelianGroup' satisfy the following laws: +-- +-- [Commutativity] @x <> y = y <> x@ +-- +class Group a => AbelianGroup a +instance AbelianGroup () +instance AbelianGroup b => AbelianGroup (a -> b) +instance AbelianGroup a => AbelianGroup (Dual a) +instance AbelianGroup Any +instance AbelianGroup All +instance AbelianGroup (Sum Integer) +instance AbelianGroup (Sum Int) +instance AbelianGroup (Sum Int8) +instance AbelianGroup (Sum Int16) +instance AbelianGroup (Sum Int32) +instance AbelianGroup (Sum Int64) +instance AbelianGroup (Sum Word) +instance AbelianGroup (Sum Word8) +instance AbelianGroup (Sum Word16) +instance AbelianGroup (Sum Word32) +instance AbelianGroup (Sum Word64) +instance AbelianGroup (Sum (Ratio Integer)) +instance AbelianGroup (Sum (Ratio Int)) +instance AbelianGroup (Sum (Ratio Int8)) +instance AbelianGroup (Sum (Ratio Int16)) +instance AbelianGroup (Sum (Ratio Int32)) +instance AbelianGroup (Sum (Ratio Int64)) +instance AbelianGroup (Sum (Ratio Word)) +instance AbelianGroup (Sum (Ratio Word8)) +instance AbelianGroup (Sum (Ratio Word16)) +instance AbelianGroup (Sum (Ratio Word32)) +instance AbelianGroup (Sum (Ratio Word64)) +instance AbelianGroup (Product (Ratio Integer)) +instance AbelianGroup (Product (Ratio Int)) +instance AbelianGroup (Product (Ratio Int8)) +instance AbelianGroup (Product (Ratio Int16)) +instance AbelianGroup (Product (Ratio Int32)) +instance AbelianGroup (Product (Ratio Int64)) +instance AbelianGroup (Product (Ratio Word)) +instance AbelianGroup (Product (Ratio Word8)) +instance AbelianGroup (Product (Ratio Word16)) +instance AbelianGroup (Product (Ratio Word32)) +instance AbelianGroup (Product (Ratio Word64)) +instance AbelianGroup (Product (Ratio Natural)) +instance AbelianGroup a => AbelianGroup (Const a b) +instance AbelianGroup a => AbelianGroup (Identity a) +instance AbelianGroup a => AbelianGroup (Proxy a) +instance AbelianGroup Ordering +instance (AbelianGroup a, AbelianGroup b) => AbelianGroup (a,b) +instance (AbelianGroup a, AbelianGroup b, AbelianGroup c) => AbelianGroup (a,b,c) +instance (AbelianGroup a, AbelianGroup b, AbelianGroup c, AbelianGroup d) => AbelianGroup (a,b,c,d) +instance (AbelianGroup a, AbelianGroup b, AbelianGroup c, AbelianGroup d, AbelianGroup e) => AbelianGroup (a,b,c,d,e) +instance AbelianGroup a => AbelianGroup (Down a) +instance AbelianGroup a => AbelianGroup (Endo a) +#if MIN_VERSION_base(4,12,0) +instance (AbelianGroup (f a), AbelianGroup (g a)) => AbelianGroup ((f :*: g) a) +instance AbelianGroup (f (g a)) => AbelianGroup ((f :.: g) a) +#endif + +#if __GLASGOW_HASKELL__ > 804 +instance AbelianGroup (Equivalence a) +instance AbelianGroup (Comparison a) +instance AbelianGroup (Predicate a) +instance AbelianGroup a => AbelianGroup (Op a b) +#endif + +instance (Eq a, AbelianGroup a) => AbelianGroup (Abelianizer a) diff --git a/src/Data/Group/Additive.hs b/src/Data/Group/Additive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Additive.hs @@ -0,0 +1,205 @@ +{-# language CPP #-} +{-# language FlexibleInstances #-} +{-# language Safe #-} +-- | +-- Module : Data.Group.Additive +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'AdditiveGroup' and 'AdditiveAbelianGroup', +-- along with the relevant combinators. +-- +module Data.Group.Additive +( -- * Additive groups + AdditiveGroup + -- ** Combinators +, (-) +, (+) +, (×) +, copower + -- * Additive abelian groups +, AdditiveAbelianGroup +) where + + +#if __GLASGOW_HASKELL__ > 804 +import Data.Functor.Contravariant +#endif +import Data.Functor.Const +import Data.Functor.Identity +import Data.Group +import Data.Int +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.Semigroup +import Data.Word + +import Prelude hiding ((-), (+)) + +infixl 6 -, + +infixl 7 × + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> :set -XTypeApplications + +-- -------------------------------------------------------------------- -- +-- Additive groups + +-- | An additive group is a 'Group' whose operation can be thought of +-- as addition in some sense. +-- +-- For example, the additive group of integers \( (ℤ, 0, +) \). +-- +class Group g => AdditiveGroup g where + +instance AdditiveGroup () +instance AdditiveGroup b => AdditiveGroup (a -> b) +instance AdditiveGroup a => AdditiveGroup (Dual a) +instance AdditiveGroup a => AdditiveGroup (Down a) +instance AdditiveGroup Any +instance AdditiveGroup (Sum Integer) +instance AdditiveGroup (Sum Int) +instance AdditiveGroup (Sum Int8) +instance AdditiveGroup (Sum Int16) +instance AdditiveGroup (Sum Int32) +instance AdditiveGroup (Sum Int64) +instance AdditiveGroup (Sum Word) +instance AdditiveGroup (Sum Word8) +instance AdditiveGroup (Sum Word16) +instance AdditiveGroup (Sum Word32) +instance AdditiveGroup (Sum Word64) +instance AdditiveGroup (Sum (Ratio Integer)) +instance AdditiveGroup (Sum (Ratio Int)) +instance AdditiveGroup (Sum (Ratio Int8)) +instance AdditiveGroup (Sum (Ratio Int16)) +instance AdditiveGroup (Sum (Ratio Int32)) +instance AdditiveGroup (Sum (Ratio Int64)) +instance AdditiveGroup (Sum (Ratio Word)) +instance AdditiveGroup (Sum (Ratio Word8)) +instance AdditiveGroup (Sum (Ratio Word16)) +instance AdditiveGroup (Sum (Ratio Word32)) +instance AdditiveGroup (Sum (Ratio Word64)) +instance (AdditiveGroup a, AdditiveGroup b) => AdditiveGroup (a,b) +instance (AdditiveGroup a, AdditiveGroup b, AdditiveGroup c) => AdditiveGroup (a,b,c) +instance (AdditiveGroup a, AdditiveGroup b, AdditiveGroup c, AdditiveGroup d) => AdditiveGroup (a,b,c,d) +instance (AdditiveGroup a, AdditiveGroup b, AdditiveGroup c, AdditiveGroup d, AdditiveGroup e) => AdditiveGroup (a,b,c,d,e) +instance AdditiveGroup a => AdditiveGroup (Const a b) +instance AdditiveGroup a => AdditiveGroup (Identity a) +instance AdditiveGroup a => AdditiveGroup (Proxy a) +instance AdditiveGroup a => AdditiveGroup (Endo a) +#if __GLASGOW_HASKELL__ > 804 +instance AdditiveGroup a => AdditiveGroup (Op a b) +#endif + +-- | Infix alias for 'minus'. +-- +-- === __Examples__: +-- +-- >>> let x = Sum (3 :: Int) +-- >>> x - x +-- Sum {getSum = 0} +-- +-- >>> let x = Any True +-- >>> x - x +-- Any {getAny = True} +-- +(-) :: AdditiveGroup a => a -> a -> a +(-) = minus +{-# inline (-) #-} + +-- | Infix alias for 'copower'. +-- +-- === __Examples__: +-- +-- >>> let x = Sum (3 :: Int) +-- >>> 2 × x +-- Sum {getSum = 6} +-- +(×) :: (Integral n, AdditiveGroup a) => n -> a -> a +(×) = copower +{-# inline (×) #-} + +-- | Infix alias for additive @('<>')@. +-- +-- === __Examples__: +-- +-- >>> Sum (1 :: Int) + Sum (40 :: Int) +-- Sum {getSum = 41} +-- +(+) :: AdditiveGroup g => g -> g -> g +(+) = (<>) +{-# inline (+) #-} + +-- | Add an element of an additive group to itself @n@-many times. +-- +-- This represents @ℕ@-indexed copowers of an element @g@ of +-- an additive group, i.e. iterated coproducts of group elements. +-- This is representable by the universal property +-- \( C(∐_n g, x) ≅ C(g, x)^n \). +-- +-- === __Examples__: +-- +-- >>> copower 2 (Sum (3 :: Int)) +-- Sum {getSum = 6} +-- +copower :: (Integral n, AdditiveGroup g) => n -> g -> g +copower = gtimes +{-# inline copower #-} + +-- -------------------------------------------------------------------- -- +-- Additive abelian groups + +-- | An additive abelian group is an 'AbelianGroup' whose operation can be thought of +-- as commutative addition in some sense. Almost all additive groups are abelian. +-- +class (AbelianGroup g, AdditiveGroup g) => AdditiveAbelianGroup g +instance AdditiveAbelianGroup () +instance AdditiveAbelianGroup b => AdditiveAbelianGroup (a -> b) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Dual a) +instance AdditiveAbelianGroup Any +instance AdditiveAbelianGroup (Sum Integer) +instance AdditiveAbelianGroup (Sum Int) +instance AdditiveAbelianGroup (Sum Int8) +instance AdditiveAbelianGroup (Sum Int16) +instance AdditiveAbelianGroup (Sum Int32) +instance AdditiveAbelianGroup (Sum Int64) +instance AdditiveAbelianGroup (Sum Word) +instance AdditiveAbelianGroup (Sum Word8) +instance AdditiveAbelianGroup (Sum Word16) +instance AdditiveAbelianGroup (Sum Word32) +instance AdditiveAbelianGroup (Sum Word64) +instance AdditiveAbelianGroup (Sum (Ratio Integer)) +instance AdditiveAbelianGroup (Sum (Ratio Int)) +instance AdditiveAbelianGroup (Sum (Ratio Int8)) +instance AdditiveAbelianGroup (Sum (Ratio Int16)) +instance AdditiveAbelianGroup (Sum (Ratio Int32)) +instance AdditiveAbelianGroup (Sum (Ratio Int64)) +instance AdditiveAbelianGroup (Sum (Ratio Word)) +instance AdditiveAbelianGroup (Sum (Ratio Word8)) +instance AdditiveAbelianGroup (Sum (Ratio Word16)) +instance AdditiveAbelianGroup (Sum (Ratio Word32)) +instance AdditiveAbelianGroup (Sum (Ratio Word64)) +instance (AdditiveAbelianGroup a, AdditiveAbelianGroup b) => AdditiveAbelianGroup (a,b) +instance (AdditiveAbelianGroup a, AdditiveAbelianGroup b, AdditiveAbelianGroup c) => AdditiveAbelianGroup (a,b,c) +instance (AdditiveAbelianGroup a, AdditiveAbelianGroup b, AdditiveAbelianGroup c, AdditiveAbelianGroup d) => AdditiveAbelianGroup (a,b,c,d) +instance (AdditiveAbelianGroup a, AdditiveAbelianGroup b, AdditiveAbelianGroup c, AdditiveAbelianGroup d, AdditiveAbelianGroup e) => AdditiveAbelianGroup (a,b,c,d,e) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Const a b) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Identity a) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Proxy a) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Down a) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Endo a) +#if __GLASGOW_HASKELL__ > 804 +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Op a b) +#endif diff --git a/src/Data/Group/Cyclic.hs b/src/Data/Group/Cyclic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Cyclic.hs @@ -0,0 +1,179 @@ +{-# language BangPatterns #-} +{-# language FlexibleInstances #-} +{-# language Safe #-} +-- | +-- Module : Data.Group.Cyclic +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'CyclicGroup' +-- along with the relevant combinators. +-- +module Data.Group.Cyclic +( -- * Cyclic groups + CyclicGroup(..) + -- ** Combinators +, generate +, classify +) where + +import Data.Functor.Const +import Data.Functor.Identity +import Data.Group +import Data.Int +import Data.List +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Word + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> :set -XTypeApplications + +-- -------------------------------------------------------------------- -- +-- Cyclic groups + +-- | A 'CyclicGroup' is a 'Group' that is generated by a single element. +-- This element is called a /generator/ of the group. There can be many +-- generators for a group, e.g., any representative of an equivalence +-- class of prime numbers of the integers modulo @n@, but to make things +-- easy, we ask for only one generator. +-- +class Group g => CyclicGroup g where + generator :: g + {-# minimal generator #-} + +instance CyclicGroup () where + generator = () + {-# inline generator #-} + +-- instance CyclicGroup b => CyclicGroup (a -> b) where +-- generator = const generator +-- {-# inlinable generator #-} + +instance CyclicGroup a => CyclicGroup (Dual a) where + generator = Dual (invert generator) + {-# inlinable generator #-} + +instance CyclicGroup (Sum Integer) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Rational) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Int) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Int8) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Int16) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Int32) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Int64) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Word) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Word8) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Word16) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Word32) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup (Sum Word64) where + generator = 1 + {-# inline generator #-} + +instance CyclicGroup a => CyclicGroup (Const a b) where + generator = Const generator + {-# inlinable generator #-} + +instance CyclicGroup a => CyclicGroup (Identity a) where + generator = Identity generator + {-# inlinable generator #-} + +instance CyclicGroup a => CyclicGroup (Proxy a) where + generator = Proxy + {-# inlinable generator #-} + +instance (CyclicGroup a, CyclicGroup b) => CyclicGroup (a,b) where + generator = (generator, generator) + {-# inlinable generator #-} + +instance (CyclicGroup a, CyclicGroup b, CyclicGroup c) => CyclicGroup (a,b,c) where + generator = (generator, generator, generator) + {-# inlinable generator #-} + +instance (CyclicGroup a, CyclicGroup b, CyclicGroup c, CyclicGroup d) => CyclicGroup (a,b,c,d) where + generator = (generator, generator, generator, generator) + {-# inlinable generator #-} + +instance (CyclicGroup a, CyclicGroup b, CyclicGroup c, CyclicGroup d, CyclicGroup e) => CyclicGroup (a,b,c,d,e) where + generator = (generator, generator, generator, generator, generator) + {-# inlinable generator #-} + +instance CyclicGroup a => CyclicGroup (Down a) where + generator = Down generator + {-# inline generator #-} + +instance CyclicGroup a => CyclicGroup (Endo a) where + generator = Endo $ const generator + {-# inline generator #-} + +-- -------------------------------------------------------------------- -- +-- Cyclic group combinators + +-- | Lazily generate all elements of a 'CyclicGroup' from its generator. +-- +-- /Note/: fuses. +-- +generate :: (Eq a, CyclicGroup a) => [a] +generate = unfoldr go (generator, 0 :: Integer) + where + go (a, !n) + | a == mempty, n > 0 = Nothing + | otherwise = Just (a, (a <> generator, succ n)) +{-# noinline generate #-} + +-- | Classify elements of a 'CyclicGroup'. +-- +-- Apply a classifying function @a -> Bool@ to the elements +-- of a 'CyclicGroup' as generated by its designated generator. +-- +-- === __Examples__: +-- +-- >>> classify (< (3 :: Sum Word8)) +-- [Sum {getSum = 1},Sum {getSum = 2}] +-- +classify :: (Eq a, CyclicGroup a) => (a -> Bool) -> [a] +classify p = filter p generate +{-# inline classify #-} diff --git a/src/Data/Group/Finite.hs b/src/Data/Group/Finite.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Finite.hs @@ -0,0 +1,138 @@ +{-# language CPP #-} +{-# language FlexibleInstances #-} +{-# language Safe #-} +-- | +-- Module : Data.Group.Finite +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix + +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'FiniteGroup' +-- along with the relevant combinators. +-- +module Data.Group.Finite +( -- * Finite groups + FiniteGroup + -- ** Finite group combinators +, safeOrder + -- * Finite abelian groups +, FiniteAbelianGroup +) where + +import Data.Functor.Const +import Data.Functor.Identity +import Data.Group +import Data.Int +import Data.Monoid +#if __GLASGOW_HASKELL__ >= 810 +import Data.Ord +#endif +import Data.Proxy +import Data.Word + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> :set -XTypeApplications + +-- -------------------------------------------------------------------- -- +-- Finite groups + +-- | A 'FiniteGroup' is a 'Group' whose underlying set is finite. +-- This is equivalently a group object in \( FinSet \). +-- +-- Finite groups often arise when considering symmetry of mathematical +-- or physical objects, when those objects admit just a finite number of +-- structure-preserving transformations. Important examples of finite groups +-- include cyclic groups and permutation groups. +-- +class (Group g, Bounded g) => FiniteGroup g where + +instance FiniteGroup () +instance FiniteGroup a => FiniteGroup (Dual a) +instance FiniteGroup a => FiniteGroup (Const a b) +instance FiniteGroup a => FiniteGroup (Identity a) +instance FiniteGroup a => FiniteGroup (Proxy a) +instance (FiniteGroup a, FiniteGroup b) => FiniteGroup (a,b) +instance (FiniteGroup a, FiniteGroup b, FiniteGroup c) => FiniteGroup (a,b,c) +instance (FiniteGroup a, FiniteGroup b, FiniteGroup c, FiniteGroup d) => FiniteGroup (a,b,c,d) +instance (FiniteGroup a, FiniteGroup b, FiniteGroup c, FiniteGroup d, FiniteGroup e) => FiniteGroup (a,b,c,d,e) +instance FiniteGroup Any +instance FiniteGroup All +instance FiniteGroup (Sum Int) +instance FiniteGroup (Sum Int8) +instance FiniteGroup (Sum Int16) +instance FiniteGroup (Sum Int32) +instance FiniteGroup (Sum Int64) +instance FiniteGroup (Sum Word) +instance FiniteGroup (Sum Word8) +instance FiniteGroup (Sum Word16) +instance FiniteGroup (Sum Word32) +instance FiniteGroup (Sum Word64) +instance FiniteGroup Ordering + +#if __GLASGOW_HASKELL__ >= 810 +instance FiniteGroup a => FiniteGroup (Down a) +#endif + +-- -------------------------------------------------------------------- -- +-- Finite group combinators + +-- | A safe version of 'order' for 'FiniteGroup's. +-- +-- This is gauranteed to terminate with either @Infinite@ or @Finite@. +-- +-- === __Examples__: +-- +-- >>> order @(Sum Word8) 3 +-- Finite 255 +-- +-- >>> order (Any False) +-- Finite 1 +-- +-- >>> order (All False) +-- Infinite +-- +safeOrder :: (Eq g, FiniteGroup g) => g -> Order +safeOrder = order +{-# inline safeOrder #-} + +-- -------------------------------------------------------------------- -- +-- Finite abelian groups + +-- | Commutative 'FiniteGroup's +-- +class FiniteGroup g => FiniteAbelianGroup g + +instance FiniteAbelianGroup () +instance FiniteAbelianGroup a => FiniteAbelianGroup (Dual a) +instance FiniteAbelianGroup (Sum Int) +instance FiniteAbelianGroup (Sum Int8) +instance FiniteAbelianGroup (Sum Int16) +instance FiniteAbelianGroup (Sum Int32) +instance FiniteAbelianGroup (Sum Int64) +instance FiniteAbelianGroup (Sum Word) +instance FiniteAbelianGroup (Sum Word8) +instance FiniteAbelianGroup (Sum Word16) +instance FiniteAbelianGroup (Sum Word32) +instance FiniteAbelianGroup (Sum Word64) +instance FiniteAbelianGroup a => FiniteAbelianGroup (Const a b) +instance FiniteAbelianGroup a => FiniteAbelianGroup (Identity a) +instance FiniteAbelianGroup a => FiniteAbelianGroup (Proxy a) +instance (FiniteAbelianGroup a, FiniteAbelianGroup b) => FiniteAbelianGroup (a,b) +instance (FiniteAbelianGroup a, FiniteAbelianGroup b, FiniteAbelianGroup c) => FiniteAbelianGroup (a,b,c) +instance (FiniteAbelianGroup a, FiniteAbelianGroup b, FiniteAbelianGroup c, FiniteAbelianGroup d) => FiniteAbelianGroup (a,b,c,d) +instance (FiniteAbelianGroup a, FiniteAbelianGroup b, FiniteAbelianGroup c, FiniteAbelianGroup d, FiniteAbelianGroup e) => FiniteAbelianGroup (a,b,c,d,e) +instance FiniteAbelianGroup Ordering + +#if __GLASGOW_HASKELL__ >= 810 +instance FiniteAbelianGroup a => FiniteAbelianGroup (Down a) +#endif diff --git a/src/Data/Group/Foldable.hs b/src/Data/Group/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Foldable.hs @@ -0,0 +1,175 @@ +{-# language CPP #-} +{-# language FlexibleInstances #-} +{-# language Safe #-} +#if MIN_VERSION_base(4,12,0) +{-# language TypeOperators #-} +#endif +-- | +-- Module : Data.Group +-- Copyright : (c) 2020 Reed Mullanix, Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Reed Mullanix , +-- Emily Pillmore +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module provides definitions 'GroupFoldable', +-- along with useful combinators. +-- +module Data.Group.Foldable +( -- * Group foldable + GroupFoldable(..) + -- ** Group foldable combinators +, gold +, goldr +, toFreeGroup +) where + + +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Identity +import Data.Group +import Data.Group.Free +import Data.Group.Free.Church +import Data.Group.Permutation +import Data.Monoid + +#if MIN_VERSION_base(4,12,0) +import GHC.Generics +#endif + + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> import Data.Word +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts + +-- -------------------------------------------------------------------- -- +-- Group foldable + +-- | The class of data structures that can be groupoidally folded. +-- +-- 'GroupFoldable' has difficult-to-define laws in terms of Haskell, +-- but is well-understood categorically: 'GroupFoldable's are +-- functors (not necessarily 'Functor's) in the slice category \( [\mathcal{Hask}, \mathcal{Hask}] / F \), +-- where \( F \) is the free group functor in \( \mathcal{Hask} \). Hence, they are +-- defined by the natural transformations \( [\mathcal{Hask},\mathcal{Hask}](-, F) \) - i.e. 'toFG', or 'toFreeGroup'. +-- +class GroupFoldable t where + -- | Apply a 'Group' fold to some container. + -- + -- This function takes a container that can be represented as a + -- 'FreeGroup', and simplifies the container as a word in the + -- free group, producing a final output according to some + -- mapping of elements into the target group. + -- + -- The name is a pun on 'Group' and 'Data.Foldable.fold'. + -- + -- === __Examples__: + -- + -- >>> let x = FreeGroup $ [Left (1 :: Sum Word8), Left 2, Right 2, Right 3] + -- >>> goldMap id x + -- Sum {getSum = 2} + -- + -- >>> goldMap (\a -> if a < 2 then mempty else a) x + -- Sum {getSum = 3} + -- + goldMap :: Group g => (a -> g) -> t a -> g + goldMap f t = runFG (toFG t) f + {-# inline goldMap #-} + + -- | Translate a 'GroupFoldable' container into a Church-encoded + -- free group. + -- + -- Analagous to 'Data.Foldable.toList' for 'Foldable', if 'Data.Foldable.toList' respected the + -- associativity of ⊥. + -- + toFG :: t a -> FG a + toFG t = FG $ \k -> goldMap k t + {-# inline toFG #-} + {-# minimal goldMap | toFG #-} + +instance GroupFoldable FG where + toFG = id + +instance GroupFoldable FreeGroup where + toFG = reflectFG + +instance GroupFoldable Sum where + goldMap f = f . getSum + +instance GroupFoldable Product where + goldMap f = f . getProduct + +instance GroupFoldable Dual where + goldMap f = f . getDual + +instance GroupFoldable (Const a) where + goldMap _ _ = mempty + +instance GroupFoldable Identity where + goldMap f = f . runIdentity + +instance (GroupFoldable f, GroupFoldable g) => GroupFoldable (Compose f g) where + goldMap f = goldMap (goldMap f) . getCompose + +#if MIN_VERSION_base(4,12,0) +instance (GroupFoldable f, GroupFoldable g) => GroupFoldable (f :*: g) where + goldMap f (a :*: b) = goldMap f a <> goldMap f b + +instance (GroupFoldable f, GroupFoldable g) => GroupFoldable (f :+: g) where + toFG (L1 l) = toFG l + toFG (R1 r) = toFG r + +instance (GroupFoldable f, GroupFoldable g) => GroupFoldable (f :.: g) where + goldMap f = goldMap (goldMap f) . unComp1 +#endif + +instance GroupFoldable Abelianizer where + goldMap _ Quot = mempty + goldMap f (Commuted a) = f a + +-- -------------------------------------------------------------------- -- +-- Group foldable combinators + +-- | Simplify a word in 'GroupFoldable' container as a word +-- in a 'FreeGroup'. +-- +-- The name is a pun on 'Group' and 'Data.Foldable.fold'. +-- +-- === __Examples__: +-- +-- >>> let x = FreeGroup $ [Left (1 :: Sum Word8), Left 2, Right 2, Right 3] +-- >>> gold x +-- Sum {getSum = 2} +-- +gold :: (GroupFoldable t, Group g) => t g -> g +gold = goldMap id +{-# inline gold #-} + +-- | Convert a 'GroupFoldable' container into a 'FreeGroup' +-- +toFreeGroup :: (GroupFoldable t, Group g) => t g -> FreeGroup g +toFreeGroup = reifyFG . toFG +{-# inline toFreeGroup #-} + +-- | A right group fold from a 'GroupFoldable' container to its permutation group +-- +-- Analogous to 'Data.Foldable.foldr' for monoidal 'Foldable's. +-- +goldr + :: GroupFoldable t + => Group g + => (a -> Permutation g) + -> t a + -> Permutation g +goldr = goldMap +{-# inline goldr #-} diff --git a/src/Data/Group/Free.hs b/src/Data/Group/Free.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Free.hs @@ -0,0 +1,171 @@ +{-# language Safe #-} +-- | +-- Module : Data.Group +-- Copyright : (c) 2020 Reed Mullanix, Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Reed Mullanix , +-- Emily Pillmore +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module provides definitions for 'FreeGroup's and 'FreeAbelianGroup's, +-- along with useful combinators. +-- +module Data.Group.Free +( -- * Free groups + FreeGroup(..) + -- ** Free group combinators +, simplify +, interpret +, interpret' +, present + -- * Free abelian groups +, FreeAbelianGroup(..) + -- ** Free abelian group combinators +, abmap +, abjoin +, singleton +, abInterpret +) where + +import Control.Applicative +import Control.Monad + +import Data.Bifunctor +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Group + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> import Data.Word +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts + +-- | A representation of a free group over an alphabet @a@. +-- +-- The intuition here is that @Left a@ represents a "negative" @a@, +-- whereas @Right a@ represents "positive" @a@. +-- +-- __Note:__ This does not perform simplification upon multiplication or construction. +-- To do this, one should use 'simplify'. +-- +newtype FreeGroup a = FreeGroup { runFreeGroup :: [Either a a] } + deriving (Show, Eq, Ord) + +instance Semigroup (FreeGroup a) where + (FreeGroup g) <> (FreeGroup g') = FreeGroup (g ++ g') + +instance Monoid (FreeGroup a) where + mempty = FreeGroup [] + +instance Group (FreeGroup a) where + invert (FreeGroup g) = FreeGroup $ fmap inv g + where + inv :: Either a a -> Either a a + inv (Left a) = Right a + inv (Right a) = Left a + +instance Functor FreeGroup where + fmap f (FreeGroup g) = FreeGroup $ fmap (bimap f f) g + +instance Applicative FreeGroup where + pure a = FreeGroup $ pure $ pure a + (<*>) = ap + +instance Monad FreeGroup where + return = pure + (FreeGroup g) >>= f = FreeGroup $ concatMap go g + where + go (Left a) = runFreeGroup $ invert $ f a + go (Right a) = runFreeGroup $ f a + +instance Alternative FreeGroup where + empty = mempty + (<|>) = (<>) + +-- | /O(n)/ Simplifies a word in a free group. +-- +-- === __Examples:__ +-- +-- >>> simplify $ FreeGroup [Right 'a', Left 'b', Right 'c', Left 'c', Right 'b', Right 'a'] +-- FreeGroup {runFreeGroup = [Right 'a',Right 'a']} +-- +simplify :: (Eq a) => FreeGroup a -> FreeGroup a +simplify (FreeGroup g) = FreeGroup $ foldr go [] g + where + go (Left a) ((Right a'):as) | a == a' = as + go (Right a) ((Left a'):as) | a == a' = as + go a as = a:as + +-- | /O(n)/ Interpret a word in a free group over some group @g@ as an element in a group @g@. +-- +interpret :: (Group g) => FreeGroup g -> g +interpret (FreeGroup g) = foldr go mempty g + where + go (Left a) acc = invert a <> acc + go (Right a) acc = a <> acc + +-- | /O(n)/ Strict variant of 'interpret'. +-- +interpret' :: (Group g) => FreeGroup g -> g +interpret' (FreeGroup g) = foldl' go mempty g + where + go acc (Left a) = acc <> invert a + go acc (Right a) = acc <> a + +-- | Present a 'Group' as a 'FreeGroup' modulo relations. +-- +present :: Group g => FreeGroup g -> (FreeGroup g -> g) -> g +present = flip ($) +{-# inline present #-} + +-- | A representation of a free abelian group over an alphabet @a@. +-- +-- The intuition here is group elements correspond with their positive +-- or negative multiplicities, and as such are simplified by construction. +-- +newtype FreeAbelianGroup a = FreeAbelianGroup { runFreeAbelian :: Map a Int } + deriving (Show, Eq, Ord) + +instance (Ord a) => Semigroup (FreeAbelianGroup a) where + (FreeAbelianGroup g) <> (FreeAbelianGroup g') = + FreeAbelianGroup $ Map.unionWith (+) g g' + +instance (Ord a) => Monoid (FreeAbelianGroup a) where + mempty = FreeAbelianGroup mempty + +instance (Ord a) => Group (FreeAbelianGroup a) where + invert (FreeAbelianGroup g) = FreeAbelianGroup $ fmap negate g + +-- NOTE: We can't implement Functor/Applicative/Monad here +-- due to the Ord constraint. C'est La Vie! + +-- | Functorial 'fmap' for a 'FreeAbelianGroup'. +-- +abmap :: (Ord b) => (a -> b) -> FreeAbelianGroup a -> FreeAbelianGroup b +abmap f (FreeAbelianGroup g) = FreeAbelianGroup $ Map.mapKeys f g + +-- | Lift a singular value into a 'FreeAbelianGroup'. Analogous to 'pure'. +-- +singleton :: a -> FreeAbelianGroup a +singleton a = FreeAbelianGroup $ Map.singleton a 1 + +-- | Monadic 'join' for a 'FreeAbelianGroup'. +-- +abjoin :: (Ord a) => FreeAbelianGroup (FreeAbelianGroup a) -> FreeAbelianGroup a +abjoin (FreeAbelianGroup g) = FreeAbelianGroup $ Map.foldMapWithKey go g + where + go (FreeAbelianGroup g') n = fmap (*n) g' + +-- | Interpret a free group as a word in the underlying group @g@. +-- +abInterpret :: (Group g) => FreeAbelianGroup g -> g +abInterpret (FreeAbelianGroup g) = Map.foldMapWithKey (flip gtimes) g diff --git a/src/Data/Group/Free/Church.hs b/src/Data/Group/Free/Church.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Free/Church.hs @@ -0,0 +1,158 @@ +{-# language RankNTypes #-} +{-# language Safe #-} +-- | +-- Module : Data.Group +-- Copyright : (c) 2020 Reed Mullanix, Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Reed Mullanix , +-- Emily Pillmore +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module provides definitions for Church-encoded +-- 'FreeGroup's, 'FreeAbelianGroup's, along with useful combinators. +-- +module Data.Group.Free.Church +( -- * Church-encoded free groups + FG(..) + -- ** Church-encoded free group combinators +, interpretFG +, reifyFG +, reflectFG +, presentFG + -- * Church-encoded free abelian groups +, FA(..) + -- ** Church-encoded free abelian group combinators +, forgetFA +, interpretFA +, reifyFA +, reflectFA +) where + +import Control.Applicative +import Control.Monad + +import Data.Group +import Data.Group.Free +import qualified Data.Map.Strict as Map + +-- | The Church-encoding of a 'FreeGroup'. +-- +-- This datatype represents the free group on some @a@-valued +-- generators. For more information on why this encoding is preferred, +-- see Dan Doel's in +-- the Comonad Reader. +-- +newtype FG a = FG { runFG :: forall g. (Group g) => (a -> g) -> g } + +instance Semigroup (FG a) where + (FG g) <> (FG g') = FG $ \k -> g k <> g' k + +instance Monoid (FG a) where + mempty = FG $ const mempty + +instance Group (FG a) where + invert (FG g) = FG (invert . g) + +instance Functor FG where + fmap f (FG fa) = FG $ \k -> fa (k . f) + +instance Applicative FG where + pure a = FG ($ a) + (<*>) = ap + +instance Monad FG where + return = pure + (FG fg) >>= f = FG $ \k -> fg (\a -> (runFG $ f a) k) + +instance Alternative FG where + empty = mempty + (<|>) = (<>) + +-- | Interpret a Church-encoded free group as a concrete 'FreeGroup'. +-- +interpretFG :: Group g => FG g -> g +interpretFG (FG fg) = fg id +{-# inline interpretFG #-} + +-- | Convert a Church-encoded free group to a concrete 'FreeGroup'. +-- +reifyFG :: FG a -> FreeGroup a +reifyFG fg = interpretFG $ fmap pure fg +{-# inline reifyFG #-} + +-- | Convert a concrete 'FreeGroup' to a Church-encoded free group. +-- +reflectFG :: FreeGroup a -> FG a +reflectFG (FreeGroup fg) = FG $ \k -> foldMap (go k) fg + where + go k (Left a) = invert (k a) + go k (Right a) = k a +{-# inline reflectFG #-} + +-- | Present a 'Group' as a 'FG' modulo relations. +-- +presentFG :: Group g => FG g -> (FG g -> g) -> g +presentFG = flip ($) +{-# inline presentFG #-} + +---------------------------------------- +-- Free Abelian Groups + +-- | The Church-encoding of a 'FreeAbelianGroup'. +-- +-- This datatype represents the free group on some @a@-valued +-- generators, along with their exponents in the group. +-- +newtype FA a = FA { runFA :: forall g. (Group g) => (a -> Int -> g) -> g } + +instance Semigroup (FA a) where + (FA g) <> (FA g') = FA $ \k -> g k <> g' k + +instance Monoid (FA a) where + mempty = FA $ const mempty + +instance Group (FA a) where + invert (FA g) = FA (invert . g) + +instance Functor FA where + fmap f (FA fa) = FA $ \k -> fa (k . f) + +instance Applicative FA where + pure a = FA $ \k -> k a 1 + (<*>) = ap + +instance Monad FA where + return = pure + (FA fa) >>= f = FA $ \k -> fa (\a n -> gtimes n $ (runFA $ f a) k) + +instance Alternative FA where + empty = mempty + (<|>) = (<>) + +-- | Interpret a Church-encoded free abelian group as a concrete 'FreeAbelianGroup'. +-- +interpretFA :: Group g => FA g -> g +interpretFA (FA fa) = fa (flip gtimes) +{-# inline interpretFA #-} + +-- | Convert a Church-encoded free abelian group to a concrete 'FreeAbelianGroup'. +-- +reifyFA :: Ord a => FA a -> FreeAbelianGroup a +reifyFA = interpretFA . fmap singleton +{-# inline reifyFA #-} + +-- | Convert a concrete 'FreeAbelianGroup' to a Church-encoded free abelian group. +-- +reflectFA :: Ord a => FreeAbelianGroup a -> FA a +reflectFA (FreeAbelianGroup fa) = FA $ \k -> Map.foldMapWithKey k fa +{-# inline reflectFA #-} + +-- | Forget the commutative structure of a Church-encoded free abelian group, +-- turning it into a standard free group. +-- +forgetFA :: Group a => FA a -> FG a +forgetFA fa = FG ($ interpretFA fa) +{-# inline forgetFA #-} diff --git a/src/Data/Group/Multiplicative.hs b/src/Data/Group/Multiplicative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Multiplicative.hs @@ -0,0 +1,168 @@ +{-# language FlexibleInstances #-} +{-# language Safe #-} +-- | +-- Module : Data.Group.Multiplicative +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- Reed Mullanix +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains definitions for 'MultiplicativeGroup' and +-- 'MultiplicativeAbelianGroup', along with the relevant combinators. +-- +module Data.Group.Multiplicative +( -- * Multiplicative Groups + MultiplicativeGroup + -- ** combinators +, (/) +, (*) +, (^) +, power + -- * Multiplicative abelian groups +, MultiplicativeAbelianGroup +) where + + +import Data.Functor.Const +import Data.Functor.Identity +import Data.Group +import Data.Int +import Data.Proxy +import Data.Ratio +import Data.Semigroup +import Data.Word + +import Numeric.Natural + +import Prelude hiding ((^), (/), (*)) + +infixl 7 /, * +infixr 8 ^ + +-- $setup +-- +-- >>> import qualified Prelude +-- >>> import Data.Group +-- >>> import Data.Monoid +-- >>> import Data.Semigroup +-- >>> :set -XTypeApplications + +-- -------------------------------------------------------------------- -- +-- Multiplicative groups + +-- | An multiplicative group is a 'Group' whose operation can be thought of +-- as multiplication in some sense. +-- +-- For example, the multiplicative group of rationals \( (ℚ, 1, *) \). +-- +class Group g => MultiplicativeGroup g + +instance MultiplicativeGroup () +instance MultiplicativeGroup b => MultiplicativeGroup (a -> b) +instance MultiplicativeGroup a => MultiplicativeGroup (Dual a) +instance MultiplicativeGroup All +instance MultiplicativeGroup (Product (Ratio Integer)) +instance MultiplicativeGroup (Product (Ratio Natural)) +instance MultiplicativeGroup (Product (Ratio Int)) +instance MultiplicativeGroup (Product (Ratio Int8)) +instance MultiplicativeGroup (Product (Ratio Int16)) +instance MultiplicativeGroup (Product (Ratio Int32)) +instance MultiplicativeGroup (Product (Ratio Int64)) +instance MultiplicativeGroup (Product (Ratio Word)) +instance MultiplicativeGroup (Product (Ratio Word8)) +instance MultiplicativeGroup (Product (Ratio Word16)) +instance MultiplicativeGroup (Product (Ratio Word32)) +instance MultiplicativeGroup (Product (Ratio Word64)) +instance (MultiplicativeGroup a, MultiplicativeGroup b) => MultiplicativeGroup (a,b) +instance (MultiplicativeGroup a, MultiplicativeGroup b, MultiplicativeGroup c) => MultiplicativeGroup (a,b,c) +instance (MultiplicativeGroup a, MultiplicativeGroup b, MultiplicativeGroup c, MultiplicativeGroup d) => MultiplicativeGroup (a,b,c,d) +instance (MultiplicativeGroup a, MultiplicativeGroup b, MultiplicativeGroup c, MultiplicativeGroup d, MultiplicativeGroup e) => MultiplicativeGroup (a,b,c,d,e) +instance MultiplicativeGroup a => MultiplicativeGroup (Const a b) +instance MultiplicativeGroup a => MultiplicativeGroup (Identity a) +instance MultiplicativeGroup a => MultiplicativeGroup (Proxy a) + +-- | Infix alias for multiplicative inverse. +-- +-- === __Examples__: +-- +-- >>> let x = Product (4 :: Rational) +-- >>> x / 2 +-- Product {getProduct = 2 % 1} +-- +(/) :: MultiplicativeGroup a => a -> a -> a +(/) = minus +{-# inline (/) #-} + +-- | Infix alias for multiplicative @('<>')@. +-- +-- === __Examples__: +-- +-- >>> Product (2 :: Rational) * Product (3 :: Rational) +-- Product {getProduct = 6 % 1} +-- +(*) :: MultiplicativeGroup g => g -> g -> g +(*) = (<>) +{-# inline (*) #-} + +-- | Infix alias for 'power'. +-- +-- === __Examples__: +-- +-- >>> let x = Product (3 :: Rational) +-- >>> x ^ 3 +-- Product {getProduct = 27 % 1} +-- +(^) :: (Integral n, MultiplicativeGroup a) => a -> n -> a +(^) = power +{-# inline (^) #-} + +-- | Multiply an element of a multiplicative group by itself @n@-many times. +-- +-- This represents @ℕ@-indexed powers of an element @g@ of +-- a multiplicative group, i.e. iterated products of group elements. +-- This is representable by the universal property +-- \( C(x, ∏_n g) ≅ C(x, g)^n \). +-- +-- === __Examples__: +-- +-- >>> power (Product (3 :: Rational)) 3 +-- Product {getProduct = 27 % 1} +-- +power :: (Integral n, MultiplicativeGroup g) => g -> n -> g +power a n = gtimes n a +{-# inline power #-} + +-- -------------------------------------------------------------------- -- +-- Multiplicative abelian groups + +-- | A multiplicative abelian group is a 'Group' whose operation can be thought of +-- as commutative multiplication in some sense. Almost all multiplicative groups +-- are abelian. +-- +class (MultiplicativeGroup g, AbelianGroup g) => MultiplicativeAbelianGroup g +instance MultiplicativeAbelianGroup () +instance MultiplicativeAbelianGroup b => MultiplicativeAbelianGroup (a -> b) +instance MultiplicativeAbelianGroup a => MultiplicativeAbelianGroup (Dual a) +instance MultiplicativeAbelianGroup All +instance MultiplicativeAbelianGroup (Product (Ratio Integer)) +instance MultiplicativeAbelianGroup (Product (Ratio Natural)) +instance MultiplicativeAbelianGroup (Product (Ratio Int)) +instance MultiplicativeAbelianGroup (Product (Ratio Int8)) +instance MultiplicativeAbelianGroup (Product (Ratio Int16)) +instance MultiplicativeAbelianGroup (Product (Ratio Int32)) +instance MultiplicativeAbelianGroup (Product (Ratio Int64)) +instance MultiplicativeAbelianGroup (Product (Ratio Word)) +instance MultiplicativeAbelianGroup (Product (Ratio Word8)) +instance MultiplicativeAbelianGroup (Product (Ratio Word16)) +instance MultiplicativeAbelianGroup (Product (Ratio Word32)) +instance MultiplicativeAbelianGroup (Product (Ratio Word64)) +instance (MultiplicativeAbelianGroup a, MultiplicativeAbelianGroup b) => MultiplicativeAbelianGroup (a,b) +instance (MultiplicativeAbelianGroup a, MultiplicativeAbelianGroup b, MultiplicativeAbelianGroup c) => MultiplicativeAbelianGroup (a,b,c) +instance (MultiplicativeAbelianGroup a, MultiplicativeAbelianGroup b, MultiplicativeAbelianGroup c, MultiplicativeAbelianGroup d) => MultiplicativeAbelianGroup (a,b,c,d) +instance (MultiplicativeAbelianGroup a, MultiplicativeAbelianGroup b, MultiplicativeAbelianGroup c, MultiplicativeAbelianGroup d, MultiplicativeAbelianGroup e) => MultiplicativeAbelianGroup (a,b,c,d,e) +instance MultiplicativeAbelianGroup a => MultiplicativeAbelianGroup (Const a b) +instance MultiplicativeAbelianGroup a => MultiplicativeAbelianGroup (Identity a) +instance MultiplicativeAbelianGroup a => MultiplicativeAbelianGroup (Proxy a) diff --git a/src/Data/Group/Permutation.hs b/src/Data/Group/Permutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Group/Permutation.hs @@ -0,0 +1,121 @@ +{-# language PatternSynonyms #-} +{-# language Safe #-} +{-# language ViewPatterns #-} +-- | +-- Module : Data.Group +-- Copyright : (c) 2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Reed Mullanix , +-- Emily Pillmore +-- +-- Stability : stable +-- Portability : non-portable +-- +-- This module provides definitions for 'Permutation's +-- along with useful combinators. +-- +module Data.Group.Permutation +( -- * Permutation groups + Permutation(..) + -- ** Permutation group combinators +, permute +, pairwise +, (-$) +, ($-) +, embed +, retract + -- ** Permutation patterns +, pattern Permute +) where + + +import Data.Group +import Data.Group.Additive +import Data.Group.Multiplicative + +infixr 0 $-, -$ + +-- -------------------------------------------------------------------- -- +-- Permutations + +-- | Isomorphism of a finite set onto itself. Each entry consists of one +-- half of the isomorphism. +-- +-- /Note/: It is the responsibility of the user to provide inverse proofs +-- for 'to' and 'from'. Be responsible! +-- +data Permutation a = Permutation + { to :: a -> a + -- ^ The forward half of the bijection + , from :: a -> a + -- ^ The inverse half of the bijection + } + +-- instance Profunctor Permutation where +-- dimap = :'( + +instance Semigroup a => Semigroup (Permutation a) where + a <> b = Permutation (to a <> to b) (from a <> from b) + +instance Monoid a => Monoid (Permutation a) where + mempty = Permutation id id + +instance Group a => Group (Permutation a) where + invert (Permutation t f) = Permutation (f . t) (t . f) + +instance AbelianGroup a => AbelianGroup (Permutation a) +instance AdditiveGroup a => AdditiveGroup (Permutation a) +instance AdditiveAbelianGroup a => AdditiveAbelianGroup (Permutation a) +instance MultiplicativeGroup a => MultiplicativeGroup (Permutation a) + + +-- -------------------------------------------------------------------- -- +-- Permutation group combinators + +-- | Build a 'Permutation' from a bijective pair. +-- +permute :: (a -> a) -> (a -> a) -> Permutation a +permute = Permutation +{-# inline permute #-} + +-- | Destroy a 'Permutation', producing the underlying pair of +-- bijections. +-- +pairwise :: Permutation a -> (a -> a, a -> a) +pairwise p = (to p, from p) +{-# inline pairwise #-} + +-- | Infix alias for the 'to' half of 'Permutation' bijection +-- +(-$) :: Permutation a -> a -> a +(-$) = to +{-# inline (-$) #-} + +-- | Infix alias for the 'from' half of 'Permutation' bijection +-- +($-) :: Permutation a -> a -> a +($-) = from +{-# inline ($-) #-} + +-- | Embed a 'Group' into the 'Permutation' group on it's underlying set. +-- +embed :: (Group g) => g -> Permutation g +embed g = Permutation { to = (g <>), from = (invert g <>) } + +-- | Get a group element out of the permutation group. +-- This is a left inverse to 'embed', i.e. +-- +-- @ +-- retract . embed = id +-- @ +-- +retract :: (Group g) => Permutation g -> g +retract p = p -$ mempty + +-- | Bidirectional pattern synonym for embedding/retraction of groups +-- into their permutation groups. +-- +pattern Permute :: Group g => Permutation g -> g +pattern Permute p <- (embed -> p) + where Permute p = retract p diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,7 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) + +main :: IO () +main = doctest $ flags ++ pkgs ++ module_sources