(** ** Working with the state monad *)
Remark bind_inversion:
forall (A B: Type) (f: mon A) (g: A -> mon B)
(y: B) (s1 s3: state) (i: sincr s1 s3),
bind f g s1 = R y s3 i ->
exists x, exists s2, exists i1, exists i2,
f s1 = R x s2 i1 /\ g x s2 = R y s3 i2.
Ltac monadInv1 H :=
match type of H with
| (R _ _ _ = R _ _ _) =>
inversion H; clear H; try subst
| (ret _ _ = R _ _ _) =>
inversion H; clear H; try subst
| (bind ?F ?G ?S = R ?X ?S' ?I) =>
let x := fresh "x" in (
let s := fresh "s" in (
let i1 := fresh "INCR" in (
let i2 := fresh "INCR" in (
let EQ1 := fresh "EQ" in (
let EQ2 := fresh "EQ" in (
destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
clear H;
try (monadInv1 EQ2)))))))
end.
Ltac monadInv H :=
match type of H with
| (ret _ _ = R _ _ _) => monadInv1 H
| (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H
| (?F _ _ _ _ _ _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ = R _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
end.
Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
match l with
| nil => ret tt
| (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
end.
Remark mlist_iter2_fold:
forall (A B: Type) (f: A -> B -> mon unit) l s,
exists i,
mlist_iter2 f l s =
R tt (fold_left (fun a p => match f (fst p) (snd p) a with R _ s2 _ => s2 end) l s) i.

(* Specifications: *)
Lemma ptree_mfold_spec:
forall (A: Type) (f: positive -> A -> mon unit) t s x s' i,
ptree_mfold f t s = R x s' i ->
exists i', mlist_iter2 f (PTree.elements t) s = R tt s' i'.