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

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

Browse source
This commit is contained in:
Joshua Moerman 2018-04-09 17:57:49 +02:00
parent 72d6310cae
commit da2265da90
4 changed files with 179 additions and 145 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
src/EquivariantMap.hs
View file

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

22
src/EquivariantSet.hs
View file

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

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

154
src/Orbit/Class.hs
View file

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