This code is from an assignment I already solved. Still I am trying to figure out if I could fix my initial attempt.
So we got this tree structure and the foldTree function.
data Tree a = Leaf a
| Node (Tree a) (Tree a)
foldTree :: (b -> b -> b) -> (a -> b) -> Tree a -> b
foldTree op f (Leaf x) = f x
foldTree op f (Node l r) = foldTree op f l `op` foldTree op f r
Now mapTree has to be implemented using foldTree.
I got it done this way.
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree' f tree = foldTree Node (Leaf . f) tree
What I initially came up with and still don't get to work is this:
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f tree = foldTree Node transFunc tree
where transFunc :: Tree a -> Tree b
transFunc (Leaf x) = Leaf (f x)
transFunc (Node l r) = Node (transFunc l) (transFunc r)
The second function is wrong because of its type: Tree a -> Tree b while foldTree expects it to be a -> b where a is taken from Tree a. b is required by mapTree to be Tree b therefore the third argument to foldTree should be of type a -> Tree b.
So the simplest fixed version of your transFunc is:
mapTree :: forall a b. (a -> b) -> Tree a -> Tree b
mapTree f tree = foldTree Node transFunc tree
where transFunc :: a -> Tree b
transFunc x = Leaf (f x)
Note that you need to enable ScopedTypeVariables extension to compile it.
And that version of transFunc is an equivalent of your working solution: (Leaf . f)
Related
I'm looking for a function with this signature:
chainTraversal :: k -> (k -> a -> Maybe (k, b)) -> Map k a -> Map k b
You give it an initial key to start at, a function and a map.
It will extract the element at the position k in the Map, and feed that element to the function. Based on this, the function will return another key to look at next.
It's some mix between a filter and a traversal, with the elements themselves giving the next position to open. The result is the list of elements that has been traversed. It can be shorter than the original map.
Edit: taking into account a comment.
Since all the lookups are done in the original Map:
foo :: k -> (k -> a -> Maybe (k, b)) -> Map k a -> Map k b
foo k f m = fromList $ unfoldr g k
where
g k = (\(k', b) -> (k', (k, b))) -- k ? k' ? you decide
<$> (f' k =<< (m `at` k))
f' k (k', a) = f k a -- or: f k' a ? you decide
or something like that.
You'll have to implement the at function in terms of one of the lookupNN functions of your choosing.
It's not a filter since it must stop on the first Nothing produced by f.
There is no existing function with that signature and behavior. You'll have to write it yourself.
There seems to be a difference in the evaluation order of applicative do notation / ado vs. applicative lifting via <$>/map on the first argument, and <*>/apply for remaining arguments.
At least, this is what I have read so far and what is reflected in the course of the exercise shown below. Questions:
Why is the evaluation order of solution 1 and 2 different (general concepts)?
How can I rewrite solution 2 (without ado), respecting the preorder assertion from the test?
Given
Exercise from the PureScript by Example book (Chapter 7) can be found here:
3.(Medium) Write a function traversePreOrder :: forall a m b. Applicative m => (a -> m b) -> Tree a -> m (Tree b) that performs a pre-order traversal of the tree. [...] Applicative do notation (ado) is the easiest way to write this function.
Algebraic data type Tree:
data Tree a
= Leaf
| Branch (Tree a) a (Tree a)
Test expecting the traverse order [1,2,3,4,5,6,7]:
Assert.equal (1 .. 7)
$ snd
$ runWriter
$ traversePreOrder (\x -> tell [ x ])
$ Branch (Branch (leaf 3) 2 (leaf 4)) 1 (Branch (leaf 6) 5 (leaf 7))
Note: I am not sure, what tell and runWriter exactly do - this is a copied code block from the exercise.
For illustration - the example tree looks like this:
What I tried
Solution 1: ado (works)
traversePreOrder :: forall a m b. Applicative m => (a -> m b) -> Tree a -> m (Tree b)
traversePreOrder f Leaf = pure Leaf
traversePreOrder f (Branch tl v tr) = ado
ev <- f v
etl <- traversePreOrder f tl
etr <- traversePreOrder f tr
in Branch etl ev etr
Solution 2: conventional lifting (does not work)
traversePreOrder :: forall a m b. Applicative m => (a -> m b) -> Tree a -> m (Tree b)
traversePreOrder f Leaf = pure Leaf
traversePreOrder f (Branch tl v tr) =
let
ev = f v -- I consciously tried to place this evaluation first, does not work
etl = traversePreOrder f tl
etr = traversePreOrder f tr
in
Branch <$> etl <*> ev <*> etr
This triggers the error:
expected [1,2,3,4,5,6,7], got [3,2,4,1,6,5,7]
let
ev = f v -- I consciously tried to place this evaluation first, does not work
etl = traversePreOrder f tl
etr = traversePreOrder f tr
in
Branch <$> etl <*> ev <*> etr
Source order does not matter in functional programming. You could place these let declarations in any order, it would work the same - they would create the same values, and these values would describe the same computation, and will form the same programs when used in the same expressions.
The "evaluation order" that actually matters here is a property of the applicative functor you're using - the order in which applicative effects are applied. The order is governed by the operators from the Applicative typeclass which you are using here, namely <*>: it is documented to first apply the effects from the left hand side, then the effects from the right hand side. To implement pre-order traversal, you will therefore have to write
traversePreOrder :: forall a m b. Applicative m => (a -> m b) -> Tree a -> m (Tree b)
traversePreOrder f Leaf = pure Leaf
traversePreOrder f (Branch tl v tr) =
(\ev etl etr -> Branch etl ev etr) <$> f v <*> traversePreOrder f tl <*> traversePreOrder f tr
(Disclaimer: I don't know PureScript very well, but it looks very much like Haskell and seems to work the same here.)
let rec fold_inorder f acc t =
match t with
| Leaf -> acc
| Node (l, n, r) -> f (fold_inorder f acc l) (f n (fold_inorder f acc r))
I'm trying to print the infold of a tree as following :
fold_inorder (fun acc x -> acc # [x]) [] (Node (Node (Leaf,1,Leaf), 2, Node (Leaf,3,Leaf))) = [1;2;3]
I'm getting an error saying my [x] is
This expression has type 'a list
but an expression was expected of type 'a
The type variable 'a occurs inside 'a list
I'm really not sure what to do from here. Can anyone nudge me in the right direction?
In your definition of fold_inorder, what type do you expect f to have?
If I look at this call:
f n (fold_inorder f acc r)
it appears that the first parameter of f is a new value from a tree node and the second parameter is an accumulated value.
But in your test call you define f like this:
(fun acc x -> ...)
This suggests that the first parameter is the accumulated value and the second parameter is a new value from a tree node.
i am asket to Define the function:
treeMap :: (a -> b) -> BinaryTree a -> BinaryTree b
Which takes a function and a binary tree, and produces a binary tree in which all nodes are the result of applying the function on the given tree
the binary tree is:
data BinaryTree a = Nil | BNode a (BinaryTree a) (BinaryTree a)
and my code doesnt complie. i am getting an error of:
error: Not in scope: data constructor ‘BinaryTree’
treeMap f (BNode x (BinaryTree l) (BinaryTree r)) = | ^^^^^^^^^^
my code:
data BinaryTree a = Nil | BNode a (BinaryTree a) (BinaryTree a)
treeMap :: (a -> b) -> BinaryTree a -> BinaryTree b
treeMap f Nil = Nil
treeMap f (BNode x (BinaryTree l) (BinaryTree r)) =
BNode (f x) (BinaryTree (treeMap f l)) (BinaryTree (treeMap f r))
Your pattern (BNode x (BinaryTree l) (BinaryTree r)) is not a valid pattern. Indeed the data definition of a binary tree says:
data BinaryTree a = Nil | BNode a (BinaryTree a) (BinaryTree a)
so that means that BNode is a data constructor that packs three arguments. The type of the last two arguments is BinaryTree a, but you can not use types in pattern matching.
You thus should use l and r as variables for these parameters (or you can use the data constructors of the BinaryTree a type).
The same when you construct a BinaryTree a type. You call the constructor with BNode x l r with x, l and r the values, you do not specify the types here in the expression. You can specify the types, byt then you use the :: operator.
You can thus fix your code with:
treeMap :: (a -> b) -> BinaryTree a -> BinaryTree b
treeMap f Nil = Nil
treeMap f (BNode x l r) = BNode (f x) (treeMap f l) (treeMap f r)
or more elegant:
treeMap :: (a -> b) -> BinaryTree a -> BinaryTree b
treeMap f = go
where go Nil = Nil
go (BNode x l r) = BNode (f x) (go l) (go r)
That being said, you can let ghc derive the Functor instance for you, by using the DeriveFunctor pragma:
{-# LANGUAGE DeriveFunctor #-}
data BinaryTree a = Nil | BNode a (BinaryTree a) (BinaryTree a) deriving Functor
The treeMap is just fmap :: Functor f => (a -> b) -> f a -> f b with f ~ BinaryTree here.
I’d like to define the following function using Program Fixpoint or Function in Coq:
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Program.Wf.
Require Import Recdef.
Inductive Tree := Node : nat -> list Tree -> Tree.
Fixpoint height (t : Tree) : nat :=
match t with
| Node x ts => S (fold_right Nat.max 0 (map height ts))
end.
Program Fixpoint mapTree (f : nat -> nat) (t : Tree) {measure (height t)} : Tree :=
match t with
Node x ts => Node (f x) (map (fun t => mapTree f t) ts)
end.
Next Obligation.
Unfortunately, at this point I have a proof obligation height t < height (Node x ts) without knowing that t is a member of ts.
Similarly with Function instead of Program Fixpoint, only that Function detects the problem and aborts the definition:
Error:
the term fun t : Tree => mapTree f t can not contain a recursive call to mapTree
I would expect to get a proof obligation of In t ts → height t < height (Node x ts).
Is there a way of getting that that does not involve restructuring the function definition? (I know work-arounds that require inlining the definition of map here, for example – I’d like to avoid these.)
Isabelle
To justify that expectation, let me show what happens when I do the same in Isabelle, using the function command, which is (AFAIK) related to Coq’s Function command:
theory Tree imports Main begin
datatype Tree = Node nat "Tree list"
fun height where
"height (Node _ ts) = Suc (foldr max (map height ts) 0)"
function mapTree where
"mapTree f (Node x ts) = Node (f x) (map (λ t. mapTree f t) ts)"
by pat_completeness auto
termination
proof (relation "measure (λ(f,t). height t)")
show "wf (measure (λ(f, t). height t))" by auto
next
fix f :: "nat ⇒ nat" and x :: nat and ts :: "Tree list" and t
assume "t ∈ set ts"
thus "((f, t), (f, Node x ts)) ∈ measure (λ(f, t). height t)"
by (induction ts) auto
qed
In the termination proof, I get the assumption t ∈ set ts.
Note that Isabelle does not require a manual termination proof here, and the following definition works just fine:
fun mapTree where
"mapTree f (Node x ts) = Node (f x) (map (λ t. mapTree f t) ts)"
This works because the map function has a “congruence lemma” of the form
xs = ys ⟹ (⋀x. x ∈ set ys ⟹ f x = g x) ⟹ map f xs = map g ys
that the function command uses to find out that the termination proof only needs to consider t ∈ set ts..
If such a lemma is not available, e.g. because I define
definition "map' = map"
and use that in mapTree, I get the same unprovable proof obligation as in Coq. I can make it work again by declaring a congruence lemma for map', e.g. using
declare map_cong[folded map'_def,fundef_cong]
In this case, you actually do not need well-founded recursion in its full generality:
Require Import Coq.Lists.List.
Set Implicit Arguments.
Inductive tree := Node : nat -> list tree -> tree.
Fixpoint map_tree (f : nat -> nat) (t : tree) : tree :=
match t with
| Node x ts => Node (f x) (map (fun t => map_tree f t) ts)
end.
Coq is able to figure out by itself that recursive calls to map_tree are performed on strict subterms. However, proving anything about this function is difficult, as the induction principle generated for tree is not useful:
tree_ind :
forall P : tree -> Prop,
(forall (n : nat) (l : list tree), P (Node n l)) ->
forall t : tree, P t
This is essentially the same problem you described earlier. Luckily, we can fix the issue by proving our own induction principle with a proof term.
Require Import Coq.Lists.List.
Import ListNotations.
Unset Elimination Schemes.
Inductive tree := Node : nat -> list tree -> tree.
Set Elimination Schemes.
Fixpoint tree_ind
(P : tree -> Prop)
(IH : forall (n : nat) (ts : list tree),
fold_right (fun t => and (P t)) True ts ->
P (Node n ts))
(t : tree) : P t :=
match t with
| Node n ts =>
let fix loop ts :=
match ts return fold_right (fun t' => and (P t')) True ts with
| [] => I
| t' :: ts' => conj (tree_ind P IH t') (loop ts')
end in
IH n ts (loop ts)
end.
Fixpoint map_tree (f : nat -> nat) (t : tree) : tree :=
match t with
| Node x ts => Node (f x) (map (fun t => map_tree f t) ts)
end.
The Unset Elimination Schemes command prevents Coq from generating its default (and not useful) induction principle for tree. The occurrence of fold_right on the induction hypothesis simply expresses that the predicate P holds of every tree t' appearing in ts.
Here is a statement that you can prove using this induction principle:
Lemma map_tree_comp f g t :
map_tree f (map_tree g t) = map_tree (fun n => f (g n)) t.
Proof.
induction t as [n ts IH]; simpl; f_equal.
induction ts as [|t' ts' IHts]; try easy.
simpl in *.
destruct IH as [IHt' IHts'].
specialize (IHts IHts').
now rewrite IHt', <- IHts.
Qed.
You can now do this with Equations and get the right elimination principle automatically, using either structural nested recursion or well-founded recursion
In general, it might be advisable to avoid this problem. But if one really wants to obtain the proof obligation that Isabelle gives you, here is a way:
In Isabelle, we can give an external lemma that stats that map applies its arguments only to members of the given list. In Coq, we cannot do this in an external lemma, but we can do it in the type. So instead of the normal type of map
forall A B, (A -> B) -> list A -> list B
we want the type to say “f is only ever applied to elements of the list:
forall A B (xs : list A), (forall x : A, In x xs -> B) -> list B
(It requires reordering the argument so that the type of f can mention xs).
Writing this function is not trivial, and I found it easier to use a proof script:
Definition map {A B} (xs : list A) (f : forall (x:A), In x xs -> B) : list B.
Proof.
induction xs.
* exact [].
* refine (f a _ :: IHxs _).
- left. reflexivity.
- intros. eapply f. right. eassumption.
Defined.
But you can also write it “by hand”:
Fixpoint map {A B} (xs : list A) : forall (f : forall (x:A), In x xs -> B), list B :=
match xs with
| [] => fun _ => []
| x :: xs => fun f => f x (or_introl eq_refl) :: map xs (fun y h => f y (or_intror h))
end.
In either case, the result is nice: I can use this function in mapTree, i.e.
Program Fixpoint mapTree (f : nat -> nat) (t : Tree) {measure (height t)} : Tree :=
match t with
Node x ts => Node (f x) (map ts (fun t _ => mapTree f t))
end.
Next Obligation.
and I don’t have to do anything with the new argument to f, but it shows up in the the termination proof obligation, as In t ts → height t < height (Node x ts) as desired. So I can prove that and define mapTree:
simpl.
apply Lt.le_lt_n_Sm.
induction ts; inversion_clear H.
- subst. apply PeanoNat.Nat.le_max_l.
- rewrite IHts by assumption.
apply PeanoNat.Nat.le_max_r.
Qed.
It only works with Program Fixpoint, not with Function, unfortunately.