unfoldable 0.5.0 → 0.6.0

raw patch · 5 files changed

+352/−44 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/redblack.hs +107/−0
• src/Data/Biunfoldable.hs +112/−0
• src/Data/Unfoldable.hs +27/−16
• src/Data/Unfolder.hs +103/−26
• unfoldable.cabal +3/−2

@@ -0,0 +1,107 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++import Control.Applicative+import Data.Unfoldable+import Data.Unfolder++import Data.Maybe+import System.Random+import Data.List (intercalate)++-- red-black tree implementation adapted from https://gist.github.com/2660297+data Nat = Zero | Succ Nat deriving (Eq, Ord, Show)+data NatW :: Nat -> * where+  ZeroW :: NatW Zero+  SuccW :: NatW n -> NatW (Succ n)++data RedBlack = Black | Red deriving (Eq, Ord, Show)++data RedBlackTree a where +  T :: Node Black n a -> RedBlackTree a+deriving instance Show a => Show (RedBlackTree a)++data Node :: RedBlack -> Nat -> * -> * where+  Leaf :: Node Black Zero a+  B :: Node cL    n a -> a -> Node cR    n a -> Node Black (Succ n) a+  R :: Node Black n a -> a -> Node Black n a -> Node Red    n       a+deriving instance Show a => Show (Node c n a)++instance Unfoldable RedBlackTree where+  unfold = u ZeroW+    where+      u :: forall n f a. (Unfoldable (Node Black n), Unfolder f) +        => NatW n -> f a -> f (RedBlackTree a)+      u n fa = choose +        [ T <$> (unfold :: Unfolder f => f a -> f (Node Black n a)) fa+        , u (SuccW n) fa+        ]+  +instance Unfoldable (Node Black Zero) where+  unfold _ = choose [ pure Leaf ]++instance Unfoldable (Node Black n) => Unfoldable (Node Black (Succ n)) where+  unfold = u+    where+      u :: forall f a. Unfolder f => f a -> f (Node Black (Succ n) a)+      u fa = choose +        [ B <$> b <*> fa <*> b+        , B <$> b <*> fa <*> r+        , B <$> r <*> fa <*> b+        , B <$> r <*> fa <*> r+        ]+        where+          r :: Unfolder f => f (Node Red n a)+          r = unfold fa+          b :: Unfolder f => f (Node Black n a)+          b = unfold fa++instance Unfoldable (Node Black n) => Unfoldable (Node Red n) where+  unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ]++rbtree :: Int -> RedBlackTree Int+rbtree l = fromJust $ fromList [0..l]++rbtreeShapes :: Int -> [RedBlackTree ()]+rbtreeShapes d = limitDepth d unfold_++randomRBTree :: IO (RedBlackTree Bool)+randomRBTree = getStdRandom randomDefault++newtype Formula = Formula [Integer]+instance Show Formula where+  show (Formula xs) +    | all (== 0) xs = "0"+    | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [0..]+        where+          showOne (x, 0) = show x+          showOne (1, 1) = "x"+          showOne (x, 1) = show x ++ "x"+          showOne (1, n) = "x^" ++ show n+          showOne (x, n) = show x ++ "x^" ++ show n++add, mul :: [Integer] -> [Integer] -> [Integer]+add xs [] = xs+add [] ys = ys+add (x:xs) (y:ys) = (x + y) : add xs ys+mul _ [] = []+mul [] _ = []+mul (x:xs) (y:ys) = (x * y) : add (map (x*) ys) (add (map (y*) xs) (0 : mul xs ys))++instance Num Formula where+  fromInteger x = Formula [x]+  Formula xs + Formula ys = Formula (add xs ys)+  Formula xs * Formula ys = Formula (mul xs ys)++x :: Formula+x = Formula [0, 1]++-- See http://oeis.org/A001137+rbFormula :: Int -> NumConst Formula (RedBlackTree a)+rbFormula d = ala (limitDepth d) unfold (NumConst x)

@@ -0,0 +1,112 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Biunfoldable+-- Copyright   :  (c) Sjoerd Visscher 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Class of data structures with 2 type arguments that can be unfolded.+-----------------------------------------------------------------------------+module Data.Biunfoldable +  (++  -- * Biunfoldable+    Biunfoldable(..)+  , biunfold_+  , biunfoldBF+  , biunfoldBF_++  -- ** Specific unfolds+  , biunfoldr+  , fromLists+  , randomDefault+  , arbitraryDefault++  ) +  where++import Control.Applicative+import Data.Unfolder+import Data.Functor.Constant+import Control.Monad.Trans.State+import qualified System.Random as R+import Test.QuickCheck.Arbitrary (Arbitrary(..))+import Test.QuickCheck.Gen (Gen(..))+import Data.Maybe++-- | Data structures with 2 type arguments (kind @* -> * -> *@) that can be unfolded.+--+-- For example, given a data type+--+-- > data Tree a b = Empty | Leaf a | Node (Tree a b) b (Tree a b)+--+-- a suitable instance would be+--+-- > instance Biunfoldable Tree where+-- >   biunfold fa fb = choose+-- >     [ pure Empty+-- >     , Leaf <$> fa+-- >     , Node <$> biunfold fa fb <*> fb <*> biunfold fa fb+-- >     ]+--+-- i.e. it follows closely the instance for 'Bitraversable', but instead of matching on an input value,+-- we 'choose' from a list of all cases.+class Biunfoldable t where+  -- | Given a way to generate elements, return a way to generate structures containing those elements.+  biunfold :: Unfolder f => f a -> f b -> f (t a b)++-- | Unfold the structure, always using @()@ as elements.+biunfold_ :: (Biunfoldable t, Unfolder f) => f (t () ())+biunfold_ = biunfold (pure ()) (pure ())++-- | Breadth-first unfold, which orders the result by the number of 'choose' calls.+biunfoldBF :: (Biunfoldable t, Unfolder f) => f a -> f b -> f (t a b)+biunfoldBF = ala2 bfs biunfold++-- | Unfold the structure breadth-first, always using @()@ as elements.+biunfoldBF_ :: (Biunfoldable t, Unfolder f) => f (t () ())+biunfoldBF_ = bfs biunfold_++-- | @biunfoldr@ builds a data structure from a seed value.+biunfoldr :: Biunfoldable t => (c -> Maybe (a, c)) -> (c -> Maybe (b, c)) -> c -> Maybe (t a b)+biunfoldr fa fb z = terminate . flip runStateT z $ biunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb)+  where+    terminate [] = Nothing+    terminate ((t, c):ts) = if isNothing (fa c) && isNothing (fb c) then Just t else terminate ts++-- | Create a data structure using the lists as input.+-- This can fail because there might not be a data structure with the same number+-- of element positions as the number of elements in the lists.+fromLists :: Biunfoldable t => [a] -> [b] -> Maybe (t a b)+fromLists = curry $ biunfoldr unconsA unconsB+  where+    unconsA ([], _) = Nothing+    unconsA (a:as, bs) = Just (a, (as, bs))+    unconsB (_, []) = Nothing+    unconsB (as, b:bs) = Just (b, (as, bs))++-- | Generate a random value, can be used as default instance for 'R.Random'.+randomDefault :: (R.Random a, R.Random b, R.RandomGen g, Biunfoldable t) => g -> (t a b, g)+randomDefault = runState . getRandom $ biunfold (Random . state $ R.random) (Random . state $ R.random)++-- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.+arbitraryDefault :: (Arbitrary a, Arbitrary b, Biunfoldable t) => Gen (t a b)+arbitraryDefault = MkGen $ \r n -> let Arb _ f = biunfold arbUnit arbUnit in +  fromMaybe (error "Failed to generate a value.") (f r (n + 1))++instance Biunfoldable Either where+  biunfold fa fb = choose +    [ Left <$> fa+    , Right <$> fb+    ]++instance Biunfoldable (,) where+  biunfold fa fb = choose +    [ (,) <$> fa <*> fb ]++instance Biunfoldable Constant where+  biunfold fa _ = choose +    [ Constant <$> fa ]

@@ -25,6 +25,7 @@   , leftMost   , rightMost   , allDepthFirst+  , allToDepth   , allBreadthFirst   , randomDefault   , arbitraryDefault@@ -72,11 +73,11 @@  -- | Breadth-first unfold, which orders the result by the number of 'choose' calls. unfoldBF :: (Unfoldable t, Unfolder f) => f a -> f (t a)-unfoldBF = runBFS . unfold . packBFS+unfoldBF = ala bfs unfold  -- | Unfold the structure breadth-first, always using @()@ as elements. unfoldBF_ :: (Unfoldable t, Unfolder f) => f (t ())-unfoldBF_ = unfoldBF (pure ())+unfoldBF_ = bfs unfold_  -- | @unfoldr@ builds a data structure from a seed value. It can be specified as: -- @@ -104,11 +105,15 @@ rightMost :: Unfoldable t => Maybe (t ()) rightMost = getDualA unfold_ --- | Generate all the values depth first.+-- | Generate all the values depth-first. allDepthFirst :: Unfoldable t => [t ()] allDepthFirst = unfold_ --- | Generate all the values breadth first.+-- | Generate all the values upto a given depth, depth-first.+allToDepth :: Unfoldable t => Int -> [t ()]+allToDepth d = limitDepth d unfold_++-- | Generate all the values breadth-first. allBreadthFirst :: Unfoldable t => [t ()] allBreadthFirst = unfoldBF_ @@ -122,37 +127,43 @@   fromMaybe (error "Failed to generate a value.") (f r (n + 1))  instance Unfoldable [] where-  unfold f = choose +  unfold fa = choose      [ pure []-    , (:) <$> f <*> unfold f+    , (:) <$> fa <*> unfold fa     ]  instance Unfoldable Maybe where-  unfold f = choose +  unfold fa = choose      [ pure Nothing-    , Just <$> f+    , Just <$> fa     ]  instance (Bounded a, Enum a) => Unfoldable (Either a) where-  unfold f = choose +  unfold fa = choose      [ Left <$> boundedEnum-    , Right <$> f+    , Right <$> fa     ]  instance (Bounded a, Enum a) => Unfoldable ((,) a) where-  unfold f = (,) <$> boundedEnum <*> f+  unfold fa = choose +    [ (,) <$> boundedEnum <*> fa ]  instance Unfoldable Identity where-  unfold = fmap Identity+  unfold fa = choose +    [ Identity <$> fa ]  instance (Bounded a, Enum a) => Unfoldable (Constant a) where-  unfold = fmap Constant . const boundedEnum+  unfold _ = choose +    [ Constant <$> boundedEnum ]    instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where-  unfold f = Pair <$> unfold f <*> unfold f+  unfold fa = choose+    [ Pair <$> unfold fa <*> unfold fa ]  instance (Unfoldable p, Unfoldable q) => Unfoldable (Compose p q) where-  unfold = fmap Compose . unfold . unfold+  unfold fa = choose+    [ Compose <$> unfold (unfold fa) ]  instance Unfoldable f => Unfoldable (Reverse f) where-  unfold = fmap Reverse . getDualA . unfold . DualA+  unfold fa = choose+    [ Reverse <$> getDualA (unfold (DualA fa)) ]

@@ -16,6 +16,7 @@ {-# LANGUAGE      ScopedTypeVariables   , GeneralizedNewtypeDeriving+  , RankNTypes   #-} module Data.Unfolder    (@@ -27,16 +28,28 @@   , boundedEnum      -- ** Unfolder instances-  , DualA(..)   , Random(..) -  , BFS(..)-  , runBFS-  , packBFS-     , Arb(..)   , arbUnit   +  , NumConst(..)+  +  -- * UnfolderTransformer+  , UnfolderTransformer(..)+  , ala+  , ala2+  +  -- ** UnfolderTransformer instances+  , DualA(..)++  , NT(..)+  , WithRec(..)+  , withRec+  , limitDepth+  +  , BFS(..)+  , bfs   )    where  @@ -61,7 +74,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary(..)) import Test.QuickCheck.Gen (Gen(..)) -import Data.Monoid (Monoid)+import Data.Monoid (Monoid(..)) import Data.Maybe (catMaybes, listToMaybe) import Data.Foldable (asum) import Data.Traversable (traverse)@@ -83,6 +96,7 @@ chooseMonadDefault ms = chooseInt (length ms) >>= (ms !!)  -- | If a datatype is bounded and enumerable, we can use 'chooseInt' to generate a value.+-- This is the function to use if you want to unfold a datatype that has no type arguments (has kind *). boundedEnum :: forall f a. (Unfolder f, Bounded a, Enum a) => f a boundedEnum = (\x -> toEnum (x + lb)) <$> chooseInt (1 + ub - lb)   where@@ -107,26 +121,12 @@   chooseInt 0 = Nothing   chooseInt _ = Just 0 --- | 'DualA' flips the '(<|>)' operator.-newtype DualA f a = DualA { getDualA :: f a }-  deriving (Functor, Applicative)-instance Alternative f => Alternative (DualA f) where-  empty = DualA empty-  DualA a <|> DualA b = DualA (b <|> a)--- | Reverse the list passed to choose.-instance Unfolder f => Unfolder (DualA f) where-  choose = DualA . choose . reverse . map getDualA-  chooseInt n = DualA $ (\x -> n - 1 - x) <$> chooseInt n--fstP :: Product p q a -> p a-fstP (Pair p _) = p--sndP :: Product p q a -> q a-sndP (Pair _ q) = q- -- | Derived instance. instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where   choose ps = Pair (choose $ map fstP ps) (choose $ map sndP ps)+    where+      fstP (Pair p _) = p+      sndP (Pair _ q) = q   chooseInt n = Pair (chooseInt n) (chooseInt n)  -- | Derived instance.@@ -157,7 +157,7 @@  -- | Derived instance. instance (Functor m, Monad m) => Unfolder (MaybeT m) where-  choose ms = MaybeT $ fmap (listToMaybe . catMaybes) (mapM runMaybeT ms)+  choose ms = MaybeT $ listToMaybe . catMaybes <$> mapM runMaybeT ms   chooseInt 0 = MaybeT $ return Nothing   chooseInt _ = MaybeT $ return (Just 0)   @@ -194,6 +194,64 @@   chooseInt n = Random . StateT $ return . R.randomR (0, n - 1)  +-- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. +class UnfolderTransformer t where+  -- | Lift a computation from the argument unfolder to the constructed unfolder.+  lift :: Unfolder f => f a -> t f a++-- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer.+ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b+ala lower f = lower . f . lift++-- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer.+ala2 :: (UnfolderTransformer t, Unfolder f) => (t f c -> f c) -> (t f a -> t f b -> t f c) -> f a -> f b -> f c+ala2 lower f = ala lower . f . lift+++-- | 'DualA' flips the @\<|>@ operator from `Alternative`.+newtype DualA f a = DualA { getDualA :: f a }+  deriving (Eq, Show, Functor, Applicative)++instance Alternative f => Alternative (DualA f) where+  empty = DualA empty+  DualA a <|> DualA b = DualA (b <|> a)++-- | Reverse the list passed to choose.+instance Unfolder f => Unfolder (DualA f) where+  choose = DualA . choose . reverse . map getDualA+  chooseInt n = DualA $ (\x -> n - 1 - x) <$> chooseInt n++instance UnfolderTransformer DualA where+  lift = DualA+++-- | Natural transformations+data NT f g = NT { getNT :: forall a. f a -> g a }++newtype WithRec f a = WithRec { getWithRec :: ReaderT (Int -> NT f f) f a }+  deriving (Functor, Applicative, Alternative)++-- | Applies a certain function depending on the depth at every recursive position.+instance Unfolder f => Unfolder (WithRec f) where+  choose ms = WithRec . ReaderT $ \f -> +    getNT (f 0) $ choose (map (\(WithRec (ReaderT m)) -> m (f . succ)) ms)++instance UnfolderTransformer WithRec where+  lift = WithRec . ReaderT . const++-- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'.+-- The depth is passed as 'Int', so you can apply a different function at each depth.+-- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor.+-- See 'limitDepth' for an example how to use this function.+withRec :: (Int -> NT f f) -> WithRec f a -> f a+withRec f = (`runReaderT` f) . getWithRec++-- | Limit the depth of an unfolding.+limitDepth :: Unfolder f => Int -> WithRec f a -> f a+limitDepth m = withRec (\d -> NT $ if d == m then const empty else id)+++ -- | Return a generator of values of a given depth. -- Returns 'Nothing' if there are no values of that depth or deeper. -- The depth is the number of 'choose' calls.@@ -216,9 +274,13 @@ instance Applicative f => Unfolder (BFS f) where   choose ms = BFS $ \d -> if d == 0 then Just [] else flattenBFS (map (`getBFS` (d - 1)) ms) -runBFS :: Unfolder f => BFS f x -> f x-runBFS (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f d)+instance UnfolderTransformer BFS where+  lift = packBFS +-- | Change the order of unfolding to be breadth-first.+bfs :: Unfolder f => BFS f x -> f x+bfs (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f d)+ packBFS :: f x -> BFS f x packBFS r = BFS $ \d -> if d == 0 then Just [r] else Nothing @@ -261,3 +323,18 @@  arbUnit :: Arbitrary a => Arb a arbUnit = Arb 0 (\r n -> Just $ unGen arbitrary r n)++-- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@.+newtype NumConst a x = NumConst { getNumConst :: a } deriving (Eq, Show)+instance Functor (NumConst a) where+  fmap _ (NumConst a) = NumConst a+instance Num a => Applicative (NumConst a) where+  pure _ = NumConst 1+  NumConst a <*> NumConst b = NumConst $ a * b+instance Num a => Alternative (NumConst a) where+  empty = NumConst 0+  NumConst a <|> NumConst b = NumConst $ a + b+-- | Unfolds to a constant numeric value. Useful for counting shapes.+instance Num a => Unfolder (NumConst a) where+  choose [] = empty+  choose as = foldr1 (<|>) as

@@ -1,5 +1,5 @@ Name:                 unfoldable-Version:              0.5.0+Version:              0.6.0 Synopsis:             Class of data structures that can be unfolded. Description:          Just as there's a Foldable class, there should also be an Unfoldable class.                        .@@ -30,7 +30,8 @@      Exposed-modules:     Data.Unfolder-    Data.Unfoldable  +    Data.Unfoldable+    Data.Biunfoldable      Build-depends:       base         >= 4   && < 5