mirror of
https://github.com/Jaxan/ons-hs.git
synced 2025-04-27 14:47:45 +02:00
Implemented Generics for Orbit. This required a move the type families instead of data families.
This commit is contained in:
Joshua Moerman
parent
72d6310cae
commit
da2265da90
4 changed files with 179 additions and 145 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
toOrbit = OrbEqSet
|
||||
type Orb (EquivariantSet a) = EquivariantSet a
|
||||
toOrbit = id
|
||||
support _ = Support.empty
|
||||
getElement (OrbEqSet x) _ = x
|
||||
index _ = 0
|
||||
getElement x _ = x
|
||||
index _ _ = 0
|
||||
|
||||
deriving instance Show (Orb a) => Show (Orb (EquivariantSet a))
|
||||
deriving instance Eq (Orb a) => Eq (Orb (EquivariantSet a))
|
||||
deriving instance Ord (Orb a) => Ord (Orb (EquivariantSet a))
|
||||
-- deriving instance Show (Orb a) => Show (Orb (EquivariantSet a))
|
||||
-- deriving instance Eq (Orb a) => Eq (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
|
||||
|
|
|
|||
129
src/Orbit.hs
129
src/Orbit.hs
|
|
@ -1,5 +1,5 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# 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 orb = getElement orb (Support.def (index orb))
|
||||
getElementE :: forall a. Orbit a => Orb a -> a
|
||||
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
|
||||
toOrbit _ = OrbRational
|
||||
type Orb Rat = ()
|
||||
toOrbit _ = ()
|
||||
support r = Support.singleton r
|
||||
getElement _ s = Support.min s
|
||||
index _ = 1
|
||||
|
||||
deriving instance Show (Orb Rat)
|
||||
deriving instance Eq (Orb Rat)
|
||||
deriving instance Ord (Orb Rat)
|
||||
index _ _ = 1
|
||||
|
||||
|
||||
-- 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
|
||||
toOrbit s = OrbSupport (Support.size s)
|
||||
type Orb Support = Int
|
||||
toOrbit s = Support.size s
|
||||
support s = s
|
||||
getElement _ s = s
|
||||
index (OrbSupport n) = n
|
||||
|
||||
deriving instance Show (Orb Support)
|
||||
deriving instance Eq (Orb Support)
|
||||
deriving instance Ord (Orb Support)
|
||||
index _ n = n
|
||||
|
||||
|
||||
-- Disjoint unions are easy: just work on either side.
|
||||
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 (Orbit a, Orbit b) => Orbit (Either a b)
|
||||
|
||||
deriving instance (Show (Orb a), Show (Orb b)) => Show (Orb (Either a b))
|
||||
deriving instance (Eq (Orb a), Eq (Orb b)) => Eq (Orb (Either a b))
|
||||
deriving instance (Ord (Orb a), Ord (Orb b)) => Ord (Orb (Either a b))
|
||||
deriving instance Orbit ()
|
||||
deriving instance (Orbit a, Orbit b) => Orbit (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 oa ob = OrbPair oa ob <$> prodStrings (index oa) (index ob)
|
||||
product :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
|
||||
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 oa ob = OrbPair oa ob <$> sepProdStrings (index oa) (index ob)
|
||||
separatedProduct :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
|
||||
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 oa ob = OrbPair oa ob <$> rincProdStrings (index oa) (index ob)
|
||||
leftProduct :: (Orbit a, Orbit b) => Proxy a -> Proxy b -> Orb a -> Orb b -> [Orb (a,b)]
|
||||
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
|
||||
toOrbit (Trivial a) = OrbTrivial a
|
||||
type Orb (Trivial a) = a
|
||||
toOrbit (Trivial a) = a
|
||||
support _ = Support.empty
|
||||
getElement (OrbTrivial a) _ = Trivial a
|
||||
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))
|
||||
getElement a _ = Trivial a
|
||||
index _ _ = 0
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
{-
|
||||
I tried to do generics, but failed. One cannot do generic injective
|
||||
data constructors. I will keep it here now, for later reference.
|
||||
default toOrbit :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => a -> Orb a
|
||||
toOrbit = gtoOrbit . from
|
||||
|
||||
{-# language DefaultSignatures #-}
|
||||
{-# 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
|
||||
default support :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => a -> Support
|
||||
support = gsupport . from
|
||||
|
||||
default getElement :: (Generic a, GOrbit (Rep a)) => Orb a -> Support -> a
|
||||
getElement = undefined
|
||||
default getElement :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => Orb a -> Support -> a
|
||||
getElement o s = to (ggetElement o s)
|
||||
|
||||
default index :: (Generic a, GOrbit (Rep a)) => Orb a -> Int
|
||||
index = undefined
|
||||
default index :: (Generic a, GOrbit (Rep a), Orb a ~ GOrb (Rep a)) => Proxy a -> Orb a -> Int
|
||||
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 :: * -> *
|
||||
gtoOrbit :: f a -> GOrb f a
|
||||
type GOrb f :: *
|
||||
gtoOrbit :: f a -> GOrb f
|
||||
gsupport :: f a -> Support
|
||||
ggetElement :: GOrb f a -> Support -> f a
|
||||
gindex :: GOrb f a -> Int
|
||||
-}
|
||||
ggetElement :: GOrb f -> Support -> f a
|
||||
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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue