diff --git a/Data/Universe.hs b/Data/Universe.hs --- a/Data/Universe.hs +++ b/Data/Universe.hs @@ -72,9 +72,27 @@ instance Universe a => Universe (Last a) where universe = map Last universe -- see http://mathlesstraveled.com/2008/01/07/recounting-the-rationals-part-ii-fractions-grow-on-trees/ --- TODO: since we know these numerators and denominators are always going to be --- in reduced terms, we could use (:%) when we know we're compiling with GHC to --- get a small speed boost +-- +-- also, Brent Yorgey writes: +-- +-- positiveRationals2 :: [Ratio Integer] +-- positiveRationals2 = iterate' next 1 +-- where +-- next x = let (n,y) = properFraction x in recip (fromInteger n + 1 - y) +-- iterate' f x = let x' = f x in x' `seq` (x : iterate' f x') +-- +-- Compiling this code with -O2 and doing some informal tests seems to +-- show that positiveRationals and positiveRationals2 have almost exactly +-- the same efficiency for generating the entire list (e.g. the times for +-- finding the sum of the first 100000 rationals are pretty much +-- indistinguishable). positiveRationals is still the clear winner for +-- generating just the nth rational for some particular n -- some simple +-- experiments seem to indicate that doing this with positiveRationals2 +-- scales linearly while with positiveRationals it scales sub-linearly, +-- as expected. +-- +-- Surprisingly, replacing % with :% in positiveRationals seems to make +-- no appreciable difference. positiveRationals :: [Ratio Integer] positiveRationals = 1 : map lChild positiveRationals +++ map rChild positiveRationals where lChild frac = numerator frac % (numerator frac + denominator frac) @@ -90,32 +108,28 @@ tableToFunction = (!) . fromList . zip monoUniverse monoUniverse = universeF --- instances for Representable functors; in general we want --- instance (Finite (Key f), Ord (Key f), Universe a, Representable f) --- => Universe (f a) --- where universe = map tabulate universe --- but this has ridiculous overlap, so we expand this for each of the --- instantiations of f that are Representable instead +instance Universe a => Universe (Identity a) where universe = map Identity universe +instance Universe (f a) => Universe (IdentityT f a) where universe = map IdentityT universe +instance (Finite e, Ord e, Universe (m a)) => Universe (ReaderT e m a) where universe = map ReaderT universe +instance Universe (f (g a)) => Universe (Compose f g a) where universe = map Compose universe +instance (Universe (f a), Universe (g a)) => Universe (Functor.Product f g a) where universe = [Functor.Pair f g | (f, g) <- universe +*+ universe] -instance Universe a => Universe (Identity a) where universe = map Identity universe -instance (Representable f, Finite (Key f), Ord (Key f), Universe a) - => Universe (IdentityT f a) - where universe = map tabulate universe +-- We could do this: +-- +-- instance Universe (f a) => Universe (Rep f a) where universe = map Rep universe +-- +-- However, since you probably only apply Rep to functors when you want to +-- think of them as being representable, I think it makes sense to use an +-- instance based on the representable-ness rather than the inherent +-- universe-ness. +-- +-- Please complain if you disagree! instance (Representable f, Finite (Key f), Ord (Key f), Universe a) => Universe (Rep f a) where universe = map tabulate universe instance (Representable f, Finite s, Ord s, Finite (Key f), Ord (Key f), Universe a) => Universe (TracedT s f a) where universe = map tabulate universe -instance (Representable f, Finite e, Ord e, Finite (Key f), Ord (Key f), Universe a) - => Universe (ReaderT e f a) - where universe = map tabulate universe -instance (Representable f, Representable g, Finite (Key f), Ord (Key f), Finite (Key g), Ord (Key g), Universe a) - => Universe (Compose f g a) - where universe = map tabulate universe -instance (Representable f, Representable g, Finite (Key f), Ord (Key f), Finite (Key g), Ord (Key g), Universe a) - => Universe (Functor.Product f g a) - where universe = map tabulate universe instance Finite () instance Finite Bool @@ -148,7 +162,24 @@ instance Finite a => Finite (First a) where universeF = map First universeF instance Finite a => Finite (Last a) where universeF = map Last universeF -instance (Ord a, Finite a, Finite b) => Finite (a -> b) +instance (Ord a, Finite a, Finite b) => Finite (a -> b) where + universeF = map tableToFunction tables where + tables = sequence [universeF | _ <- monoUniverse] + tableToFunction = (!) . fromList . zip monoUniverse + monoUniverse = universeF + +instance Finite a => Finite (Identity a) where universeF = map Identity universeF +instance Finite (f a) => Finite (IdentityT f a) where universeF = map IdentityT universeF +instance (Finite e, Ord e, Finite (m a)) => Finite (ReaderT e m a) where universeF = map ReaderT universeF +instance Finite (f (g a)) => Finite (Compose f g a) where universeF = map Compose universeF +instance (Finite (f a), Finite (g a)) => Finite (Functor.Product f g a) where universeF = liftM2 Functor.Pair universeF universeF + +instance (Representable f, Finite (Key f), Ord (Key f), Finite a) + => Finite (Rep f a) + where universeF = map tabulate universeF +instance (Representable f, Finite s, Ord s, Finite (Key f), Ord (Key f), Finite a) + => Finite (TracedT s f a) + where universeF = map tabulate universeF -- to add as people ask for them: -- instance (Eq a, Finite a) => Finite (Endo a) (+Universe) diff --git a/universe.cabal b/universe.cabal --- a/universe.cabal +++ b/universe.cabal @@ -1,5 +1,5 @@ name: universe -version: 0.1 +version: 0.2 synopsis: Classes for types where we know all the values description: A small package, in the spirit of data-default, which allows the munging of finite and recursively enumerable types license: BSD3 @@ -16,7 +16,7 @@ source-repository this type: git location: https://github.com/dmwit/universe - tag: 0.1 + tag: 0.2 library exposed-modules: Data.Universe,