mirror of
https://github.com/Jaxan/ons-hs.git
synced 2025-04-27 14:47:45 +02:00
More types of products
This commit is contained in:
parent
b273931b9c
commit
4698b4d260
6 changed files with 89 additions and 15 deletions
|
@ -114,6 +114,9 @@ values, that can be much faster.
|
||||||
|
|
||||||
## Changelog
|
## Changelog
|
||||||
|
|
||||||
|
version 0.3.0.0 (2024-11-06):
|
||||||
|
* More types of products
|
||||||
|
|
||||||
version 0.2.3.0 (2024-11-05):
|
version 0.2.3.0 (2024-11-05):
|
||||||
* Updates the testing and benchmarking framework.
|
* Updates the testing and benchmarking framework.
|
||||||
* Replaced benchmarking dependencies, making the build process much faster.
|
* Replaced benchmarking dependencies, making the build process much faster.
|
||||||
|
|
|
@ -23,7 +23,7 @@ type Table a = EquivariantMap (Word a) Bool
|
||||||
|
|
||||||
|
|
||||||
-- Utility functions
|
-- Utility functions
|
||||||
exists f = not . null . filter f
|
exists f = not . null . filter f
|
||||||
forAll f = null . filter (not . f)
|
forAll f = null . filter (not . f)
|
||||||
ext p a = p <> [a]
|
ext p a = p <> [a]
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
cabal-version: 2.2
|
cabal-version: 2.2
|
||||||
name: ons-hs
|
name: ons-hs
|
||||||
version: 0.2.3.0
|
version: 0.3.0.0
|
||||||
synopsis: Implementation of the ONS (Ordered Nominal Sets) library in Haskell
|
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.
|
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
|
homepage: https://github.com/Jaxan/ons-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 :: (Nominal a, Nominal b) => (a -> b) -> Orbit a -> Orbit b
|
||||||
omap f = toOrbit . f . getElementE
|
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 :: (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.}
|
-- 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 :: (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 :: (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
|
||||||
|
|
|
@ -3,34 +3,58 @@ module Nominal.Products where
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.MemoTrie
|
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 :: Alternative f => Int -> Int -> f [Ordering]
|
||||||
prodStrings = memo2 gen where
|
prodStrings = memo2 gen where
|
||||||
gen 0 0 = pure []
|
gen 0 0 = pure []
|
||||||
gen 0 n = pure $ replicate n GT
|
|
||||||
gen n 0 = pure $ replicate n LT
|
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 1 1 = pure [LT, GT] <|> pure [EQ] <|> pure [GT, LT]
|
||||||
gen n m = (LT :) <$> prodStrings (n-1) m
|
gen n m = (LT :) <$> prodStrings (n-1) m
|
||||||
<|> (EQ :) <$> prodStrings (n-1) (m-1)
|
<|> (EQ :) <$> prodStrings (n-1) (m-1)
|
||||||
<|> (GT :) <$> prodStrings n (m-1)
|
<|> (GT :) <$> prodStrings n (m-1)
|
||||||
|
|
||||||
|
-- Only produces the combinations where the supports are disjoint
|
||||||
sepProdStrings :: Alternative f => Int -> Int -> f [Ordering]
|
sepProdStrings :: Alternative f => Int -> Int -> f [Ordering]
|
||||||
sepProdStrings = memo2 gen where
|
sepProdStrings = memo2 gen where
|
||||||
gen 0 0 = pure []
|
gen 0 0 = pure []
|
||||||
gen 0 n = pure $ replicate n GT
|
|
||||||
gen n 0 = pure $ replicate n LT
|
gen n 0 = pure $ replicate n LT
|
||||||
|
gen 0 n = pure $ replicate n GT
|
||||||
gen 1 1 = pure [LT, GT] <|> pure [GT, LT]
|
gen 1 1 = pure [LT, GT] <|> pure [GT, LT]
|
||||||
gen n m = (LT :) <$> sepProdStrings (n-1) m
|
gen n m = (LT :) <$> sepProdStrings (n-1) m
|
||||||
<|> (GT :) <$> sepProdStrings n (m-1)
|
<|> (GT :) <$> sepProdStrings n (m-1)
|
||||||
|
|
||||||
rincProdStrings :: Alternative f => Int -> Int -> f [Ordering]
|
-- Combinations where the left element supports the right element
|
||||||
rincProdStrings = memo2 gen where
|
lsupprProdStrings :: Alternative f => Int -> Int -> f [Ordering]
|
||||||
|
lsupprProdStrings = memo2 gen where
|
||||||
gen n 0 = pure $ replicate n LT
|
gen n 0 = pure $ replicate n LT
|
||||||
gen 0 _ = empty
|
|
||||||
gen 1 1 = pure [EQ]
|
gen 1 1 = pure [EQ]
|
||||||
gen n m
|
gen n m
|
||||||
| n < m = empty
|
| n < m = empty
|
||||||
| otherwise = (LT :) <$> rincProdStrings (n-1) m
|
| otherwise = (LT :) <$> lsupprProdStrings (n-1) m
|
||||||
<|> (EQ :) <$> rincProdStrings (n-1) (m-1)
|
<|> (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:
|
{- NOTE on performance:
|
||||||
Previously, I had INLINABLE and SPECIALIZE pragmas for all above definitions.
|
Previously, I had INLINABLE and SPECIALIZE pragmas for all above definitions.
|
||||||
|
|
|
@ -63,6 +63,19 @@ repeatRationals :: Int -> OrbitList [Rat]
|
||||||
repeatRationals 0 = singleOrbit []
|
repeatRationals 0 = singleOrbit []
|
||||||
repeatRationals n = productWith (:) rationals (repeatRationals (n-1))
|
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 / ...
|
-- Map / Filter / ...
|
||||||
|
|
||||||
|
@ -92,8 +105,26 @@ foldl f b = L.foldl (\acc -> f acc . getElementE) b . unOrbitList
|
||||||
|
|
||||||
-- Combinations
|
-- 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 :: 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 :: (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)
|
productWith f as bs = map (uncurry f) (OrbitList.product as bs)
|
||||||
|
|
Loading…
Add table
Reference in a new issue