size-based (empty) → 0.1.0.0

raw patch · 8 files changed

+835/−0 lines, 8 filesdep +basedep +dictionary-sharingdep +template-haskellsetup-changed

Dependencies added: base, dictionary-sharing, template-haskell, testing-type-modifiers

Files

Control/Enumerable.hs +307/−0
Control/Enumerable/Count.hs +242/−0
Control/Enumerable/Derive.hs +57/−0
Control/Enumerable/Values.hs +79/−0
Control/Sized.hs +78/−0
LICENSE +30/−0
Setup.hs +2/−0
size-based.cabal +40/−0

+ Control/Enumerable.hs view

@@ -0,0 +1,307 @@+{-#LANGUAGE TemplateHaskell#-}
+
+{-| 
+This module provides the 'Enumerable' class, which has a simple purpose: Provide any enumeration for any instance type. The prerequisite is that the enumeration data type is a sized functor (see "Control.Sized") with the enumerated type as the type parameter. The general idea is that the size of a value is the number of constructor applications it contains. 
+
+Because Sized functors often rely of memoization, sharing is important. Since class dictionaries are not always shared, a mechanism is added that guarantees optimal sharing (it never creates two separate instance members for the same type). This is why the type of 'enumerate' is @Shared f a@ instead of simply @f a@. The technicalities of this memoization are not important, but it means there are two modes for accessing an enumeration: 'local' and 'global'. The former means sharing is guaranteed within this value, but subsequent calls to local may recreate dictionaries. The latter guarantees optimal sharing even between calls. It also means the enumeration will never be garbage collected, so use with care in programs that run for extended periods of time and contains many (especially non-regular) types. 
+
+Once a type has an instance, it can be enumerated in several ways (by instantiating 'global' to different types). For instance @global :: Count [Maybe Bool]@ would only count the number of lists of Maybe Bool of each size (using "Control.Enumerable.Count"). @global :: Values [Maybe Bool] would give the actual values for all sizes as lists. See <https://hackage.haskell.org/package/testing-feat FEAT> for a more elaborate enumeration type that allows access to any value in the enumeration (given an index) in polynomial time, uniform selection from a given size etc. 
+
+Instances can be constructed in three ways:
+
+1: Manually by passing 'datatype' a list where each element is an application of the constructor functions 'c0', 'c1' etc, so a data type like Maybe would have @enumerate = datatype [c0 Nothing, c1 Just]@. This assumes all field types of all constructors are enumerable (recursive constructors work fine). The functions passed to @cX@ do not have to be constructors, but should be injective functions (if they are not injective the enumeration will contain duplicates). So "smart constructors" can be used, for instance the @Rational@ datatype is defined by an injection from the natural numbers. 
+
+2: Automatically with Template Haskell ('deriveEnumerable'). A top level declaration like @deriveEnumerable ''Maybe@ would derive an instance for the @Maybe@ data type. 
+
+3: Manually using the operations of a sized functor (see "Control.Sized") to build a @Shareable f a@ value, then apply 'share' to it. To use other instances of 'Enumerable' use 'access'. 
+
+-}
+module Control.Enumerable 
+  ( Enumerable(..)
+  -- * Class based construction
+  , datatype, c0, c1, c2, c3, c4, c5, c6, c7
+  -- * Access
+  , global, local
+  
+  -- * Automatic derivation
+  , deriveEnumerable
+  , dAll, dExcluding, dExcept, ConstructorDeriv, deriveEnumerable'
+  
+  -- * Non-class construction
+  , access, share, Shared, Shareable, Typeable, module Control.Sized
+  
+  -- * Enumerating functions
+  , function, CoEnumerable(..)
+  
+  -- * Other stuff (required for instances)
+  , Infinite
+  )where
+import Control.Sized
+import Data.ClassSharing
+
+-- For instances
+import Data.Modifiers
+import Data.Bits
+import Data.Word
+import Data.Int
+import Data.Ratio
+import Control.Enumerable.Derive hiding (global)
+
+instance (Typeable f, Sized f) => Sized (Shareable f) where
+  pay       = Shareable . fmap pay . run
+  fin       = Shareable . const . fin
+  pair x y  = Shareable $ \r -> pair (run x r) (run y r)
+
+class Typeable a => Enumerable a where
+  enumerate :: (Typeable f, Sized f) => Shared f a
+
+
+-- | Used instead of enumerate when manually building instances.
+access :: (Enumerable a, Sized f, Typeable f) => Shareable f a
+access = unsafeAccess enumerate
+
+-- | Guarantees local sharing. All enumerations are shared inside each invokation of local, but may not be shared between them. 
+{-#INLINE local#-}
+local :: (Typeable f, Sized f, Enumerable a) => f a
+local = run access (unsafeNewRef ())
+
+{-#NOINLINE gref#-}
+gref :: Ref
+gref = unsafeNewRef ()
+
+-- | This is the primary way to access enumerations for usage. Guarantees global sharing of enumerations of the same type. Note that this means the enumerations are never garbage collected. 
+global :: (Typeable f, Sized f, Enumerable a) => f a
+global = run access gref
+
+-- | Builds an enumeration of a data type from a list of constructors (see c0-c7)
+datatype :: (Typeable a, Sized f, Typeable f) => [Shareable f a] -> Shared f a
+datatype = share . pay . aconcat
+
+
+-- | Takes a constructor with arity 0 (a pure value)
+c0 :: Sized f => a -> Shareable f a
+c0 = pure
+
+-- | Takes a constructor of arity 1
+c1 :: (Enumerable a, Sized f, Typeable f) => (a -> x) -> Shareable f x
+c1 f = fmap f access
+
+c2 :: (Enumerable a, Enumerable b, Sized f, Typeable f) => (a -> b -> x) -> Shareable f x
+c2 f = c1 (uncurry f)
+
+c3 :: (Enumerable a, Enumerable b, Enumerable c, Sized f, Typeable f) => (a -> b -> c -> x) -> Shareable f x
+c3 f = c2 (uncurry f)
+
+c4 :: (Enumerable a, Enumerable b, Enumerable c, Enumerable d, Sized f, Typeable f) => (a -> b -> c -> d -> x) -> Shareable f x
+c4 f = c3 (uncurry f)
+
+c5 :: (Enumerable a, Enumerable b, Enumerable c, Enumerable d, Enumerable e, Sized f, Typeable f) => (a -> b -> c -> d -> e -> x) -> Shareable f x
+c5 f = c4 (uncurry f)
+
+c6 :: (Enumerable a, Enumerable b, Enumerable c, Enumerable d, Enumerable e, Enumerable g, Sized f, Typeable f) => (a -> b -> c -> d -> e -> g -> x) -> Shareable f x
+c6 f = c5 (uncurry f)
+
+c7 :: (Enumerable a, Enumerable b, Enumerable c, Enumerable d, Enumerable e, Enumerable g, Enumerable h, Sized f, Typeable f) => (a -> b -> c -> d -> e -> g -> h -> x) -> Shareable f x
+c7 f = c6 (uncurry f)
+
+-- More than seven constructor components? Uncurry your constructor!
+
+
+-- | The unit constructor is free
+instance Enumerable () where
+  enumerate = share (pure ())
+
+-- All tuple constructors are free
+instance (Enumerable a, Enumerable b) => Enumerable (a,b) where
+  enumerate = share $ pair access access -- Pairs are free
+
+instance (Enumerable a, Enumerable b, Enumerable c) => Enumerable (a,b,c) where
+  enumerate = share $ c1 $ \(a,(b,c)) -> (a,b,c)
+
+instance (Enumerable a, Enumerable b, Enumerable c, Enumerable d) 
+             => Enumerable (a,b,c,d) where
+  enumerate = share $ c1 $ \(a,(b,(c,d))) -> (a,b,c,d)
+
+instance (Enumerable a, Enumerable b, Enumerable c, Enumerable d, Enumerable e) 
+             => Enumerable (a,b,c,d,e) where
+  enumerate = share $ c1 $ \(a,(b,(c,(d,e)))) -> (a,b,c,d,e)
+
+
+instance Enumerable Bool where
+  enumerate = datatype [pure False, pure True]
+
+instance (Enumerable a, Enumerable b) => Enumerable (Either a b) where
+  enumerate = datatype [c1 Left, c1 Right]
+
+instance Enumerable a => Enumerable [a] where
+  enumerate = datatype [pure [], c2 (:)]
+
+instance Enumerable a => Enumerable (Maybe a) where
+  enumerate = datatype [pure Nothing, c1 Just]
+
+instance Enumerable Ordering where
+  enumerate = datatype [pure LT, pure EQ, pure GT]
+
+instance Enumerable Integer where
+  enumerate = share $ c1 nat <|> c1 (\(Nat n) -> -n-1)
+
+instance Enumerable Word where enumerate = share word
+
+instance Enumerable Word8 where enumerate = share word -- enumerate = share (fromInteger <$> fin 256) -- Flat definition
+
+instance Enumerable Word16 where enumerate = share word
+
+instance Enumerable Word32 where enumerate = share word
+
+instance Enumerable Word64 where enumerate = share word
+
+instance Enumerable Int where enumerate = share int
+
+instance Enumerable Int8 where enumerate = share int
+
+instance Enumerable Int16 where enumerate = share int
+
+instance Enumerable Int32 where enumerate = share int
+
+instance Enumerable Int64 where enumerate = share int
+
+-- | ASCII characters
+instance Enumerable Char where
+  enumerate = share $ (toEnum . fromIntegral) <$> kbits 7
+   -- Swap the printable characters to the start of the enumeration
+   -- swapCharacters :: Word8 -> Char
+
+-- | Not a proper injection
+instance Enumerable Float where
+  enumerate = share $ c2 $ \b a -> encodeFloat a (fromIntegral (b :: Int8))
+
+-- | Not a proper injection
+instance Enumerable Double where
+  enumerate = share $ encodeFloat <$> access <*> e where
+    e = negate <$> enumerateBounded (-1) (-lo)  <|> enumerateBounded 0 hi
+    (lo,hi) = floatRange (0 :: Double) 
+
+
+-- | A class of infinite precision integral types. 'Integer' is the principal 
+-- class member.
+class (Typeable a, Integral a) => Infinite a
+instance Infinite Integer
+
+
+instance Infinite a => Enumerable (Ratio a) where
+  enumerate = share (c1 $ rat . nat)
+  
+-- | Bijection into the rationals
+rat :: Integral a => Integer -> Ratio a
+rat i | i < 0 = error "Index out of bounds"
+rat i = go 1 1 i where
+  go a b 0 = a % b
+  go a b i = let (i',m) = i `divMod` 2 in if m == 1 then go (a+b) b i' else go a (a +b) i'
+
+
+-- From Data.Modifiers:
+instance Enumerable Unicode where
+  enumerate = datatype [fmap Unicode $ enumerateBounded 
+    (fromEnum (minBound :: Char)) 
+    (fromEnum (maxBound :: Char))]
+
+instance Enumerable Printable where
+  enumerate = share $ fmap Printable $ enumerateBounded 32 126
+
+enumerateBounded :: (Sized f, Enum a) => Int -> Int -> f a
+enumerateBounded lo hi = trans <$> finSized (toInteger (hi - lo)) where
+  trans i = toEnum $ fromInteger (toInteger lo + i)
+
+
+
+-- * modifiers:
+-- Enumerable Printable
+-- Enumerable Unicode
+-- (Infinite a, Enumerable a) => Enumerable (NonZero a)
+-- Infinite a => Enumerable (Nat a)
+-- Enumerable a => Enumerable (NonEmpty a)
+
+instance Infinite integer => Enumerable (Nat integer) where
+  enumerate = share (Nat . fromInteger <$> naturals)
+
+instance Enumerable a => Enumerable (NonEmpty a) where
+  enumerate = datatype [c2 $ mkNonEmpty]
+
+
+word :: (FiniteBits a, Integral a, Sized f) => f a 
+word = let e = fromInteger <$> kbits (bitSize' e) in e
+
+int :: (FiniteBits a, Integral a, Sized f) => f a 
+int = let e = fromInteger <$> kbs <|> (\n -> fromInteger (-n-1)) <$> kbs
+          kbs = finSized (2^(bitSize' e - 1))
+      in e
+
+
+bitSize' :: FiniteBits a => f a -> Int
+bitSize' f = hlp (error "Enumerable: This is not supposed to be inspected") f where
+  hlp :: FiniteBits a => a -> f a -> Int
+  hlp a _ = finiteBitSize a
+
+
+-- | Work in progress
+class Typeable a => CoEnumerable a where
+  coEnumerate :: (Enumerable b,Sized f, Typeable f) => Shared f (a -> b)
+
+-- | Builds a suitable definition for @coEnumerate@ given an pattern matching function for a data type (see source for examples). 
+function :: (Typeable a, Enumerable b, Sized f, Typeable f) => Shareable f (a -> b) -> Shared f (a -> b)
+function f = datatype [ c1 const, f]
+
+
+instance (CoEnumerable a, Enumerable b) => Enumerable (a -> b) where
+  enumerate = coEnumerate
+
+instance CoEnumerable Bool where
+  coEnumerate = function $ c2 $ \x y b -> if b then x else y 
+
+instance CoEnumerable a => CoEnumerable [a] where
+  coEnumerate = function $ c2 $ 
+    \uf cf xs -> case xs of 
+       []      -> uf
+       (x:xs)  -> cf x xs
+
+
+
+
+
+
+deriveEnumerable :: Name -> Q [Dec]
+deriveEnumerable = deriveEnumerable' . dAll
+
+
+type ConstructorDeriv = (Name, [(Name, ExpQ)])
+dAll :: Name -> ConstructorDeriv
+dAll n = (n,[])
+dExcluding :: Name -> ConstructorDeriv -> ConstructorDeriv
+dExcluding n (t,nrs) = (t,(n,[|empty|]):nrs)
+dExcept :: Name -> ExpQ -> ConstructorDeriv -> ConstructorDeriv
+dExcept n e (t,nrs) = (t,(n,e):nrs)
+
+-- | Derive an instance of Enumberable with Template Haskell, with 
+-- rules for some specific constructors
+deriveEnumerable' :: ConstructorDeriv -> Q [Dec]
+deriveEnumerable' (n,cse) =
+  fmap return $ instanceFor ''Enumerable [enumDef] n 
+  where
+    enumDef :: [(Name,[Type])] -> Q Dec
+    enumDef cons = do
+      sanityCheck
+      fmap mk_freqs_binding [|datatype $ex |] 
+      where
+        ex = listE $ map cone cons
+        cone xs@(n,_) = maybe (cone' xs) id $ lookup n cse
+        cone' (n,[]) = [|c0 $(conE n)|]
+        cone' (n,_:vs) = 
+          [|c1 $(foldr appE (conE n) (map (const [|uncurry|] ) vs) )|]
+        mk_freqs_binding :: Exp -> Dec
+        mk_freqs_binding e = ValD (VarP 'enumerate ) (NormalB e) []
+        sanityCheck = case filter (`notElem` map fst cons) (map fst cse) of
+          [] -> return ()
+          xs -> error $ "Invalid constructors for "++show n++": "++show xs
+        
+
+

+ Control/Enumerable/Count.hs view

@@ -0,0 +1,242 @@+{-#LANGUAGE DeriveDataTypeable#-}++module Control.Enumerable.Count (+  Count(..), +  (!!*),+  (</>),+  module Control.Enumerable+  ) where++import Control.Enumerable+import Control.Sized+import Data.Monoid(Monoid(..))+import Data.List+import Data.Typeable(Typeable)++-- | Counts the number of values of a all sizes. Usage: @global :: Count [Bool]+newtype Count a = Count {count :: [Integer]} deriving (Typeable, Show)+++-- Switch phantom type+untyped :: Count a -> Count b+untyped (Count x) = Count x++-- countparam :: Enumerable a => f a -> Count a+-- countparam _ = global++compact :: Count a -> Count a+compact = Count . reverse . dropWhile (==0) . reverse . count++-- | Counts the number of values of a given size, 0 if out of bounds. +(!!*) :: Count a -> Int -> Integer+(Count []) !!* n = 0+(Count (x:xs)) !!* n | n < 0  = 0+                        | n == 0 = x -- TODO: Check only once+                        | otherwise = Count xs !!* (n-1)++-- Undecidable for some 0-lists, for instance datatype with only infinite values+-- instance Eq (Count a) where +--  a == b = f a == f b +--    where f = count . compact++-- Typically infinite, perhaps it should have some hard-coded limit.+--instance Show (Count a) where+--  show = show . count+++instance Functor Count where+  fmap _ (Count xs) = Count xs++instance Applicative Count where +  pure _ = Count [1]++  (Count [])  <*> (Count _)      = empty+  (Count _)  <*> (Count [])      = empty+  (Count (0:xs)) <*> ys             = pay $ Count xs <*> ys+  xs <*> (Count (0:ys))             = pay $ xs <*> Count ys+  (Count xs0@(_:xs0'))  <*> (Count ys)  = Count $ run (drop 1 $ reversals' ys) where+    mult = conv xs0+    run []     = []+    run (r:rs) = go r rs+    go r rs  = mult r :  case rs of +                           [] -> go' r xs0'+                           (r':rs') -> go r' rs'+    go' r []         = []+    go' r xs@(_:xs') = conv r xs : go' r xs'++instance Alternative Count where +  empty = Count []+  ~(Count xs) <|> ~(Count ys) = Count $ zipWithL (+) xs ys where+    zipWithL f (x:xs) (y:ys) = f x y : zipWithL f xs ys+    zipWithL _ [] ys = ys+    zipWithL _ xs [] = xs++instance Monoid (Count a) where +  mempty = empty+  mappend = (<|>)++instance Sized Count where+  pay    = Count . (0:) . count+  fin i  = Count [i]+  aconcat []  = empty+  aconcat [x] = x+  aconcat [x,y] = x <|> y+  aconcat xss = Count $ map sum $ transpose (map count xss)++{-+  finBits i | i <= 0  = Count []+  finBits i           = Count $ 1 : go 1 where+    go n | n <= lim      = n : go (2*n)+    go n | n >= i        = []+    go n                 = [i-n]+    lim = i `div` 2+-}++infixl 3 <-> +(Count xs) <-> (Count ys) = Count $ zipWithLL op xs ys where+  op n m = max 0 (n-m)+  zipWithLL f xs []         = xs+  zipWithLL f [] _          = []+  zipWithLL f (x:xs) (y:ys) = f x y : zipWithLL f xs ys++infixl 4 </>+(</>) :: Count a -> Count a -> Count a+(Count xs)   </> (Count [])      = error "Vector division by zero"+(Count xs)   </> (Count (0:ys))  = Count (drop 1 xs) </> Count ys+(Count xs0)  </> (Count (y:ys0)) = Count ds where+  ds = go xs0 (reversals' ys0)+  go [] yrs          = []+  go (xs) []         = go' xs (tail ds)+  go (x:xs) (yr:yrs) =  ((x - conv yr ds) `div` y) : go xs yrs++  revy = reverse ys0+  go' [] _ = []+  go' (x:xs) (ds') = ((x - (conv revy ds' )) `div` y) : go' xs (tail ds')+  +-- Yap is the inverse of pay.+yap :: Count a -> Count a+yap (Count xs) = Count (drop 1 xs)+++reversals' :: [a] -> [[a]]+reversals' = go [] where+  go rs xs = rs : case xs of +      [] -> []+      (x:xs) -> go (x:rs) xs+++first k = Count . take k . (++ repeat 0) . count+rev x = Count $ reverse $ count x++-- Dissapointingly, this is the fastest version of conv I have discovered so far+conv :: [Integer] -> [Integer] -> Integer+conv xs = sum . zipWith (*) xs  +{-#INLINE conv#-}++conv' :: [Integer] -> [Integer] -> Integer+conv' (_:xs) (0:ys) = conv' xs ys+conv' (0:xs) (_:ys) = conv' xs ys+conv' xs     ys = sum (zipWith (*) xs ys) +{-#INLINE conv'#-}+++cardTake :: Int -> Count a -> Count a+cardTake k (Count xs) = Count (take k xs)++cardRev :: Count a -> Count a+cardRev (Count xs) = Count (reverse xs)+-------------------------------------+-- Specialized products and divisions+-------------------------------------++strict :: Count a -> Count a+strict (Count xs) = Count $ strictL xs++strictL :: [Integer] -> [Integer]+strictL xs = foldr seq xs xs++cap :: Int -> Count a -> Count a +cap k c = strict (cardTake (k+1) c)++-- Computes the k'th index in a product+mult :: Count a -> Count b -> Int -> Integer+-- mult (Count [1]) cl n = cl !!* n+-- mult cl (Count [1]) n = cl !!* n+-- mult (Count (0:xs)) cl n = mult (Count xs) cl (n-1)+mult cl (Count [1]) n = cl !!* n+mult cl1 cl2 n           = conv sub1 rev where+  sub2 = take (n+1) $ count cl2+  rl = length sub2+  rev = reverse sub2+  sub1 = drop (n+1-rl) (count cl1)++  +prodsK, prodsK' :: [Count a] -> Int -> Count a+prodsK []  _  = Count [1]+prodsK [x] k  = x  -- No length guarantee+prodsK xs k   = cardRev $ prodsKR xs k+-- Produces the reversed K-product of all given lists +-- By removing all pays we get a much smaller actual k for the products.+-- Intermediate lists need to be freed up for garbage collection.+prodsKR :: [Count a] -> Int -> Count a+--prodsKR []              k  = Count [1]+prodsKR (Count x:xs) k  = strict $ +  Count $ foldl' prodR (reverse $ take (k+1) (x ++ repeat 0)) xs where+  +  (xs', p) = baseCosts 0 [] xs+++  prodR :: [Integer] -> Count a -> [Integer]+--  prodR [] _                  = []+--  prodR r@(_,r') (Count x) = conv x r : prodR r x+  prodR rs (Count x) = map (conv x) (initTails rs)++prodsK' xs0 k = cap k $ go xs0 where+  go []     = Count [1]+  go [x]    = x+  go (x:xs) = untyped x <*> go xs +  +  +-- prop_ProdsK k cls = prodsK smallK cls == +--  smallK = k `mod` 20++ultraDiv :: [Count ()] -> [Count ()] -> Int -> Count ()+ultraDiv xs ys k = let+  x = cardRev (prodsKR xs k)+  y = cardRev (prodsKR ys k)+  in cap k $ x </> y++initTails :: [a] -> [[a]]+initTails [] = []+initTails xs@(_:xs') = xs : initTails xs'++baseCosts acc1 acc2 []     = (acc1,acc2)+baseCosts acc1 acc2 (Count x:xs) = baseCosts (acc1 + length zs) (Count x' : acc2) xs where+    (zs, x') = break (/=0) x+++++++++{-+-- Testing+prop_multTerm a b (NonNegative n) = (count (a <*> b)) !!* n == mult a b n where+  [] !!* n = 0+  (x:xs) !!* 0 = x+  (x:xs) !!* n = xs !!* (n-1)+    +prop_multCom a b = (untyped a <*> b) == (untyped b <*> a)+  +prop_div :: Count (a -> a) -> Count a -> Property+prop_div a b = any (/= 0) (count b) ==> ((a <*> b) </> b) == untyped a++prop_div_id a = any (/= 0) (count a) ==> (a </> a) == pure ()+-}+++++

+ Control/Enumerable/Derive.hs view

@@ -0,0 +1,57 @@+{-#Language CPP#-}+{-#Language TemplateHaskell#-}+module Control.Enumerable.Derive (instanceFor, module Language.Haskell.TH) where+import Language.Haskell.TH++-- General combinator for class derivation+instanceFor :: Name -> [[(Name,[Type])] -> Q Dec] -> Name -> Q Dec+instanceFor clname confs dtname = do+  (cxt,dtvs,cons) <- extractData dtname+  cd              <- mapM conData cons+  let +#if MIN_VERSION_template_haskell(2,10,0)+    mkCxt = fmap (cxt++) $ mapM (appT (conT clname) . varT) dtvs+#else+    mkCxt = fmap (cxt++) $ mapM (classP clname . return . varT) dtvs+#endif+    mkTyp = mkInstanceType clname dtname dtvs+    mkDecs conf = conf cd++  instanceD mkCxt mkTyp (map mkDecs confs)+++mkInstanceType :: Name -> Name -> [Name] -> Q Type+mkInstanceType cn dn vns = appT (conT cn) (foldl (appT) (conT dn) (map varT vns))++extractData :: Name -> Q (Cxt, [Name], [Con])+extractData n = reify n >>= \i -> return $ case i of+#if MIN_VERSION_template_haskell(2,11,0)+  TyConI (DataD cxt _ tvbs _ cons _)   -> (cxt, map tvbName tvbs, cons)+  TyConI (NewtypeD cxt _ tvbs _ con _) -> (cxt, map tvbName tvbs, [con])+#else+  TyConI (DataD cxt _ tvbs cons _)   -> (cxt, map tvbName tvbs, cons)+  TyConI (NewtypeD cxt _ tvbs con _) -> (cxt, map tvbName tvbs, [con])+#endif++tvbName :: TyVarBndr -> Name+tvbName (PlainTV n)  = n+tvbName (KindedTV n _) = n+++conData :: Con -> Q (Name,[Type])+conData c = case c of+  NormalC n sts    -> return (n,map snd sts)+  RecC n vsts      -> return (n,map (\(_,s,t) -> t) vsts)+  InfixC st1 n st2 -> return (n,[snd st1,snd st2])+  ForallC _ _ c'   -> conData c'+++x :: IO Type+x = runQ $ (toType ''(,)) +  ++toType n = case lookup n tups of+  Nothing -> conT n+  Just q  -> q++tups = (''(), [t|()|]):map (\(n,i) -> (n, tupleT i)) (zip [''(,), ''(,,)] [2..])

+ Control/Enumerable/Values.hs view

@@ -0,0 +1,79 @@+{-#LANGUAGE DeriveDataTypeable#-}
+module Control.Enumerable.Values
+  ( values
+  , values'
+  , allValues
+  , Values (..)
+  )  where
+
+import Control.Enumerable
+
+-- | Constructs all values of a given size. 
+values :: Enumerable a => Int -> [a]
+values = runValues global
+
+-- | Constructs all values up to a given size.
+values' :: Enumerable a => Int -> [[a]]
+values' i = let f = runValues global in [f x|x <- [0..i]]
+
+allValues :: Enumerable a => [[a]]
+allValues = aux global global where
+  aux :: Values a -> MaxSize a -> [[a]]
+  aux (Values f) (MaxSize m) = map f (zipWith const [0..] m)
+
+
+
+newtype Values a = Values {runValues :: Int -> [a]} deriving Typeable
+
+instance Functor Values where
+  fmap f = Values . fmap (fmap f) . runValues
+
+instance Applicative Values where
+  pure x     = Values $ \i -> if i == 0 then [x] else []
+  fs <*> xs  = fmap (uncurry ($)) (pair fs xs)
+  
+instance Alternative Values where
+  empty     = Values $ \_ -> []
+  xs <|> ys = Values $ \i -> runValues xs i ++ runValues ys i
+
+instance Sized Values where
+  pay xs       = Values $ \i -> if i > 0 then runValues xs (i-1) else []
+  pair xs ys   = Values $ \i -> [(x,y)|n <- [0..i], x <- runValues xs n, y <- runValues ys (i-n)]
+  
+  fin n        = Values $ \i -> if i == 0 then [0..n-1] else []
+  aconcat []   = empty
+  aconcat [x]  = x
+  aconcat xss  = Values $ \i -> concatMap (($ i) . runValues) xss
+
+
+
+
+-- Useful for detecting if an enumeration is finite. 
+data MaxSize a = MaxSize {runMaxSize :: [()]} deriving Show
+instance Functor MaxSize where fmap _ = MaxSize . runMaxSize
+
+instance Applicative MaxSize where 
+  pure _ = MaxSize [()]
+  MaxSize [] <*> _  = empty
+  _ <*> MaxSize []  = empty
+  f <*> x = MaxSize $ tail (runMaxSize f ++ runMaxSize x)
+
+instance Alternative MaxSize where
+  empty = MaxSize []
+  a <|> b = MaxSize (runMaxSize a `zipL` runMaxSize b) where
+    zipL [] x = x
+    zipL x [] = x
+    zipL (_:xs) (_:ys) = () : xs `zipL` ys
+
+
+instance Sized MaxSize where
+  pay = MaxSize . (():) . runMaxSize
+
+
+type TT = Bool --  [[[[[[[[[[Bool]]]]]]]]]]
+tst1 n = take n $ runMaxSize (local :: MaxSize TT)
+
+
+
+-- -- | All values are memoised. Warning: Using this may be faster but potentially uses a lot of memory. 
+-- data Memoised a = Memoised {unMemoised :: [[a]]}

+ Control/Sized.hs view

@@ -0,0 +1,78 @@+++{-| ++This module provides the 'Sized' class. Instances of this class are typically collection data types for infinite sets of values with a finite number of values of any given size. ++A simple example is "Control.Enumerable.Count" that just counts the number of values of each size. "Control.Enumerable.Values" provides all values of a given size. +<https://hackage.haskell.org/package/testing-feat FEAT> provides any value in the set much more efficiently. ++-}+module Control.Sized (module Control.Applicative, Sized(..), kbits) where+import Control.Applicative++-- | A sized functor is an applicative functor extended with a notion of cost/size of contained values. This is useful for any type of bounded recursion over infinite sets, most notably for various kind of enumerations. +--+-- The intention is that every sized functor definition models a (usually) infinite set (technically a bag) with a finite number of values of any given size. As long as every cyclic (recursive) definition has at least one application of pay, this invariant is guaranteed. +--+-- The module "Control.Enumerable" provides sized functor definitions for a lot of data types, such that the size of a value is the number of constructor applications it contains. It also allows deriving these functors for any user defined data type (using Template Haskell). +class Alternative f => Sized f where+  -- | Increases the cost/size of all values in the given set. +  pay :: f a -> f a++  -- | Default: @pair a b = (,) <$> a <*> b@. +  pair :: f a -> f b -> f (a,b)+  pair a b = (,) <$> a <*> b++  -- | Default: @aconcat = foldr (\<|>) empty@+  aconcat :: [f a] -> f a+  aconcat []   = empty+  aconcat xs   = foldr1 (<|>) xs++  {- | Finite numeric types. @fin n@ contains all non-negative numbers below n. This definition is flat, all integers have the same size. +  Implementing this function efficiently will have a great impact on applications that use a lot of bounded numberic types (e.g. Int).+  +  Default: aconcat (map pure [0..n-1]) -}+  fin :: Integer -> f Integer+  fin n = aconcat (map pure [0..n-1])+  +  {- |Same as 'fin' but the size of values may differ. +  By default, the size of an integer is the number of significant bits in its binary representation. In other words, 0 has size zero, the values for size k>0 in @finBits n@ are in the interval +  @(2^(k-1),min (2^k-1) n)@. -}+  finSized :: Integer -> f Integer+  finSized = stdFinBits++  -- | Non-negative integers. By default, the size of an integer is the number of digits in its binary representation. +  naturals :: f Integer+  naturals = stdNaturals+++stdNaturals :: Sized f => f Integer+stdNaturals = pure 0 <|> go 0 where+  go n = pay $ ((2^n)+) <$> fin (2^n) <|> (go (n+1))++stdNaturals' :: Sized f => f Integer+stdNaturals' = pure 0 <|> go 1 where+  go n   = pay $ (n+) <$> fin n <|> go (2*n)+++stdFinBits :: Sized f => Integer -> f Integer+stdFinBits i | i <= 0  = empty+stdFinBits i           = pure 0 <|> go 1 where+  go n | n <= lim   = pay $ (n+) <$> fin n <|> go (2*n)+  go n | n >= i     = empty+  go n              = pay $ (n+) <$> fin (i-n)+  lim = i `div` 2++-- Non-negative integers of a given maximal number of bits. +kbits :: Sized f => Int -> f Integer+kbits k = finSized (2^k)+++++-- integers :: Sized f => (Int -> (Integer,Integer)) -> f Integer+-- integers = ++-- ints :: Sized f => Int -> (Int -> (Integer,Integer)) -> f Integer+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2015, Jonas Duregård
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Jonas Duregård nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ size-based.cabal view

@@ -0,0 +1,40 @@+-- Initial sized-functors.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                size-based
+version:             0.1.0.0
+synopsis:            Sized functors, for size-based enumerations
+description:
+  
+license:             BSD3
+license-file:        LICENSE
+author:              Jonas Duregård
+maintainer:          jonas.duregard@chalmers.se
+-- copyright:           
+category:            Data
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+source-repository head   
+  type:      git
+  location:  https://github.com/JonasDuregard/sized-functors
+
+library
+  exposed-modules:     
+    Control.Sized
+    Control.Enumerable
+    Control.Enumerable.Count
+    Control.Enumerable.Values
+--    Control.Enumerable.Functions
+--    Control.Enumerable.LazySearch
+
+  other-modules:       
+    Control.Enumerable.Derive
+  other-extensions:    GADTs, DeriveDataTypeable
+  build-depends:       base >=4.7 && <5, 
+                       dictionary-sharing >= 0.1 && < 1.0, 
+                       testing-type-modifiers >= 0.1 && < 1.0,
+                       template-haskell  >=2.5 && <2.12
+  -- hs-source-dirs:      
+  default-language:    Haskell2010