diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for free-algebras +## Version 0.0.7.1 +- `Data.Group.Free.normalize` and `Data.Group.Free.normalizeL` are not both + `O(n)`, but the former is implemented using the latter (e.g. transforms + `DList` to a list). + ## Version 0.0.7.0 - Poly kinded `Control.Algebra.Free.FreeAlgebra` and `Control.Algebra.Free2.FreeAlgebra2` diff --git a/free-algebras.cabal b/free-algebras.cabal --- a/free-algebras.cabal +++ b/free-algebras.cabal @@ -1,5 +1,5 @@ name: free-algebras -version: 0.0.7.0 +version: 0.0.7.1 synopsis: Free algebras in Haskell. description: Universal algebra approach to free algebras including higher kinded algebraic structures like functors, applicative functors or monads. category: Algebra, Control, Monads @@ -7,7 +7,7 @@ bug-reports: https://github.com/coot/free-algebras/issues author: Marcin Szamotulski maintainer: profunctor@pm.me -copyright: (c) 2018 Marcin Szamotulski +copyright: (c) 2018-2019 Marcin Szamotulski license: MPL-2.0 license-file: LICENSE build-type: Simple @@ -15,7 +15,7 @@ extra-source-files: ChangeLog.md README.md -tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 source-repository head type: git @@ -36,23 +36,6 @@ Paths_free_algebras hs-source-dirs: src - default-extensions: - ConstraintKinds - DataKinds - DeriveFunctor - EmptyDataDecls - FlexibleInstances - FlexibleContexts - KindSignatures - InstanceSigs - MultiParamTypeClasses - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies build-depends: base >= 4.9 && <5 , constraints >= 0.8 && <0.11.0 diff --git a/src/Control/Algebra/Free.hs b/src/Control/Algebra/Free.hs --- a/src/Control/Algebra/Free.hs +++ b/src/Control/Algebra/Free.hs @@ -1,5 +1,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- 'ListT' transformer is depreciated +{-# OPTIONS_GHC -Wno-deprecations #-} + module Control.Algebra.Free ( -- Higher free algebra class FreeAlgebra1 (..) diff --git a/src/Control/Algebra/Free2.hs b/src/Control/Algebra/Free2.hs --- a/src/Control/Algebra/Free2.hs +++ b/src/Control/Algebra/Free2.hs @@ -1,4 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + module Control.Algebra.Free2 ( FreeAlgebra2 (..) , Proof (..) diff --git a/src/Control/Monad/Action.hs b/src/Control/Monad/Action.hs --- a/src/Control/Monad/Action.hs +++ b/src/Control/Monad/Action.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + module Control.Monad.Action where import Control.Monad (join) diff --git a/src/Data/Algebra/Free.hs b/src/Data/Algebra/Free.hs --- a/src/Data/Algebra/Free.hs +++ b/src/Data/Algebra/Free.hs @@ -1,5 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + module Data.Algebra.Free ( -- * Free algebra class FreeAlgebra (..) diff --git a/src/Data/Algebra/Pointed.hs b/src/Data/Algebra/Pointed.hs --- a/src/Data/Algebra/Pointed.hs +++ b/src/Data/Algebra/Pointed.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} + module Data.Algebra.Pointed ( Pointed (..) , PointedMonoid (..) diff --git a/src/Data/Group/Free.hs b/src/Data/Group/Free.hs --- a/src/Data/Group/Free.hs +++ b/src/Data/Group/Free.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + {- | Free groups @@ -13,6 +15,7 @@ , normalize , FreeGroupL + , consL , fromList , toList , normalizeL @@ -59,31 +62,32 @@ FreeGroup as >>= f = FreeGroup $ as >>= runFreeGroup . either f f -- | --- Normalize a list, i.e. remove adjusten inverses from a word, i.e. --- @ab⁻¹ba⁻¹c = c@ +-- Normalize a @Dlist@, i.e. remove adjusten inverses from a word, i.e. +-- @ab⁻¹ba⁻¹c = c@. Note that this function is implemented using +-- @'normalizeL'@, implemnting it directly on @DList@s would be @O(n^2)@ +-- instead of @O(n)@. -- --- Complexity: @O(n)@ +-- /Complexity:/ @O(n)@ normalize :: Eq a => DList (Either a a) -> DList (Either a a) -normalize = DList.foldr fn DList.empty - where - fn a as = case as of - DList.Nil -> DList.singleton a - _ -> - let b = DList.head as - bs = DList.tail as - in case (a, b) of - (Left x, Right y) | x == y -> bs - (Right x, Left y) | x == y -> bs - _ -> DList.cons a as +normalize = DList.fromList . normalizeL . DList.toList -- | --- Smart constructor which normalizes a list. +-- Smart constructor which normalizes a dlist. +-- +-- /Complexity:/ @O(n)@ fromDList :: Eq a => DList (Either a a) -> FreeGroup a -fromDList = FreeGroup . normalize +fromDList = freeGroupFromList . DList.toList +-- | +-- Construct a FreeGroup from a list. +-- +-- /Complextiy:/ @O(n)@ +freeGroupFromList :: Eq a => [Either a a] -> FreeGroup a +freeGroupFromList = FreeGroup . DList.fromList . normalizeL + toDList :: FreeGroup a -> DList (Either a a) toDList = runFreeGroup @@ -113,20 +117,40 @@ forget = proof -- | --- Free group in the class of groups which multiplication is strict on the left, i.e. +-- Free group in the class of groups which multiplication is strict on the +-- left, i.e. -- -- prop> undefined <> a = undefined newtype FreeGroupL a = FreeGroupL { runFreeGroupL :: [Either a a] } deriving (Show, Eq, Ord) +-- | Like @'normalize'@ but for lists. +-- +-- /Complexity:/ @O(n)@ normalizeL :: Eq a => [Either a a] -> [Either a a] -normalizeL = DList.toList . normalize . DList.fromList +normalizeL = foldr consL_ [] +-- | Cons a generator (@'Right' x@) or its inverse (@'Left' x@) to the left +-- hand side of a 'FreeGroupL'. +-- +-- /Complexity:/ @O(1)@ +consL :: Eq a => Either a a -> FreeGroupL a -> FreeGroupL a +consL a (FreeGroupL as) = FreeGroupL (consL_ a as) + +consL_ :: Eq a => Either a a -> [Either a a] -> [Either a a] +consL_ a [] = [a] +consL_ a as@(b:bs) = case (a, b) of + (Left x, Right y) | x == y -> bs + (Right x, Left y) | x == y -> bs + _ -> a : as + -- | --- Smart constructors +-- Smart constructor which normalizes a list. +-- +-- /Complexity:/ @O(n)@ fromList :: Eq a => [Either a a] -> FreeGroupL a fromList = FreeGroupL . normalizeL @@ -134,7 +158,7 @@ toList = runFreeGroupL instance Eq a => Semigroup (FreeGroupL a) where - FreeGroupL as <> FreeGroupL bs = FreeGroupL $ normalizeL (as ++ bs) + FreeGroupL as <> FreeGroupL bs = FreeGroupL $ foldr consL_ bs as instance Eq a => Monoid (FreeGroupL a) where mempty = FreeGroupL [] diff --git a/src/Data/Monoid/Abelian.hs b/src/Data/Monoid/Abelian.hs --- a/src/Data/Monoid/Abelian.hs +++ b/src/Data/Monoid/Abelian.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + module Data.Monoid.Abelian ( FreeAbelianMonoid (..) ) where diff --git a/src/Data/Semigroup/Abelian.hs b/src/Data/Semigroup/Abelian.hs --- a/src/Data/Semigroup/Abelian.hs +++ b/src/Data/Semigroup/Abelian.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module Data.Semigroup.Abelian ( AbelianSemigroup , FreeAbelianSemigroup diff --git a/src/Data/Semigroup/SemiLattice.hs b/src/Data/Semigroup/SemiLattice.hs --- a/src/Data/Semigroup/SemiLattice.hs +++ b/src/Data/Semigroup/SemiLattice.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + module Data.Semigroup.SemiLattice ( FreeSemiLattice , fromNonEmpty diff --git a/test/Test/Data/Group/Free.hs b/test/Test/Data/Group/Free.hs --- a/test/Test/Data/Group/Free.hs +++ b/test/Test/Data/Group/Free.hs @@ -3,8 +3,8 @@ ( tests ) where -import Control.Monad (mapM) import Data.Semigroup (Semigroup (..)) +import Data.Bool (bool) import Data.Group (invert) import Data.DList (DList) import qualified Data.DList as DList @@ -13,19 +13,16 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Data.Group.Free (fromDList, normalize) +import Data.Group.Free (fromDList, normalize, fromList, normalizeL) +genList :: Gen a -> Gen [Either a a] +genList gen = + Gen.list (Range.linear 0 100) gen' + where + gen' = Gen.bool >>= bool (Right <$> gen) (Left <$> gen) + genDList :: Gen a -> Gen (DList (Either a a)) -genDList gen = do - as <- Gen.list (Range.linear 0 100) gen - DList.fromList <$> mapM - (\a -> do - b <- Gen.bool - if b - then return $ Right a - else return $ Left a - ) - as +genDList gen = DList.fromList <$> genList gen prop_normalize :: Property prop_normalize = property $ do @@ -33,7 +30,7 @@ normalize (normalize as) === normalize as normalize (as `DList.append` rev as) === DList.empty - where + where rev :: DList (Either a a) -> DList (Either a a) rev = DList.foldr (\a as -> DList.snoc as (either Right Left a)) DList.empty @@ -49,14 +46,47 @@ prop_unit = property $ do fg <- fromDList <$> H.forAll (genDList Gen.bool) - fg <> mempty === fg - mempty <> fg === fg + fg <> mempty === fg + mempty <> fg === fg prop_associativity :: Property prop_associativity = property $ do fg <- fromDList <$> H.forAll (genDList Gen.bool) fg' <- fromDList <$> H.forAll (genDList Gen.bool) fg'' <- fromDList <$> H.forAll (genDList Gen.bool) + + (fg <> fg') <> fg'' === fg <> (fg' <> fg'') + +prop_normalizeL :: Property +prop_normalizeL = property $ do + as <- H.forAll (genList Gen.bool) + + normalizeL (normalizeL as) === normalizeL as + normalizeL (as ++ rev as) === [] + where + rev :: [Either a a] -> [Either a a] + rev = foldl (\as a -> either Right Left a : as) [] + +prop_invertL :: Property +prop_invertL = property $ do + fg <- fromList <$> H.forAll (genList Gen.bool) + + invert (invert fg) === fg + invert fg <> fg === mempty + fg <> invert fg === mempty + +prop_unitL :: Property +prop_unitL = property $ do + fg <- fromList <$> H.forAll (genList Gen.bool) + + fg <> mempty === fg + mempty <> fg === fg + +prop_associativityL :: Property +prop_associativityL = property $ do + fg <- fromList <$> H.forAll (genList Gen.bool) + fg' <- fromList <$> H.forAll (genList Gen.bool) + fg'' <- fromList <$> H.forAll (genList Gen.bool) (fg <> fg') <> fg'' === fg <> (fg' <> fg'')