From Hammer Require Import Hammer.

Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx.

Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E).
Module Import MP := WProperties_fun E M.
Import FM Dec.F.
Import M.

Definition Add := MP.Add.

Section BasicProperties.

Variable s s' s'': t.
Variable x y z : elt.

Lemma mem_eq:
E.eq x y -> mem x s=mem y s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.mem_eq".
intro H; rewrite H; auto.
Qed.

Lemma equal_mem_1:
(forall a, mem a s=mem a s') -> equal s s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_mem_1".
intros; apply equal_1; unfold Equal; intros.
do 2 rewrite mem_iff; rewrite H; tauto.
Qed.

Lemma equal_mem_2:
equal s s'=true -> forall a, mem a s=mem a s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_mem_2".
intros; rewrite (equal_2 H); auto.
Qed.

Lemma subset_mem_1:
(forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_mem_1".
intros; apply subset_1; unfold Subset; intros a.
do 2 rewrite mem_iff; auto.
Qed.

Lemma subset_mem_2:
subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_mem_2".
intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
Qed.

Lemma empty_mem: mem x empty=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.empty_mem".
rewrite <- not_mem_iff; auto with set.
Qed.

Lemma is_empty_equal_empty: is_empty s = equal s empty.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.is_empty_equal_empty".
apply bool_1; split; intros.
auto with set.
rewrite <- is_empty_iff; auto with set.
Qed.

Lemma choose_mem_1: choose s=Some x -> mem x s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.choose_mem_1".
auto with set.
Qed.

Lemma choose_mem_2: choose s=None -> is_empty s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.choose_mem_2".
auto with set.
Qed.

Lemma add_mem_1: mem x (add x s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_mem_1".
auto with set.
Qed.

Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_mem_2".
apply add_neq_b.
Qed.

Lemma remove_mem_1: mem x (remove x s)=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_mem_1".
rewrite <- not_mem_iff; auto with set.
Qed.

Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_mem_2".
apply remove_neq_b.
Qed.

Lemma singleton_equal_add:
equal (singleton x) (add x empty)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.singleton_equal_add".
rewrite (singleton_equal_add x); auto with set.
Qed.

Lemma union_mem:
mem x (union s s')=mem x s || mem x s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_mem".
apply union_b.
Qed.

Lemma inter_mem:
mem x (inter s s')=mem x s && mem x s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_mem".
apply inter_b.
Qed.

Lemma diff_mem:
mem x (diff s s')=mem x s && negb (mem x s').
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.diff_mem".
apply diff_b.
Qed.

Lemma mem_3 : ~In x s -> mem x s=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.mem_3".
intros; rewrite <- not_mem_iff; auto.
Qed.

Lemma mem_4 : mem x s=false -> ~In x s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.mem_4".
intros; rewrite not_mem_iff; auto.
Qed.

Lemma equal_refl: equal s s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_refl".
auto with set.
Qed.

Lemma equal_sym: equal s s'=equal s' s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_sym".
intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
Qed.

Lemma equal_trans:
equal s s'=true -> equal s' s''=true -> equal s s''=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_trans".
intros; rewrite (equal_2 H); auto.
Qed.

Lemma equal_equal:
equal s s'=true -> equal s s''=equal s' s''.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_equal".
intros; rewrite (equal_2 H); auto.
Qed.

Lemma equal_cardinal:
equal s s'=true -> cardinal s=cardinal s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.equal_cardinal".
auto with set.
Qed.

Lemma subset_refl: subset s s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_refl".
auto with set.
Qed.

Lemma subset_antisym:
subset s s'=true -> subset s' s=true -> equal s s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_antisym".
auto with set.
Qed.

Lemma subset_trans:
subset s s'=true -> subset s' s''=true -> subset s s''=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_trans".
do 3 rewrite <- subset_iff; intros.
apply subset_trans with s'; auto.
Qed.

Lemma subset_equal:
equal s s'=true -> subset s s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_equal".
auto with set.
Qed.

Lemma choose_mem_3:
is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.choose_mem_3".
intros.
generalize (@choose_1 s) (@choose_2 s).
destruct (choose s);intros.
exists e;auto with set.
generalize (H1 Logic.eq_refl); clear H1.
intros; rewrite (is_empty_1 H1) in H; discriminate.
Qed.

Lemma choose_mem_4: choose empty=None.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.choose_mem_4".
generalize (@choose_1 empty).
case (@choose empty);intros;auto.
elim (@empty_1 e); auto.
Qed.

Lemma add_mem_3:
mem y s=true -> mem y (add x s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_mem_3".
auto with set.
Qed.

Lemma add_equal:
mem x s=true -> equal (add x s) s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_equal".
auto with set.
Qed.

Lemma remove_mem_3:
mem y (remove x s)=true -> mem y s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_mem_3".
rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
Qed.

Lemma remove_equal:
mem x s=false -> equal (remove x s) s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_equal".
intros; apply equal_1; apply remove_equal.
rewrite not_mem_iff; auto.
Qed.

Lemma add_remove:
mem x s=true -> equal (add x (remove x s)) s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_remove".
intros; apply equal_1; apply add_remove; auto with set.
Qed.

Lemma remove_add:
mem x s=false -> equal (remove x (add x s)) s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_add".
intros; apply equal_1; apply remove_add; auto.
rewrite not_mem_iff; auto.
Qed.

Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.is_empty_cardinal".
intros; apply bool_1; split; intros.
rewrite MP.cardinal_1; simpl; auto with set.
assert (cardinal s = 0) by (apply zerob_true_elim; auto).
auto with set.
Qed.

Lemma singleton_mem_1: mem x (singleton x)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.singleton_mem_1".
auto with set.
Qed.

Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.singleton_mem_2".
intros; rewrite singleton_b.
unfold eqb; destruct (E.eq_dec x y); intuition.
Qed.

Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.singleton_mem_3".
intros; apply singleton_1; auto with set.
Qed.

Lemma union_sym:
equal (union s s') (union s' s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_sym".
auto with set.
Qed.

Lemma union_subset_equal:
subset s s'=true -> equal (union s s') s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_subset_equal".
auto with set.
Qed.

Lemma union_equal_1:
equal s s'=true-> equal (union s s'') (union s' s'')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_equal_1".
auto with set.
Qed.

Lemma union_equal_2:
equal s' s''=true-> equal (union s s') (union s s'')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_equal_2".
auto with set.
Qed.

Lemma union_assoc:
equal (union (union s s') s'') (union s (union s' s''))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_assoc".
auto with set.
Qed.

Lemma add_union_singleton:
equal (add x s) (union (singleton x) s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_union_singleton".
auto with set.
Qed.

Lemma union_add:
equal (union (add x s) s') (add x (union s s'))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_add".
auto with set.
Qed.

Lemma union_subset_1: subset s (union s s')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_subset_1".
auto with set.
Qed.

Lemma union_subset_2: subset s' (union s s')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_subset_2".
auto with set.
Qed.

Lemma union_subset_3:
subset s s''=true -> subset s' s''=true ->
subset (union s s') s''=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_subset_3".
intros; apply subset_1; apply union_subset_3; auto with set.
Qed.

Lemma inter_sym: equal (inter s s') (inter s' s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_sym".
auto with set.
Qed.

Lemma inter_subset_equal:
subset s s'=true -> equal (inter s s') s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_subset_equal".
auto with set.
Qed.

Lemma inter_equal_1:
equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_equal_1".
auto with set.
Qed.

Lemma inter_equal_2:
equal s' s''=true -> equal (inter s s') (inter s s'')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_equal_2".
auto with set.
Qed.

Lemma inter_assoc:
equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_assoc".
auto with set.
Qed.

Lemma union_inter_1:
equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_inter_1".
auto with set.
Qed.

Lemma union_inter_2:
equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_inter_2".
auto with set.
Qed.

Lemma inter_add_1: mem x s'=true ->
equal (inter (add x s) s') (add x (inter s s'))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_add_1".
auto with set.
Qed.

Lemma inter_add_2: mem x s'=false ->
equal (inter (add x s) s') (inter s s')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_add_2".
intros; apply equal_1; apply inter_add_2.
rewrite not_mem_iff; auto.
Qed.

Lemma inter_subset_1: subset (inter s s') s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_subset_1".
auto with set.
Qed.

Lemma inter_subset_2: subset (inter s s') s'=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_subset_2".
auto with set.
Qed.

Lemma inter_subset_3:
subset s'' s=true -> subset s'' s'=true ->
subset s'' (inter s s')=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.inter_subset_3".
intros; apply subset_1; apply inter_subset_3; auto with set.
Qed.

Lemma diff_subset: subset (diff s s') s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.diff_subset".
auto with set.
Qed.

Lemma diff_subset_equal:
subset s s'=true -> equal (diff s s') empty=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.diff_subset_equal".
auto with set.
Qed.

Lemma remove_inter_singleton:
equal (remove x s) (diff s (singleton x))=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_inter_singleton".
auto with set.
Qed.

Lemma diff_inter_empty:
equal (inter (diff s s') (inter s s')) empty=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.diff_inter_empty".
auto with set.
Qed.

Lemma diff_inter_all:
equal (union (diff s s') (inter s s')) s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.diff_inter_all".
auto with set.
Qed.

End BasicProperties.

Hint Immediate empty_mem is_empty_equal_empty add_mem_1
remove_mem_1 singleton_equal_add union_mem inter_mem
diff_mem equal_sym add_remove remove_add : set.
Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
subset_refl subset_equal subset_antisym
add_mem_3 add_equal remove_mem_3 remove_equal : set.

Lemma set_rec:  forall (P:t->Type),
(forall s s', equal s s'=true -> P s -> P s') ->
(forall s x, mem x s=false -> P s -> P (add x s)) ->
P empty -> forall s, P s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.set_rec".
intros.
apply set_induction; auto; intros.
apply X with empty; auto with set.
apply X with (add x s0); auto with set.
apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
apply X0; auto with set; apply mem_3; auto.
Qed.

Lemma exclusive_set : forall s s' x,
~(In x s/\In x s') <-> mem x s && mem x s'=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exclusive_set".
intros; do 2 rewrite mem_iff.
destruct (mem x s); destruct (mem x s'); intuition.
Qed.

Section Fold.
Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
Variables (i:A).
Variables (s s':t)(x:elt).

Lemma fold_empty: (fold f empty i) = i.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.fold_empty".
apply fold_empty; auto.
Qed.

Lemma fold_equal:
equal s s'=true -> eqA (fold f s i) (fold f s' i).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.fold_equal".
intros; apply fold_equal with (eqA:=eqA); auto with set.
Qed.

Lemma fold_add:
mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.fold_add".
intros; apply fold_add with (eqA:=eqA); auto.
rewrite not_mem_iff; auto.
Qed.

Lemma add_fold:
mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_fold".
intros; apply add_fold with (eqA:=eqA); auto with set.
Qed.

Lemma remove_fold_1:
mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_fold_1".
intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
Qed.

Lemma remove_fold_2:
mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_fold_2".
intros; apply remove_fold_2 with (eqA:=eqA); auto.
rewrite not_mem_iff; auto.
Qed.

Lemma fold_union:
(forall x, mem x s && mem x s'=false) ->
eqA (fold f (union s s') i) (fold f s (fold f s' i)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.fold_union".
intros; apply fold_union with (eqA:=eqA); auto.
intros; rewrite exclusive_set; auto.
Qed.

End Fold.

Lemma add_cardinal_1:
forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_cardinal_1".
auto with set.
Qed.

Lemma add_cardinal_2:
forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_cardinal_2".
intros; apply add_cardinal_2; auto.
rewrite not_mem_iff; auto.
Qed.

Lemma remove_cardinal_1:
forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_cardinal_1".
intros; apply remove_cardinal_1; auto with set.
Qed.

Lemma remove_cardinal_2:
forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.remove_cardinal_2".
intros; apply Equal_cardinal; apply equal_2; auto with set.
Qed.

Lemma union_cardinal:
forall s s', (forall x, mem x s && mem x s'=false) ->
cardinal (union s s')=cardinal s+cardinal s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_cardinal".
intros; apply union_cardinal; auto; intros.
rewrite exclusive_set; auto.
Qed.

Lemma subset_cardinal:
forall s s', subset s s'=true -> cardinal s<=cardinal s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.subset_cardinal".
intros; apply subset_cardinal; auto with set.
Qed.

Section Bool.

Variable f:elt->bool.
Variable Comp: Proper (E.eq==>Logic.eq) f.

Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.Bool.Comp'".
repeat red; intros; f_equal; auto.
Qed.

Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.filter_mem".
intros; apply filter_b; auto.
Qed.

Lemma for_all_filter:
forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_filter".
intros; apply bool_1; split; intros.
apply is_empty_1.
unfold Empty; intros.
rewrite filter_iff; auto.
red; destruct 1.
rewrite <- (@for_all_iff s f) in H; auto.
rewrite (H a H0) in H1; discriminate.
apply for_all_1; auto; red; intros.
revert H; rewrite <- is_empty_iff.
unfold Empty; intro H; generalize (H x); clear H.
rewrite filter_iff; auto.
destruct (f x); auto.
Qed.

Lemma exists_filter :
forall s, exists_ f s=negb (is_empty (filter f s)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exists_filter".
intros; apply bool_1; split; intros.
destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
apply bool_6.
red; intros; apply (@is_empty_2 _ H0 a); auto with set.
generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
destruct (choose (filter f s)).
intros H0 _; apply exists_1; auto.
exists e; generalize (H0 e); rewrite filter_iff; auto.
intros _ H0.
rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate.
Qed.

Lemma partition_filter_1:
forall s, equal (fst (partition f s)) (filter f s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.partition_filter_1".
auto with set.
Qed.

Lemma partition_filter_2:
forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.partition_filter_2".
auto with set.
Qed.

Lemma filter_add_1 : forall s x, f x = true ->
filter f (add x s) [=] add x (filter f s).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.filter_add_1".
red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
intuition.
rewrite <- H; apply Comp; auto.
Qed.

Lemma filter_add_2 : forall s x, f x = false ->
filter f (add x s) [=] filter f s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.filter_add_2".
red; intros; do 2 (rewrite filter_iff; auto); set_iff.
intuition.
assert (f x = f a) by (apply Comp; auto).
rewrite H in H1; rewrite H2 in H1; discriminate.
Qed.

Lemma add_filter_1 : forall s s' x,
f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_filter_1".
unfold Add, MP.Add; intros.
repeat rewrite filter_iff; auto.
rewrite H0; clear H0.
assert (E.eq x y -> f y = true) by
(intro H0; rewrite <- (Comp _ _ H0); auto).
tauto.
Qed.

Lemma add_filter_2 : forall s s' x,
f x=false -> (Add x s s') -> filter f s [=] filter f s'.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.add_filter_2".
unfold Add, MP.Add, Equal; intros.
repeat rewrite filter_iff; auto.
rewrite H0; clear H0.
assert (f a = true -> ~E.eq x a).
intros H0 H1.
rewrite (Comp _ _ H1) in H.
rewrite H in H0; discriminate.
tauto.
Qed.

Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) ->
forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.union_filter".
clear Comp' Comp f.
intros.
assert (compat_bool E.eq (fun x => orb (f x) (g x))).
unfold compat_bool, Proper, respectful; intros.
rewrite (H x y H1);  rewrite (H0 x y H1); auto.
unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
assert (f a || g a = true <-> f a = true \/ g a = true).
split; auto with bool.
intro H3; destruct (orb_prop _ _ H3); auto.
tauto.
Qed.

Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.filter_union".
unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
Qed.

Lemma for_all_mem_1: forall s,
(forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_mem_1".
intros.
rewrite for_all_filter; auto.
rewrite is_empty_equal_empty.
apply equal_mem_1;intros.
rewrite filter_b; auto.
rewrite empty_mem.
generalize (H a); case (mem a s);intros;auto.
rewrite H0;auto.
Qed.

Lemma for_all_mem_2: forall s,
(for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_mem_2".
intros.
rewrite for_all_filter in H; auto.
rewrite is_empty_equal_empty in H.
generalize (equal_mem_2 _ _ H x).
rewrite filter_b; auto.
rewrite empty_mem.
rewrite H0; simpl;intros.
rewrite <- negb_false_iff; auto.
Qed.

Lemma for_all_mem_3:
forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_mem_3".
intros.
apply (bool_eq_ind (for_all f s));intros;auto.
rewrite for_all_filter in H1; auto.
rewrite is_empty_equal_empty in H1.
generalize (equal_mem_2 _ _ H1 x).
rewrite filter_b; auto.
rewrite empty_mem.
rewrite H.
rewrite H0.
simpl;auto.
Qed.

Lemma for_all_mem_4:
forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_mem_4".
intros.
rewrite for_all_filter in H; auto.
destruct (choose_mem_3 _ H) as (x,(H0,H1));intros.
exists x.
rewrite filter_b in H1; auto.
elim (andb_prop _ _ H1).
split;auto.
rewrite <- negb_true_iff; auto.
Qed.

Lemma for_all_exists:
forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.for_all_exists".
intros.
rewrite for_all_b; auto.
rewrite exists_b; auto.
induction (elements s); simpl; auto.
destruct (f a); simpl; auto.
Qed.

End Bool.
Section Bool'.

Variable f:elt->bool.
Variable Comp: compat_bool E.eq f.

Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.Bool'.Comp'".
unfold compat_bool, Proper, respectful in *; intros; f_equal; auto.
Qed.

Lemma exists_mem_1:
forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exists_mem_1".
intros.
rewrite for_all_exists; auto.
rewrite for_all_mem_1;auto with bool.
intros;generalize (H x H0);intros.
rewrite negb_true_iff; auto.
Qed.

Lemma exists_mem_2:
forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exists_mem_2".
intros.
rewrite for_all_exists in H; auto.
rewrite negb_false_iff in H.
rewrite <- negb_true_iff.
apply for_all_mem_2 with (2:=H); auto.
Qed.

Lemma exists_mem_3:
forall s x, mem x s=true -> f x=true -> exists_ f s=true.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exists_mem_3".
intros.
rewrite for_all_exists; auto.
rewrite negb_true_iff.
apply for_all_mem_3 with x;auto.
rewrite negb_false_iff; auto.
Qed.

Lemma exists_mem_4:
forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.exists_mem_4".
intros.
rewrite for_all_exists in H; auto.
rewrite negb_true_iff in H.
destruct (for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,p); auto.
elim p;intros.
exists x;split;auto.
rewrite <-negb_false_iff; auto.
Qed.

End Bool'.

Section Sum.

Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0.
Notation compat_opL := (compat_op E.eq Logic.eq).
Notation transposeL := (transpose Logic.eq).

Lemma sum_plus :
forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.sum_plus".
unfold sum.
intros f g Hf Hg.
assert (fc : compat_opL (fun x:elt =>plus (f x))).  red; auto.
assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega.
assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto.
assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega.
assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto.
assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
intros s;pattern s; apply set_rec.
intros.
rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H).
rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H).
rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto.
intros; do 3 (rewrite (fold_add _ _ st);auto).
rewrite H0;simpl;omega.
do 3 rewrite fold_empty;auto.
Qed.

Lemma sum_filter : forall f, (compat_bool E.eq f) ->
forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.sum_filter".
unfold sum; intros f Hf.
assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))).
repeat red; intros.
rewrite (Hf _ _ H); auto.
assert (ct : transposeL (fun x => plus (if f x then 1 else 0))).
red; intros; omega.
intros s;pattern s; apply set_rec.
intros.
change elt with E.t.
rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto.
intros; rewrite (fold_add _ _ st _ cc ct); auto.
generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
assert (~ In x (filter f s0)).
intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
case (f x); simpl; intros.
rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto.
rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto.
intros; rewrite fold_empty;auto.
rewrite MP.cardinal_1; auto.
unfold Empty; intros.
rewrite filter_iff; auto; set_iff; tauto.
Qed.

Lemma fold_compat :
forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
(f g:elt->A->A),
(compat_op E.eq eqA f) -> (transpose eqA f) ->
(compat_op E.eq eqA g) -> (transpose eqA g) ->
forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
(eqA (fold f s i) (fold g s i)).
Proof. hammer_hook "FSetEqProperties" "FSetEqProperties.WEqProperties_fun.fold_compat".
intros A eqA st f g fc ft gc gt i.
intro s; pattern s; apply set_rec; intros.
transitivity (fold f s0 i).
apply fold_equal with (eqA:=eqA); auto.
rewrite equal_sym; auto.
transitivity (fold g s0 i).
apply H0; intros; apply H1; auto with set.
elim  (equal_2 H x); auto with set; intros.
apply fold_equal with (eqA:=eqA); auto with set.
transitivity (f x (fold f s0 i)).
apply fold_add with (eqA:=eqA); auto with set.
transitivity (g x (fold f s0 i)); auto with set.
transitivity (g x (fold g s0 i)); auto with set.
apply gc; auto with *.
symmetry; apply fold_add with (eqA:=eqA); auto.
do 2 rewrite fold_empty; reflexivity.
Qed.

Lemma sum_compat :
forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
intros.
unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *.
intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
Qed.

End Sum.

End WEqProperties_fun.

Module WEqProperties (M:WS) := WEqProperties_fun M.E M.
Module EqProperties := WEqProperties.


(** * Trace Relocation *)

Set Implicit Arguments.

Require Import decidable_In.
Require Import extralibrary.
Require Import sublist.
Require Import language_syntax.
Require Import variable_sets.

(** A pseudo-term or a -formula syntactically belongs to infinitely
   many classes. For example, a term [t] from [pterm m] belongs also
   to [pterm k] for all traces [k] including [ov_t (t)] as a sublist.

   - The relocation function is based on the fact that
     the being-in-a-list part is inessential so long as
     the trace contains all the variables needed for
     the construction of an expression e, i.e., [bv (e)]. *)

Fixpoint treloc  m (t: term m) l {struct t} : sub_name (ov_t t) l -> term l :=
  match t return sub_name (ov_t t) l -> term l with
    | Var x _    => fun H => @Var l x (H x (in_eq x nil))
    | Cst c       => fun _ => @Cst l c
    | App f t0 t1 => fun H =>
                     App f (treloc t0 (sub_ov_funL f t0 t1 H))
                           (treloc t1 (sub_ov_funR f t0 t1 H))
  end.

Fixpoint freloc m (A: formula m) l {struct A} : sub_name (ov_f A) l -> formula l :=
  match A return sub_name (ov_f A) l -> formula l with
    | Atom (p,t) => fun H =>
                    Atom (p, treloc t (In_inv_atom _ _ H))
    | B --> C    => fun H =>
                    freloc B (In_inv_impL _ _ H) --> freloc C (In_inv_impR _ _ H)
    | Forall x B => fun H =>
                    Forall x (freloc B (In_inv_all _ H))
  end.

(** Relocation is reflexive. *)

Lemma treloc_id : forall m (t: term m) (h:sub_name (ov_t t) m),
  t = treloc t h.
Proof.
  induction t; simpl; intros; f_equal; auto with datatypes.
Qed.

Lemma freloc_id : forall m (A: formula m) (h:sub_name (ov_f A) m),
  A = freloc A h.
Proof.
  induction A as [m [p t] | |]; simpl; intros; repeat f_equal; auto using treloc_id.
Qed.

Hint Resolve treloc_id freloc_id.
Hint Rewrite <- treloc_id freloc_id : relocation.

(** Repeated application of relocation is equivalent to a single application. *)

Lemma treloc_idempotent : forall m (t:term m) l k
  (h1: sub_name (ov_t t) l)
  (h2: sub_name (ov_t (treloc t h1)) k)
  (h3: sub_name (ov_t t) k),
  treloc t h3 = treloc (treloc t h1) h2.
Proof.
  induction t; simpl; intros; f_equal; auto with datatypes.
Qed.

Lemma freloc_idempotent : forall m (A:formula m) l k
  (h1: sub_name (ov_f A) l)
  (h2: sub_name (ov_f (freloc  A h1)) k)
  (h3: sub_name (ov_f A) k),
  freloc A h3 = freloc (freloc A h1) h2.
Proof.
  induction A as [m [p t]| |]; simpl; intros; f_equal; auto.
  f_equal; auto using treloc_idempotent.
Qed.

Hint Resolve treloc_idempotent freloc_idempotent.
Hint Rewrite <- treloc_idempotent freloc_idempotent : relocation.

(** Equality is preserved by relocation *)

Lemma treloc_eq : forall m (t s :term m) l
  (h1: sub_name (ov_t t) l)
  (h2: sub_name (ov_t s) l),
  t = s ->
  treloc t h1 = treloc s h2.
Proof.
  intros; subst.
  induction s; simpl; f_equal; auto with datatypes.
Qed.

Lemma freloc_eq : forall m (A B :formula m) l
  (h1: sub_name (ov_f A) l)
  (h2: sub_name (ov_f B) l),
  A = B ->
  freloc A h1 = freloc B h2.
Proof.
  intros; subst.
  generalize dependent l.
  induction B as [? [p t] | | ]; simpl; intros; f_equal; auto.
  f_equal; auto using treloc_eq.
Qed.

Hint Resolve treloc_eq freloc_eq.

(** Relocation has no effect upon constants. *)

Lemma treloc_oc : forall m (t:term m) k (h:sub_name (ov_t t) k),
  oc_t t = oc_t (treloc t h).
Proof.
  induction t; simpl; intros; f_equal; auto.
Qed.

Lemma freloc_oc : forall m (A:formula m) k (h:sub_name (ov_f A) k),
  oc_f A = oc_f (freloc A h).
Proof.
  induction A as [m [p t] | |]; simpl; intros; f_equal; auto using treloc_oc.
Qed.

Hint Resolve treloc_oc freloc_oc.
Hint Rewrite <- treloc_oc freloc_oc : relocation.

(** Relocation has no effect upon variables. *)

Lemma treloc_bv : forall m (t:term m) k (h:sub_name (ov_t t) k),
  ov_t t = ov_t (treloc t h).
Proof.
  induction t; simpl; intros; f_equal; auto.
Qed.

Lemma freloc_bv : forall m (A:formula m) k (h:sub_name (ov_f A) k),
  ov_f A = ov_f (freloc A h).
Proof.
  induction A as [m [p t] | |]; simpl; intros; f_equal; auto using treloc_bv.
Qed.

Hint Resolve treloc_bv freloc_bv.
Hint Rewrite <- treloc_bv freloc_bv : relocation.

Lemma treloc_ov_1 : forall (t:term nil) m (h: sub_name (ov_t t) m),
  ov_t (treloc t h) = nil.
Proof.
intros; rewrite <- treloc_bv; auto.
Qed.

Lemma treloc_ov_2 : forall (t:term nil) m (h: sub_name (ov_t t) m),
  forall l, sub_name (ov_t (treloc t h)) l.
Proof.
  intros; rewrite treloc_ov_1; auto with datatypes.
Qed.

Hint Resolve treloc_ov_1 treloc_ov_2.
Hint Rewrite -> treloc_ov_1 : relocation.

Lemma freloc_ov_1 : forall (A:formula nil) m (h: sub_name (ov_f A) m),
  ov_f (freloc A h) = nil.
Proof.
intros; rewrite <- freloc_bv; auto.
Qed.

Lemma freloc_ov_2 : forall (A:formula nil) m (h: sub_name (ov_f A) m),
  forall l, sub_name (ov_f (freloc A h)) l.
Proof.
  intros; rewrite freloc_ov_1; auto with datatypes.
Qed.

Hint Resolve freloc_ov_1 freloc_ov_2.
Hint Rewrite -> freloc_ov_1 : relocation.


(*******************************************************************)
(* Copyright 2010 Alexandre Pilkiewicz                             *)
(*     <alexandre.pilkiewicz@polytechnique.org >                   *)
(* This program is free software. It comes without any warranty,   *)
(* to the extent permitted by applicable law. You can redistribute *)
(* it and/or modify it under the terms of the WTFPL, Version 2, as *)
(* published by Sam Hocevar. See http://sam.zoy.org/wtfpl/COPYING  *)
(* for more details.                                               *)
(*******************************************************************)

(* this small example suppose that you have included insert-cases.el
   in your .emacs. If you have not, you can of course run the file,
   but reproducing it might be a bit painful ! *)

Add Rec LoadPath "../theories" as Case_Tactics.
Add ML Path "../src".
Require Import Case_Tactics.

(* the (S* )Case tactics, by Aaron Bohannon
   http://www.cis.upenn.edu/~bcpierce/sf/Basics.html#lab27
 *)

(* The Case tactic allows you to add "comments" in your code, telling
   which subcase you are dealing with*)

Goal (True -> 1 = 1 -> False) -> False.
Proof.
  intro H.
  apply H.
  Case "True".
  (* Notice that the hypothesis have been modified *)
  constructor.
  Case "1 = 1".
  reflexivity.
Qed.

(* But it is more powerful than simple comments. If you try to enter a
   new case before finishing the current one, it fails. So imagine
   that the goal changes slightly *)

Inductive pack := Pack: True -> pack.

Goal (pack -> 1 = 1 -> False) -> False.
Proof.
  intro H.
  apply H.
  Case "True".
  constructor.
  (* The subgoal has not been eliminated. Try to un-comment the next line *)
  (*Case "1 = 1".*)
  (* It fails with "Tactic failure: because we are working on a
     different case."*)
  constructor.

  Case "1 = 1".
  reflexivity.
Qed.

(* This helps a lot with maintainability: you know precisely which
   sub-goal fails *)

(* Inductive types *)

(* when working with inductive types, it is recommended to write a
   tactic that automatically apply the proper (S* )Case tactic to each
   subgoal when performing a destruction or induction

   http://www.cis.upenn.edu/~bcpierce/sf/Rel.html#lab260
*)

Inductive pack2 (A:Prop) : Prop :=
|Pack1: (A /\ True)-> pack2 A
|Pack2: A -> pack2 A.

Tactic Notation "pack2_cases" tactic(first) tactic(c) :=
  first;
  [ c "Pack1" | c "Pack2"].

Goal forall A, pack2 A -> A.
Proof.
  intros A PACK2.
  pack2_cases (destruct PACK2) Case.

  (* notice that Case := "Pack1" is already in the hypothesis. If you
     are lazy, are using emacs and have added the insert_case.el in
     your .emacs, just press C-c C-a C-q or C-c C-a C-z to copy it
     directly *)
  Case "Pack1".
    destruct H. assumption.
  Case "Pack2".
    assumption.
Qed.

(* But this can quickly become tedious, especially if you are working
   with big inductive (like this one
   http://compcert.inria.fr/doc/html/Op.html#operation )

   Here comes the goal of this contribution: automatically build such tactic.
   *)

Goal forall n, n = n + 0.
Proof.
  (* don't miss the ' at the end of induction' *)
  induction' n; simpl.

  (* Notice this is already in the goal *)
  Case "O".
  reflexivity.

  (* and this too *)
  Case "S".
  f_equal. assumption.
Qed.

(*when you use an intro pattern, it is used to build nicer names for subgoals *)
Goal forall A B (f: A -> B) l, length l = length (List.map f l).
Proof.
  intros A B f l.
  induction' l as [| a l'].

  Case "nil".
  reflexivity.

  Case "cons a l'".
  simpl. f_equal. assumption.
Qed.

(* it also works with destruct' and case' *)
Goal forall n, n = 0 \/ n <> 0.
Proof.
  destruct' n as [|n'].
  Case "O".
    left; reflexivity.
  Case "S n'".
    right. intro H. inversion H.
Qed.

Require Import List.
Goal forall l: list nat, l = nil \/ l = hd 0 l :: tl l.
Proof.
  case' l as [|n l'] _eqn.
  Case "nil".
    left. reflexivity.
  Case "cons n l'".
    right. simpl. reflexivity.
Qed.

(* the library only defines induction', destruct' and case', because
   those are the only one I use. But you can of course do the
   same. The only tactic related to inductive that I do not know how
   to deal with is the inversion tactic since it does not produce the
   same number of goal. There is in fact a inversion' tactics, but it
   fails every time some subgoals are automatically eliminated *)

(* the primed tactics don't always use the name of the
   constructor. There are two special cases for or (\/) and sumbool
   ({}+{}) where the content of the hypothesis is put in the tag *)

Lemma nat_eq_dec : forall (n m: nat), {n = m} + {n <> m}.
Proof.
  decide equality.
Qed.

Notation "x == y" := (nat_eq_dec x y) (at level 70, no associativity).

Tactic Notation "dest" constr(a) "==" constr(b) :=
  (* the tactic cannot just return the string, it has to be stored in
     some hypothesis *)
  destruct' (a == b).

Tactic Notation "dest" "==" :=
  match goal with
    | H : context[?a == ?b] |- _ =>
      dest a == b
    | |- context[?a == ?b] =>
      dest a == b
  end.

Goal forall foo,
  (if foo == 42 then
     False
   else
     False
  ) -> False.
Proof.
  intro. dest ==.
  (* note that the notation for 42 is used *)
  Case "foo = 42".
    auto.
  Case "foo <> 42".
    auto.
Qed.

Goal forall foo bar baz,
  (if foo == bar then
    if bar == baz then
      False
    else
      (foo <> baz -> False)
   else
     if bar == baz then
      (foo <> baz -> False)
    else
      False
  ) -> False.
Proof.
  intros foo bar baz H. repeat (dest ==); try assumption.

  (* here the C-c C-a C-q command can be pretty handy *)
  Case "foo = bar"; SCase "bar <> baz".
  apply H. subst. assumption.

  Case "foo <> bar"; SCase "bar = baz".
  apply H. subst. assumption.
Qed.

(* it also works with bindings and when lemma needs to be reducesed *)
Definition true_imp_true:= forall (TRUE_in:True), True.
Lemma useless: forall (n:nat) (EQ:n = n) (TRUE_out:True), true_imp_true.
Proof. red. auto. Qed.

(* Other example *)
Axiom classicT : forall P:Prop, {P} + {~P}.

Notation "'_If' X 'then' Y 'else' Z" := (if classicT X then Y else Z) (at level 100).

Ltac case_if :=
  match goal with
    | |- _If ?P then _ else _ =>
      destruct' (classicT P)
  end.

Goal forall a: nat, _If a = 0 then 0 = a else 0 <> a.
Proof.
  intro.
  case_if.
  Case "a = 0".
    auto.
  Case "a <> 0".
    auto.
Qed.

(* another tactic defined in the ml library is the "string of foo in
   H" tactic. It builds a coq string from any term, and put it in
   H. The wraper string_of is easier to use, even if it is written in
   CPS style *)

Ltac Case_Goal :=
  match goal with
    | |- ?G =>
      string_of G (fun strG =>
        fst_Case_tac strG)
  end.

Goal (True /\ 1 = 1).
Proof.
  split; Case_Goal.
  Case "True".
    constructor.
  Case "1 = 1".
    reflexivity.
Qed.

(* one might have noticed that notations were used with the string_of
   tactic, but not with the induction' tactic.*)

(* to make the 'ed tactics use notation (this works only for
   constructors without arguments for now), use *)
Set Notations With Case.
Goal forall n:nat, n >= 0.
Proof.
  induction' n as [|n'].
  Case "0". (* notice the 0 *)
    auto.
  Case "S n'".
    auto.
Qed.

(* to get a string without notations, use string_of_without *)

Ltac Case_Goal' :=
  match goal with
    | |- ?G =>
      string_of_without G (fun strG =>
        fst_Case_tac strG)
  end.

Goal (1 <= 2 /\ 1 <> 2).
Proof.
  split; Case_Goal'.
  Case "le (S O) (S (S O))".
    constructor. constructor.
  Case "not (eq (S O) (S (S O)))".
    congruence.
Qed.


(** Here we define W-types of polynomials *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import displayed_algebras.displayed_algebra.

Declare Scope container_scope.

Definition transportf_depfun
           {A B : UU}
           {Y : A → UU}
           {Z : B → UU}
           (f : A → B)
           (ff : ∏ (a : A), Y a → Z(f a))
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (y : Y a₁)
  : transportf
      Z
      (maponpaths f p)
      (ff a₁ y)
    =
    ff a₂ (transportf Y p y).
Proof.
  induction p.
  apply idpath.
Defined.

Definition transportf_fun_space
           {X : UU}
           {Y : X → UU}
           {Z : UU}
           {x₁ x₂ : X}
           (p : x₁ = x₂)
           (f : Y x₁ → Z)
           (y : Y x₂)
  : transportf (λ x, Y x → Z) p f y
    =
    f (transportb Y p y).
Proof.
  induction p.
  apply idpath.
Defined.

Definition sum_fam
           {X₁ X₂ : UU}
           (Y₁ : X₁ → UU)
           (Y₂ : X₂ → UU)
  : X₁ ⨿ X₂ → UU.
Proof.
  intro z.
  induction z as [z | z].
  - exact (Y₁ z).
  - exact (Y₂ z).
Defined.

Definition transportf_maponpaths_inl
           {X₁ X₂ : UU}
           (Y₁ : X₁ → UU)
           (Y₂ : X₂ → UU)
           {x₁ x₂ : X₁}
           (p : x₁ = x₂)
           (y : sum_fam Y₁ Y₂ (inl x₁))
  : transportf
      (λ x, sum_fam Y₁ Y₂ x)
      (maponpaths inl p)
      y
    =
    transportf Y₁ p y.
Proof.
  induction p.
  apply idpath.
Defined.

Definition transportf_maponpaths_inr
           {X₁ X₂ : UU}
           (Y₁ : X₁ → UU)
           (Y₂ : X₂ → UU)
           {x₁ x₂ : X₂}
           (p : x₁ = x₂)
           (y : sum_fam Y₁ Y₂ (inr x₁))
  : transportf
      (λ x, sum_fam Y₁ Y₂ x)
      (maponpaths inr p)
      y
    =
    transportf Y₂ p y.
Proof.
  induction p.
  apply idpath.
Defined.

Definition transportb_maponpaths_pathsdirprod
           {X₁ X₂ : UU}
           (Y₁ : X₁ → UU)
           (Y₂ : X₂ → UU)
           {x₁ x₂ : X₁} {y₁ y₂ : X₂}
           (p : x₁ = x₂) (q : y₁ = y₂)
           (z : Y₁ x₂ ⨿ Y₂ y₂)
  : transportb
      (λ x, Y₁ (pr1 x) ⨿ Y₂ (pr2 x))
      (pathsdirprod p q)
      z
    =
    coprod_rect
      _
      (λ w, inl (transportb Y₁ p w))
      (λ w, inr (transportb Y₂ q w))
      z.
Proof.
  induction p, q.
  induction z ; apply idpath.
Defined.

Definition transportf_prod
           {A B : UU}
           {Y : A → UU}
           {Z : B → UU}
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           {b₁ b₂ : B}
           (q : b₁ = b₂)
           (y : Y a₁)
           (z : Z b₁)
  : transportf
      (λ (x : A × B), Y (pr1 x) × Z (pr2 x))
      (pathsdirprod p q)
      (y ,, z)
    =
    transportf Y p y ,, transportf Z q z.
Proof.
  induction p.
  induction q.
  apply idpath.
Defined.

(** Basics of containers *)
Record container :=
  mkContainer
    {
      shapes : UU ;
      positions : shapes → UU
    }.

(** Builder *)
Definition make_container
           (S : UU)
           (P : S → UU)
  : container.
Proof.
  use mkContainer.
  - exact S.
  - exact P.
Defined.

Notation "S ◅ P" := (make_container S P) (at level 60) : container_scope.

Local Open Scope container_scope.

(** Constructions of containers *)
Definition constant_container
           (A : UU)
  : container
  := A ◅ (λ _, ∅).

Definition identity_container
  : container
  := unit ◅ (λ _, unit).

Definition sum_container
           (C₁ C₂ : container)
  : container
  := (shapes C₁ ⨿ shapes C₂) ◅ (coprod_rect _ (positions C₁) (positions C₂)).

Definition prod_container
           (C₁ C₂ : container)
  : container
  := (shapes C₁ × shapes C₂) ◅ (λ z, positions C₁ (pr1 z) ⨿ positions C₂ (pr2 z)).

Definition poly_container
           (P : poly_code)
  : container.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - exact (constant_container A).
  - exact identity_container.
  - exact (sum_container IHP₁ IHP₂).
  - exact (prod_container IHP₁ IHP₂).
Defined.

(** Interpretation of containers *)
Definition interpret_container
           (C : container)
           (X : UU)
  : UU
  := ∑ (s : shapes C), positions C s → X.

Notation "⟦ C ⟧ X" := (interpret_container C X) (at level 70) : container_scope.

Definition cpair
           (C : container)
           {X : UU}
           (s : shapes C)
           (p : positions C s → X)
  : ⟦ C ⟧ X
  := s ,, p.

Definition interpret_map
           (C : container)
           {X Y : UU}
           (f : X → Y)
  : ⟦ C ⟧ X → ⟦ C ⟧ Y
  := λ z, cpair C (pr1 z) (λ q, f (pr2 z q)).

Definition interpret_map_id
           (C : container)
           (X : UU)
           (x : ⟦ C ⟧ X)
  : interpret_map C (idfun X) x = x
  := idpath _.

Definition interpret_map_comp
           (C : container)
           {X Y Z : UU}
           (f : X → Y) (g : Y → Z)
           (x : ⟦ C ⟧ X)
  : interpret_map C (λ z, g(f z)) x
    =
    interpret_map C g (interpret_map C f x)
  := idpath _.

(** Interpretation of the constructions (up to equivalence) *)

(** Constant *)
Definition interpret_constant
           (A : UU)
           (X : UU)
  : ⟦ constant_container A ⟧ X → A
  := λ z, pr1 z.

Definition to_interpret_constant
           (A : UU)
           (X : UU)
  : A → ⟦ constant_container A ⟧ X
  := λ a, a ,, fromempty.

Definition interpret_constant_weq
           (A : UU)
           (X : UU)
  : ⟦ constant_container A ⟧ X ≃ A.
Proof.
  use make_weq.
  - exact (interpret_constant A X).
  - use gradth.
    + exact (to_interpret_constant A X).
    + intros x.
      use total2_paths_f.
      * exact (idpath _).
      * use funextsec.
        intro z ; induction z.
    + intros x.
      apply idpath.
Defined.

(** Identity *)
Definition interpret_identity
           (X : UU)
  : ⟦ identity_container ⟧ X → X
  := λ z, pr2 z tt.

Definition to_interpret_identity
           (X : UU)
  : X → ⟦ identity_container ⟧ X
  := λ z, tt ,, (λ _, z).

Definition interpret_identity_weq
           (X : UU)
  : ⟦ identity_container ⟧ X ≃ X.
Proof.
  use make_weq.
  - exact (interpret_identity X).
  - use gradth.
    + exact (to_interpret_identity X).
    + intros x.
      induction x as [sx px].
      induction sx.
      apply (maponpaths (λ z, tt ,, z)).
      use funextsec.
      intro z.
      induction z.
      apply idpath.
    + intro y.
      apply idpath.
Defined.

(** Sum *)
Definition interpret_sum
           (C₁ C₂ : container)
           (X : UU)
  : ⟦ sum_container C₁ C₂ ⟧ X
    →
    (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X).
Proof.
  intros z.
  induction z as [sz pz].
  induction sz as [sz | sz].
  + exact (inl (sz ,, pz)).
  + exact (inr (sz ,, pz)).
Defined.

Definition to_interpret_sum
           (C₁ C₂ : container)
           (X : UU)
  : (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X)
    →
    ⟦ sum_container C₁ C₂ ⟧ X.
Proof.
  intros z.
  induction z as [z | z].
  - exact (inl (pr1 z) ,, pr2 z).
  - exact (inr (pr1 z) ,, pr2 z).
Defined.

Definition interpret_sum_weq
           (C₁ C₂ : container)
           (X : UU)
  : ⟦ sum_container C₁ C₂ ⟧ X
    ≃
    (⟦ C₁ ⟧ X) ⨿ (⟦ C₂ ⟧ X).
Proof.
  use make_weq.
  - exact (interpret_sum C₁ C₂ X).
  - use gradth.
    + exact (to_interpret_sum C₁ C₂ X).
    + intro z.
      induction z as [sz pz].
      induction sz as [sz | sz].
      * apply idpath.
      * apply idpath.
    + intros z.
      induction z as [z | z].
      * apply idpath.
      * apply idpath.
Defined.

(** The product *)
Definition interpret_prod
           (C₁ C₂ : container)
           (X : UU)
  : ⟦ prod_container C₁ C₂ ⟧ X
    →
    (⟦ C₁ ⟧ X) × (⟦ C₂ ⟧ X).
Proof.
  intros z.
  refine ((pr11 z ,, _) ,, (pr21 z ,, _)).
  - exact (λ q, pr2 z (inl q)).
  - exact (λ q, pr2 z (inr q)).
Defined.

Definition to_interpret_prod
           (C₁ C₂ : container)
           (X : UU)
  : (⟦ C₁ ⟧ X) × (⟦ C₂ ⟧ X)
    →
    ⟦ prod_container C₁ C₂ ⟧ X
  := λ z, (pr11 z ,, pr12 z) ,, coprod_rect _ (λ q, pr21 z q) (λ q, pr22 z q).

Definition interpret_prod_weq
           (C₁ C₂ : container)
           (X : UU)
  : ⟦ prod_container C₁ C₂ ⟧ X
    ≃
    (⟦ C₁ ⟧ X) × (⟦ C₂ ⟧ X).
Proof.
  use make_weq.
  - exact (interpret_prod C₁ C₂ X).
  - use gradth.
    + exact (to_interpret_prod C₁ C₂ X).
    + intro z.
      use total2_paths_f.
      * apply idpath.
      * use funextsec.
        intro q.
        induction q.
        ** apply idpath.
        ** apply idpath.
    + intros z.
      apply idpath.
Defined.

(** Polynomials *)
Definition interpret_poly
           (P : poly_code)
           (X : UU)
  : ⟦ poly_container P ⟧ X
    →
    poly_act P X.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply interpret_constant.
  - apply interpret_identity.
  - intro z.
    induction (interpret_sum (poly_container P₁) (poly_container P₂) X z) as [q | q].
    + exact (inl (IHP₁ q)).
    + exact (inr (IHP₂ q)).
  - intro z.
    pose (interpret_prod (poly_container P₁) (poly_container P₂) X z) as q.
    exact (IHP₁ (pr1 q) ,, IHP₂ (pr2 q)).
Defined.

Definition to_interpret_poly
           (P : poly_code)
           (X : UU)
  : poly_act P X
    →
    ⟦ poly_container P ⟧ X.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply to_interpret_constant.
  - apply to_interpret_identity.
  - intro z.
    induction z as [z | z].
    + exact (to_interpret_sum
               (poly_container P₁) (poly_container P₂) X
               (inl (IHP₁ z))).
    + exact (to_interpret_sum
               (poly_container P₁) (poly_container P₂) X
               (inr (IHP₂ z))).
  - exact (λ z, to_interpret_prod
                  (poly_container P₁) (poly_container P₂) X
                  (IHP₁ (pr1 z) ,, IHP₂ (pr2 z))).
Defined.

Definition to_interpret_poly_interpret_poly'
           (P : poly_code)
           (X : UU)
           (x : ⟦ poly_container P ⟧ X)
  : to_interpret_poly P X (interpret_poly P X x) = x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ]
  ; induction x as [i x].
  - use total2_paths_f.
    + apply idpath.
    + use funextsec ; cbn.
      intro z ; induction z.
  - induction i.
    use total2_paths_f.
    + apply idpath.
    + use funextsec.
      intro z.
      induction z.
      apply idpath.
  - induction i as [i | i].
    + use total2_paths_f.
      * exact (maponpaths inl (maponpaths pr1 (IHP₁ (i ,, x)))).
      * use funextsec.
        intro z.
        refine (_ @ eqtohomot (fiber_paths (IHP₁ (i ,, x))) z).
        refine (transportf_fun_space _ _ _ @ _ @ !(transportf_fun_space _ _ _)).
        apply maponpaths.
        refine (_ @ transportf_maponpaths_inl _ _ _ _).
        apply transportf_paths.
        refine (!_).
        exact (maponpathsinv0 inl _).
    + use total2_paths_f.
      * exact (maponpaths inr (maponpaths pr1 (IHP₂ (i ,, x)))).
      * simpl.
        use funextsec.
        intro z.
        refine (_ @ eqtohomot (fiber_paths (IHP₂ (i ,, x))) z).
        refine (transportf_fun_space _ _ _ @ _ @ !(transportf_fun_space _ _ _)).
        apply maponpaths.
        refine (_ @ transportf_maponpaths_inr _ _ _ _).
        apply transportf_paths.
        refine (!_).
        exact (maponpathsinv0 inr _).
  - use total2_paths_f.
    + exact (pathsdirprod (maponpaths pr1 (IHP₁ _)) (maponpaths pr1 (IHP₂ _))).
    + use funextsec.
      intro z.
      refine (transportf_fun_space _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        simpl.
        apply transportb_maponpaths_pathsdirprod.
      }
      induction z as [z | z] ; simpl.
      * refine (_ @ eqtohomot
                      (fiber_paths
                         (IHP₁
                            (cpair
                               (poly_container P₁)
                               (pr1 i)
                               (λ q, x (inl q)))))
                      z).
        exact (!(transportf_fun_space _ _ _)).
      * refine (_ @ eqtohomot
                      (fiber_paths
                         (IHP₂
                            (cpair
                               (poly_container P₂)
                               (pr2 i)
                               (λ q, x (inr q)))))
                      z).
        exact (!(transportf_fun_space _ _ _)).
Defined.

Definition interpret_poly_to_interpret_poly
           (P : poly_code)
           (X : UU)
           (y : poly_act P X)
  : interpret_poly P X (to_interpret_poly P X y) = y.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - apply idpath.
  - induction y as [y | y].
    + exact (maponpaths inl (IHP₁ y)).
    + exact (maponpaths inr (IHP₂ y)).
  - exact (pathsdirprod (IHP₁ (pr1 y)) (IHP₂ (pr2 y))).
Defined.

Definition interpret_poly_weq
           (P : poly_code)
           (X : UU)
  : ⟦ poly_container P ⟧ X
    ≃
    poly_act P X.
Proof.
  use make_weq.
  - exact (interpret_poly P X).
  - use gradth.
    + exact (to_interpret_poly P X).
    + exact (to_interpret_poly_interpret_poly' P X).
    + exact (interpret_poly_to_interpret_poly P X).
Defined.

Definition to_interpret_poly_interpret_poly
           (P : poly_code)
           (X : UU)
           (x : ⟦ poly_container P ⟧ X)
  : to_interpret_poly P X (interpret_poly P X x) = x
  := homotinvweqweq (interpret_poly_weq P X) x.

(** W-types for containers *)
Inductive W (C : container) : UU :=
| sup : ⟦ C ⟧ (W C) → W C.

Fixpoint W_rec_map
         (C : container)
         (Y : UU)
         (fY : ⟦ C ⟧ Y → Y)
         (z : W C)
  : Y
  := match z with
     | sup _ f => fY (cpair
                        C
                        (pr1 f)
                        (λ p, W_rec_map C Y fY (pr2 f p)))
     end.

Definition W_rec_comp
           (C : container)
           (Y : UU)
           (fY : ⟦ C ⟧ Y → Y)
           (z : ⟦ C ⟧ (W C))
  : W_rec_map C Y fY (sup C z) = fY (interpret_map C (W_rec_map C Y fY) z)
  := idpath _.

Fixpoint W_ind_map
         (C : container)
         (Y : W C → UU)
         (Yc : ∏ (i : shapes C)
                 (f : positions C i → W C)
                 (v : ∏ (y : positions C i), Y(f y)),
               Y (sup C (i ,, f)))
         (z : W C)
  : Y z
  := match z with
     | sup _ z => Yc (pr1 z) (pr2 z) (λ i, W_ind_map C Y Yc (pr2 z i))
     end.

Definition W_ind_comp
           (C : container)
           (Y : W C → UU)
           (Yc : ∏ (i : shapes C)
                   (f : positions C i → W C)
                   (v : ∏ (y : positions C i), Y(f y)),
                 Y (sup C (i ,, f)))
           (z : ⟦ C ⟧ (W C))
  : W_ind_map C Y Yc (sup C z)
    =
    Yc (pr1 z) (pr2 z) (λ i, W_ind_map C Y Yc (pr2 z i))
  := idpath _.

(** W-types for polynomials *)
Definition poly_initial
           (P : poly_code)
  : UU
  := W (poly_container P).

Definition poly_initial_alg
           (P : poly_code)
  : poly_act P (poly_initial P) → poly_initial P
  := λ z, sup (poly_container P) (to_interpret_poly P _ z).

Definition poly_initial_rec
           (P : poly_code)
           (Y : UU)
           (fY : poly_act P Y → Y)
           (z : poly_initial P)
  : Y
  := W_rec_map
       (poly_container P) Y
       (λ q, fY (interpret_poly P Y q))
       z.

Definition poly_initial_comp_help
           (P : poly_code)
           (X Y : UU)
           (f : X → Y)
           (x : poly_act P X)
  : interpret_map
      (poly_container P)
      f
      (to_interpret_poly P X x)
    =
    to_interpret_poly P Y (poly_map P f x).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - use total2_paths_f.
    + apply idpath.
    + cbn.
      use funextsec.
      intro z ; induction z.
  - apply idpath.
  - induction x as [x | x].
    + use total2_paths_f.
      * exact (maponpaths inl (maponpaths pr1 (IHP₁ x))).
      * refine (_ @ fiber_paths (IHP₁ x)).
        use funextsec.
        intro z.
        refine (transportf_fun_space _ _ _ @ _ @ !(transportf_fun_space _ _ _)).
        apply maponpaths.
        refine (_ @ transportf_maponpaths_inl _ _ _ _).
        apply transportf_paths.
        refine (!_).
        exact (maponpathsinv0 inl _).
    + use total2_paths_f.
      * exact (maponpaths inr (maponpaths pr1 (IHP₂ x))).
      * refine (_ @ fiber_paths (IHP₂ x)).
        use funextsec.
        intro z.
        refine (transportf_fun_space _ _ _ @ _ @ !(transportf_fun_space _ _ _)).
        apply maponpaths.
        refine (_ @ transportf_maponpaths_inr _ _ _ _).
        apply transportf_paths.
        refine (!_).
        exact (maponpathsinv0 inr _).
  - use total2_paths_f.
    + exact (pathsdirprod
               (maponpaths pr1 (IHP₁ _))
               (maponpaths pr1 (IHP₂ _))).
    + use funextsec.
      intro z.
      refine (transportf_fun_space _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        simpl.
        apply transportb_maponpaths_pathsdirprod.
      }
      induction z as [z | z] ; simpl.
      * refine (_ @ eqtohomot (fiber_paths (IHP₁ _)) z).
        exact (!(transportf_fun_space _ _ _)).
      * refine (_ @ eqtohomot (fiber_paths (IHP₂ _)) z).
        exact (!(transportf_fun_space _ _ _)).
Defined.

Definition poly_initial_comp
           (P : poly_code)
           (Y : UU)
           (fY : poly_act P Y → Y)
           (z : poly_act P (poly_initial P))
  : poly_initial_rec
      P Y fY
      (poly_initial_alg P z)
    =
    fY (poly_map P (poly_initial_rec P Y fY) z).
Proof.
  refine (W_rec_comp
            (poly_container P) Y (λ q, fY (interpret_poly P Y q))
            _
          @
          maponpaths
            fY
            _).
  refine (_ @ interpret_poly_to_interpret_poly _ _ _).
  apply maponpaths.
  apply poly_initial_comp_help.
Defined.

Definition poly_initial_ind_help
           {P : poly_code}
           {T : UU}
           {Y : T → UU}
           {i : shapes (poly_container P)}
           {h : positions (poly_container P) i → T}
           (H : ∏ (y : positions (poly_container P) i), Y (h y))
  : poly_dact_UU P Y (interpret_poly P T (i,, h)).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - exact i.
  - exact (H tt).
  - induction i as [i | i].
    + exact (IHP₁ i h H).
    + exact (IHP₂ i h H).
  - exact (IHP₁ _ _ (λ z, H (inl z)) ,, IHP₂ _ _ (λ z, H (inr z))).
Defined.

Definition poly_initial_ind
           (P : poly_code)
           (Y : poly_initial P → UU)
           (Yc : ∏ (x : poly_act P (poly_initial P)),
                 poly_dact_UU P Y x
                 →
                 Y (poly_initial_alg P x))
  : ∏ (x : poly_initial P), Y x.
Proof.
  refine (W_ind_map
            (poly_container P)
            Y
            (λ i h H, _)).
  exact (transportf
           Y
           (maponpaths
              (sup _)
              (to_interpret_poly_interpret_poly _ _ _))
           (Yc (interpret_poly P _ (i ,, h)) (poly_initial_ind_help H))).
Defined.

Definition transportf_poly_dact_UU
           {P : poly_code}
           {X : UU}
           {Y : X → UU}
           (x : poly_act P X)
           (f : ∏ x : X, Y x)
  : transportf
      (poly_dact_UU P Y)
      (interpret_poly_to_interpret_poly P X x)
      (poly_initial_ind_help
         (λ i,
          f (pr2 (to_interpret_poly P X x) i)))
    =
    poly_dmap P Y f x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - apply idpath.
  - induction x as [x | x].
    + exact (transportf_maponpaths_inl _ _ _ _ @ IHP₁ x).
    + exact (transportf_maponpaths_inr _ _ _ _ @ IHP₂ x).
  - exact (transportf_prod _ _ _ _
            @ pathsdirprod
                (IHP₁ (pr1 x))
                (IHP₂ (pr2 x))).
Qed.

Definition poly_initial_ind_comp_help
           {A B C : UU}
           {Y : A → UU}
           {Z : C → UU}
           {f : A → B} {f' : B → A}
           (e : ∏ a, f'(f a) = a)
           {g : B → C}
           (ff : ∏ (a : A), Y a → Z (g(f a)))
           {a : A}
           (y : Y (f' (f a)))
  : transportf
      Z
      (maponpaths g (maponpaths f (e a)))
      (ff (f'(f a)) y)
    =
    ff a (transportf Y (e a) y).
Proof.
  refine (_ @ transportf_depfun (λ z, g(f z)) ff (e a) y).
  apply transportf_paths.
  apply maponpathscomp.
Qed.

Definition poly_initial_ind_comp
           (P : poly_code)
           (Y : poly_initial P → UU)
           (Yc : ∏ (x : poly_act P (poly_initial P)),
                 poly_dact_UU P Y x
                 →
                 Y (poly_initial_alg P x))
           (x : poly_act P (poly_initial P))
  : poly_initial_ind P Y Yc (poly_initial_alg P x)
    =
    Yc x (poly_dmap P Y (poly_initial_ind P Y Yc) x).
Proof.
  cbn.
  etrans.
  {
    refine (maponpaths
              (λ z, transportf
                      Y
                      (maponpaths
                         (sup (poly_container P))
                         z)
                      _)
              _).
    refine (!(homotweqweqinvweq (interpret_poly_weq P (poly_initial P)) x) @ _).
    apply maponpaths.
    etrans.
    {
      apply pathscomp0rid.
    }
    apply pathsinv0inv0.
  }
  refine (poly_initial_ind_comp_help
            (interpret_poly_to_interpret_poly _ _)
            Yc
            _
          @ _).
  apply maponpaths.
  apply transportf_poly_dact_UU.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal8.

From lfind Require Import LFind.
Lemma lfind_state  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) (IHl:@eq lst (drop (Succ x1) (drop (Succ x2) (Cons x3 l)))
  (drop (Succ x2) (drop (Succ x1) (Cons x3 l)))):@eq lst (drop (Succ x1) (drop (Succ x2) (Cons x3 (Cons n l))))
  (drop (Succ x2) (drop (Succ x1) (Cons x3 (Cons n l)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal8_drop_Cons_assoc_33_drop_Cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) :=
 let lfind_var := "x1:" ++ "(" ++ show x1 ++ ")"++ "|" ++"x2:" ++ "(" ++ show x2 ++ ")"++ "|" ++"x3:" ++ "(" ++ show x3 ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"++ "|" ++"l:" ++ "(" ++ show l ++ ")"
 in let lfind_v := print x1 lfind_var
 in lfind_state lfind_v  x2 x3 n l.
QuickChick collect_data.
Success.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e382m105_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import ordinals.

From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import proof_trees.
From Cyclic_PA.Logic Require Import substitute.

Definition demorgan1_sub_formula (A E F : formula) (S : subst_ind) : formula :=
  formula_sub_ind A (neg (lor E F)) (neg E) S.

Lemma demorgan1_sub_formula_closed :
    forall (A : formula),
        closed A = true ->
            forall (E F : formula) (S : subst_ind),
                closed (demorgan1_sub_formula A E F S) = true.
Proof.
intros A CA E F S.
unfold demorgan1_sub_formula.
apply (formula_sub_ind_closed _ _ _ CA).
unfold closed; fold closed.
apply and_bool_prop.
Qed.

Fixpoint demorgan1_sub_ptree_fit
  (P : ptree) (E F : formula) (S : subst_ind) : ptree :=
match P, S with
| deg_up d P', _ => deg_up d (demorgan1_sub_ptree_fit P' E F S)

| ord_up alpha P', _ => ord_up alpha (demorgan1_sub_ptree_fit P' E F S)

| node A, _ => P

| exchange_ab A B d alpha P', lor_ind S_B S_A =>
    exchange_ab
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula B E F S_B)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind S_A S_B))

| exchange_cab C A B d alpha P', lor_ind (lor_ind S_C S_B) S_A =>
    exchange_cab
      (demorgan1_sub_formula C E F S_C)
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula B E F S_B)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (lor_ind S_C S_A) S_B))

| exchange_abd A B D d alpha P', lor_ind (lor_ind S_B S_A) S_D =>
    exchange_abd
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula B E F S_B)
      (demorgan1_sub_formula D E F S_D)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (lor_ind S_A S_B) S_D))

| exchange_cabd C A B D d alpha P', lor_ind (lor_ind (lor_ind S_C S_B) S_A) S_D =>
    exchange_cabd
      (demorgan1_sub_formula C E F S_C)
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula B E F S_B)
      (demorgan1_sub_formula D E F S_D)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D))

| contraction_a A d alpha P', _ =>
    contraction_a
      (demorgan1_sub_formula A E F S)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind S S))

| contraction_ad A D d alpha P', lor_ind S_A S_D =>
    contraction_ad
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula D E F S_D)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (lor_ind S_A S_A) S_D))

| weakening_ad A D d alpha P', lor_ind S_A S_D =>
    weakening_ad
      (demorgan1_sub_formula A E F S_A)
      (demorgan1_sub_formula D E F S_D)
      d alpha
      (demorgan1_sub_ptree_fit P' E F S_D)

| demorgan_ab A B d1 d2 alpha1 alpha2 P1 P2, _ =>
    (match form_eqb A E, form_eqb B F, S with
    | true, true, (1) =>
      (match nat_eqb d1 (ptree_deg P) with
      | true => ord_up (ptree_ord P) P1
      | false => deg_up (ptree_deg P) (ord_up (ptree_ord P) P1)
      end)
    | _, _, _ => P
    end)

| demorgan_abd A B D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_AB S_D =>
    (match form_eqb A E, form_eqb B F, S_AB with
    | true, true, (1) =>
      (match nat_eqb d1 (ptree_deg P) with
      | true =>
          ord_up
            (ptree_ord P)
            (demorgan1_sub_ptree_fit P1 E F (lor_ind (non_target (neg A)) S_D))
      | false =>
          deg_up
            (ptree_deg P)
              (ord_up
                (ptree_ord P)
                (demorgan1_sub_ptree_fit
                  P1 E F
                  (lor_ind (non_target (neg A)) S_D)))
      end)
    | _, _, _ =>
        demorgan_abd
          A B
          (demorgan1_sub_formula D E F S_D)
          d1 d2 alpha1 alpha2
          (demorgan1_sub_ptree_fit P1 E F (lor_ind (non_target (neg A)) S_D))
          (demorgan1_sub_ptree_fit P2 E F (lor_ind (non_target (neg B)) S_D))
    end)

| negation_a A d alpha P', _ => P

| negation_ad A D d alpha P', lor_ind S_A S_D =>
    negation_ad
      A
      (demorgan1_sub_formula D E F S_D)
      d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (non_target A) S_D))

| quantification_a A n t d alpha P', _ => P

| quantification_ad A D n t d alpha P', lor_ind S_A S_D =>
    quantification_ad
      A
      (demorgan1_sub_formula D E F S_D)
      n t d alpha
      (demorgan1_sub_ptree_fit P' E F (lor_ind (0) S_D))

| w_rule_a A n d alpha g, _ => P

| w_rule_ad A D n d alpha g, lor_ind S_A S_D =>
    w_rule_ad
      A
      (demorgan1_sub_formula D E F S_D)
      n d alpha
      (fun (t : c_term) =>
          demorgan1_sub_ptree_fit (g t) E F (lor_ind (non_target A) S_D))

| cut_ca C A d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ca
      (demorgan1_sub_formula C E F S)
      A d1 d2 alpha1 alpha2
      (demorgan1_sub_ptree_fit P1 E F (lor_ind S (non_target A)))
      P2

| cut_ad A D d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ad
      A
      (demorgan1_sub_formula D E F S)
      d1 d2 alpha1 alpha2
      P1
      (demorgan1_sub_ptree_fit P2 E F (lor_ind (0) S))

| cut_cad C A D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_C S_D =>
    cut_cad
      (demorgan1_sub_formula C E F S_C)
      A
      (demorgan1_sub_formula D E F S_D)
      d1 d2 alpha1 alpha2
      (demorgan1_sub_ptree_fit P1 E F (lor_ind S_C (non_target A)))
      (demorgan1_sub_ptree_fit P2 E F (lor_ind (0) S_D))

| _, _ => P
end.

Definition demorgan1_sub_ptree
  (P : ptree) (E F : formula) (S : subst_ind) : ptree :=
match subst_ind_fit (ptree_formula P) S with
| false => P
| true => demorgan1_sub_ptree_fit P E F S
end.

Lemma demorgan1_ptree_formula_true :
    forall (P : ptree) (E F : formula) (S : subst_ind),
        subst_ind_fit (ptree_formula P) S = true ->
            demorgan1_sub_ptree_fit P E F S = demorgan1_sub_ptree P E F S.
Proof.
intros P E F S FS.
unfold demorgan1_sub_ptree.
rewrite FS.
reflexivity.
Qed.

Lemma demorgan1_ptree_formula' :
    forall (P : ptree) (E F : formula),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    ptree_formula (demorgan1_sub_ptree P E F S) =
                        demorgan1_sub_formula (ptree_formula P) E F S.
Proof.
intros P E F.
induction P; try intros PV S FS;
unfold demorgan1_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold demorgan1_sub_ptree_fit; fold demorgan1_sub_ptree_fit.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
13-14 : destruct PV as [[[PF PV] PD] PO].

1-2 : rewrite (demorgan1_ptree_formula_true _ _ _ _ FS);
      unfold ptree_formula; fold ptree_formula;
      apply (IHP PV _ FS).

1 : { inversion PV as [PX].
      unfold demorgan1_sub_ptree, demorgan1_sub_formula, formula_sub_ind.
      rewrite FS.
      unfold ptree_formula; fold ptree_formula.
      destruct (axiom_atomic _ PX) as [[a fa] | [a fa]];
      rewrite fa;
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb;
      reflexivity. }

5 : reflexivity.

9,11,13,15,16 : unfold ptree_formula, demorgan1_sub_formula, formula_sub_ind, formula_sub_ind_fit, form_eqb;
                destruct S;
                try reflexivity.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

1,5,6,13 :  apply and_bool_prop in FS';
            destruct FS' as [FS1 FS2];
            unfold ptree_formula, demorgan1_sub_formula, formula_sub_ind, formula_sub_ind_fit;
            fold formula_sub_ind_fit;
            rewrite FS,FS1,FS2;
            reflexivity.

4-6 : case (form_eqb f E) eqn:EQ1;
      case (form_eqb f0 F) eqn:EQ2;
      unfold ptree_formula, demorgan1_sub_formula, formula_sub_ind, subst_ind_fit, formula_sub_ind_fit, form_eqb;
      fold ptree_formula form_eqb formula_sub_ind_fit subst_ind_fit;
      try rewrite EQ1;
      try rewrite EQ2;
      try reflexivity.

all : unfold "&&".

4 : { destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
      apply form_eqb_eq in EQ1,EQ2.
      destruct EQ1,EQ2.
      case (nat_eqb n (ptree_deg (demorgan_ab f f0 n n0 o o0 P1 P2))) eqn:EQ;
      unfold ptree_formula; fold ptree_formula;
      apply P1F. }

all : destruct S1; inversion FS' as [FS''].

5 : { destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
      apply form_eqb_eq in EQ1,EQ2.
      destruct EQ1,EQ2.
      assert (subst_ind_fit (ptree_formula P1) (lor_ind (non_target (neg f)) S2) = true) as FS1.
      { rewrite P1F.
        unfold subst_ind_fit, non_target; fold subst_ind_fit.
        apply FS'. }
      case (nat_eqb n (ptree_deg (demorgan_abd f f0 f1 n n0 o o0 P1 P2))) eqn:EQ;
      unfold ptree_formula; fold ptree_formula;
      rewrite (demorgan1_ptree_formula_true _ _ _ _ FS1);
      rewrite (IHP1 P1V _ FS1);
      unfold demorgan1_sub_formula;
      rewrite P1F;
      rewrite non_target_sub_lor;
      unfold formula_sub_ind;
      rewrite FS'';
      reflexivity. }

1-3 : apply and_bool_prop in FS';
      destruct FS' as [FS1 FS2];
      apply and_bool_prop in FS1;
      destruct FS1 as [FS1_1 FS1_2].

3 : destruct S1_1; inversion FS'' as [FS'''];
    apply and_bool_prop in FS1_1;
    destruct FS1_1 as [FS1_1_1 FS1_1_2].

all : unfold ptree_formula, demorgan1_sub_formula, formula_sub_ind, formula_sub_ind_fit, form_eqb;
      fold ptree_formula form_eqb formula_sub_ind_fit;
      try rewrite FS;
      try rewrite FS'';
      try rewrite EQ;
      try rewrite FS1_1,FS1_2,FS2;
      try rewrite FS1_1_1,FS1_1_2,FS1_2,FS2;
      unfold "&&";
      try reflexivity.
Qed.

Lemma demorgan1_ptree_formula :
    forall (P : ptree) (E F : formula),
        valid P ->
            forall (S : subst_ind),
                ptree_formula (demorgan1_sub_ptree P E F S) =
                    demorgan1_sub_formula (ptree_formula P) E F S.
Proof.
intros P E F PV S.
destruct (subst_ind_fit (ptree_formula P) S) eqn:FS.
- apply (demorgan1_ptree_formula' _ _ _ PV _ FS).
- unfold demorgan1_sub_ptree, demorgan1_sub_formula, formula_sub_ind.
  rewrite FS.
  reflexivity.
Qed.

Lemma demorgan1_ptree_deg :
    forall (P : ptree) (E F : formula),
        valid P ->
            forall (S : subst_ind),
                ptree_deg (demorgan1_sub_ptree P E F S) = ptree_deg P.
Proof.
intros P E F PV.
unfold demorgan1_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold demorgan1_sub_ptree_fit; fold demorgan1_sub_ptree_fit;
unfold ptree_deg in *; fold ptree_deg in *;
try reflexivity.

1 : destruct PV as [[IO PV] NO].

8,9 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb f E) eqn:EQ1;
      case (form_eqb f0 F) eqn:EQ2;
      unfold ptree_deg; fold ptree_deg;
      try rewrite P1D;
      try rewrite P2D;
      case (nat_eqb (ptree_deg P1) (Nat.max (ptree_deg P1) (ptree_deg P2))) eqn:EQ;
      unfold ptree_deg; fold ptree_deg;
      try reflexivity.

4 : apply nat_eqb_eq in EQ;
    destruct EQ;
    reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_deg; fold ptree_deg;
      try reflexivity.

- apply nat_eqb_eq in EQ;
  destruct EQ.
  rewrite <- (IHP1 P1V (lor_ind (non_target (neg f)) S2)).
  rewrite P1F.
  unfold subst_ind_fit, non_target; fold subst_ind_fit.
  rewrite FS'.
  reflexivity.
Qed.

Lemma demorgan1_ptree_ord :
    forall (P : ptree) (E F : formula),
        valid P ->
            forall (S : subst_ind),
                ptree_ord (demorgan1_sub_ptree P E F S) = ptree_ord P.
Proof.
intros P E F PV.
unfold demorgan1_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold demorgan1_sub_ptree_fit; fold demorgan1_sub_ptree_fit;
unfold ptree_ord in *; fold ptree_ord in *;
try reflexivity.

1 : destruct PV as [ID PV].

8,9 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb f E) eqn:EQ1;
      case (form_eqb f0 F) eqn:EQ2;
      unfold ptree_deg; fold ptree_deg;
      case (nat_eqb n (Nat.max n n0)) eqn:EQ;
      try reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_ord; fold ptree_ord;
      try reflexivity.
Qed.

(* *)
Lemma demorgan1_valid :
    forall (P : ptree) (E F : formula),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    valid (demorgan1_sub_ptree P E F S).
Proof.
intros P E F PV.
induction P; try intros S FS;
unfold demorgan1_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold demorgan1_sub_ptree_fit; fold demorgan1_sub_ptree_fit.

all : try apply PV.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
3-8 : destruct PV as [[[PF PV] PD] PO].
9 : destruct PV as [[[[PF FC] PV] PD] PO].
12-13 : destruct PV as [[[PF PV] PD] PO].
10,11,15,16,17: inversion PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

3,4,5,6,8,9,10,11,14,15,16,17 : destruct S; inversion FS as [FS'];
                                try destruct (and_bool_prop _ _ FS') as [FS1 FS2].

4,5,6,11 :  destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

6 : destruct S1_1; inversion FS'' as [FS'''];
    destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

16 :  { assert (forall t, subst_ind_fit (ptree_formula (p t)) (lor_ind (non_target f) S2) = true) as FSt.
        { intros t.
          destruct (PV t) as [[[PF PVt] PD] PO].
          rewrite PF.
          unfold subst_ind_fit; fold subst_ind_fit.
          rewrite non_target_sub_fit.
          unfold "&&".
          apply FS2. }

        repeat split;
        destruct (PV t) as [[[PF PVt] PD] PO];
        rewrite (demorgan1_ptree_formula_true _ _ _ _ (FSt t)).
        - rewrite (demorgan1_ptree_formula _ _ _ PVt).
          rewrite PF.
          unfold demorgan1_sub_formula.
          rewrite (non_target_term_sub _ n (projT1 t)).
          rewrite non_target_sub_lor.
          reflexivity.
        - apply (X _ PVt _ (FSt t)).
        - rewrite (demorgan1_ptree_deg _ _ _ PVt).
          apply PD.
        - rewrite (demorgan1_ptree_ord _ _ _ PVt).
          apply PO. }

10 :  assert (closed (neg (lor E F)) = true -> closed (neg E) = true) as CIMP.
10 :  { unfold closed; fold closed;
        apply and_bool_prop. }

7,8,11,12 : case (form_eqb f E) eqn:EQ1;
            case (form_eqb f0 F) eqn:EQ2;
            unfold ptree_deg; fold ptree_deg;
            try apply PV.

11,15 : case (nat_eqb n (Nat.max n n0)) eqn:EQ.

all : try apply form_eqb_eq in EQ1;
      try destruct EQ1;
      try apply form_eqb_eq in EQ2;
      try destruct EQ2;
      repeat rewrite demorgan1_ptree_formula_true;
      repeat split;
      try apply IHP;
      try apply IHP1;
      try apply IHP2;
      unfold ptree_deg; fold ptree_deg;
      try rewrite demorgan1_ptree_deg;
      try rewrite demorgan1_ptree_ord;
      try apply ptree_ord_nf;
      unfold ptree_ord; fold ptree_ord;
      try rewrite demorgan1_ptree_formula;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold demorgan1_sub_formula, formula_sub_ind;
      try apply PV;
      try apply PD;
      try rewrite PO;
      try apply P1V;
      try rewrite P1D in *;
      try rewrite P1O;
      try apply P2V;
      try rewrite P2D in *;
      try rewrite P2O;
      try apply FS;
      try apply ID;
      try apply IO;
      try apply NO;
      unfold subst_ind_fit, non_target; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite FS;
      try rewrite FS';
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try rewrite FS2;
      unfold "&&";
      try reflexivity;
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb; fold form_eqb;
      try rewrite non_target_sub';
      try reflexivity;
      try rewrite <- (sub_fit_true _ _ _ _ FS1);
      try apply (formula_sub_ind_closed _ _ _ FC CIMP);
      try apply max_lem1;
      try apply EQ;
      try apply ord_lt_max_succ_l;
      try case (form_eqb f (lor E F));
      try case (form_eqb f0 (lor E F));
      try case (form_eqb (substitution f n (projT1 c)) (lor E F));
      try case (form_eqb f (lor f f0));
      try case (form_eqb f0 (lor f f0));
      try case (form_eqb f (lor f F));
      try case (form_eqb f0 (lor f F));
      try case (form_eqb f (lor E f0));
      try case (form_eqb f0 (lor E f0));
      try reflexivity.
Qed.


Require Import
        Fiat.Narcissus.Common.Specs.

Set Implicit Arguments.

Definition compose E B
           (monoid : Monoid B)
           (format1 : E -> B * E)
           (format2 : E -> B * E) :=
  fun e0 =>
    let (p, e1) := format1 e0 in
    let (q, e2) := format2 e1 in
    (mappend p q, e2).

Lemma compose_format_correct A A' B
      (cache : Cache)
      (monoid : Monoid B)
      (project : A -> A')
      (predicate : A -> Prop)
      (predicate' : A' -> Prop)
      (format1 : A' -> CacheFormat -> B * CacheFormat)
      (format2 : A -> CacheFormat -> B * CacheFormat)
      (decode1 : B -> CacheDecode -> A' * B * CacheDecode)
      (decode1_pf : format_decode_correct monoid predicate' format1 decode1)
      (decode2 : A' -> B -> CacheDecode -> A * B * CacheDecode)
      (decode2_pf : forall proj,
          format_decode_correct monoid
            (fun data => predicate data /\ project data = proj)
            format2
            (decode2 proj))
  : format_decode_correct monoid (fun a => predicate' (project a) /\ predicate a)
     (fun (data : A) (ctx : CacheFormat) =>
      compose monoid (format1 (project data)) (format2 data) ctx)
     (fun (bin : B) (env : CacheDecode) =>
      let (bundle, env') := decode1 bin env in let (proj, rest) := bundle in decode2 proj rest env').
Proof.
  intros env env' xenv xenv' data data' bin ext ext' env_pm pred_pm com_pf.
  unfold compose in com_pf.
  destruct (format1 (project data) env) as [b1 e1] eqn: eq1.
  destruct (format2 data e1) as [b2 e2] eqn: eq2.
  destruct (decode1 (mappend b1 (mappend b2 ext)) env') as [ [d1 r1] e1'] eqn: eq1'.
  destruct (decode1_pf _ _ _ _ _ _ _ _ _ env_pm (proj1 pred_pm) eq1 eq1') as [de [dp dt] ].
  inversion com_pf; subst; clear com_pf.
  rewrite <- mappend_assoc. rewrite eq1'.
  destruct (decode2 (project data) (mappend b2 ext) e1') as [ [d2 r2] e2'] eqn: eq2'.
  specialize (decode2_pf (project data)  _ _ _ _ _ _ _ _ _ de (conj (proj2 pred_pm) eq_refl) eq2 eq2').
  inversion 1. subst. intuition.
Qed.


From Coq Require Import List Lia String ZArith.
From WiSE Require Import streams imp symbolic.symex.
Import ListNotations.

(** * Implementation of a naive bug finder for [IMP] *)

(** A task list is a list of programs to be executed in a given symbolic state. *)
Definition tasks := list sym_state.

(** A [status] corresponds to the current state of the bugfinding loop *)
Inductive status :=
  | BugFound (s : sym_state)
  | Pending
  | Finished.

Definition then_do q '(((path, env), p) : sym_state) :=
  ((path, env), Seq p q).

(** Executing a task according to [sym_step] *)
Fixpoint expand path env prog : list sym_state :=
  match prog with
  | Skip => []
  | Aff x e =>
    [(path, sym_update env x (sym_aeval env e), Skip)]
  | Err => []
  | Ite b p1 p2 =>
    [
      (Band path (sym_beval env b), env, p1);
      (Band path (Bnot (sym_beval env b)), env, p2)
    ]
  | Loop b p =>
    [
      (Band path (sym_beval env b), env, Seq p (Loop b p));
      (Band path (Bnot (sym_beval env b)), env, Skip)
    ]
  | Seq Skip p2 => [(path, env, p2)]
  | Seq p1 p2 =>
    List.map (then_do p2) (expand path env p1)
  end.

(** Bugfinding loop: at every iteration, a task is choosen and then executed.
    If the execution results in an error, a [BugFound] message is
    emitted. If executing the task terminates in a state [s] without error,
    a message [Clear s] is emitted. If executing the task generates a list [l] of subtasks,
    then the loop signals that further computations are pending and add [l] to the worklist.
    Finally, if the task list is empty, the loop emits the token [Finished] continuously.
*)
CoFixpoint run (l : tasks) : stream (option sym_state) :=
  match l with
  | [] => scons None (run [])
  | ((path, env), prog)::next =>
    let next_next := expand path env prog in
    scons (Some (path, env, prog)) (run (next ++ next_next))
  end.

(** [run_n] predicts the tasks list after n iteration *)
Fixpoint run_n (n : nat) (tasks : list sym_state) : list sym_state :=
  match n, tasks with
  | 0, _ => tasks
  | S n, [] => []
  | S n, (path, env, prog)::next =>
    let next_next := expand path env prog in
    run_n n (next ++ next_next)
  end.

Definition display (st : option sym_state) : status :=
  match st with
  | None => Finished
  | Some (path, env, prog) =>
    if is_error prog then BugFound (path, env, prog)
    else Pending
    (* else if is_skip prog then Clear (path, env, prog)
    else Pending (path, env, prog) *)
  end.

Definition init (p : IMP) : list sym_state :=
  [((Bcst true, id), p)].

Definition find_bugs (p : IMP) : stream status :=
  map display (run (init p)).

Definition init_assuming (p : IMP) (cond : bexpr) :=
  [(cond, id, p)].

Definition find_bugs_assuming (p : IMP) (cond : bexpr) : stream status :=
  map display (run (init_assuming p cond)).

(** Examples *)
Section Examples.

Section Simple.
Example my_prog :=
  Ite
    (Beq (Var "x"%string) (Cst 0%Z))
    Err
    Skip.
Compute (peek 10 (find_bugs my_prog)).
Example a := (Var "a"%string).
Example b := (Var "b"%string).
Example trivial_assertion :=
  Seq
    (Aff "a"%string b)
    (Assert (Bnot (Beq a b))).
Compute (peek 10 (find_bugs trivial_assertion)).
End Simple.

Section Gcd.

(*
function gcd(a, b)
    while a ≠ b
        if a <= b
            b := b − a
        else
            a := a − b
    return a
*)

Example gcd :=
  Loop
    (Bnot (Beq a b))
    (Ite
       (Ble a b)
       (Aff "b"%string (Sub b a))
       (Aff "a"%string (Sub a b))).

Example init_store (x : ident) : Z :=
  match x with
  | "a"%string => 9
  | "b"%string => 6
  | _ => 0
  end.

(* gcd(9, 6) --> (3, 3) *)
Example execute_gcd:
  exec
    init_store
    gcd
    (update (update init_store "a"%string 3%Z) "b"%string 3%Z).
Proof.
  unfold gcd.

  (* First Iteration *)
  apply exec_loop_true with
    (update init_store "a"%string 3%Z);
  auto.
  1: (* correctness of provided store *)
  apply exec_Ite_false; auto.
  apply exec_Aff.
  auto.

  (* Second Iteration *)
  apply exec_loop_true with
    (update (update init_store "a"%string 3%Z) "b"%string 3%Z); auto.

  1: (* correctness of provided store *)
  apply exec_Ite_true; auto.
  apply exec_Aff.
  auto.

  (* Termination *)
  apply exec_loop_false.
  auto.
Qed.

Example a0 := (Var "a0"%string).
Example b0 := (Var "b0"%string).

(* Now, a correct version of `gcd` with assertions. *)

(*
function gcd(a, b)
    while a ≠ b
        if a <= b
            b := b − a
        else
            a := a − b

        assert a + b + 1 <= \old(a) + \old(b)
    return a
*)

Example gcd_assertions :=
  Loop
    (Bnot (Beq a b))
    (Seq
      (Aff "a0"%string a)
      (Seq
        (Aff "b0"%string b)
        (Seq
          (Ite
             (Ble a b)
             (Aff "b"%string (Sub b a))
             (Aff "a"%string (Sub a b)))
          (Assert (Ble (Add (Add a b) (Cst 1%Z)) (Add a0 b0)))))).

Example init_store' (x : ident) : Z :=
  match x with
  | "a"%string => 4
  | "b"%string => 2
  | _ => 0
  end.

(* gcd(4, 2) --> (2, 2) *)
Example execute_gcd_noerr:
  exec
    init_store'
    gcd_assertions
    (update
      (update
        (update init_store' "a0"%string 4)
        "b0"%string 2)
      "a"%string 2).
  unfold gcd_assertions.

  (* First Iteration *)
  apply exec_loop_true with
    (update
      (update
        (update init_store' "a0"%string 4)
        "b0"%string 2)
      "a"%string 2);
  auto.

  1: (* correctness of provided store *)
  (* `a0 = a` *)
  apply exec_Seq with (update init_store' "a0"%string 4%Z);
  try constructor; auto.

  (* `b0 = b` *)
  apply exec_Seq with
    (update (update init_store' "a0"%string 4%Z) "b0"%string 2%Z);
  try constructor; auto.

  (* if... ; ... *)
  apply exec_Seq with
    (update
      (update
        (update init_store' "a0"%string 4%Z)
        "b0"%string 2%Z)
      "a"%string 2%Z).

  1: (* if ... *)
  apply exec_Ite_false; auto.
  apply exec_Aff.
  auto.

  (* assert ... *)
  unfold Assert.
  apply exec_Ite_true; auto.
  apply exec_Skip.

  (* Termination *)
  apply exec_loop_false.
  auto.
Qed.

(* Now, a *buggy* version of `gcd` with assertions. *)

(*
function gcd_buggy(a, b)
    while a ≠ b
        if a <= b
            b := b − a
        else
            a := a + b  // Should be `a - b`

        assert a + b + 1 <= \old(a) + \old(b)
    return a
*)

Example gcd_buggy :=
  Loop
    (Bnot (Beq a b))
    (Seq
      (Aff "a0"%string a)
      (Seq
        (Aff "b0"%string b)
        (Seq
          (Ite
             (Ble a b)
             (Aff "b"%string (Sub b a))
             (Aff "a"%string (Add a b)))
          (Assert (Ble (Add (Add a b) (Cst 1%Z)) (Add a0 b0)))))).

(* gcd_buggy(4, 2) --> Err *)
Example execute_gcd_err:
  forall s, ~ exec init_store' gcd_buggy s.
  intros s.
  unfold not; intros.
  inversion H; try (inversion H4; fail).

  inversion H4; clear H4 H2; subst; simpl in *.
  inversion H12; clear H12; subst; simpl in *.
  inversion H5; clear H5; subst; simpl in *.
  inversion H4; clear H4; subst; simpl in *.

  - (* then case *)
    inversion H3; clear H3; subst; simpl in *.
    inversion H10; clear H10; subst; simpl in *.
    inversion H9.
  - (* else case *)
    inversion H11; clear H11; subst; simpl in *.
    inversion H3; clear H3; subst; simpl in *.
    inversion H10; clear H10; subst; simpl in *.
    inversion H8; clear H8; subst; simpl in *; inversion H5.
    inversion H7.
Qed.
Notation "'Bug' π" := (BugFound (π, _, _)) (at level 80).
Eval compute in (peek 20 (find_bugs gcd_buggy)).
End Gcd.

End Examples.