Implemented Generics for Orbit. This required a move the type families instead of data families.

src/EquivariantMap.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -86,27 +87,25 @@ delete k (EqMap m) = EqMap (Map.delete (toOrbit k) m)
 -- Can be done with just Map.unionWith and without getElementE but is a bit
 -- harder (probably easier). Also true for related functions
 -- op should be equivariant!
-unionWith :: (Orbit k, Orbit v, Ord (Orb k)) => (v -> v -> v) -> EquivariantMap k v -> EquivariantMap k v -> EquivariantMap k v
+unionWith :: forall k v. (Orbit k, Orbit v, Ord (Orb k)) => (v -> v -> v) -> EquivariantMap k v -> EquivariantMap k v -> EquivariantMap k v
 unionWith op (EqMap m1) (EqMap m2) = EqMap (Map.unionWithKey opl m1 m2)
-  where opl ko p1 p2 = let k = getElementE ko in mapel k (mapelInv k p1 `op` mapelInv k p2)
+  where opl ko p1 p2 = let k = getElementE ko :: k in mapel k (mapelInv k p1 `op` mapelInv k p2)
 
-intersectionWith :: (Orbit k, Orbit v1, Orbit v2, Orbit v3, Ord (Orb k)) => (v1 -> v2 -> v3) -> EquivariantMap k v1 -> EquivariantMap k v2 -> EquivariantMap k v3
+intersectionWith :: forall k v1 v2 v3. (Orbit k, Orbit v1, Orbit v2, Orbit v3, Ord (Orb k)) => (v1 -> v2 -> v3) -> EquivariantMap k v1 -> EquivariantMap k v2 -> EquivariantMap k v3
 intersectionWith op (EqMap m1) (EqMap m2) = EqMap (Map.intersectionWithKey opl m1 m2)
-  where opl ko p1 p2 = let k = getElementE ko in mapel k (mapelInv k p1 `op` mapelInv k p2)
+  where opl ko p1 p2 = let k = getElementE ko :: k in mapel k (mapelInv k p1 `op` mapelInv k p2)
-
 
 -- Traversal
 
 -- f should be equivariant
-map :: (Orbit k, Orbit v1, Orbit v2) => (v1 -> v2) -> EquivariantMap k v1 -> EquivariantMap k v2
+map :: forall k v1 v2. (Orbit k, Orbit v1, Orbit v2) => (v1 -> v2) -> EquivariantMap k v1 -> EquivariantMap k v2
 map f (EqMap m) = EqMap (Map.mapWithKey f2 m)
-  where f2 ko p1 = let k = getElementE ko in mapel k (f $ mapelInv k p1)
+  where f2 ko p1 = let k = getElementE ko :: k in mapel k (f $ mapelInv k p1)
 
 mapWithKey :: (Orbit k, Orbit v1, Orbit v2) => (k -> v1 -> v2) -> EquivariantMap k v1 -> EquivariantMap k v2
 mapWithKey f (EqMap m) = EqMap (Map.mapWithKey f2 m)
   where f2 ko p1 = let k = getElementE ko in mapel k (f k $ mapelInv k p1)
 
-
 -- Conversion
 
 keysSet :: EquivariantMap k v -> EquivariantSet k
@@ -119,6 +118,6 @@ fromSet f (EqSet s) = EqMap (Map.fromSet f2 s)
 
 -- Filter
 
-filter :: (Orbit k, Orbit v) => (v -> Bool) -> EquivariantMap k v -> EquivariantMap k v
+filter :: forall k v. (Orbit k, Orbit v) => (v -> Bool) -> EquivariantMap k v -> EquivariantMap k v
 filter p (EqMap m) = EqMap (Map.filterWithKey p2 m)
-  where p2 ko pr = let k = getElementE ko in p $ mapelInv k pr
+  where p2 ko pr = let k = getElementE ko :: k in p $ mapelInv k pr

src/EquivariantSet.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module EquivariantSet where
 
+import Data.Proxy
+
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Semigroup (Semigroup)
@@ -38,15 +42,15 @@ deriving instance Ord (Orb a) => Semigroup (EquivariantSet a)
 -- We could derive a correct instance if I had written generic instances.
 -- Didn't do that yet, but a direct instance is also nice.
 instance Orbit (EquivariantSet a) where
-  newtype Orb (EquivariantSet a) = OrbEqSet (EquivariantSet a)
+  type Orb (EquivariantSet a) = EquivariantSet a
-  toOrbit = OrbEqSet
+  toOrbit = id
   support _ = Support.empty
-  getElement (OrbEqSet x) _ = x
+  getElement x _ = x
-  index _ = 0
+  index _ _ = 0
 
-deriving instance Show (Orb a) => Show (Orb (EquivariantSet a))
+-- deriving instance Show (Orb a) => Show (Orb (EquivariantSet a))
-deriving instance Eq (Orb a) => Eq (Orb (EquivariantSet a))
+-- deriving instance Eq (Orb a) => Eq (Orb (EquivariantSet a))
-deriving instance Ord (Orb a) => Ord (Orb (EquivariantSet a))
+-- deriving instance Ord (Orb a) => Ord (Orb (EquivariantSet a))
 
 
 -- Query
@@ -91,9 +95,9 @@ intersection :: Ord (Orb a) => EquivariantSet a -> EquivariantSet a -> Equivaria
 intersection a b = EqSet $ Set.intersection (unEqSet a) (unEqSet b)
 
 -- This is the meat of the file! Relies on the ordering of Orbit.product
-product :: (Orbit a, Orbit b) => EquivariantSet a -> EquivariantSet b -> EquivariantSet (a, b)
+product :: forall a b. (Orbit a, Orbit b) => EquivariantSet a -> EquivariantSet b -> EquivariantSet (a, b)
 product (EqSet sa) (EqSet sb) = EqSet . Set.fromDistinctAscList . concat
-                              $ Orbit.product <$> Set.toAscList sa <*> Set.toAscList sb
+                              $ Orbit.product (Proxy @a) (Proxy @b) <$> Set.toAscList sa <*> Set.toAscList sb
 
 
 -- Filter

src/Orbit.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -8,20 +8,18 @@ module Orbit
   , module Orbit.Class
   ) where
 
+import Data.Proxy
+
 import Support (Support, Rat(..))
 import qualified Support
 
 import Orbit.Products
 import Orbit.Class
 
--- 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 can get 'default' values, if we don't care about the support.
-getElementE :: Orbit a => Orb a -> a
+getElementE :: forall a. Orbit a => Orb a -> a
-getElementE orb = getElement orb (Support.def (index orb))
+getElementE orb = getElement orb (Support.def (index (Proxy :: Proxy a) orb))
 
 -- We can `map` orbits to orbits for equivariant functions
 omap :: (Orbit a, Orbit b) => (a -> b) -> Orb a -> Orb b
@@ -30,15 +28,11 @@ omap f = toOrbit . f . getElementE
 -- We can construct orbits from rational numbers. There is exactly one orbit,
 -- so this can be represented by the unit type.
 instance Orbit Rat where
-  data Orb Rat = OrbRational
+  type Orb Rat = ()
-  toOrbit _ = OrbRational
+  toOrbit _ = ()
   support r = Support.singleton r
   getElement _ s = Support.min s
-  index _ = 1
+  index _ _ = 1
-
-deriving instance Show (Orb Rat)
-deriving instance Eq (Orb Rat)
-deriving instance Ord (Orb Rat)
 
 
 -- Supports themselves are nominal. Note that this is a very important instance
@@ -47,83 +41,35 @@ deriving instance Ord (Orb Rat)
 -- directly as T = (Trivial Int, Support). The orbit of a given support is
 -- completely specified by an integer.
 instance Orbit Support where
-  newtype Orb Support = OrbSupport Int
+  type Orb Support = Int
-  toOrbit s = OrbSupport (Support.size s)
+  toOrbit s = Support.size s
   support s = s
   getElement _ s = s
-  index (OrbSupport n) = n
+  index _ n = n
-
-deriving instance Show (Orb Support)
-deriving instance Eq (Orb Support)
-deriving instance Ord (Orb Support)
 
 
--- Disjoint unions are easy: just work on either side.
+deriving instance (Orbit a, Orbit b) => Orbit (Either a b)
-instance (Orbit a, Orbit b) => Orbit (Either a b) where
-  newtype Orb (Either a b) = OrbEither (Either (Orb a) (Orb b))
-  toOrbit (Left a) = OrbEither (Left (toOrbit a))
-  toOrbit (Right b) = OrbEither (Right (toOrbit b))
-  support (Left a) = support a
-  support (Right b) = support b
-  getElement (OrbEither (Left oa)) s = Left (getElement oa s)
-  getElement (OrbEither (Right ob)) s = Right (getElement ob s)
-  index (OrbEither (Left oa)) = index oa
-  index (OrbEither (Right ob)) = index ob
 
-deriving instance (Show (Orb a), Show (Orb b)) => Show (Orb (Either a b))
+deriving instance Orbit ()
-deriving instance (Eq (Orb a), Eq (Orb b)) => Eq (Orb (Either a b))
+deriving instance (Orbit a, Orbit b) => Orbit (a, b)
-deriving instance (Ord (Orb a), Ord (Orb b)) => Ord (Orb (Either a b))
+deriving instance (Orbit a, Orbit b, Orbit c) => Orbit (a, b, c)
+deriving instance (Orbit a, Orbit b, Orbit c, Orbit d) => Orbit (a, b, c, d)
 
+deriving instance Orbit a => Orbit [a]
+deriving instance Orbit a => Orbit (Maybe a)
 
--- The cartesian product is a non-trivial instance. We represent orbits in a
--- product as described inthe paper: with two orbits, and how the match. The
--- matchings can be given as strings, which can be easily enumerated, in order
--- to enumerate the whole product.
-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 = 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) = 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 . 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))
-deriving instance (Eq (Orb a), Eq (Orb b)) => Eq (Orb (a, b))
-deriving instance (Ord (Orb a), Ord (Orb b)) => Ord (Orb (a, b))
-
--- Could be in prelude or some other general purpose lib
-{-# INLINABLE partitionOrd #-}
-partitionOrd :: (a -> Ordering) -> [a] -> ([a], [a])
-partitionOrd p xs = foldr (selectOrd p) ([], []) xs
-
-selectOrd :: (a -> Ordering) -> a -> ([a], [a]) -> ([a], [a])
-selectOrd f x ~(ls, rs) = case f x of
-  LT -> (x : ls, rs)
-  EQ -> (x : ls, x : rs)
-  GT -> (ls, x : rs)
 
 -- Enumerate all orbits in a product A x B. In lexicographical order!
-product :: (Orbit a, Orbit b) => Orb a -> Orb b -> [Orb (a, b)]
+product :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
-product oa ob = OrbPair oa ob <$> prodStrings (index oa) (index ob)
+product pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> prodStrings (index pa oa) (index pb ob)
 
 -- Separated product: A * B = { (a,b) | Exist C1, C2 disjoint supporting a, b resp.}
-separatedProduct :: (Orbit a, Orbit b) => Orb a -> Orb b -> [Orb (a, b)]
+separatedProduct :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
-separatedProduct oa ob = OrbPair oa ob <$> sepProdStrings (index oa) (index ob)
+separatedProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> sepProdStrings (index pa oa) (index pb  ob)
 
 -- "Left product": A |x B = { (a,b) | C supports a => C supports b }
-leftProduct :: (Orbit a, Orbit b) => Orb a -> Orb b -> [Orb (a, b)]
+leftProduct :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
-leftProduct oa ob = OrbPair oa ob <$> rincProdStrings (index oa) (index ob)
+leftProduct pa pb oa ob = OrbPair (OrbRec oa) (OrbRec ob) <$> rincProdStrings (index pa oa) (index pb ob)
 
 {-# INLINABLE product #-}
 {-# INLINABLE separatedProduct #-}
@@ -136,25 +82,8 @@ newtype Trivial a = Trivial { unTrivial :: a }
 
 -- We need to remember the value!
 instance Orbit (Trivial a) where
-  newtype Orb (Trivial a) = OrbTrivial a
+  type Orb (Trivial a) = a
-  toOrbit (Trivial a) = OrbTrivial a
+  toOrbit (Trivial a) = a
   support _ = Support.empty
-  getElement (OrbTrivial a) _ = Trivial a
+  getElement a _ = Trivial a
-  index _ = 0
+  index _ _ = 0
-
-deriving instance Show a => Show (Orb (Trivial a))
-deriving instance Eq a => Eq (Orb (Trivial a))
-deriving instance Ord a => Ord (Orb (Trivial a))
-
-
--- Orbits themselves are trivial.
-instance Orbit a => Orbit (Orb a) where
-  newtype Orb (Orb a) = OrbOrb (Orb a)
-  toOrbit a = OrbOrb a
-  support _ = Support.empty
-  getElement (OrbOrb oa) _ = oa
-  index _ = 0
-
-deriving instance Show (Orb a) => Show (Orb (Orb a))
-deriving instance Eq (Orb a) => Eq (Orb (Orb a))
-deriving instance Ord (Orb a) => Ord (Orb (Orb a))

src/Orbit/Class.hs

@@ -1,7 +1,18 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Orbit.Class where
 
+import Data.Void
+import Data.Proxy (Proxy(..))
+import GHC.Generics
+
 import Support
 
 -- This is the main meat of the package. The Orbit typeclass, it gives us ways
@@ -14,43 +25,134 @@ import Support
 -- implemented, even when the type 'a' does not have an Ord instance.
 --
 -- Laws / conditions:
--- * index . toOrbit == Set.size . support
+-- * index . toOrbit == size . support
 -- * getElement o s is defined if index o == Set.size s
 class Orbit a where
-  data Orb a :: *
+  type Orb a :: *
   toOrbit :: a -> Orb a
   support :: a -> Support
   getElement :: Orb a -> Support -> a
-  index :: Orb a -> Int
+  index :: Proxy a -> Orb a -> Int
 
+  -- default Orb a :: (Generic a, GOrbit (Rep a)) => *
+  type Orb a = GOrb (Rep a)
 
-{-
+  default toOrbit :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => a -> Orb a
-I tried to do generics, but failed. One cannot do generic injective
+  toOrbit = gtoOrbit . from
-data constructors. I will keep it here now, for later reference.
 
-{-# language DefaultSignatures #-}
+  default support :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => a -> Support
-{-# LANGUAGE FlexibleContexts #-}
-import GHC.Generic
-
-  default Orb a :: (Generic a, GOrbit (Rep a)) => *
-  data Orb a = Orb () -- how to make a default data instance declaration?
-
-  default toOrbit :: (Generic a, GOrbit (Rep a)) => a -> Orb a
-  toOrbit = _ . gtoOrbit . from
-
-  default support :: (Generic a, GOrbit (Rep a)) => a -> Support
   support = gsupport . from
 
-  default getElement :: (Generic a, GOrbit (Rep a)) => Orb a -> Support -> a
+  default getElement :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => Orb a -> Support -> a
-  getElement = undefined
+  getElement o s = to (ggetElement o s)
 
-  default index :: (Generic a, GOrbit (Rep a)) => Orb a -> Int
+  default index :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => Proxy a -> Orb a -> Int
-  index = undefined
+  index _ = gindex (Proxy :: Proxy (Rep a))
 
+  {-# INLINABLE toOrbit #-}
+  {-# INLINABLE support #-}
+  {-# INLINABLE getElement #-}
+  {-# INLINABLE index #-}
+
+
+-- Generic class, so that custom data types can be derived
 class GOrbit f where
-  data GOrb f :: * -> *
+  type GOrb f :: *
-  gtoOrbit :: f a -> GOrb f a
+  gtoOrbit :: f a -> GOrb f
   gsupport :: f a -> Support
-  ggetElement :: GOrb f a -> Support -> f a
+  ggetElement :: GOrb f -> Support -> f a
-  gindex :: GOrb f a -> Int
+  gindex :: Proxy f -> GOrb f -> Int
--}
+
+
+-- Instance for the Void type
+instance GOrbit V1 where
+  type GOrb V1 = Void
+  gtoOrbit v = undefined
+  gsupport _ = empty
+  ggetElement v _ = undefined
+  gindex _ _ = 0
+
+
+-- Instance for the Uni type
+instance GOrbit U1 where
+  type GOrb U1 = ()
+  gtoOrbit _ = ()
+  gsupport _ = empty
+  ggetElement _ _ = U1
+  gindex _ _ = 0
+
+
+-- Disjoint unions are easy: just work on either side.
+instance (GOrbit f, GOrbit g) => GOrbit (f :+: g) where
+  type GOrb (f :+: g) = Either (GOrb f) (GOrb g)
+  gtoOrbit (L1 a) = Left  (gtoOrbit a)
+  gtoOrbit (R1 b) = Right (gtoOrbit b)
+  gsupport (L1 a) = gsupport a
+  gsupport (R1 b) = gsupport b
+  ggetElement (Left  oa) s = L1 (ggetElement oa s)
+  ggetElement (Right ob) s = R1 (ggetElement ob s)
+  gindex proxy (Left  oa) = gindex (left proxy) oa where
+    left :: proxy (f :+: g) -> Proxy f
+    left _ = Proxy
+  gindex proxy (Right ob) = gindex (right proxy) ob where
+    right :: proxy (f :+: g) -> Proxy g
+    right _ = Proxy
+
+
+-- The cartesian product is a non-trivial instance. We represent orbits in a
+-- product as described inthe paper: with two orbits, and how the match. The
+-- matchings can be given as strings, which can be easily enumerated, in order
+-- to enumerate the whole product.
+instance (GOrbit f, GOrbit g) => GOrbit (f :*: g) where
+  type GOrb (f :*: g) = OrbPair (GOrb f) (GOrb g)
+  gtoOrbit ~(a :*: b) = OrbPair (gtoOrbit a) (gtoOrbit b) (bla sa sb) 
+    where
+      sa = toList $ gsupport a
+      sb = toList $ gsupport 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)
+  gsupport ~(a :*: b) = (gsupport a) `union` (gsupport b)
+  ggetElement (OrbPair oa ob l) s = (ggetElement oa $ toSet ls) :*: (ggetElement ob $ toSet rs)
+    where
+      ~(ls, rs) = partitionOrd fst . zip l . toList $ s
+      toSet = fromDistinctAscList . fmap snd
+  gindex _ (OrbPair _ _ l) = length l
+
+data OrbPair a b = OrbPair !a !b ![Ordering]
+  deriving (Show, Eq, Ord, Generic)
+
+-- Could be in prelude or some other general purpose lib
+partitionOrd :: (a -> Ordering) -> [a] -> ([a], [a])
+partitionOrd p xs = foldr (selectOrd p) ([], []) xs
+
+selectOrd :: (a -> Ordering) -> a -> ([a], [a]) -> ([a], [a])
+selectOrd f x ~(ls, rs) = case f x of
+  LT -> (x : ls, rs)
+  EQ -> (x : ls, x : rs)
+  GT -> (ls, x : rs)
+
+
+instance Orbit a => GOrbit (K1 c a) where
+  type GOrb (K1 c a) = OrbRec a
+  gtoOrbit (K1 x) = OrbRec (toOrbit x)
+  gsupport (K1 x) = support x
+  ggetElement (OrbRec x) s = K1 $ getElement x s
+  gindex p (OrbRec o) = index (Proxy :: Proxy a) o
+
+newtype OrbRec a = OrbRec (Orb a)
+  deriving (Generic)
+deriving instance Show (Orb a) => Show (OrbRec a)
+deriving instance Ord (Orb a) => Ord (OrbRec a)
+deriving instance Eq (Orb a) => Eq (OrbRec a)
+
+
+instance GOrbit f => GOrbit (M1 i c f) where
+  type GOrb (M1 i c f) = GOrb f
+  gtoOrbit (M1 x) = gtoOrbit x
+  gsupport (M1 x) = gsupport x
+  ggetElement x s = M1 $ ggetElement x s
+  gindex p o = gindex (Proxy :: Proxy f) o