packages feed

unfoldable 0.9 → 0.9.1

raw patch · 7 files changed

+126/−76 lines, 7 files

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+0.9.1+-----+* added `Nth` unfolder+* added brackets example+ 0.9 --- * added `chooseMap` method
+ examples/brackets.hs view
@@ -0,0 +1,30 @@+-- From https://byorgey.wordpress.com/2016/10/25/adventures-in-enumerating-balanced-brackets/+import Data.Unfolder+import Data.MemoTrie (memo2)+import Control.Applicative++enumBrackets :: Unfolder f => Int -> f String+enumBrackets n = enumBracketsTail n 0++enumBracketsTail :: Unfolder f => Int -> Int -> f String+enumBracketsTail = enumBracketsTail'+  where+    -- Ensure memoization happens for a specific `f`+    enumBracketsTail' = memo2 enumBracketsTail''+    enumBracketsTail'' 0 c = pure (replicate c ')')+    enumBracketsTail'' n 0 = ('(':) <$> enumBracketsTail' (n-1) 1+    enumBracketsTail'' n c =+      ('(':) <$> enumBracketsTail' (n-1) (c+1)+      <|>+      ((')':) <$> enumBracketsTail' n (c-1))++{-++>>> enumBrackets 3 :: [String]+["((()))","(()())","(())()","()(())","()()()"]+>>> getNth (enumBrackets 40) 16221270422764920820+"((((((((()((())()(()()()())(()))((()()()()(()((()())))((()())))))))()))()())()))"+>>> size (enumBrackets 100)+896519947090131496687170070074100632420837521538745909320++-}
examples/btree.hs view
@@ -1,4 +1,3 @@-import Control.Applicative import Data.Unfoldable import Data.Unfolder
examples/redblack.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -import Control.Applicative import Data.Unfoldable import Data.Unfolder @@ -15,54 +14,54 @@ 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)+-- Red-Black tree implementation adapted from https://gist.github.com/2660297+data Nat = Zero | Succ Nat data NatW :: Nat -> * where-  ZeroW :: NatW Zero-  SuccW :: NatW n -> NatW (Succ n)+  ZeroW :: NatW 'Zero+  SuccW :: NatW n -> NatW ('Succ n) -data RedBlack = Black | Red deriving (Eq, Ord, Show)+data RedBlack = Black | Red -data RedBlackTree a where -  T :: Node Black n a -> RedBlackTree a+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+  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) +      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 n fa = choose+        [ T <$> (unfold :: f a -> f (Node 'Black n a)) fa         , u (SuccW n) fa         ]-  -instance Unfoldable (Node Black Zero) where++instance Unfoldable (Node 'Black 'Zero) where   unfold _ = choose [ pure Leaf ] -instance Unfoldable (Node Black n) => Unfoldable (Node Black (Succ n)) where+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 +      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 :: f (Node 'Red n a)           r = unfold fa-          b :: Unfolder f => f (Node Black n a)+          b :: f (Node 'Black n a)           b = unfold fa -instance Unfoldable (Node Black n) => Unfoldable (Node Red n) where+instance Unfoldable (Node 'Black n) => Unfoldable (Node 'Red n) where   unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ]  rbtree :: Int -> RedBlackTree Int@@ -76,9 +75,9 @@  newtype Formula = Formula [Integer] instance Show Formula where-  show (Formula xs) +  show (Formula xs)     | all (== 0) xs = "0"-    | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [0..]+    | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [(0::Int)..]         where           showOne (x, 0) = show x           showOne (1, 1) = "x"@@ -99,9 +98,9 @@   Formula xs + Formula ys = Formula (add xs ys)   Formula xs * Formula ys = Formula (mul xs ys) -x :: Formula-x = Formula [0, 1]+varX :: Formula+varX = Formula [0, 1]  -- See http://oeis.org/A001137 rbFormula :: Int -> NumConst Formula (RedBlackTree a)-rbFormula d = ala (limitDepth d) unfold (NumConst x)+rbFormula d = ala (limitDepth d) unfold (NumConst varX)
src/Data/Unfoldable.hs view
@@ -10,19 +10,19 @@ -- -- Class of data structures that can be unfolded. ------------------------------------------------------------------------------{-# LANGUAGE CPP, Safe #-}+{-# LANGUAGE CPP, Safe, TupleSections #-} #ifdef GENERICS {-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts #-} #endif-module Data.Unfoldable +module Data.Unfoldable   (-  +   -- * Unfoldable     Unfoldable(..)   , unfold_   , unfoldBF   , unfoldBF_-  +   -- ** Specific unfolds   , unfoldr   , fromList@@ -33,10 +33,10 @@   , allBreadthFirst   , randomDefault   , arbitraryDefault-  -  ) ++  )   where-    + import Control.Applicative import Data.Unfolder import Data.Functor.Compose@@ -50,6 +50,7 @@ import Test.QuickCheck (Arbitrary(..), Gen, sized, resize) import Data.Maybe import qualified Data.Sequence as S+import qualified Data.Tree as T  #ifdef GENERICS import GHC.Generics@@ -83,23 +84,23 @@ -- > import GHC.Generics -- > -- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving Generic1--- > +-- > -- > instance Unfoldable Tree class Unfoldable t where   -- | Given a way to generate elements, return a way to generate structures containing those elements.   unfold :: Unfolder f => f a -> f (t a)-  + #ifdef GENERICS-  +   default unfold :: (Generic1 t, GUnfold (Rep1 t), Unfolder f) => f a -> f (t a)   unfold fa = to1 <$> choose (gunfold fa)-  + class GUnfold r where   gunfold :: Unfolder f => f a -> [f (r a)]-  + instance GUnfold V1 where   gunfold _ = []-  + instance GUnfold U1 where   gunfold _ = [pure U1] @@ -114,7 +115,7 @@  instance GUnfold f => GUnfold (M1 i c f) where   gunfold fa = map (M1 <$>) (gunfold fa)-  + instance (GUnfold f, GUnfold g) => GUnfold (f :+: g) where   gunfold fa = map (L1 <$>) (gunfold fa) ++ map (R1 <$>) (gunfold fa) @@ -139,7 +140,7 @@ unfoldBF_ = bfs unfold_  -- | @unfoldr@ builds a data structure from a seed value. It can be specified as:--- +-- -- > unfoldr f z == fromList (Data.List.unfoldr f z) unfoldr :: Unfoldable t => (b -> Maybe (a, b)) -> b -> Maybe (t a) unfoldr f z = terminate . flip runStateT z . unfoldBF . StateT $ maybeToList . f@@ -182,39 +183,39 @@  -- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'. arbitraryDefault :: (Arbitrary a, Unfoldable t) => Gen (t a)-arbitraryDefault = let Arb _ gen = unfold arbUnit in +arbitraryDefault = let Arb _ gen = unfold arbUnit in   fromMaybe (error "Failed to generate a value.") <$> sized (\n -> resize (n + 1) gen)  instance Unfoldable [] where-  unfold fa = choose -    [ pure []-    , (:) <$> fa <*> unfold fa-    ]+  unfold fa = go where+    go = choose+      [ pure []+      , (:) <$> fa <*> go ]  instance Unfoldable Maybe where-  unfold fa = choose +  unfold fa = choose     [ pure Nothing     , Just <$> fa     ]  instance (Bounded a, Enum a) => Unfoldable (Either a) where-  unfold fa = choose +  unfold fa = choose     [ Left <$> boundedEnum     , Right <$> fa     ]  instance (Bounded a, Enum a) => Unfoldable ((,) a) where-  unfold fa = choose +  unfold fa = choose     [ (,) <$> boundedEnum <*> fa ]  instance Unfoldable Identity where-  unfold fa = choose +  unfold fa = choose     [ Identity <$> fa ]  instance (Bounded a, Enum a) => Unfoldable (Constant a) where-  unfold _ = choose +  unfold _ = choose     [ Constant <$> boundedEnum ]-  + instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where   unfold fa = choose     [ Pair <$> unfold fa <*> unfold fa ]@@ -234,6 +235,11 @@     [ Reverse <$> getDualA (unfold (DualA fa)) ]  instance Unfoldable S.Seq where-  unfold fa = choose-    [ pure empty-    , (S.<|) <$> fa <*> unfold fa ]+  unfold fa = go where+    go = choose+      [ pure empty+      , (S.<|) <$> fa <*> go ]++instance Unfoldable T.Tree where+  unfold fa = go where+    go = choose [ T.Node <$> fa <*> unfold go ]
src/Data/Unfolder.hs view
@@ -44,6 +44,7 @@   , arbUnit    , NumConst(..)+  , Nth(..)    -- * UnfolderTransformer   , UnfolderTransformer(..)@@ -75,7 +76,6 @@ import Data.Functor.Reverse import Control.Applicative.Backwards import Control.Applicative.Lift-import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.List import Control.Monad.Trans.Maybe@@ -88,23 +88,21 @@ import Test.QuickCheck (Arbitrary(..), Gen, oneof, elements, sized, resize)  import Data.Monoid (Monoid(..))-import Data.Maybe (catMaybes, listToMaybe)-import Data.Foldable (asum, foldl')-import Data.Traversable (traverse)+import Data.Maybe (catMaybes) import qualified Data.Sequence as S  -- | Unfolders provide a way to unfold data structures. -- The methods have default implementations in terms of 'Alternative', -- but you can implement 'chooseMap' to act on recursive positions of the -- data structure, or simply to provide a faster implementation than--- 'asum . map f'.+-- 'foldr ((<|>) . f) empty'. class Alternative f => Unfolder f where   -- | Choose one of the values from the list.   choose :: [f a] -> f a   choose = chooseMap id   -- | Choose one of the values from the list and apply the given function.   chooseMap :: (a -> f b) -> [a] -> f b-  chooseMap f = asum . map f+  chooseMap f = foldr ((<|>) . f) empty   -- | Given a number 'n', return a number between '0' and 'n - 1'.   chooseInt :: Int -> f Int   chooseInt n = chooseMap pure [0 .. n - 1]@@ -132,7 +130,7 @@ --   of the higher values. This means that f.e. breadth-first unfolding and arbitrary will prefer --   lower values. betweenD :: (Unfolder f, Enum a) => a -> a -> f a-betweenD lb ub = betweenD' lb (fromEnum ub - fromEnum lb)+betweenD lb0 ub = betweenD' lb0 (fromEnum ub - fromEnum lb0)   where     betweenD' lb n | n < 0 = empty                    | otherwise = choose [pure lb, betweenD' (succ lb) (pred n)]@@ -189,9 +187,6 @@ instance Unfolder f => Unfolder (Lift f)  -- | Derived instance.-instance (Functor m, Monad m, Error e) => Unfolder (ErrorT e m)---- | Derived instance. instance (Functor m, Monad m, Monoid e) => Unfolder (ExceptT e m)  -- | Derived instance.@@ -229,6 +224,11 @@ instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where   chooseMap f = WriterT . chooseMap (runWriterT . f) +-- | Don't choose but return all items.+instance Unfolder S.Seq where+#if MIN_VERSION_containers(0,5,6)+  chooseInt n = S.fromFunction n id+#endif   newtype Random g m a = Random { getRandom :: StateT g m a }@@ -247,6 +247,24 @@   chooseInt n = Random . StateT $ return . R.randomR (0, n - 1)  +data Nth a = Nth+  { size :: Integer+  , getNth :: Integer -> a+  }+instance Functor Nth where+  fmap f (Nth sizeA as) = Nth sizeA (f . as)+instance Applicative Nth where+  pure a = Nth 1 (const a)+  Nth sizeF fs <*> Nth sizeA as = Nth (sizeF * sizeA) $ \n ->+    let (l, r) = n `divMod` sizeA in fs l (as r)+instance Alternative Nth where+  empty = Nth 0 (const undefined)+  Nth sizeA as <|> Nth sizeB bs = Nth (sizeA + sizeB) $ \n ->+    if n < sizeA then as n else bs (n - sizeA)+instance Unfolder Nth where+  chooseInt n = Nth (toInteger n) fromInteger++ -- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. class UnfolderTransformer t where   -- | Lift a computation from the argument unfolder to the constructed unfolder.@@ -404,11 +422,4 @@   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-  chooseMap f = foldr ((<|>) . f) empty--instance Unfolder S.Seq where-  chooseMap f = foldr ((<|>) . f) empty-#if MIN_VERSION_containers(0,5,6)-  chooseInt n = S.fromFunction n id-#endif+instance Num a => Unfolder (NumConst a)
unfoldable.cabal view
@@ -1,5 +1,5 @@ Name:                 unfoldable-Version:              0.9+Version:              0.9.1 Synopsis:             Class of data structures that can be unfolded. Description:          Just as there's a Foldable class, there should also be an Unfoldable class.                       .