Using the function mapEither for multiset's I can turn a MultiSet into a pair of two multisets. When f is returning Left the element is inserted into the first Multiset of the pair, and if f is returning Right the element is inserted into the second MultiSet of the pair.
How can I insert the same element into both MultiSets at the same time, as if f were returning Right and Left at the same time?
f:: LocalType -> Either LocalType LocalType
f (Sometype lt) = Left lt -- And Right lt
f lt = Left lt
parRule :: (MultiSet LocalType) -> (MultiSet LocalType)
parRule sequent = do
let list = MultiSet.mapEither f sequent
For reference, I use Data.Multiset package, https://hackage.haskell.org/package/multiset-0.3.4.3/docs/Data-MultiSet.html.
You can use a type like These to capture the ability to return both. You can then use toAscOccurList and fromOccurList (or fromAscOccurList if your function is monotonic) to compute the new MultiSet.
You could use These as Daniel Wagner suggests, but I would use a slightly different function to start with, which seems like a slightly better match to the library API. Furthermore, I would recommend a different implementation strategy for performance.
data SP a b = SP !a !b
toPair :: SP a b -> (a, b)
toPair (SP a b) = (a, b)
mapPairOcc :: (Ord b, Ord c) => (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> (MultiSet b, MultiSet c)
mapPairOcc f = toPair . mapPairOcc' f
mapPairOcc' :: (Ord b, Ord c) => (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> SP (MultiSet b) (MultiSet c)
mapPairOcc' f = foldl' go (SP empty empty) . toAscOccurList
where
go (SP bs cs) a
| ((b, bn), (c, cn)) <- f a
= SP (insertMany b bn bs) (insertMany c cn cs)
When you know that f is strictly monotone in the sense that
a < a' ==> fst (f a) < fst (f a') /\ snd (f a) < snd (f a')
it's possible to do better, building the results in O(n) time. The best way to do this seems to be to use Data.Map internals. I'll reuse the SP type from above.
import Data.Map.Lazy (Map)
import Data.MultiSet (MultiSet, Occur)
import qualified Data.MultiSet as MS
import qualified Data.Map.Internal as M
import Control.Monad (guard)
-- | Map over the keys and values in a map, producing
-- two maps with new keys and values. The passed function
-- must be strictly monotone in the keys in the sense
-- described above.
mapMaybeWithKey2Mono :: (k -> a -> (Maybe (l,b), Maybe (m,c))) -> Map k a -> (Map l b, Map m c)
mapMaybeWithKey2Mono f = toPair . mapMaybeWithKey2Mono' f
mapMaybeWithKey2Mono' :: (k -> a -> (Maybe (l,b), Maybe (m,c))) -> Map k a -> SP (Map l b) (Map m c)
mapMaybeWithKey2Mono' _ M.Tip = SP M.Tip M.Tip
mapMaybeWithKey2Mono' f (M.Bin _ kx x l r)
| (fl, fr) <- f kx x
= SP (groink fl mfl1 mfr1) (groink fr mfl2 mfr2)
where
groink :: Maybe (q, x) -> Map q x -> Map q x -> Map q x
groink m n o = case m of
Just (k', y) -> M.link k' y n o
Nothing -> M.link2 n o
SP mfl1 mfl2 = mapMaybeWithKey2Mono' f l
SP mfr1 mfr2 = mapMaybeWithKey2Mono' f r
Using this new general Map function, we can define the function we want on multisets:
mapPairAscOcc :: (a -> Occur -> ((b, Occur), (c, Occur))) -> MultiSet a -> (MultiSet b, MultiSet c)
mapPairAscOcc f m
| (p, q) <- mapMaybeWithKey2Mono go . MS.toMap $ m
= (MS.fromOccurMap p, MS.fromOccurMap q)
where
-- a -> Occur -> (Maybe (b, Occur), Maybe (c, Occur))
go a aocc
| ((b, bocc), (c, cocc)) <- f a aocc
= ( (b, bocc) <$ guard (bocc > 0)
, (c, cocc) <$ guard (cocc > 0) )
I took the function mapEither from the Data.MultiSet and modified it such that it supports These type.
-- | /O(n)/. Map and separate the 'This' and 'That' or 'These' results
-- modified function of mapEither to map both cases in case f return These
-- code of mapEither found in source code,
mapThese :: (Ord b, Ord c) => (a -> These b c) -> MultiSet a -> (MultiSet b, MultiSet c)
mapThese f = (\(ls,rs) -> (MultiSet.fromOccurList ls, MultiSet.fromOccurList rs)) . mapThese' . MultiSet.toOccurList
where mapThese' [] = ([],[])
mapThese' ((x,n):xs) = case f x of
This l -> let (ls,rs) = mapThese' xs in ((l,n):ls, rs)
That r -> let (ls,rs) = mapThese' xs in (ls, (r,n):rs)
These u i -> let (ls,rs) = mapThese' xs in ((u,n):ls, (i,n):rs)
In the case f returns These, both MultiSet's have an added element.
Related
I'm looking for a Haskell function that combines two Maps of different types. I.e. something like
mergeWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c
I want it to behave like an inner join in SQL.
unionWith doesn't cut it since it requires both Maps to have values of the same type.
Is there such a function? If not, what's the most efficient way to implement it?
Does intersectionWith not fit the bill?
This was the best that I could do myself
import qualified Data.Map.Strict as M
mergeWith :: (Ord k) => (a -> b -> c) -> M.Map k a -> M.Map k b -> M.Map k c
mergeWith f m1 m2 = M.fromList $ g (M.toList m1) (M.toList m2)
where
g [] _ = []
g _ [] = []
g m1'#((k1, v1):_) m2'#((k2, v2):_)
| k1 < k2 = g (tail m1') m2'
| k1 > k2 = g m1' (tail m2')
| otherwise = (k1, f v1 v2) : g (tail m1') (tail m2')
It sholud have O(n) complexity where n is the size of the bigger Map
I am working on a modification of Control.Foldl datatype that provides instances of Category and Arrow.
My definition is as follows:
data FoldlCat a b = forall x c. FoldlCat (x -> a -> c) x (c -> x) (c -> b)
where the first argument stands for a "step" function (savedState -> newInput -> intermediateValue), second is for initial savedState, third is a "save" function (intermediateValue -> savedState) and the last one is an "extract" function (intermediateValue -> newOutput).
So something like map (*10) . scanl (+) 0 can be expressed as FoldlCat (+) 0 id (*10).
The main purpose of a save function is to facilitate definitions of id and arr like so:
id = FoldlCat (\_ x -> x) () (const ()) id
Now I am unsuccessfully trying to come up with an instance of ArrowLoop. I can not see any reason for it not being possible, however, I am not comfortable enough with fix-like concepts. My best attempt so far typechecks but loops forever.
instance ArrowLoop FoldlCat where
loop (FoldlCat s b a d) = FoldlCat step b (a . snd) fst where
step x = loop' d (s x)
loop' f g x = let ~(v, ~(c,d)) = let ~v = g (x,d) in (v, f v)
in (c, v)
I would be grateful if someone could share their approach on defining such an instance (extra kudos if it would work with a strict tuple in accumulator inside of (.)) or explain why that is not possible or advice on a better structure for FoldlCat.
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Arrows #-}
import Data.List (unfoldr)
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
-- | FoldlCat step init save export
data FoldlCat a b = forall x c. FoldlCat (x -> a -> c) x (c -> x) (c -> b)
mapCat :: (a -> b) -> FoldlCat a b
mapCat f = FoldlCat (\_ x -> x) () (const ()) f
evalList :: FoldlCat t b -> [t] -> [b]
evalList (FoldlCat s b a d) ys = unfoldr stepan (b, ys) where
stepan (accVal, (x:xs)) = Just (nexVal, (newAcc, xs)) where
newMeta = s accVal x
newAcc = a newMeta
nexVal = d newMeta
stepan (accVal, []) = Nothing
delay :: b -> FoldlCat b b
delay def = FoldlCat (,) def snd fst
instance Category FoldlCat where
id = mapCat id
(.) (FoldlCat step2 begin2 acc2 done2) (FoldlCat step1 begin1 acc1 done1) =
let step = \(a, b) y -> let !a' = step1 a y
!b' = step2 b (done1 a') in (a', b')
begin = (begin1, begin2)
acc = \(x, y) -> ((acc1 x), (acc2 y))
done = \(a, b) -> done2 b
in
FoldlCat step begin acc done
instance Arrow FoldlCat where
arr f = mapCat f
first (FoldlCat s b a d) = FoldlCat step b (a . fst) extF where
step = (\a (x, y) -> (s a x, y))
extF = (\(ok, y) -> (d ok, y))
instance ArrowLoop FoldlCat where
loop (FoldlCat s b a d) = FoldlCat step b (a . snd) fst where
step x = loop' d (s x)
loop' f g x = let ~(v, ~(c,d)) = let ~v = g (x,d) in (v, f v)
in (c, v)
chaseFromZero = proc target -> do
rec let step = signum (target - x)
x <- FoldlCat (+) 0 id id <<< delay 0 -< step
id -< x
main = print $ evalList chaseFromZero [1..5]
EDIT Although I am not sure how and why it works, fixing strictness of step in (.) (i.e. removing bang in let !a' = step1 a y) seems to make this example work.
I need a function that does this:
>>> func (+1) [1,2,3]
[[2,2,3],[2,3,3],[2,3,4]]
My real case is more complex, but this example shows the gist of the problem. The main difference is that in reality using indexes would be infeasible. The List should be a Traversable or Foldable.
EDIT: This should be the signature of the function:
func :: Traversable t => (a -> a) -> t a -> [t a]
And closer to what I really want is the same signature to traverse but can't figure out the function I have to use, to get the desired result.
func :: (Traversable t, Applicative f) :: (a -> f a) -> t a -> f (t a)
It looks like #Benjamin Hodgson misread your question and thought you wanted f applied to a single element in each partial result. Because of this, you've ended up thinking his approach doesn't apply to your problem, but I think it does. Consider the following variation:
import Control.Monad.State
indexed :: (Traversable t) => t a -> (t (Int, a), Int)
indexed t = runState (traverse addIndex t) 0
where addIndex x = state (\k -> ((k, x), k+1))
scanMap :: (Traversable t) => (a -> a) -> t a -> [t a]
scanMap f t =
let (ti, n) = indexed (fmap (\x -> (x, f x)) t)
partial i = fmap (\(k, (x, y)) -> if k < i then y else x) ti
in map partial [1..n]
Here, indexed operates in the state monad to add an incrementing index to elements of a traversable object (and gets the length "for free", whatever that means):
> indexed ['a','b','c']
([(0,'a'),(1,'b'),(2,'c')],3)
and, again, as Ben pointed out, it could also be written using mapAccumL:
indexed = swap . mapAccumL (\k x -> (k+1, (k, x))) 0
Then, scanMap takes the traversable object, fmaps it to a similar structure of before/after pairs, uses indexed to index it, and applies a sequence of partial functions, where partial i selects "afters" for the first i elements and "befores" for the rest.
> scanMap (*2) [1,2,3]
[[2,2,3],[2,4,3],[2,4,6]]
As for generalizing this from lists to something else, I can't figure out exactly what you're trying to do with your second signature:
func :: (Traversable t, Applicative f) => (a -> f a) -> t a -> f (t a)
because if you specialize this to a list you get:
func' :: (Traversable t) => (a -> [a]) -> t a -> [t a]
and it's not at all clear what you'd want this to do here.
On lists, I'd use the following. Feel free to discard the first element, if not wanted.
> let mymap f [] = [[]] ; mymap f ys#(x:xs) = ys : map (f x:) (mymap f xs)
> mymap (+1) [1,2,3]
[[1,2,3],[2,2,3],[2,3,3],[2,3,4]]
This can also work on Foldable, of course, after one uses toList to convert the foldable to a list. One might still want a better implementation that would avoid that step, though, especially if we want to preserve the original foldable type, and not just obtain a list.
I just called it func, per your question, because I couldn't think of a better name.
import Control.Monad.State
func f t = [evalState (traverse update t) n | n <- [0..length t - 1]]
where update x = do
n <- get
let y = if n == 0 then f x else x
put (n-1)
return y
The idea is that update counts down from n, and when it reaches 0 we apply f. We keep n in the state monad so that traverse can plumb n through as you walk across the traversable.
ghci> func (+1) [1,1,1]
[[2,1,1],[1,2,1],[1,1,2]]
You could probably save a few keystrokes using mapAccumL, a HOF which captures the pattern of traversing in the state monad.
This sounds a little like a zipper without a focus; maybe something like this:
data Zippy a b = Zippy { accum :: [b] -> [b], rest :: [a] }
mapZippy :: (a -> b) -> [a] -> [Zippy a b]
mapZippy f = go id where
go a [] = []
go a (x:xs) = Zippy b xs : go b xs where
b = a . (f x :)
instance (Show a, Show b) => Show (Zippy a b) where
show (Zippy xs ys) = show (xs [], ys)
mapZippy succ [1,2,3]
-- [([2],[2,3]),([2,3],[3]),([2,3,4],[])]
(using difference lists here for efficiency's sake)
To convert to a fold looks a little like a paramorphism:
para :: (a -> [a] -> b -> b) -> b -> [a] -> b
para f b [] = b
para f b (x:xs) = f x xs (para f b xs)
mapZippy :: (a -> b) -> [a] -> [Zippy a b]
mapZippy f xs = para g (const []) xs id where
g e zs r d = Zippy nd zs : r nd where
nd = d . (f e:)
For arbitrary traversals, there's a cool time-travelling state transformer called Tardis that lets you pass state forwards and backwards:
mapZippy :: Traversable t => (a -> b) -> t a -> t (Zippy a b)
mapZippy f = flip evalTardis ([],id) . traverse g where
g x = do
modifyBackwards (x:)
modifyForwards (. (f x:))
Zippy <$> getPast <*> getFuture
I ended up figuring it out. See the video and slides of a talk I gave:
slides/pdf
video
Original question:
In my effort to understand generic recursion schemes (i.e., that use Fix) I have found it useful to write list-only versions of the various schemes. It makes it much easier to understand the actual schemes (without the additional overhead of the Fix stuff).
However, I have not yet figured out how to define list-only versions of zygo and futu.
Here are my specialised definitions so far:
cataL :: (a -> b -> b) -> b -> [a] -> b
cataL f b (a : as) = f a (cataL f b as)
cataL _ b [] = b
paraL :: (a -> [a] -> b -> b) -> b -> [a] -> b
paraL f b (a : as) = f a as (paraL f b as)
paraL _ b [] = b
-- TODO: histo
-- DONE: zygo (see below)
anaL :: (b -> (a, b)) -> b -> [a]
anaL f b = let (a, b') = f b in a : anaL f b'
anaL' :: (b -> Maybe (a, b)) -> b -> [a]
anaL' f b = case f b of
Just (a, b') -> a : anaL' f b'
Nothing -> []
apoL :: ([b] -> Maybe (a, Either [b] [a])) -> [b] -> [a]
apoL f b = case f b of
Nothing -> []
Just (x, Left c) -> x : apoL f c
Just (x, Right e) -> x : e
-- DONE: futu (see below)
hyloL :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c
hyloL f z g = cataL f z . anaL' g
hyloL' :: (a -> c -> c) -> c -> (c -> Maybe (a, c)) -> c
hyloL' f z g = case g z of
Nothing -> z
Just (x,z') -> f x (hyloL' f z' g)
How do you define histo, zygo and futu for lists?
Zygomorphism is the high-falutin' mathsy name we give to folds built from two semi-mutually recursive functions. I'll give an example.
Imagine a function pm :: [Int] -> Int (for plus-minus) which intersperses + and - alternately through a list of numbers, such that pm [v,w,x,y,z] = v - (w + (x - (y + z))). You can write it out using primitive recursion:
lengthEven :: [a] -> Bool
lengthEven = even . length
pm0 [] = 0
pm0 (x:xs) = if lengthEven xs
then x - pm0 xs
else x + pm0 xs
Clearly pm0 is not compositional - you need to inspect the length of the whole list at each position to determine whether you're adding or subtracting. Paramorphism models primitive recursion of this sort, when the folding function needs to traverse the whole subtree at each iteration of the fold. So we can at least rewrite the code to conform to an established pattern.
paraL :: (a -> [a] -> b -> b) -> b -> [a] -> b
paraL f z [] = z
paraL f z (x:xs) = f x xs (paraL f z xs)
pm1 = paraL (\x xs acc -> if lengthEven xs then x - acc else x + acc) 0
But this is inefficient. lengthEven traverses the whole list at each iteration of the paramorphism resulting in an O(n2) algorithm.
We can make progress by noting that both lengthEven and para can be expressed as a catamorphism with foldr...
cataL = foldr
lengthEven' = cataL (\_ p -> not p) True
paraL' f z = snd . cataL (\x (xs, acc) -> (x:xs, f x xs acc)) ([], z)
... which suggests that we may be able to fuse the two operations into a single pass over the list.
pm2 = snd . cataL (\x (isEven, total) -> (not isEven, if isEven
then x - total
else x + total)) (True, 0)
We had a fold which depended on the result of another fold, and we were able to fuse them into one traversal of the list. Zygomorphism captures exactly this pattern.
zygoL :: (a -> b -> b) -> -- a folding function
(a -> b -> c -> c) -> -- a folding function which depends on the result of the other fold
b -> c -> -- zeroes for the two folds
[a] -> c
zygoL f g z e = snd . cataL (\x (p, q) -> (f x p, g x p q)) (z, e)
On each iteration of the fold, f sees its answer from the last iteration as in a catamorphism, but g gets to see both functions' answers. g entangles itself with f.
We'll write pm as a zygomorphism by using the first folding function to count whether the list is even or odd in length and the second one to calculate the total.
pm3 = zygoL (\_ p -> not p) (\x isEven total -> if isEven
then x - total
else x + total) True 0
This is classic functional programming style. We have a higher order function doing the heavy lifting of consuming the list; all we had to do was plug in the logic to aggregate results. The construction evidently terminates (you need only prove termination for foldr), and it's more efficient than the original hand-written version to boot.
Aside: #AlexR points out in the comments that zygomorphism has a big sister called mutumorphism, which captures mutual recursion in all
its glory. mutu generalises zygo in that both the folding
functions are allowed to inspect the other's result from the previous
iteration.
mutuL :: (a -> b -> c -> b) ->
(a -> b -> c -> c) ->
b -> c ->
[a] -> c
mutuL f g z e = snd . cataL (\x (p, q) -> (f x p q, g x p q)) (z, e)
You recover zygo from mutu simply by ignoring the extra argument.
zygoL f = mutuL (\x p q -> f x p)
Of course, all of these folding patterns generalise from lists to the fixed point of an arbitrary functor:
newtype Fix f = Fix { unFix :: f (Fix f) }
cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = f . fmap (cata f) . unFix
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f = snd . cata (\x -> (Fix $ fmap fst x, f x))
zygo :: Functor f => (f b -> b) -> (f (b, a) -> a) -> Fix f -> a
zygo f g = snd . cata (\x -> (f $ fmap fst x, g x))
mutu :: Functor f => (f (b, a) -> b) -> (f (b, a) -> a) -> Fix f -> a
mutu f g = snd . cata (\x -> (f x, g x))
Compare the definition of zygo with that of zygoL. Also note that zygo Fix = para, and that the latter three folds can be implemented in terms of cata. In foldology everything is related to everything else.
You can recover the list version from the generalised version.
data ListF a r = Nil_ | Cons_ a r deriving Functor
type List a = Fix (ListF a)
zygoL' :: (a -> b -> b) -> (a -> b -> c -> c) -> b -> c -> List a -> c
zygoL' f g z e = zygo k l
where k Nil_ = z
k (Cons_ x y) = f x y
l Nil_ = e
l (Cons_ x (y, z)) = g x y z
pm4 = zygoL' (\_ p -> not p) (\x isEven total -> if isEven
then x - total
else x + total) True 0
Histomorphism models dynamic programming, the technique of tabulating the results of previous subcomputations. (It's sometimes called course-of-value induction.) In a histomorphism, the folding function has access to a table of the results of earlier iterations of the fold. Compare this with the catamorphism, where the folding function can only see the result of the last iteration. The histomorphism has the benefit of hindsight - you can see all of history.
Here's the idea. As we consume the input list, the folding algebra will output a sequence of bs. histo will jot down each b as it emerges, attaching it to the table of results. The number of items in the history is equal to the number of list layers you've processed - by the time you've torn down the whole list, the history of your operation will have a length equal to that of the list.
This is what the history of iterating a list(ory) looks like:
data History a b = Ancient b | Age a b (History a b)
History is a list of pairs of things and results, with an extra result at the end corresponding to the []-thing. We'll pair up each layer of the input list with its corresponding result.
cataL = foldr
history :: (a -> History a b -> b) -> b -> [a] -> History a b
history f z = cataL (\x h -> Age x (f x h) h) (Ancient z)
Once you've folded up the whole list from right to left, your final result will be at the top of the stack.
headH :: History a b -> b
headH (Ancient x) = x
headH (Age _ x _) = x
histoL :: (a -> History a b -> b) -> b -> [a] -> b
histoL f z = headH . history f z
(It happens that History a is a comonad, but headH (née extract) is all we need to define histoL.)
History labels each layer of the input list with its corresponding result. The cofree comonad captures the pattern of labelling each layer of an arbitrary structure.
data Cofree f a = Cofree { headC :: a, tailC :: f (Cofree f a) }
(I came up with History by plugging ListF into Cofree and simplifying.)
Compare this with the free monad,
data Free f a = Free (f (Free f a))
| Return a
Free is a coproduct type; Cofree is a product type. Free layers up a lasagne of fs, with values a at the bottom of the lasagne. Cofree layers up the lasagne with values a at each layer. Free monads are generalised externally-labelled trees; cofree comonads are generalised internally-labelled trees.
With Cofree in hand, we can generalise from lists to the fixpoint of an arbitrary functor,
newtype Fix f = Fix { unFix :: f (Fix f) }
cata :: Functor f => (f b -> b) -> Fix f -> b
cata f = f . fmap (cata f) . unFix
histo :: Functor f => (f (Cofree f b) -> b) -> Fix f -> b
histo f = headC . cata (\x -> Cofree (f x) x)
and once more recover the list version.
data ListF a r = Nil_ | Cons_ a r deriving Functor
type List a = Fix (ListF a)
type History' a b = Cofree (ListF a) b
histoL' :: (a -> History' a b -> b) -> b -> List a -> b
histoL' f z = histo g
where g Nil_ = z
g (Cons_ x h) = f x h
Aside: histo is the dual of futu. Look at their types.
histo :: Functor f => (f (Cofree f a) -> a) -> (Fix f -> a)
futu :: Functor f => (a -> f (Free f a)) -> (a -> Fix f)
futu is histo with the arrows flipped and with Free replaced by
Cofree. Histomorphisms see the past; futumorphisms predict the future.
And much like cata f . ana g can be fused into a hylomorphism,
histo f . futu g can be fused into a
chronomorphism.
Even if you skip the mathsy parts, this paper by Hinze and Wu features a good, example-driven tutorial on histomorphisms and their usage.
Since no one else has answered for futu yet, I'll try to stumble my way through. I'm going to use ListF a b = Base [a] = ConsF a b | NilF
Taking the type in recursion-schemes: futu :: Unfoldable t => (a -> Base t (Free (Base t) a)) -> a -> t.
I'm going to ignore the Unfoldable constraint and substitute [b] in for t.
(a -> Base [b] (Free (Base [b]) a)) -> a -> [b]
(a -> ListF b (Free (ListF b) a)) -> a -> [b]
Free (ListF b) a) is a list, possibly with an a-typed hole at the end. This means that it's isomorphic to ([b], Maybe a). So now we have:
(a -> ListF b ([b], Maybe a)) -> a -> [b]
Eliminating the last ListF, noticing that ListF a b is isomorphic to Maybe (a, b):
(a -> Maybe (b, ([b], Maybe a))) -> a -> [b]
Now, I'm pretty sure that playing type-tetris leads to the only sensible implementation:
futuL f x = case f x of
Nothing -> []
Just (y, (ys, mz)) -> y : (ys ++ fz)
where fz = case mz of
Nothing -> []
Just z -> futuL f z
Summarizing the resulting function, futuL takes a seed value and a function which may produce at least one result, and possibly a new seed value if it produced a result.
At first I thought this was equivalent to
notFutuL :: (a -> ([b], Maybe a)) -> a -> [b]
notFutuL f x = case f x of
(ys, mx) -> ys ++ case mx of
Nothing -> []
Just x' -> notFutuL f x'
And in practice, perhaps it is, more or less, but the one significant difference is that the real futu guarantees productivity (i.e. if f always returns, you will never be stuck waiting forever for the next list element).
If often need to zip two lists, discarding non matching elements (where "matching" is definied by comparing parts of the elements of the lists). For example:
let as = [(1,"a"), (2,"b"), (4,"c")]
let bs = [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
zipWithAdjust (fst) (fst) as bs
-- ~> [((2,"b"),(2,"a")), ((4,"c"),(4,"c"))]
I implemented zipWithAdjust as follows:
zipWithAdjust :: (Ord c, Show a, Show b, Show c) => (a -> c) -> (b -> c) -> [a] -> [b] -> [(a,b)]
zipWithAdjust cmpValA cmpValB (a:as) (b:bs)
| cmpValA a == cmpValB b = (a,b) : zipWithAdjust cmpValA cmpValB as bs
| cmpValA a > cmpValB b = zipWithAdjust cmpValA cmpValB (a:as) bs
| cmpValA a < cmpValB b = zipWithAdjust cmpValA cmpValB as (b:bs)
zipWithAdjust _ _ _ _ = []
It works fine, but I have a feeling that there is a standard way to do such zip. I found Data.Align and this SO Question but can't figure out how to use it for my use case.
Is there a standard way to do this (using library functions)? Is it Data.Align? If so, how do I implement the above function using Data.Align?
Edit: Changed the < case to get implementation matching with example.
As far as I know, there's no such function. However, you could make your function more general by using (a -> b -> Ordering) instead of two additional functions:
zipWithAdjust :: (a -> b -> Ordering) -> [a] -> [b] -> [(a,b)]
zipWithAdjust cmp (a:as) (b:bs)
| ord == LT = zipWithAdjust cmp as (b:bs)
| ord == GT = zipWithAdjust cmp (a:as) (bs)
| ord == EQ = (a,b) : zipWithAdjust cmp as bs
where ord = cmp a b
zipWithAdjust _ _ _ = []
result = zipWithAdjust (\x y -> compare (fst x) (fst y)) [(1,"a"), (2,"b"), (4,"c")] [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
However, I wouldn't call this zip anymore, but something like compareMerge or similar.
You might like Data.Map's intersection capabilities. It's slightly less capable in some ways and more capable in others. For example:
> let as = fromList [(1,"a"), (2,"b"), (4,"c")]; bs = fromList [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
> intersectionWith (,) as bs
fromList [(2,("b","a")),(4,("c","c"))]
I would say it's a bit more idiomatic to say
zipWithAdjust cmpA cmpB (a:as) (b:bs) =
case cmpA a `compare` cmpB b of
EQ -> (a, b) : zipWithAdjust cmpA cmpB as bs
GT -> zipWithAdjust cmpA cmpB (a:as) bs
LT -> zipWithAdjust cmpA cmpB as (b:bs)
zipWithAdjust _ _ _ _ = []
It would certainly be faster, since it reduces the number of times you have to calculate cmpA a and cmpB b. This isn't truly a zip since you are filtering at the same time, and also offsetting in your GT and LT cases. I would say that this solution is perfectly fine as it is, there isn't a need to implement it using standard functions.
edit: using These a b type from Data.These (used by Data.Align), with this:
ordzipBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [These a b]
ordzipBy f g a#(x:t) b#(y:r) = case compare (f x) (g y) of
LT -> This x : ordzipBy f g t b
GT -> That y : ordzipBy f g a r
EQ -> These x y : ordzipBy f g t r
ordzipBy _ _ a [] = map This a
ordzipBy _ _ [] b = map That b
we can express three set operations as:
diffBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [a]
meetBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [(a, b)]
joinBy :: (Ord t) => (a -> t) -> (a->a->a) -> [a] -> [a] -> [a]
diffBy f g xs ys = [x | This x <- ordzipBy f g xs ys]
meetBy f g xs ys = [(x,y) | These x y <- ordzipBy f g xs ys]
joinBy f h xs ys = mergeThese h `map` ordzipBy f f xs ys
what you describe is meetBy, i.e. set intersection operation, with the two ordered lists seen as sets.
The ability of a compiler to efficiently compile these definitions is another question though. The three set functions hand-coded along the lines of ordzipBy might run faster.
ordzipBy f g is compatible with align, and [] with nil, but the type machinery involved in making it happen is above my pay grade. :) Also, it's not clear to me whether the law align (f <$> xs) (g <$> ys) = bimap f g <$> align xs ys would make sense at all because mapping the functions f and g can very well change the mutual ordering of elements of xs and ys.
The two problems (the types, and the law) are related: the parts of data recovered by selector functions for ordering purposes serve as positions, as shape, yet are part of the original data. (cf. instance Alternative ZipList in Haskell?).
update: see if the following works as you expected.
{-# LANGUAGE InstanceSigs, DatatypeContexts #-}
import Data.These
import Data.Align
newtype Ord a => ZL a b = ZL {unzl :: [(a,b)]}
deriving (Eq, Show)
instance Ord a => Functor (ZL a) where
fmap f (ZL xs) = ZL [(k, f v) | (k,v)<-xs]
instance Ord a => Align (ZL a) where
nil = ZL []
align :: (ZL a b) -> (ZL a c) -> (ZL a (These b c))
align (ZL a) (ZL b) = ZL (g a b) where
g a#((k,x):t) b#((n,y):r) = case compare k n of
LT -> (k, This x ) : g t b
GT -> (n, That y) : g a r
EQ -> (k, These x y) : g t r
g a [] = [(k, This x) | (k,x) <- a]
g [] b = [(n, That y) | (n,y) <- b]
diffBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [a]
meetBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [(a, b)]
joinBy :: (Ord t) => (a -> t) -> (a->a->a) -> [a] -> [a] -> [a]
diffBy f g xs ys = catThis . map snd . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(g y,y) | y<-ys])
meetBy f g xs ys = catThese . map snd . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(g y,y) | y<-ys])
joinBy f h xs ys = map (mergeThese h . snd) . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(f y,y) | y<-ys])
Infinite lists aren't handled well though, while the hand-coded functions can obviously quite easily be made to handle such cases correctly:
*Main> diffBy id id [1..5] [4..9]
[1,2,3]
*Main> diffBy id id [1..5] [4..]
[1,2,3Interrupted.
*Main> meetBy id id [1,3..10] [2,5..20]
[(5,5)]
*Main> joinBy id const [1,3..10] [2,5..20]
[1,2,3,5,7,8,9,11,14,17,20]