diff --git a/base/Data/Universe/Class.hs b/base/Data/Universe/Class.hs index e92fb74..8b8d6f3 100644 --- a/base/Data/Universe/Class.hs +++ b/base/Data/Universe/Class.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif module Data.Universe.Class - ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants. - Universe(..) - , Finite(..) - ) where + ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants. + Universe(..) + , Finite(..) + ) where import Data.List (genericLength) import Data.Universe.Helpers @@ -26,10 +27,10 @@ import Data.Universe.Helpers -- in 'length' pfx = 'length' (nub pfx) -- @ class Universe a where - universe :: [a] + universe :: Stream a #ifdef DEFAULT_SIGNATURES - default universe :: (Enum a, Bounded a) => [a] - universe = universeDef + default universe :: (Enum a, Bounded a) => Stream a + universe = universeDef #endif -- | Creating an instance of this class is a declaration that your 'universe' @@ -56,8 +57,9 @@ class Universe a where -- Just 1 -- @ class Universe a => Finite a where - universeF :: [a] - universeF = universe + universeF :: Stream a + universeF = universe - cardinality :: proxy a -> Integer - cardinality = genericLength . ((\_ -> universeF) :: Finite t => proxy t -> [t]) + -- TODO: change to Tagged, then the computation will be memoized! + cardinality :: proxy a -> Integer + cardinality _ = streamLength (universeF :: Stream a) diff --git a/base/Data/Universe/Helpers.hs b/base/Data/Universe/Helpers.hs index a064106..f67ea23 100644 --- a/base/Data/Universe/Helpers.hs +++ b/base/Data/Universe/Helpers.hs @@ -1,59 +1,187 @@ +{-# LANGUAGE RankNTypes, DeriveFunctor, DeriveFoldable, DeriveTraversable, GADTs, TupleSections, BangPatterns #-} module Data.Universe.Helpers ( - -- | This module is for functions that are useful for writing instances, - -- but not necessarily for using them (and hence are not exported by the - -- main module to avoid cluttering up the namespace). - - -- * Building lists - universeDef, - interleave, - diagonal, - diagonals, - (+++), - (+*+), - choices, - - -- * Building cardinalities - -- | These functions are handy for inheriting the definition of - -- 'Data.Universe.Class.cardinality' in a newtype instance. For example, - -- one might write - -- - -- > newtype Foo = Foo Bar - -- > instance Finite Foo where cardinality = cardinality . unwrapProxy Foo - unwrapProxy, - unwrapProxy1of2, - unwrapProxy2of2, - - -- * Debugging - -- | These functions exist primarily as a specification to test against. - unfairCartesianProduct, - unfairChoices - ) where + -- | This module is for functions that are useful for writing instances, + -- but not necessarily for using them (and hence are not exported by the + -- main module to avoid cluttering up the namespace). + + -- * Tree + Stream (..), + unstream, + streamLength, + consStream, + unfoldrInfiniteStream, + streamIterate, + + -- * Building lists + universeDef, + interleave, + diagonal, + (+++), + (+*+), + -- choices, + + -- * Building cardinalities + -- | These functions are handy for inheriting the definition of + -- 'Data.Universe.Class.cardinality' in a newtype instance. For example, + -- one might write + -- + -- > newtype Foo = Foo Bar + -- > instance Finite Foo where cardinality = cardinality . unwrapProxy Foo + unwrapProxy, + unwrapProxy1of2, + unwrapProxy2of2, + + -- * Debugging + -- | These functions exist primarily as a specification to test against. + unfairCartesianProduct, + -- unfairChoices + ) where import Data.List +import Data.Foldable +import Data.Traversable + +import Debug.Trace + +data Stream a where + Stream :: !(s -> Step a s) -> !s -> Stream a + +instance Functor Stream where + fmap f (Stream next s0) = Stream next' s0 + where + next' s = case next s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' + +data Step a s + = Yield a !s + | Skip !s + | Done + +instance Functor (Step a) where + fmap f (Yield x s) = Yield x (f s) + fmap f (Skip s) = Skip (f s) + fmap _ Done = Done + +consStream :: a -> Stream a -> Stream a +consStream x (Stream next' initS) = Stream next Nothing + where + next Nothing = Yield x (Just initS) + next (Just s) = fmap Just (next' s) + +unfoldrStream :: s -> (s -> Maybe (a, s)) -> Stream a +unfoldrStream initS next' = Stream next initS + where + next s = case next' s of + Nothing -> Done + Just (x, s) -> Yield x s + +unfoldrInfiniteStream :: s -> (s -> (a, s)) -> Stream a +unfoldrInfiniteStream initS next = Stream (uncurry Yield . next) initS + +streamIterate :: a -> (a -> a) -> Stream a +streamIterate x f = Stream next x where + next x = Yield x (f x) + +streamLength :: Stream a -> Integer +streamLength (Stream next s) = go 0 s where + go !acc !s = case next s of + Yield _ s -> go (1 + acc) s + Skip s -> go acc s + Done -> acc + +emptyStream :: Stream a +emptyStream = Stream (const Done) () + +foldlStream :: (b -> a -> b) -> b -> Stream a -> b +foldlStream f z (Stream next s) = go z s + where + go acc s = case next s of + Done -> acc + Skip s' -> go acc s' + Yield x s' -> go (f acc x) s' + +-- | Flatten a stream back into a list. +unstream :: Stream a -> [a] +unstream (Stream next s0) = go s0 + where + go !s = case next s of + Done -> [] + Skip s' -> go s' + Yield x s' -> x : go s' -- | For many types, the 'universe' should be @[minBound .. maxBound]@; -- 'universeDef' makes it easy to make such types an instance of 'Universe' via -- the snippet -- -- > instance Universe Foo where universe = universeDef -universeDef :: (Bounded a, Enum a) => [a] -universeDef = [minBound .. maxBound] +universeDef :: (Bounded a, Enum a) => Stream a +universeDef = Stream next [minBound .. maxBound] where + next [] = Done + next (x : xs) = Yield x xs + +-- | Fair 2-way interleaving. +(+++) :: Stream a -> Stream a -> Stream a +Stream nextA initA +++ Stream nextB initB = Stream next (NextA initA initB) + where + next (NextA sa sb) = case nextA sa of + Done -> Skip (DrainB sb) + Skip sa' -> Skip (NextB sa' sb) + Yield x sa' -> Yield x (NextB sa' sb) + next (NextB sa sb) = case nextB sb of + Done -> Skip (DrainA sa) + Skip sb' -> Skip (NextA sa sb') + Yield x sb' -> Yield x (NextA sa sb') + next (DrainA sa) = case nextA sa of + Done -> Done + Skip sa' -> Skip (DrainA sa') + Yield x sa' -> Yield x (DrainA sa') + next (DrainB sb) = case nextB sb of + Done -> Done + Skip sb' -> Skip (DrainB sb') + Yield x sb' -> Yield x (DrainB sb') + +-- State for (+++) +data I2 sa sb + = NextA !sa !sb + | NextB !sa !sb + | DrainA !sa + | DrainB !sb + +-- TODO: make "square producter" +-- +-- - first go from top-to-corner +-- - then left-to-corner +-- - then corner +-- - ... continue with next level +-- +-- @ +-- 1234 +-- 2234 +-- 3334 +-- 4444 +-- @ +-- +unfairProduct :: (a -> b -> c) -> Stream a -> Stream b -> Stream c +unfairProduct f as bs = foldlStream (\cs a -> fmap (f a) bs +++ cs) emptyStream as -- | Fair n-way interleaving: given a finite number of (possibly infinite) -- lists, produce a single list such that whenever @v@ has finite index in one -- of the input lists, @v@ also has finite index in the output list. No list's -- elements occur more frequently (on average) than another's. -interleave :: [[a]] -> [a] -interleave = concat . transpose +interleave :: [Stream a] -> Stream a +interleave = foldl' (+++) emptyStream -- TODO -- | Unfair n-way interleaving: given a possibly infinite number of (possibly -- infinite) lists, produce a single list such that whenever @v@ has finite -- index in an input list at finite index, @v@ also has finite index in the -- output list. Elements from lists at lower index occur more frequently, but -- not exponentially so. -diagonal :: [[a]] -> [a] -diagonal = concat . diagonals +diagonal :: [Stream a] -> Stream a +diagonal = interleave -- todo +{- -- | Like 'diagonal', but expose a tiny bit more (non-semantic) information: -- if you lay out the input list in two dimensions, each list in the result -- will be one of the diagonals of the input. In particular, each element of @@ -61,32 +189,30 @@ diagonal = concat . diagonals -- list. diagonals :: [[a]] -> [[a]] diagonals = tail . go [] where - -- it is critical for some applications that we start producing answers - -- before inspecting es_ - go b es_ = [h | h:_ <- b] : case es_ of - [] -> transpose ts - e:es -> go (e:ts) es - where ts = [t | _:t <- b] - --- | Fair 2-way interleaving. -(+++) :: [a] -> [a] -> [a] -xs +++ ys = interleave [xs,ys] + -- it is critical for some applications that we start producing answers + -- before inspecting es_ + go b es_ = [h | h:_ <- b] : case es_ of + [] -> transpose ts + e:es -> go (e:ts) es + where ts = [t | _:t <- b] +-} -- | Slightly unfair 2-way Cartesian product: given two (possibly infinite) -- lists, produce a single list such that whenever @v@ and @w@ have finite -- indices in the input lists, @(v,w)@ has finite index in the output list. -- Lower indices occur as the @fst@ part of the tuple more frequently, but not -- exponentially so. -(+*+) :: [a] -> [b] -> [(a,b)] -[] +*+ _ = [] -- special case: don't want to construct an infinite list of empty lists to pass to diagonal -xs +*+ ys = diagonal [[(x, y) | x <- xs] | y <- ys] +(+*+) :: Stream a -> Stream b -> Stream (a, b) +(+*+) = unfairProduct (,) +{- -- | Slightly unfair n-way Cartesian product: given a finite number of -- (possibly infinite) lists, produce a single list such that whenever @vi@ has -- finite index in list i for each i, @[v1, ..., vn]@ has finite index in the -- output list. -choices :: [[a]] -> [[a]] +choices :: [Stream a] -> [[a]] choices = foldr ((map (uncurry (:)) .) . (+*+)) [[]] +-} -- | Convert a proxy for a newtype to a proxy for the contained type, given the -- newtype's constructor. @@ -107,14 +233,13 @@ unwrapProxy2of2 _ _ = [] -- | Very unfair 2-way Cartesian product: same guarantee as the slightly unfair -- one, except that lower indices may occur as the @fst@ part of the tuple -- exponentially more frequently. -unfairCartesianProduct :: [a] -> [b] -> [(a,b)] -unfairCartesianProduct _ [] = [] -- special case: don't want to walk down xs forever hoping one of them will produce a nonempty thing -unfairCartesianProduct xs ys = go xs ys where - go (x:xs) ys = map ((,) x) ys +++ go xs ys - go [] ys = [] +unfairCartesianProduct :: Stream a -> Stream b -> Stream (a, b) +unfairCartesianProduct = unfairProduct (,) +{- -- | Very unfair n-way Cartesian product: same guarantee as the slightly unfair -- one, but not as good in the same sense that the very unfair 2-way product is -- worse than the slightly unfair 2-way product. unfairChoices :: [[a]] -> [[a]] unfairChoices = foldr ((map (uncurry (:)) .) . unfairCartesianProduct) [[]] +-} diff --git a/instances/base/Data/Universe/Instances/Base.hs b/instances/base/Data/Universe/Instances/Base.hs index a9a4cf3..454fff8 100644 --- a/instances/base/Data/Universe/Instances/Base.hs +++ b/instances/base/Data/Universe/Instances/Base.hs @@ -14,11 +14,13 @@ import Data.Universe.Class import Data.Universe.Helpers import Data.Word +instance Universe Integer where + universe = streamIterate 0 succ +++ streamIterate (-1) pred + instance Universe () where universe = universeDef instance Universe Bool where universe = universeDef instance Universe Char where universe = universeDef instance Universe Ordering where universe = universeDef -instance Universe Integer where universe = [0, -1..] +++ [1..] instance Universe Int where universe = universeDef instance Universe Int8 where universe = universeDef instance Universe Int16 where universe = universeDef @@ -30,24 +32,34 @@ instance Universe Word16 where universe = universeDef instance Universe Word32 where universe = universeDef instance Universe Word64 where universe = universeDef -instance (Universe a, Universe b) => Universe (Either a b) where universe = map Left universe +++ map Right universe -instance Universe a => Universe (Maybe a ) where universe = Nothing : map Just universe +instance (Universe a, Universe b) => Universe (Either a b) where universe = fmap Left universe +++ fmap Right universe +instance Universe a => Universe (Maybe a ) where universe = consStream Nothing $ fmap Just universe + +instance (Universe a, Universe b) => Universe (a, b) where + universe = universe +*+ universe + +instance (Universe a, Universe b, Universe c) => Universe (a, b, c) where + universe = fmap reassoc (universe +*+ universe +*+ universe) where + reassoc ((a,b),c) = (a,b,c) + +instance (Universe a, Universe b, Universe c, Universe d) => Universe (a, b, c, d) where + universe = fmap reassoc (universe +*+ universe) where + reassoc ((a,b),(c,d)) = (a,b,c,d) -instance (Universe a, Universe b) => Universe (a, b) where universe = universe +*+ universe -instance (Universe a, Universe b, Universe c) => Universe (a, b, c) where universe = [(a,b,c) | ((a,b),c) <- universe +*+ universe +*+ universe] -instance (Universe a, Universe b, Universe c, Universe d) => Universe (a, b, c, d) where universe = [(a,b,c,d) | (((a,b),c),d) <- universe +*+ universe +*+ universe +*+ universe] -instance (Universe a, Universe b, Universe c, Universe d, Universe e) => Universe (a, b, c, d, e) where universe = [(a,b,c,d,e) | ((((a,b),c),d),e) <- universe +*+ universe +*+ universe +*+ universe +*+ universe] +instance (Universe a, Universe b, Universe c, Universe d, Universe e) => Universe (a, b, c, d, e) where + universe = fmap reassoc (universe +*+ universe) where + reassoc ((a,b,c),(d,e)) = (a,b,c,d,e) instance Universe a => Universe [a] where - universe = diagonal $ [[]] : [[h:t | t <- universe] | h <- universe] + universe = error "not-implented" -- diagonal $ [[]] : [[h:t | t <- universe] | h <- universe] -instance Universe All where universe = map All universe -instance Universe Any where universe = map Any universe -instance Universe a => Universe (Sum a) where universe = map Sum universe -instance Universe a => Universe (Product a) where universe = map Product universe -instance Universe a => Universe (Dual a) where universe = map Dual universe -instance Universe a => Universe (First a) where universe = map First universe -instance Universe a => Universe (Last a) where universe = map Last universe +instance Universe All where universe = fmap All universe +instance Universe Any where universe = fmap Any universe +instance Universe a => Universe (Sum a) where universe = fmap Sum universe +instance Universe a => Universe (Product a) where universe = fmap Product universe +instance Universe a => Universe (Dual a) where universe = fmap Dual universe +instance Universe a => Universe (First a) where universe = fmap First universe +instance Universe a => Universe (Last a) where universe = fmap Last universe -- see http://mathlesstraveled.com/2008/01/07/recounting-the-rationals-part-ii-fractions-grow-on-trees/ -- @@ -71,21 +83,22 @@ instance Universe a => Universe (Last a) where universe = map Last univers -- -- Surprisingly, replacing % with :% in positiveRationals seems to make -- no appreciable difference. -positiveRationals :: [Ratio Integer] -positiveRationals = 1 : map lChild positiveRationals +++ map rChild positiveRationals where +positiveRationals :: Stream (Ratio Integer) +positiveRationals = consStream 1 $ fmap lChild positiveRationals +++ fmap rChild positiveRationals where lChild frac = numerator frac % (numerator frac + denominator frac) rChild frac = (numerator frac + denominator frac) % denominator frac -instance a ~ Integer => Universe (Ratio a) where universe = 0 : map negate positiveRationals +++ positiveRationals +instance a ~ Integer => Universe (Ratio a) where universe = consStream 0 $ fmap negate positiveRationals +++ positiveRationals -- could change the Ord constraint to an Eq one, but come on, how many finite -- types can't be ordered? +{- instance (Finite a, Ord a, Universe b) => Universe (a -> b) where - universe = map tableToFunction tables where + universe = fmap tableToFunction tables where tables = choices [universe | _ <- monoUniverse] tableToFunction = (!) . fromList . zip monoUniverse monoUniverse = universeF - +-} instance Finite () where cardinality _ = 1 instance Finite Bool where cardinality _ = 2 instance Finite Char where cardinality _ = 1114112 @@ -103,9 +116,10 @@ instance Finite Word64 where cardinality _ = 2^64 instance Finite a => Finite (Maybe a ) where cardinality _ = 1 + cardinality ([] :: [a]) instance (Finite a, Finite b) => Finite (Either a b) where - universeF = map Left universe ++ map Right universe + universeF = fmap Left universe +++ fmap Right universe cardinality _ = cardinality ([] :: [a]) + cardinality ([] :: [b]) +{- instance (Finite a, Finite b) => Finite (a, b) where universeF = liftM2 (,) universeF universeF cardinality _ = product [cardinality ([] :: [a]), cardinality ([] :: [b])] @@ -121,20 +135,22 @@ instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) where instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) where universeF = liftM5 (,,,,) universeF universeF universeF universeF universeF cardinality _ = product [cardinality ([] :: [a]), cardinality ([] :: [b]), cardinality ([] :: [c]), cardinality ([] :: [d]), cardinality ([] :: [e])] +-} -instance Finite All where universeF = map All universeF; cardinality _ = 2 -instance Finite Any where universeF = map Any universeF; cardinality _ = 2 -instance Finite a => Finite (Sum a) where universeF = map Sum universeF; cardinality = cardinality . unwrapProxy Sum -instance Finite a => Finite (Product a) where universeF = map Product universeF; cardinality = cardinality . unwrapProxy Product -instance Finite a => Finite (Dual a) where universeF = map Dual universeF; cardinality = cardinality . unwrapProxy Dual -instance Finite a => Finite (First a) where universeF = map First universeF; cardinality = cardinality . unwrapProxy First -instance Finite a => Finite (Last a) where universeF = map Last universeF; cardinality = cardinality . unwrapProxy Last +instance Finite All where universeF = fmap All universeF; cardinality _ = 2 +instance Finite Any where universeF = fmap Any universeF; cardinality _ = 2 +instance Finite a => Finite (Sum a) where universeF = fmap Sum universeF; cardinality = cardinality . unwrapProxy Sum +instance Finite a => Finite (Product a) where universeF = fmap Product universeF; cardinality = cardinality . unwrapProxy Product +instance Finite a => Finite (Dual a) where universeF = fmap Dual universeF; cardinality = cardinality . unwrapProxy Dual +instance Finite a => Finite (First a) where universeF = fmap First universeF; cardinality = cardinality . unwrapProxy First +instance Finite a => Finite (Last a) where universeF = fmap Last universeF; cardinality = cardinality . unwrapProxy Last +{- instance (Ord a, Finite a, Finite b) => Finite (a -> b) where - universeF = map tableToFunction tables where + universeF = fmap tableToFunction tables where tables = sequence [universeF | _ <- monoUniverse] tableToFunction = (!) . fromList . zip monoUniverse monoUniverse = universeF cardinality _ = cardinality ([] :: [b]) ^ cardinality ([] :: [a]) - +-} -- to add when somebody asks for it: instance (Eq a, Finite a) => Finite (Endo a) (+Universe)