joshua/ons-hs
1
Fork 0
mirror of https://github.com/Jaxan/ons-hs.git synced 2025-04-27 14:47:45 +02:00
Code Issues Releases Activity

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

Browse source
This commit is contained in:
Joshua Moerman 2017-11-01 10:26:51 +01:00
parent fa2061ac43
commit 8487919a7c
7 changed files with 236 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
ons-hs.cabal
View file

@ -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

5
src/EquivariantMap.hs
View file

@ -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

6
src/EquivariantSet.hs
View file

@ -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

43
src/Orbit.hs
View file

@ -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

85
src/Support.hs Normal file
View file

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

50
test/Bench.hs Normal file
View file

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

68
test/Spec.hs
View file

@ -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