Adds units tests + benchmarking. Abstracted Support to its own modules. Performance improvements

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

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

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
 

src/Orbit.hs

@@ -5,28 +5,14 @@
 
 module Orbit where
 
-import Data.Set (Set)
+import Support (Support, Rat(..))
-import qualified Data.Set as Set
+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
+  support r = Support.singleton r
-  getElement _ s
+  getElement _ s = Support.min s
-    | Set.null s = undefined
-    | otherwise = Set.findMin 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
+      sa = Support.toList $ support a
-      sb = Set.toAscList $ support b
+      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
+      (ls, rs) = partitionOrd fst . zip l . Support.toList $ s
-      toSet = Set.fromAscList . fmap snd
+      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
 

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
+-}

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
+             ]
+         ]

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
+