From 4698b4d26025f023235c3c9985423556d544dd52 Mon Sep 17 00:00:00 2001 From: Joshua Moerman Date: Wed, 6 Nov 2024 13:35:14 +0100 Subject: [PATCH] More types of products --- README.md | 3 +++ app/LStar.hs | 2 +- ons-hs.cabal | 2 +- src/Nominal.hs | 26 +++++++++++++++++++++----- src/Nominal/Products.hs | 38 +++++++++++++++++++++++++++++++------- src/OrbitList.hs | 33 ++++++++++++++++++++++++++++++++- 6 files changed, 89 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 1e27f6c..bc99392 100644 --- a/README.md +++ b/README.md @@ -114,6 +114,9 @@ values, that can be much faster. ## Changelog +version 0.3.0.0 (2024-11-06): +* More types of products + version 0.2.3.0 (2024-11-05): * Updates the testing and benchmarking framework. * Replaced benchmarking dependencies, making the build process much faster. diff --git a/app/LStar.hs b/app/LStar.hs index ca5bf05..7edba22 100644 --- a/app/LStar.hs +++ b/app/LStar.hs @@ -23,7 +23,7 @@ type Table a = EquivariantMap (Word a) Bool -- Utility functions -exists f = not . null . filter f +exists f = not . null . filter f forAll f = null . filter (not . f) ext p a = p <> [a] diff --git a/ons-hs.cabal b/ons-hs.cabal index 12506de..4a70b22 100644 --- a/ons-hs.cabal +++ b/ons-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ons-hs -version: 0.2.3.0 +version: 0.3.0.0 synopsis: Implementation of the ONS (Ordered Nominal Sets) library in Haskell description: Nominal sets are structured infinite sets. They have symmetries which make them finitely representable. This library provides basic manipulation of them for the total order symmetry. It includes: products, sums, maps and sets. Can work with custom data types. homepage: https://github.com/Jaxan/ons-hs diff --git a/src/Nominal.hs b/src/Nominal.hs index 35f2bbd..b461274 100644 --- a/src/Nominal.hs +++ b/src/Nominal.hs @@ -21,14 +21,30 @@ getElementE orb = getElement orb (def (index (Proxy :: Proxy a) orb)) omap :: (Nominal a, Nominal b) => (a -> b) -> Orbit a -> Orbit b omap f = toOrbit . f . getElementE --- Enumerate all orbits in a product A x B. In lexicographical order! +-- General combinator +productG :: (Nominal a, Nominal b) => (Int -> Int -> [[Ordering]]) -> Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] +productG strs pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> strs (index pa oa) (index pb ob) + +-- Enumerate all orbits in a product A x B. product :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] -product pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> prodStrings (index pa oa) (index pb ob) +product = productG prodStrings -- Separated product: A * B = { (a,b) | Exist C1, C2 disjoint supporting a, b resp.} separatedProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] -separatedProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> sepProdStrings (index pa oa) (index pb ob) +separatedProduct = productG sepProdStrings --- "Left product": A |x B = { (a,b) | C supports a => C supports b } +-- "Left product": A ⫂ B = { (a,b) | C supports a => C supports b } leftProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] -leftProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> rincProdStrings (index pa oa) (index pb ob) +leftProduct = productG lsupprProdStrings + +-- "Right product": A ⫁ B = { (a,b) | C supports a <= C supports b } +rightProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] +rightProduct = productG rsupplProdStrings + +-- Strictly increasing product = { (a,b) | all elements in a < all elements in b } +increasingProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] +increasingProduct = productG incrSepProdStrings + +-- Strictly decreasing product = { (a,b) | all elements in a > elements in b } +decreasingProduct :: (Nominal a, Nominal b) => Proxy a -> Proxy b -> Orbit a -> Orbit b -> [Orbit (a,b)] +decreasingProduct = productG decrSepProdStrings diff --git a/src/Nominal/Products.hs b/src/Nominal/Products.hs index 3af3070..9c7bf91 100644 --- a/src/Nominal/Products.hs +++ b/src/Nominal/Products.hs @@ -3,34 +3,58 @@ module Nominal.Products where import Control.Applicative import Data.MemoTrie +-- Enumerates strings to compute all possible combinations. Here `LT` means the +-- "current" element goes to the left, `EQ` goes to both, and `GT` goes to the +-- right. The elements are processed from small to large. prodStrings :: Alternative f => Int -> Int -> f [Ordering] prodStrings = memo2 gen where gen 0 0 = pure [] - gen 0 n = pure $ replicate n GT gen n 0 = pure $ replicate n LT + gen 0 n = pure $ replicate n GT gen 1 1 = pure [LT, GT] <|> pure [EQ] <|> pure [GT, LT] gen n m = (LT :) <$> prodStrings (n-1) m <|> (EQ :) <$> prodStrings (n-1) (m-1) <|> (GT :) <$> prodStrings n (m-1) +-- Only produces the combinations where the supports are disjoint sepProdStrings :: Alternative f => Int -> Int -> f [Ordering] sepProdStrings = memo2 gen where gen 0 0 = pure [] - gen 0 n = pure $ replicate n GT gen n 0 = pure $ replicate n LT + gen 0 n = pure $ replicate n GT gen 1 1 = pure [LT, GT] <|> pure [GT, LT] gen n m = (LT :) <$> sepProdStrings (n-1) m <|> (GT :) <$> sepProdStrings n (m-1) -rincProdStrings :: Alternative f => Int -> Int -> f [Ordering] -rincProdStrings = memo2 gen where +-- Combinations where the left element supports the right element +lsupprProdStrings :: Alternative f => Int -> Int -> f [Ordering] +lsupprProdStrings = memo2 gen where gen n 0 = pure $ replicate n LT - gen 0 _ = empty gen 1 1 = pure [EQ] gen n m | n < m = empty - | otherwise = (LT :) <$> rincProdStrings (n-1) m - <|> (EQ :) <$> rincProdStrings (n-1) (m-1) + | otherwise = (LT :) <$> lsupprProdStrings (n-1) m + <|> (EQ :) <$> lsupprProdStrings (n-1) (m-1) + +-- Combinations where the right element supports the left element +rsupplProdStrings :: Alternative f => Int -> Int -> f [Ordering] +rsupplProdStrings = memo2 gen where + gen 0 n = pure $ replicate n GT + gen 1 1 = pure [EQ] + gen n m + | m < n = empty + | otherwise = (EQ :) <$> rsupplProdStrings (n-1) (m-1) + <|> (GT :) <$> rsupplProdStrings n (m-1) + +-- The right support is strictly greater (hence separated) from the left +incrSepProdStrings :: Alternative f => Int -> Int -> f [Ordering] +incrSepProdStrings = memo2 gen where + gen n m = pure $ replicate n LT <|> replicate m GT + +-- The right support is strictly smaller (hence separated) from the left +decrSepProdStrings :: Alternative f => Int -> Int -> f [Ordering] +decrSepProdStrings = memo2 gen where + gen n m = pure $ replicate m GT <|> replicate n LT {- NOTE on performance: Previously, I had INLINABLE and SPECIALIZE pragmas for all above definitions. diff --git a/src/OrbitList.hs b/src/OrbitList.hs index 943c394..e065e6f 100644 --- a/src/OrbitList.hs +++ b/src/OrbitList.hs @@ -63,6 +63,19 @@ repeatRationals :: Int -> OrbitList [Rat] repeatRationals 0 = singleOrbit [] repeatRationals n = productWith (:) rationals (repeatRationals (n-1)) +distinctRationals :: Int -> OrbitList [Rat] +distinctRationals 0 = singleOrbit [] +distinctRationals n = map (uncurry (:)) . OrbitList.separatedProduct rationals $ (distinctRationals (n-1)) + +increasingRationals :: Int -> OrbitList [Rat] +increasingRationals 0 = singleOrbit [] +increasingRationals n = map (uncurry (:)) . OrbitList.increasingProduct rationals $ (increasingRationals (n-1)) + +-- Bell numbers +repeatRationalUpToPerm :: Int -> OrbitList [Rat] +repeatRationalUpToPerm 0 = singleOrbit [] +repeatRationalUpToPerm 1 = map pure rationals +repeatRationalUpToPerm n = OrbitList.map (uncurry (:)) (OrbitList.increasingProduct rationals (repeatRationalUpToPerm (n-1))) <> OrbitList.map (uncurry (:)) (OrbitList.rightProduct rationals (repeatRationalUpToPerm (n-1))) -- Map / Filter / ... @@ -92,8 +105,26 @@ foldl f b = L.foldl (\acc -> f acc . getElementE) b . unOrbitList -- Combinations +productG :: (Nominal a, Nominal b) => (Proxy a -> Proxy b -> Orbit a -> Orbit b -> [OrbPair (OrbRec a) (OrbRec b)]) -> OrbitList a -> OrbitList b -> OrbitList (a, b) +productG f (OrbitList as) (OrbitList bs) = OrbitList . concat $ (f (Proxy :: Proxy a) (Proxy :: Proxy b) <$> as <*> bs) + product :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) -product (OrbitList as) (OrbitList bs) = OrbitList . concat $ (Nominal.product (Proxy :: Proxy a) (Proxy :: Proxy b) <$> as <*> bs) +product = OrbitList.productG Nominal.product + +separatedProduct :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) +separatedProduct = OrbitList.productG Nominal.separatedProduct + +leftProduct :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) +leftProduct = OrbitList.productG Nominal.leftProduct + +rightProduct :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) +rightProduct = OrbitList.productG Nominal.rightProduct + +increasingProduct :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) +increasingProduct = OrbitList.productG Nominal.increasingProduct + +decreasingProduct :: forall a b. (Nominal a, Nominal b) => OrbitList a -> OrbitList b -> OrbitList (a, b) +decreasingProduct = OrbitList.productG Nominal.decreasingProduct productWith :: (Nominal a, Nominal b, Nominal c) => (a -> b -> c) -> OrbitList a -> OrbitList b -> OrbitList c productWith f as bs = map (uncurry f) (OrbitList.product as bs)