diff --git a/ons-hs.cabal b/ons-hs.cabal index 3b66d4f..54c6771 100644 --- a/ons-hs.cabal +++ b/ons-hs.cabal @@ -18,8 +18,10 @@ library exposed-modules: EquivariantMap , EquivariantSet , Orbit + , Support build-depends: base >= 4.7 && < 5 , containers + , data-ordlist default-language: Haskell2010 executable ons-hs-exe @@ -30,6 +32,17 @@ executable ons-hs-exe , ons-hs default-language: Haskell2010 +benchmark ons-hs-bench + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Bench.hs + build-depends: base + , criterion + , deepseq + , ons-hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + default-language: Haskell2010 + test-suite ons-hs-test type: exitcode-stdio-1.0 hs-source-dirs: test diff --git a/src/EquivariantMap.hs b/src/EquivariantMap.hs index bc05898..85dc429 100644 --- a/src/EquivariantMap.hs +++ b/src/EquivariantMap.hs @@ -13,6 +13,7 @@ import qualified Data.Map as Map import EquivariantSet (EquivariantSet(EqSet)) import Orbit +import Support -- TODO: foldable / traversable -- TODO: adjust / alter / update @@ -39,7 +40,7 @@ deriving instance Ord (Orb k) => Semigroup (EquivariantMap k v) -- Helper functions mapel :: (Orbit k, Orbit v) => k -> v -> (Orb v, [Bool]) -mapel k v = (toOrbit v, bv (Set.toAscList (support k)) (Set.toAscList (support v))) +mapel k v = (toOrbit v, bv (Support.toList (support k)) (Support.toList (support v))) bv :: [Rat] -> [Rat] -> [Bool] bv l [] = replicate (length l) False @@ -50,7 +51,7 @@ bv (x:xs) (y:ys) = case compare x y of GT -> error "Non-equivariant function" mapelInv :: (Orbit k, Orbit v) => k -> (Orb v, [Bool]) -> v -mapelInv x (oy, bv) = getElement oy (Set.fromAscList . fmap fst . Prelude.filter snd $ zip (Set.toAscList (support x)) bv) +mapelInv x (oy, bv) = getElement oy (Support.fromDistinctAscList . fmap fst . Prelude.filter snd $ zip (Support.toList (support x)) bv) -- Query diff --git a/src/EquivariantSet.hs b/src/EquivariantSet.hs index c6a8bfd..7873122 100644 --- a/src/EquivariantSet.hs +++ b/src/EquivariantSet.hs @@ -12,6 +12,7 @@ import qualified Data.Set as Set import Data.Semigroup (Semigroup) import Orbit +import Support -- TODO: think about folds (the monoids should be nominal?) -- TODO: partition / fromList / ... @@ -39,7 +40,7 @@ deriving instance Ord (Orb a) => Semigroup (EquivariantSet a) instance Orbit (EquivariantSet a) where newtype Orb (EquivariantSet a) = OrbEqSet (EquivariantSet a) toOrbit = OrbEqSet - support _ = Set.empty + support _ = Support.empty getElement (OrbEqSet x) _ = x index _ = 0 @@ -109,7 +110,8 @@ filter f (EqSet s) = EqSet . Set.filter (f . getElementE) $ s map :: (Orbit a, Orbit b, Ord (Orb b)) => (a -> b) -> EquivariantSet a -> EquivariantSet b map f = EqSet . Set.map (toOrbit . f . getElementE) . unEqSet --- f should also preserve order! +-- f should also preserve order on the orbit types! +-- This means you should know the representation to use it well mapMonotonic :: (Orbit a, Orbit b) => (a -> b) -> EquivariantSet a -> EquivariantSet b mapMonotonic f = EqSet . Set.mapMonotonic (toOrbit . f . getElementE) . unEqSet diff --git a/src/Orbit.hs b/src/Orbit.hs index 1e4b3a1..3fdbe59 100644 --- a/src/Orbit.hs +++ b/src/Orbit.hs @@ -5,28 +5,14 @@ module Orbit where -import Data.Set (Set) -import qualified Data.Set as Set +import Support (Support, Rat(..)) +import qualified Support -- TODO: Make generic instances (we already have sums and products) -- TODO: For products: replace [Ordering] with Vec Ordering if better -- TODO: replace Support by an ordered vector / list for speed? --- We take some model of the dense linear order. The rationals are a natural --- choice. (Note that every countable model is order-isomorphic, so it doesn't --- matter so much in the end.) I wrap it in a newtype, so we will only use the --- Ord instances, and because it's not very nice to work with type synonyms. --- Show instance included for debugging. -newtype Rat = Rat { unRat :: Rational } - deriving (Eq, Ord, Show) - - --- A support is a set of rational numbers, which can always be ordered. Can --- also be represented as sorted list/vector. Maybe I should also make it into --- a newtype. -type Support = Set Rat - -- This is the main meat of the package. The Orbit typeclass, it gives us ways -- to manipulate nominal elements in sets and maps. The type class has -- associated data to represent an orbit of type a. This is often much easier @@ -48,7 +34,7 @@ class Orbit a where -- We can get 'default' values, if we don't care about the support. getElementE :: Orbit a => Orb a -> a -getElementE orb = getElement orb (Set.fromAscList . fmap (Rat . toRational) $ [1 .. index orb]) +getElementE orb = getElement orb (Support.def (index orb)) -- We can construct orbits from rational numbers. There is exactly one orbit, @@ -56,10 +42,8 @@ getElementE orb = getElement orb (Set.fromAscList . fmap (Rat . toRational) $ [1 instance Orbit Rat where data Orb Rat = OrbRational toOrbit _ = OrbRational - support r = Set.singleton r - getElement _ s - | Set.null s = undefined - | otherwise = Set.findMin s + support r = Support.singleton r + getElement _ s = Support.min s index _ = 1 deriving instance Show (Orb Rat) @@ -74,7 +58,7 @@ deriving instance Ord (Orb Rat) -- completely specified by an integer. instance Orbit Support where newtype Orb Support = OrbSupport Int - toOrbit s = OrbSupport (Set.size s) + toOrbit s = OrbSupport (Support.size s) support s = s getElement _ s = s index (OrbSupport n) = n @@ -109,19 +93,19 @@ instance (Orbit a, Orbit b) => Orbit (a, b) where data Orb (a,b) = OrbPair !(Orb a) !(Orb b) ![Ordering] toOrbit (a, b) = OrbPair (toOrbit a) (toOrbit b) (bla sa sb) where - sa = Set.toAscList $ support a - sb = Set.toAscList $ support b + sa = Support.toList $ support a + sb = Support.toList $ support b bla [] ys = fmap (const GT) ys bla xs [] = fmap (const LT) xs bla (x:xs) (y:ys) = case compare x y of LT -> LT : (bla xs (y:ys)) EQ -> EQ : (bla xs ys) GT -> GT : (bla (x:xs) ys) - support (a, b) = Set.union (support a) (support b) + support (a, b) = Support.union (support a) (support b) getElement (OrbPair oa ob l) s = (getElement oa $ toSet ls, getElement ob $ toSet rs) where - (ls, rs) = partitionOrd fst . zip l . Set.toAscList $ s - toSet = Set.fromAscList . fmap snd + (ls, rs) = partitionOrd fst . zip l . Support.toList $ s + toSet = Support.fromDistinctAscList . fmap snd index (OrbPair _ _ l) = length l deriving instance (Show (Orb a), Show (Orb b)) => Show (Orb (a, b)) @@ -143,6 +127,7 @@ selectOrd f x ~(ls, rs) = case f x of product :: (Orbit a, Orbit b) => Orb a -> Orb b -> [Orb (a, b)] product oa ob = OrbPair oa ob <$> prodStrings (index oa) (index ob) +-- I tried Seq [Ordering], it was slower prodStrings :: Int -> Int -> [[Ordering]] prodStrings 0 0 = [[]] prodStrings 0 n = [replicate n GT] @@ -161,7 +146,7 @@ newtype Trivial a = Trivial { unTrivial :: a } instance Orbit (Trivial a) where newtype Orb (Trivial a) = OrbTrivial a toOrbit (Trivial a) = OrbTrivial a - support _ = Set.empty + support _ = Support.empty getElement (OrbTrivial a) _ = Trivial a index _ = 0 @@ -174,7 +159,7 @@ deriving instance Ord a => Ord (Orb (Trivial a)) instance Orbit a => Orbit (Orb a) where newtype Orb (Orb a) = OrbOrb (Orb a) toOrbit a = OrbOrb a - support _ = Set.empty + support _ = Support.empty getElement (OrbOrb oa) _ = oa index _ = 0 diff --git a/src/Support.hs b/src/Support.hs new file mode 100644 index 0000000..14f2f08 --- /dev/null +++ b/src/Support.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Support where + +import qualified Data.List as List +import qualified Data.List.Ordered as OrdList +import GHC.Generics (Generic) + + +-- We take some model of the dense linear order. The rationals are a natural +-- choice. (Note that every countable model is order-isomorphic, so it doesn't +-- matter so much in the end.) I wrap it in a newtype, so we will only use the +-- Ord instances, and because it's not very nice to work with type synonyms. +-- Show instance included for debugging. +newtype Rat = Rat { unRat :: Rational } + deriving (Eq, Ord, Show, Generic) + +-- A support is a set of rational numbers, which can always be ordered. I tried +-- an implementation using Data.Set, it was slower. We could also use Vectors? +-- Note that a sorted list makes sense in many cases, since we do not really +-- need membership queries on this type. Maybe make this into a newtype. +type Support = [Rat] -- always sorted + +size :: Support -> Int +size = List.length + +null :: Support -> Bool +null = List.null + +min :: Support -> Rat +min = List.head + +empty :: Support +empty = [] + +union :: Support -> Support -> Support +union = OrdList.union + +singleton :: Rat -> Support +singleton r = [r] + +toList :: Support -> Support +toList = id + +fromList, fromAscList, fromDistinctAscList :: [Rat] -> Support +fromList = OrdList.nubSort +fromAscList = OrdList.nub +fromDistinctAscList = id + +def :: Int -> Support +def n = fromDistinctAscList . fmap (Rat . toRational) $ [1..n] + +{- +-- The Data.Set implementation +import Data.Set (Set) +import qualified Data.Set as Set + +type Support = Set Rat + +size :: Support -> Int +size = Set.size + +null :: Support -> Bool +null = Set.null + +min :: Support -> Rat +min = Set.findMin + +empty :: Support +empty = Set.empty + +union :: Support -> Support -> Support +union = Set.union + +singleton :: Rat -> Support +singleton = Set.singleton + +toList :: Support -> [Rat] +toList = Set.toAscList + +fromList, fromAscList, fromDistinctAscList :: [Rat] -> Support +fromList = Set.fromList +fromAscList = Set.fromAscList +fromDistinctAscList = Set.fromDistinctAscList +-} diff --git a/test/Bench.hs b/test/Bench.hs new file mode 100644 index 0000000..e6d7245 --- /dev/null +++ b/test/Bench.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +import Control.DeepSeq +import Criterion.Main + +import Orbit +import Support +import EquivariantSet +import EquivariantMap + +instance NFData Rat + +(\/) :: Ord (Orb a) => EquivariantSet a -> EquivariantSet a -> EquivariantSet a +(\/) = EquivariantSet.union + +bigset :: (Rat, Rat, Rat, _) -> Bool +bigset (p, q, r, t) = EquivariantSet.member t s where + s1 = singleOrbit ((p, p), p) \/ singleOrbit ((p, p), q) \/ singleOrbit ((p, q), r) + s2 = singleOrbit (p, q) \/ singleOrbit (q, r) \/ singleOrbit (r, p) + s = EquivariantSet.product s1 s2 + +bigmap :: (Rat, Rat, _) -> Maybe (Rat, (Rat, Rat)) +bigmap (p, q, t) = EquivariantMap.lookup t m3 where + s = EquivariantSet.product (EquivariantSet.singleOrbit (p, q)) (EquivariantSet.singleOrbit (q, p)) + s2 = EquivariantSet.product s s + s3 = EquivariantSet.map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2 + m1 = EquivariantMap.fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s2 + m2 = EquivariantMap.fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s3 + m3 = EquivariantMap.unionWith const m1 m2 + +main :: IO () +main = defaultMain + -- ~ 300 ms + [ bgroup "bigmap" + [ bench "1 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43)))) -- found + , bench "2 n" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65)))) -- not found + , bench "3 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65)))) -- found + , bench "4 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1)))) -- found + , bench "5 y" $ nf bigmap (Rat 1, Rat 2, (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200)))) -- found + ] + -- ~ 13 us + , bgroup "bigset" + [ bench "1 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) )) -- found + , bench "2 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2) )) -- found + , bench "3 n" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2) )) -- not found + , bench "4 y" $ nf bigset (Rat 1, Rat 2, Rat 3, ( ((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4) )) -- found + ] + ] diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..0f100bb 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,68 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- TODO: QuickCheck instead of these unit tests + +import GHC.Stack + +import Data.Maybe (isJust, isNothing) +import Prelude (id, const, not, ($), error, return, Bool(..), IO(..), print, (>>=)) +import qualified Prelude as P -- hide stuff + +import Support (Rat(..)) +import EquivariantSet (product, member, singleOrbit, union, map, isSubsetOf) +import EquivariantMap (unionWith, lookup, fromSet) + +assert :: (a -> Bool) -> a -> IO () +assert f x = case f x of + True -> return () + False -> whoCreated x >>= print + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + let p = Rat 1 + let q = Rat 2 + let s = product (singleOrbit (p, q)) (singleOrbit (q, p)) + assert id $ member ((Rat 1, Rat 2), (Rat 5, Rat 4)) s + assert not $ member ((Rat 5, Rat 2), (Rat 5, Rat 4)) s + assert id $ member ((Rat 1, Rat 2), (Rat 2, Rat 1)) s + assert id $ member ((Rat 3, Rat 4), (Rat 2, Rat 1)) s + + let s2 = product s s + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 4))) s2 + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 2), (Rat 5, Rat 1))) s2 + assert id $ member (((Rat 1, Rat 2), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 + assert id $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 1))) s2 + assert not $ member (((Rat 0, Rat 27), (Rat 5, Rat 4)), ((Rat 1, Rat 200), (Rat 5, Rat 5))) s2 + + let s3 = map (\((a, b), (c, d)) -> ((b, a), (d, c))) s2 + assert id $ member (((Rat 5, Rat 4), (Rat 1, Rat 2)), ((Rat 5, Rat 4), (Rat 1, Rat 2))) s3 + assert id $ member (((Rat 2, Rat 1), (Rat 4, Rat 5)), ((Rat 2, Rat 1), (Rat 4, Rat 5))) s3 + + let m1 = fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s2 + assert isJust $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 3, Rat 2))) m1 + assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 1, Rat 2))) m1 + + let m2 = fromSet (\(((a, b), (c, d)), ((e, f), (g, h))) -> (b,(d,h))) s3 + assert isJust $ lookup (((Rat 6, Rat 1), (Rat 1, Rat 5)), ((Rat 4, Rat 1), (Rat 1, Rat 3))) m2 + assert isNothing $ lookup (((Rat 1, Rat 2), (Rat 2, Rat 1)), ((Rat 1, Rat 2), (Rat 4, Rat 2))) m2 + + let m3 = unionWith const m1 m2 + assert isJust $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 43))) m3 + assert isNothing $ lookup (((Rat 1, Rat 23), (Rat 5, Rat 4)), ((Rat 2, Rat 3), (Rat 54, Rat 65))) m3 + assert isJust $ lookup (((Rat 1, Rat 100), (Rat 90, Rat 20)), ((Rat 30, Rat 80), (Rat 70, Rat 65))) m3 + assert isJust $ lookup (((Rat 1, Rat 100), (Rat 100, Rat 1)), ((Rat 1, Rat 100), (Rat 100, Rat 1))) m3 + assert isJust $ lookup (((Rat 100, Rat 1), (Rat 1, Rat 100)), ((Rat 200, Rat 2), (Rat 2, Rat 200))) m3 + + let r = Rat 3 + let s1 = singleOrbit ((p, p), p) `union` singleOrbit ((p, p), q) `union` singleOrbit ((p, q), r) + let s2 = singleOrbit (p, q) `union` singleOrbit (q, r) `union` singleOrbit (r, p) + assert id $ s2 `isSubsetOf` product (singleOrbit p) (singleOrbit p) + assert not $ product (singleOrbit p) (singleOrbit p) `isSubsetOf` s2 + + let s = product s1 s2 + assert id $ member ( ((Rat 1, Rat 1), Rat 1), (Rat 1, Rat 2) ) s + assert id $ member ( ((Rat 37, Rat 37), Rat 42), (Rat 1, Rat 2) ) s + assert not $ member ( ((Rat 37, Rat 31), Rat 42), (Rat 1, Rat 2) ) s + assert id $ member ( ((Rat 1, Rat 2), Rat 3), (Rat 5, Rat 4) ) s +