Using a histomorphism (histo) from recursion-schemes I can get the a list containing only the odd indexes from an initial list:
import Data.Functor.Foldable
odds :: [a] -> [a]
odds = histo $ \case
Nil -> []
Cons h (_ :< Nil) -> [h]
Cons h (_ :< Cons _ (t :< _)) -> h:t
How can get the same thing using mhisto?
nil = Fix Nil
cons a b = Fix $ Cons a b
list = cons 1 $ cons 2 $ cons 3 $ nil
modds :: Fix (ListF a) -> [a]
modds = mhisto alg where
alg _ _ Nil = []
alg f g (Cons a b) = ?
This is it:
modds :: Fix (ListF a) -> [a]
modds = mhisto alg
where
alg _ _ Nil = []
alg odd pre (Cons a b) = a : case pre b of
Nil -> []
Cons _ b' -> odd b'
GHCi> list = cata embed [1..10] :: Fix (ListF Int)
GHCi> odds (cata embed list)
[1,3,5,7,9]
GHCi> modds list
[1,3,5,7,9]
odd folds the rest of the list, while pre digs the predecessor. Note how the availability of an y -> f y function in the Mendler algebra mirrors the introduction of Cofree in the ordinary histomorphism algebra (in which digging back can be done by reaching for the tail of the Cofree stream):
cata :: Functor f => (f c -> c) -> Fix f -> c
histo :: Functor f => (f (Cofree f c) -> c) -> Fix f -> c
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
For further reading on mcata and mhisto, see chapters 5 and 6 of Categorical programming with inductive and coinductive types, by Varmo Vene.
Related
In recursion schemes, how can I construct something with type definition like (Recursive t, CoRecursive t) -> t -> ? -> t
I try to use recursion-schemes to update nodes. Taking list as an example, I can come up with two methods like:
update :: [a] -> Natural -> a -> [a]
update = para palg where
palg Nil _ _ = []
palg (Cons a (u, _)) 0 b = b : u
palg (Cons a (u, f)) n b = a : f (n-1) b
update' :: [a] -> Natural -> a -> [a]
update' = c2 (apo acoalg) where
c2 f a b c = f (a,b,c)
acoalg ([], _, _) = Nil
acoalg (_:as , 0, b) = Cons b $ Left as
acoalg (a:as , n, b) = Cons a $ Right (as, n-1, b)
However, these two implementations are good. In these two implementations, the constructor of ListF and [] appears in both sides of the equation. And the definition does not appear to be unique. Is there a better way to perform List update with recursion schemes?
Recursion schemes is flexible approach. You can also implement your own variant.
(Reuse cata)
zipo :: (Recursive g, Recursive h) => (Base g (h -> c) -> Base h h -> c) -> g -> h -> c
zipo alg = cata zalg
where
zalg x = alg x <<< project
update :: forall a. [a] -> Natural -> a -> [a]
update xs n a = zipo alg n xs
where
alg :: Maybe ([a] -> [a]) -> ListF a [a] -> [a]
alg _ Nil = []
alg Nothing (Cons y ys) = a:ys
alg (Just n') (Cons y ys) = y:(n' ys)
Also u can implement some parallel version like
zipCata :: (Recursive g, Recursive h) => ((g -> h -> r) -> Base g g -> Base h h -> r) -> g -> h -> r
zipCata phi x y = phi (zipCata phi) (project x) (project y)
update' :: forall a. [a] -> Natural -> a -> [a]
update' xs n a = zipCata alg n xs
where
alg :: (Natural -> [a] -> [a]) -> Maybe Natural -> ListF a [a] -> [a]
alg _ _ Nil = []
alg _ Nothing (Cons _ ys) = a:ys
alg f (Just n) (Cons y ys) = y:(f n ys)
Both variants (also as your) will be get the same result
PS. I hate approach for code sample on SO
There is an elegant derinition of list of fibonacci numbers:
fibs :: [Integer]
fibs = fib 1 1 where
fib a b = a : fib b (a + b)
Can it be translated to use recursion-schemes library?
The closest I could get is the following code that uses completely different approach:
fibN' :: Nat -> Integer
fibN' = histo $ \case
(refix -> x:y:_) -> x + y
_ -> 1
I can provide the rest of the code if necessary, but essentially I get the Nth fibonacci number by using a histomorphism of Nat = Fix Maybe. Maybe (Cofree Maybe a) turns out to be isomorphic to [a], so refix can be thought just as a sort of toList to make the pattern shorter.
Upd:
I found shorter code but it only stores one value and in a non-generic way:
fib' :: (Integer, Integer) -> [Integer]
fib' = ana $ \(x, y) -> Cons x (y, x+y)
A non-generic way to store full history:
fib'' :: [Integer] -> [Integer]
fib'' = ana $ \l#(x:y:_) -> Cons x (x + y : l)
Sure. Your fibs is readily translated into an unfoldr, which is just a slightly different way to spell ana.
fibs = unfoldr (\(a, b) -> Just (a, (b, a + b))) (1,1)
Here is (sort of) what I wanted:
type L f a = f (Cofree f a)
histAna
:: (Functor f, Corecursive t) =>
(f (Cofree g a) -> Base t (L g a))
-> (L g a -> f a)
-> L g a -> t
histAna unlift psi = ana (unlift . lift) where
lift oldHist = (:< oldHist) <$> psi oldHist
psi
takes an "old history" as a seed,
produces one level and seeds just like in normal ana,
then the new seeds are appended to the "old history", so the newHistory becomes newSeed :< oldHistory
unlift produces current level from seed and history.
fibsListAna :: Num a => L Maybe a -> [a]
fibsListAna = histAna unlift psi where
psi (Just (x :< Just (y :< _))) = Just $ x + y
unlift x = case x of
Nothing -> Nil
h#(Just (v :< _)) -> Cons v h
r1 :: [Integer]
r1 = take 10 $ toList $ fibsListAna $ Just (0 :< Just (1 :< Nothing))
Stream version can also be implemented (Identity and (,) a functors respectively should be used). The binary tree case works too, but it's not clear if it's of any use. Here is a degenerated case I wrote blindly just to satisfy the type checker:
fibsTreeAna :: Num a => L Fork a -> Tree a
fibsTreeAna = histAna unlift psi where
psi (Fork (a :< _) (b :< _)) = Fork a b
unlift x = case x of
h#(Fork (a :< _) (b :< _)) -> NodeF (a + b) h h
It's not clear if we lose anything by replacing Cofree with lists:
histAna
:: (Functor f, Corecursive t) =>
(f [a] -> Base t [a])
-> ([a] -> f a)
-> [a] -> t
histAna unlift psi = ana (unlift . lift) where
lift oldHist = (: oldHist) <$> psi oldHist
In this case 'history' becomes just the path to the tree root filled by seeds.
The list version turns out to be easily simplified by using different functor so seeding and filling the level can be accomplished in one place:
histAna psi = ana lift where
lift oldHist = (: oldHist) <$> psi oldHist
fibsListAna :: Num a => [a]
fibsListAna = histAna psi [0,1] where
psi (x : y : _) = Cons (x + y) (x + y)
The original code with Cofree can be simplified too:
histAna :: (Functor f, Corecursive t) => (L f a -> Base t (f a)) -> L f a -> t
histAna psi = ana $ \oldHist -> fmap (:< oldHist) <$> psi oldHist
fibsListAna :: Num a => L Maybe a -> [a]
fibsListAna = histAna $ \case
Just (x :< Just (y :< _)) -> Cons (x + y) (Just (x + y))
fibsStreamAna :: Num a => L Identity a -> Stream a
fibsStreamAna = histAna $ \case
Identity (x :< Identity (y :< _)) -> (x + y, Identity $ x + y)
fibsTreeAna :: Num a => L Fork a -> Tree a
fibsTreeAna = histAna $ \case
Fork (a :< _) (b :< _) -> NodeF (a + b) (Fork a a) (Fork b b)
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).
I want to be able to use cata from recursion-schemes package for lists in Church encoding.
type ListC a = forall b. (a -> b -> b) -> b -> b
I used a second rank type for convenience, but I don't care. Feel free to add a newtype, use GADTs, etc. if you feel it is necessary.
The idea of Church encoding is widely known and simple:
three :: a -> a -> a -> List1 a
three a b c = \cons nil -> cons a $ cons b $ cons c nil
Basically "abstract unspecified" cons and nil are used instead of "normal" constructors. I believe everything can be encoded this way (Maybe, trees, etc.).
It's easy to show that List1 is indeed isomorphic to normal lists:
toList :: List1 a -> [a]
toList f = f (:) []
fromList :: [a] -> List1 a
fromList l = \cons nil -> foldr cons nil l
So its base functor is the same as of lists, and it should be possible to implement project for it and use the machinery from recursion-schemes.
But I couldn't, so my question is "how do I do that?". For normal lists, I can just pattern match:
decons :: [a] -> ListF a [a]
decons [] = Nil
decons (x:xs) = Cons x xs
Since I cannot pattern-match on functions, I have to use a fold to deconstruct the list. I could write a fold-based project for normal lists:
decons2 :: [a] -> ListF a [a]
decons2 = foldr f Nil
where f h Nil = Cons h []
f h (Cons hh t) = Cons h $ hh : t
However I failed to adapt it for Church-encoded lists:
-- decons3 :: ListC a -> ListF a (ListC a)
decons3 ff = ff f Nil
where f h Nil = Cons h $ \cons nil -> nil
f h (Cons hh t) = Cons h $ \cons nil -> cons hh (t cons nil)
cata has the following signature:
cata :: Recursive t => (Base t a -> a) -> t -> a
To use it with my lists, I need:
To declare the base functor type for the list using type family instance Base (ListC a) = ListF a
To implement instance Recursive (List a) where project = ...
I fail at both steps.
The newtype wrapper turned out to be the crucial step I missed. Here is the code along with a sample catamorphism from recursion-schemes.
{-# LANGUAGE LambdaCase, Rank2Types, TypeFamilies #-}
import Data.Functor.Foldable
newtype ListC a = ListC { foldListC :: forall b. (a -> b -> b) -> b -> b }
type instance Base (ListC a) = ListF a
cons :: a -> ListC a -> ListC a
cons x (ListC xs) = ListC $ \cons' nil' -> x `cons'` xs cons' nil'
nil :: ListC a
nil = ListC $ \cons' nil' -> nil'
toList :: ListC a -> [a]
toList f = foldListC f (:) []
fromList :: [a] -> ListC a
fromList l = foldr cons nil l
instance Recursive (ListC a) where
project xs = foldListC xs f Nil
where f x Nil = Cons x nil
f x (Cons tx xs) = Cons x $ tx `cons` xs
len = cata $ \case Nil -> 0
Cons _ l -> l + 1
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]