More types of products

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.

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

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

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.

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)