Require Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Classes.Equivalence.
Require Export Coq.Sets.Ensembles.
Require Import Coq.Sets.Constructive_sets.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.

Lemma Full_set_spec: forall A (v: A), Full_set A v <-> True.
Proof.
  intros.
  split; intros; constructor.
Qed.

Lemma Empty_set_spec: forall A (v: A), Empty_set A v <-> False.
  intros.
  split; intros [].
Qed.

Lemma Intersection_spec: forall A (v: A) P Q, Intersection _ P Q v <-> P v /\ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + constructor; tauto.
Qed.

Lemma Union_spec: forall A (v: A) P Q, Union _ P Q v <-> P v \/ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Disjoint_spec: forall A P Q, Disjoint A P Q <-> (forall x, P x -> Q x -> False).
Proof.
  intros; split; intros.
  + inversion H.
    eapply H2.
    unfold In; rewrite Intersection_spec; split; eauto.
  + constructor.
    intros.
    unfold In; rewrite Intersection_spec.
    intro; apply H with x; tauto.
Qed.

Lemma Included_Full_set: forall A P, Included A P (Full_set A).
Proof.
  intros.
  hnf; unfold In; intros.
  apply Full_set_spec; auto.
Qed.

Lemma Intersection_Complement: forall A (P Q: Ensemble A),
  Same_set A
  (Intersection A (Complement A P) (Complement A Q))
  (Complement A (Union A P Q)).
Proof.
  intros.
  unfold Same_set, Included, Complement, Ensembles.In.
  split; intros.
  + rewrite Union_spec.
    rewrite Intersection_spec in H.
    tauto.
  + rewrite Union_spec in H.
    rewrite Intersection_spec.
    tauto.
Qed.

Lemma Union_iff: forall U A B x, Ensembles.In U (Union U A B) x <-> Ensembles.In U A x \/ Ensembles.In U B x.
Proof.
  intros; split; intros.
  + apply Constructive_sets.Union_inv; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Empty_set_iff: forall U x, Ensembles.In U (Empty_set U) x <-> False.
Proof.
  intros; split; intro; inversion H.
Qed.

Lemma Singleton_iff: forall U x y, Ensembles.In U (Singleton U x) y <-> x = y.
Proof.
  intros; split; intro.
  + inversion H; auto.
  + subst; constructor.
Qed.

Arguments Included {U} B C.
Arguments Same_set {U} B C.

Lemma Same_set_refl: forall A (S : Ensemble A), Same_set S S. Proof. intros; split; intro; tauto. Qed.

Lemma Same_set_sym: forall A (S1 S2 : Ensemble A), Same_set S1 S2 -> Same_set S2 S1. Proof. intros; destruct H; split; auto. Qed.

Lemma Same_set_trans: forall A (S1 S2 S3: Ensemble A), Same_set S1 S2 -> Same_set S2 S3 -> Same_set S1 S3.
Proof. intros; destruct H, H0; split; repeat intro; [apply H0, H, H3 | apply H1, H2, H3]. Qed.

Add Parametric Relation {A} : (Ensemble A) Same_set
    reflexivity proved by (Same_set_refl A)
    symmetry proved by (Same_set_sym A)
    transitivity proved by (Same_set_trans A) as Same_set_rel.

Lemma Same_set_spec: forall A P Q, Same_set P Q <-> (pointwise_relation A iff) P Q.
Proof.
  intros.
  unfold Same_set, Included, In, pointwise_relation.
  firstorder.
Qed.

Lemma Complement_Empty_set: forall A, Same_set (Complement A (Empty_set _)) (Full_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro a.
  unfold Complement, Ensembles.In.
  pose proof Empty_set_iff _ a.
  pose proof Full_set_spec _ a.
  tauto.
Qed.

Lemma Intersection_comm: forall A P Q, Same_set (Intersection A P Q) (Intersection A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_assoc: forall A P Q R, Same_set (Intersection A (Intersection A P Q) R) (Intersection A P (Intersection A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Union_comm: forall A P Q, Same_set (Union A P Q) (Union A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Union_assoc: forall A P Q R, Same_set (Union A (Union A P Q) R) (Union A P (Union A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_l: forall A P Q R,
  Same_set (Intersection A (Union A Q R) P)
   (Union A (Intersection A Q P) (Intersection A R P)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_r: forall A P Q R,
  Same_set (Intersection A P (Union A Q R))
   (Union A (Intersection A P Q) (Intersection A P R)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Instance Included_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (@Included V).
Proof.
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation, Included, Ensembles.In in *.
  firstorder.
Defined.

Instance complement_proper (V: Type): Proper (Same_set ==> Same_set) (Complement V).
  hnf; intros.
  rewrite Same_set_spec in *.
  hnf; intros.
  unfold Complement, Ensembles.In.
  specialize (H a).
  tauto.
Defined.

Instance Union_proper (V: Type): Proper (Same_set ==> Same_set ==> Same_set) (Union V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *; intros.
  rewrite !Union_spec.
  firstorder.
Defined.

Instance Disjoint_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (Disjoint V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  rewrite !Disjoint_spec.
  firstorder.
Defined.

Lemma Union_Included {A: Type}: forall P Q R, Included (Union A P Q) R <-> Included P R /\ Included Q R.
Proof.
  intros.
  unfold Included.
  pose proof Union_iff A P Q.
  firstorder.
Qed.

Lemma left_Included_Union {A: Type}: forall P Q, Included P (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma right_Included_Union {A: Type}: forall P Q, Included Q (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma Union_Empty_left {A: Type}: forall P, Same_set (Union _ (Empty_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Union_Empty_right {A: Type}: forall P, Same_set (Union _ P (Empty_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Intersection_Full_left {A: Type}: forall P, Same_set (Intersection _ (Full_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Full_right {A: Type}: forall P, Same_set (Intersection _ P (Full_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_left {A: Type}: forall P, Same_set (Intersection _ (Empty_set A) P) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_right {A: Type}: forall P, Same_set (Intersection _ P (Empty_set A)) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_absort_right: forall U (A B: Ensemble U), Included A B -> Same_set (Intersection _ A B) A.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Intersection_absort_left: forall U (A B: Ensemble U), Included B A -> Same_set (Intersection _ A B) B.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Complement_Included_rev: forall (U: Type) P Q, Included P Q -> Included (Complement U Q) (Complement U P).
Proof.
  unfold Included, Complement, Ensembles.In.
  intros.
  firstorder.
Qed.

Lemma Prop_join_shrink: forall {U} (A B C R: Ensemble U),
  Included B R ->
  Prop_join A B C ->
  Prop_join (Intersection _ A R) B (Intersection _ C R).
Proof.
  unfold Prop_join, Included, Ensembles.In.
  intros.
  split; intros; rewrite !Intersection_spec in *; auto.
  + split; firstorder.
  + firstorder.
Qed.

Lemma Prop_join_shrink1: forall {U} (A B C: Ensemble U) (x: U),
  A x ->
  Prop_join A B C ->
  Prop_join (Intersection _ A (fun x0 => x <> x0)) B (Intersection _ C (fun x0 => x <> x0)).
Proof.
  intros.
  apply Prop_join_shrink; auto.
  unfold Included, In; intros.
  intro.
  subst x0.
  destruct H0.
  apply (H2 x); auto.
Qed.

Lemma Ensemble_join_Intersection_Complement: forall {A} P Q,
  Included Q P ->
  (forall x, Q x \/ ~ Q x) ->
  Prop_join Q (Intersection A P (Complement A Q)) P.
Proof.
  intros.
  unfold Prop_join.
  unfold Included, Ensembles.In in H.
  split; intros x; specialize (H0 x); specialize (H x);
  rewrite Intersection_spec; unfold Complement, Ensembles.In; try tauto.
Qed.

Instance Intersection_proper {A}: Proper (Same_set ==> Same_set ==> Same_set) (Intersection A).
Proof.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  intro a; specialize (H0 a); specialize (H a).
  rewrite !Intersection_spec.
  tauto.
Defined.

Instance Prop_join_proper {A}: Proper (@Same_set A ==> Same_set ==> Same_set ==> iff) Prop_join.
Proof.
  intros.
  do 3 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  split; intros [? ?]; split; intro; firstorder.
Defined.

Lemma Included_Disjoint: forall A P Q P' Q',
  Included P P' ->
  Included Q Q' ->
  Disjoint A P' Q' ->
  Disjoint A P Q.
Proof.
  intros.
  rewrite Disjoint_spec in H1 |- *.
  intros; apply (H1 x).
  + apply H; auto.
  + apply H0; auto.
Qed.

Lemma Union_left_Disjoint: forall A P Q R,
  Disjoint A (Union A P Q) R <-> Disjoint A P R /\ Disjoint A Q R.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Union_right_Disjoint: forall A P Q R,
  Disjoint A R (Union A P Q) <-> Disjoint A R P /\ Disjoint A R Q.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Included_Complement_Disjoint: forall A P Q,
  (Included P (Complement _ Q)) <-> Disjoint A P Q.
Proof.
  intros.
  unfold Included, Complement, In.
  rewrite Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_comm: forall A P Q,
  Disjoint A P Q <-> Disjoint A Q P.
Proof.
  intros.
  rewrite !Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_Empty_set_right: forall {A} (P: Ensemble A), Disjoint A P (Empty_set A).
Proof.
  intros.
  rewrite Disjoint_comm.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Disjoint_Empty_set_left: forall {A} (P: Ensemble A), Disjoint A (Empty_set A) P.
Proof.
  intros.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Disjoint_x1: forall {U} {UE: EqDec U eq} (A B: Ensemble U) (x0: U),
  Disjoint U (fun x: U => A x /\ x0 <> x) B ->
  ~ B x0 ->
  Disjoint U A B.
Proof.
  intros.
  rewrite Disjoint_spec in H |- *.
  intros.
  specialize (H x).
  destruct_eq_dec x0 x; [subst |]; tauto.
Qed.

Lemma Disjoint_x1': forall {U} {UE: EqDec U eq} (A B: Ensemble U) (x0: U),
  Disjoint U (Intersection _ A (fun x: U => x0 <> x)) B ->
  ~ B x0 ->
  Disjoint U A B.
Proof.
  intros.
  rewrite Disjoint_spec in H |- *.
  intros.
  specialize (H x).
  rewrite Intersection_spec in H.
  destruct_eq_dec x0 x; [subst |]; tauto.
Qed.

Lemma Included_trans: forall {A} (P Q R: Ensemble A), Included P Q -> Included Q R -> Included P R.
Proof.
  unfold Included, Ensembles.In.
  intros; firstorder.
Qed.

Lemma Intersection1_Included: forall {A} P Q R, Included P R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Intersection2_Included: forall {A} P Q R, Included Q R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Included_refl: forall A P, @Included A P P.
Proof.
  intros; hnf; auto.
Qed.

Lemma Prop_join_Disjoint:
  forall {A : Type} (P Q R : Ensemble A),
  Prop_join P Q R -> Disjoint A P Q.
Proof.
  intros.
  destruct H.
  rewrite Disjoint_spec; auto.
Qed.

Lemma Prop_join_assoc: forall A (P1 P2 P3 Q R: A -> Prop),
  Prop_join P1 Q P2 ->
  Prop_join P2 R P3 ->
  Prop_join P1 (Union _ Q R) P3.
Proof.
  unfold Prop_join.
  intros.
  destruct H, H0.
  split; intro a; rewrite Union_spec.
  + rewrite H0, H.
    tauto.
  + intros.
    destruct H4; firstorder.
Qed.

Lemma Prop_join_comm: forall {A : Type} (P Q R : Ensemble A),
  Prop_join P Q R <-> Prop_join Q P R.
Proof.
  intros.
  unfold Prop_join.
  firstorder.
Qed.

Lemma Disjoint_Union_Prop_join: forall A P Q, Disjoint A P Q -> Prop_join P Q (Union A P Q).
Proof.
  intros.
  rewrite Disjoint_spec in H.
  split.
  + intros; rewrite Union_spec; tauto.
  + auto.
Qed.

Lemma Prop_join_Empty: forall {U} (A: Ensemble U), Prop_join A (Empty_set _) A.
Proof.
  intros.
  split; intros.
  + rewrite Empty_set_spec.
    tauto.
  + rewrite Empty_set_spec in H0; auto.
Qed.

Lemma Prop_join_x1: forall {U} (A: Ensemble U) (a: U),
  ~ A a ->
  Prop_join A (eq a) (fun x => A x \/ x = a).
Proof.
  intros.
  split; intros.
  + assert (a = a0 <-> a0 = a) by (split; intros; congruence).
    tauto.
  + subst; auto.
Qed.

Definition app_same_set {A: Type} {P Q: Ensemble A} (H: Same_set P Q) (x: A): P x <-> Q x := proj1 (Same_set_spec A P Q) H x.

Coercion app_same_set : Same_set >-> Funclass.

(* TODO: rename it into preimage set *)
Definition respectful_set {A B: Type} (X: Ensemble B) (f: A -> B): Ensemble A := fun x => X (f x).

Inductive image_set {A B: Type}: Ensemble A -> (A -> B) -> Ensemble B :=
  | image_set_intro: forall (X: Ensemble A) (f: A -> B) (x: A), X x -> image_set X f (f x).

Lemma image_set_spec: forall {A B: Type} f X (y: B),
  image_set X f y <-> exists x: A, X x /\ y = f x.
Proof.
  intros.
  split; intros.
  + inversion H; subst.
    exists x.
    split; auto.
  + destruct H as [x [?H ?H]].
    subst.
    constructor; auto.
Qed.

Instance respectful_set_proper {A B: Type}: Proper (Same_set ==> pointwise_relation A (@eq B) ==> Same_set) respectful_set.
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  unfold respectful_set.
  firstorder.
  + rewrite <- H, <- H0; firstorder.
  + rewrite H, H0; firstorder.
Qed.

Instance image_set_proper2 {A B: Type}: Proper (Same_set ==> eq ==> Same_set) (@image_set A B).
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  intros.
  rewrite !image_set_spec.
  firstorder.
  + subst. firstorder.
  + subst. firstorder.
Qed.

Lemma resp_Included: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Included X Y ->
  Included (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold respectful_set, Included, In.
  intro x.
  apply H.
Qed.

Lemma resp_Same_set: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set X Y ->
  Same_set (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply resp_Included; tauto.
Qed.

Lemma resp_Intersection: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Intersection _ X Y) f)
   (Intersection _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Intersection_spec.
  reflexivity.
Qed.

Lemma resp_Union: forall {A B: Type} (X Y: Ensemble B) (f: A -> B) ,
  Same_set
   (respectful_set (Union _ X Y) f)
   (Union _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Union_spec.
  reflexivity.
Qed.

Lemma resp_Complement: forall {A B: Type} (X: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Complement _ X) f)
   (Complement _ (respectful_set X f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set, Complement, In.
  reflexivity.
Qed.

Lemma resp_Disjoint: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Disjoint _ X Y ->
  Disjoint _ (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  rewrite <- Included_Complement_Disjoint in *.
  rewrite <- resp_Complement.
  apply resp_Included; auto.
Qed.

Lemma resp_Empty: forall {A B: Type} (f: A -> B),
  Same_set (respectful_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_Included: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Included X Y ->
  Included (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Included, In.
  intro y.
  rewrite !image_set_spec.
  intros [x [? ?]].
  exists x; split; auto.
  apply H; auto.
Qed.

Lemma image_Same_set: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Same_set X Y ->
  Same_set (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply image_Included; tauto.
Qed.

Lemma image_Intersection: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Included
   (image_set (Intersection _ X Y) f)
   (Intersection _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  unfold Included, In; intros y.
  rewrite !Intersection_spec, !image_set_spec.
  intros [x [? ?]].
  rewrite Intersection_spec in H.
  split; exists x; tauto.
Qed.

Lemma image_Union: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Same_set
   (image_set (Union _ X Y) f)
   (Union _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros y.
  rewrite !Union_spec, !image_set_spec.
  pose proof (fun x => Union_spec A x X Y).
  firstorder.
Qed.

Lemma image_Disjoint_rev: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Disjoint _ (image_set X f) (image_set Y f) ->
  Disjoint _ X Y.
Proof.
  intros.
  rewrite Disjoint_spec in *.
  intros x ? ?.
  apply (H (f x)); constructor; auto.
Qed.

Lemma image_Empty: forall {A B: Type} (f: A -> B),
  Same_set (image_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_single: forall {A B: Type} (a: A) (f: A -> B),
  Same_set (image_set (eq a) f) (eq (f a)).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  split; intros; eauto.
  destruct H as [? [? ?]]; subst; auto.
Qed.

Definition Countable_Union (A: Type) (P: nat -> Ensemble A) : Ensemble A :=
  fun x => exists i, P i x.

Definition Non_Empty {U: Type} (A: Ensemble U): Prop := exists x, A x.

Definition Binart_set_list (U: Type) (A B: Ensemble U): nat -> Ensemble U :=
  fun n => match n with | 0 => A | 1 => B | _ => Empty_set _ end.

Lemma Union_is_Countable_Union: forall {U: Type} (A B: Ensemble U),
  Same_set (Union _ A B) (Countable_Union _ (Binart_set_list _ A B)).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x.
  rewrite Union_spec; unfold Countable_Union.
  split.
  + intros [? | ?].
    - exists 0; auto.
    - exists 1; auto.
  + intros [[ | [ | ]] ?].
    - left; auto.
    - right; auto.
    - intros; inversion H.
Qed.

Lemma Intersection_is_Complement_Union (classic: forall P: Prop, P \/ ~ P): forall {U: Type} (A B: Ensemble U),
  Same_set (Intersection _ A B) (Complement _ (Union _ (Complement _ A) (Complement _ B))).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x; unfold Complement, Ensembles.In.
  rewrite Union_spec, Intersection_spec.
  destruct (classic (A x)), (classic (B x)); tauto.
Qed.

(*

Lemma Finite_spec: forall A U, Finite A U <-> exists l, NoDup l /\ forall x, In x l <-> Ensembles.In A U x.
Proof.
  intros.
  split; intros.
  + induction H.
    - exists nil.
      split; [constructor |].
      intros.
      rewrite Empty_set_iff; simpl; tauto.
    - destruct IHFinite as [l [? ?]].
      exists (x :: l).
      split; [constructor; auto; rewrite H2; auto |].
      intros x0; specialize (H2 x0).
      simpl.
      unfold Add.
      rewrite Union_iff, Singleton_iff.
      tauto.
  + destruct H as [l [? ?]].
    revert U H0; induction l; intros.
    - replace U with (Empty_set A); [apply Empty_is_finite |].
      apply Extensionality_Ensembles.
      split; intros x ?; specialize (H0 x); simpl in *; repeat rewrite Empty_set_iff in *; tauto.
    - replace U with (Add A (Subtract A U a) a);
      [apply Union_is_finite | apply Extensionality_Ensembles].
      * inversion H; subst.
        apply IHl; [auto |].
        intros x; specialize (H0 x).
        unfold Subtract, Setminus; unfold Ensembles.In at 1.
        simpl in H0.
        rewrite Singleton_iff.
        assert (a = x -> ~ In x l) by (intro; subst; auto).
        tauto.
      * unfold Subtract, Setminus; unfold Ensembles.In at 1.
        rewrite Singleton_iff.
        tauto.
      * unfold Add, Subtract, Setminus.
        split; intros ?; rewrite Union_iff;
          [unfold Ensembles.In at 1 | unfold Ensembles.In at 2];
          rewrite  Singleton_iff; intro;
          specialize (H0 x); simpl in H0; [tauto |].
        inversion H; subst.
        assert (a = x -> ~ In x l) by (intro; subst; auto).
        tauto.
Qed.

*)


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute next_weekday monday.

Example test_next_weekday:
  next_weekday (next_weekday saturday) = tuesday.
Proof. simpl. reflexivity. Qed.


Require Import Coqlib.
Require Import RelationPairs.
Require Import AST.
Require Import Decision.
Require Import Structures.
Require Import PseudoJoin.

Module PJR.

  (** * Syntax *)

  Section SYNTAX.
    Inductive term :=
      | empty: term
      | var: nat -> term
      | combine: term -> term -> term.

    (** Normalization *)

    Fixpoint insert (i: nat) (t: term): term :=
      match t with
        | combine (var j) u =>
          if decide (i <= j)%nat then
            combine (var i) (combine (var j) u)
          else
            combine (var j) (insert i u)
        | _ =>
          combine (var i) t
      end.

    Fixpoint insert_term (t u: term): term :=
      match t with
        | empty => u
        | var i => insert i u
        | combine t1 t2 => insert_term t1 (insert_term t2 u)
      end.

    Definition sort (t: term) :=
      insert_term t empty.
  End SYNTAX.

  (** * Semantics *)

  Section SEMANTICS.
    Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.
    Local Opaque equiv.

    Fixpoint lookup (i: nat) (env: list E) :=
      match i, env with
        | O, x::xs => x
        | S j, x::xs => lookup j xs
        | _, _ => ∅
      end.

    Fixpoint eval (env: list E) (t: term): E :=
      match t with
        | empty => ∅
        | var i => lookup i env
        | combine t1 t2 => eval env t1 ⊕ eval env t2
      end.

    Lemma insert_sound env i t:
      eval env (insert i t) ≡ eval env (combine (var i) t).
    Proof.
      simpl.
      induction t; try reflexivity.
      - simpl.
        destruct t1 as [ | j | u1 u2]; simpl; try reflexivity.
        destruct (decide _); simpl; try reflexivity.
        rewrite IHt2.
        rewrite <- !associativity.
        rewrite (commutativity (lookup _ _)).
        reflexivity.
    Qed.

    Lemma insert_term_sound env t u:
      eval env (insert_term t u) ≡ eval env (combine t u).
    Proof.
      revert u.
      induction t as [ | i | t1 IHt1 t2 IHt2 ]; intro u.
      - simpl.
        split.
        + apply right_upper_bound.
        + apply id_left.
      - transitivity (eval env (insert i u)).
        + reflexivity.
        + apply insert_sound.
      - simpl.
        rewrite IHt1; simpl.
        rewrite IHt2; simpl.
        symmetry.
        apply associativity.
    Qed.

    Lemma sort_sound env t:
      eval env (sort t) ≡ eval env t.
    Proof.
      unfold sort.
      transitivity (eval env (combine t empty)).
      - apply insert_term_sound.
      - simpl.
        split.
        + apply id_right.
        + apply left_upper_bound.
    Qed.
  End SEMANTICS.

  (** * Verification conditions *)

  Section VERIF.
    Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.

    (** Sufficient check for 〚t〛 ≤ 〚u〛. Works on terms n normalize
      by [sort] above. *)
    Fixpoint termcmp (t u: term): bool :=
      match t, u with
        | empty, _ =>
          true
        | combine (var i) t', combine (var j) u' =>
          if decide (i = j) then
            termcmp t' u'
          else
            termcmp t u'
        | _, _ =>
          false
      end.

    Lemma termcmp_sound env t u:
      termcmp t u = true ->
      eval env t ≤ eval env u.
    Proof.
      revert t.
      induction u as [ | i | [ | i | u11 u12] IHu1 u2 IHu2];
        intros t;
        destruct t as [ | j | [ | j | t11 t12] t2];
        inversion 1;
        try apply lower_bound.
      destruct (decide _); subst.
      - simpl.
        monotonicity.
        + reflexivity.
        + eauto.
      - transitivity (eval env u2).
        + eauto.
        + simpl.
          apply right_upper_bound.
    Qed.

    Lemma termcmp_sort_sound env t u:
      termcmp (sort t) (sort u) = true ->
      eval env t ≤ eval env u.
    Proof.
      intros H.
      rewrite <- (sort_sound env t).
      rewrite <- (sort_sound env u).
      apply termcmp_sound.
      assumption.
    Qed.
  End VERIF.

  (** Lookup [x] in list [env]. If it's not in there, a corresponding
    element is added at the end of the list. Then pass the potentially
    extended environment and index to the continuation [cont]. *)
  Ltac l env x cont :=
    let rec iter i e :=
      lazymatch e with
        | x::?xs => cont env i
        | _::?xs => iter (S i) xs
        | _ =>
          let newenv := eval cbv [app] in (env++(x::nil)) in
          cont newenv i
      end in
    iter O env.

  (** Quote the pseudo-join expression [x] with the starting
    environment [env] for variables. The extended environment and
    quoted term are then passed to the continuation [cont]. *)
  Ltac q env x cont :=
    lazymatch x with
      | ∅ => cont env empty
      | ?x1 ⊕ ?x2 =>
        let cont1 env1 t1 :=
          let cont2 env2 t2 :=
            cont env2 (combine t1 t2) in
          q env1 x2 cont2 in
        q env x1 cont1
      | _ =>
        let lcont env i := cont env (var i) in
        l env x lcont
    end.

  Ltac quoteineq :=
    lazymatch goal with
      | |- le (A := ?E) ?x ?y =>
        let xcont xenv t :=
          let ycont yenv u :=
            (change (eval yenv t ≤ eval yenv u)) in
          q xenv y ycont in
        q (@nil E) x xcont
    end.
End PJR.

Ltac pjr :=
  PJR.quoteineq;
  eapply PJR.termcmp_sort_sound;
  reflexivity.

Section TEST.
  Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.
  Context {a b c d e: E}.

  Goal a ⊕ ∅ ⊕ d ≤ b ⊕ e ⊕ d ⊕ a ⊕ b.
  Proof.
    pjr.
  Qed.
End TEST.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path
  ssrint rat bigop.

From extructures Require Import ord fset fmap ffun.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope fset_scope.

Definition int_ordMixin := CanOrdMixin natsum_of_intK.
Canonical int_ordType := Eval hnf in OrdType int int_ordMixin.

Definition rat_ordMixin := [ordMixin of rat by <:].
Canonical rat_ordType := Eval hnf in OrdType rat rat_ordMixin.

Section Update.

Context {T : ordType} {S : eqType} {def : T -> S}.

Definition updm (f : ffun def) (xs : {fmap T -> S}) : ffun def :=
  mkffun (fun v => if xs v is Some x then x else f v)
         (supp f :|: domm xs).

Lemma updmE f xs x :
  updm f xs x = if xs x is Some y then y else f x.
Proof.
rewrite /updm mkffunE in_fsetU orbC mem_domm.
case e: (xs x)=> [y|] //=.
by case: ifPn=> // /suppPn ->.
Qed.

End Update.

Arguments bigcupP {_ _ _ _ _ _}.
Arguments mkfmap {_ _}.


Definition N := 23.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


(* Implementation of the compiler (both tree-based and graph-based
variant) and proof of Lemma 1 from the paper (compT e = unravel (compG
e).  *)

Require Import Graph.
Require Import Tree.
Require Import GraphUnravel.
Require Import Coq.Program.Basics.
Require Import CalculationTactics.

Require Import Coq.Logic.FunctionalExtensionality.

(* Source language. *)

Inductive Expr : Set :=
  | Val : nat -> Expr
  | Add : Expr -> Expr -> Expr
  | Throw  : Expr
  | Catch : Expr -> Expr -> Expr.

(* For the definition of the source language we have to use containers
in order to instantiate the definition of trees and graphs (which use
containers to represent strictly positive functors). *)

(* The shape type. *)

Inductive CodeSh : Set :=
| PUSH : nat -> CodeSh
| ADD : CodeSh
| THROW : CodeSh
| MARK : CodeSh
| UNMARK : CodeSh
| HALT : CodeSh.

(* Definition of the container to represent the functor [Code] from
the paper. *)

Definition Code : Cont :=
  {| shapes := CodeSh;
    pos := fun s => match s with
                      | PUSH _ => unit
                      | ADD => unit
                      | THROW => Zero
                      | MARK => sum unit unit
                      | UNMARK => unit
                      | HALT => Zero
                    end
   |}.

(* Functions to define unary and binary constructors (of the functor). *)
Definition one {A} (a : A) (x : unit) : A := a.
Definition two {A} (a b : A) (x : sum unit unit) : A :=
  match x with
            | inl _  => a
            | inr _ => b
  end.

(* Definition of the constructors for the [Code] functor. *)
Definition mkPUSH {A} i (c : A) : Ext Code A := (ext Code (PUSH i) (one c)).
Definition mkADD {A} (c : A) : Ext Code A := (ext Code ADD (one c)).
Definition mkTHROW {A} : Ext Code A := (ext Code THROW (zero _)).
Definition mkMARK {A} (c c' : A) : Ext Code A := (ext Code MARK (two c c')).
Definition mkUNMARK {A} (c : A) : Ext Code A := (ext Code UNMARK (one c)).
Definition mkHALT {A}  : Ext Code A := (ext Code HALT (zero _)).

(* Graph variants of the constructors. *)
Import Graph.
Definition gPUSH {A} i c : GraphM Code A := In (mkPUSH i c).
Definition gADD {A} c : GraphM Code A := In (mkADD c).
Definition gTHROW {A} : GraphM Code A := In mkTHROW.
Definition gMARK {A} c c' : GraphM Code A := In (mkMARK c c').
Definition gUNMARK {A} c : GraphM Code A := In (mkUNMARK c).
Definition gHALT {A} : GraphM Code A := In mkHALT.

(* Tree variants of the constructors. *)
Import Tree.
Definition tPUSH i c : Tree Code := In (mkPUSH i c).
Definition tADD c : Tree Code := In (mkADD c).
Definition tTHROW : Tree Code := In mkTHROW.
Definition tMARK c c' : Tree Code := In (mkMARK c c').
Definition tUNMARK c : Tree Code := In (mkUNMARK c).
Definition tHALT : Tree Code := In mkHALT.

Infix "|>" := (apply) (at level 60, right associativity).

(* Definition of the graph-based compiler. *)
Fixpoint compG' {A} (e : Expr) (c : GraphM Code A) : GraphM Code A :=
  match e with
      | Val n =>  gPUSH n |> c
      | Add x y =>  compG' x |> compG' y |> gADD |> c
      | Throw =>  gTHROW
      | Catch x h => letx c (fun _ c' =>
                               gMARK (compG' h |> var c') (compG' x |> gUNMARK |> var c'))
  end.

Definition compG (e : Expr) : Graph Code := compG' e |> gHALT.

(* Definition of the tree-based compiler. *)
Fixpoint compT' (e : Expr) (c : Tree Code) : Tree Code :=
  match e with
      | Val n =>  tPUSH n |> c
      | Add x y =>  compT' x |> compT' y |> tADD |> c
      | Throw =>  tTHROW
      | Catch x h => tMARK (compT' h |> c) (compT' x |> tUNMARK |> c)
  end.

Definition compT (e : Expr) : Tree Code := compT' e |> tHALT.

(* Convenience lemmas that state how unravelling works on the
constructors. *)

Lemma unravelM_mark {A env} {c1 c2 : GraphM Code A} :
  unravelM env (gMARK c1 c2) = tMARK (unravelM env c1) (unravelM env c2).
Proof.
  unfold unravelM, ufoldM, tMARK, gMARK, mkMARK. simpl. unfold cmap, two. simpl. repeat f_equal.
  apply functional_extensionality. intros. destruct x; reflexivity.
Qed.

Lemma unravelM_throw {A} {env : Env _ A} :  unravelM env gTHROW = tTHROW.
Proof.
  unfold gTHROW, tTHROW, mkTHROW, unravelM, ufoldM.  simpl. unfold cmap. simpl. repeat f_equal.
  apply zero_unique.
Qed.

Lemma unravelM_halt {A} {env : Env _ A} :  unravelM env gHALT = tHALT.
Proof.
  unfold gHALT, tHALT, mkHALT, unravelM, ufoldM.  simpl. unfold cmap. simpl. repeat f_equal.
  apply zero_unique.
Qed.

(* Proof of Lemma 1 from the paper. The following is the main lemma
for the proof, which corresponds to the induction proof from the
paper. *)

Lemma comp_unravelM {A} {e : Expr} {env} {c : GraphM Code A} : compT' e (unravelM env c)
                                                              = unravelM env (compG' e c).
Proof.   Begin.
  unfold compT, unravel, compG, apply.

  generalize dependent A.  induction e; intros; simpl; unfold apply.

  reflexivity.

  rewrite <- IHe1.  rewrite <- IHe2. reflexivity.

  rewrite unravelM_throw. reflexivity.

  RHS
  = { rewrite unravelM_letx }
  (unravelM (Extend (unravelM env c) env)
            (gMARK (compG' e2 (var tt)) (compG' e1 (gUNMARK (var tt))))).
  = { rewrite unravelM_mark }
  (tMARK ( unravelM (Extend (unravelM env c) env) (compG' e2 (var tt)))
         ( unravelM (Extend (unravelM env c) env) (compG' e1 (gUNMARK (var tt))))).
  = { rewrite IHe1 }
      (tMARK ( unravelM (Extend (unravelM env c) env) (compG' e2 (var tt)))
             ( compT' e1 (unravelM (Extend (unravelM env c) env) (gUNMARK (var tt))))).
  = { rewrite IHe2 }
      (tMARK ( compT' e2 (unravelM (Extend (unravelM env c) env)(var tt)))
             ( compT' e1 (unravelM (Extend (unravelM env c) env) (gUNMARK (var tt))))).
  = { reflexivity }
      (tMARK ( compT' e2 (unravelM env c))
             ( compT' e1 (tUNMARK (unravelM env c)))).
  [].
Qed.

(* From the above lemma we can then derive Lemma 1. *)

Lemma comp_unravel {e : Expr} : compT e = unravel (compG e).
Proof.
  unfold compT, compG, apply, unravel. erewrite <- unravelM_halt. eapply comp_unravelM.
Qed.


(******************************************************************************)
(* Chapter 1.5: Isomorphisms                                                  *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Morphisms.                   (* coq standard libs. *)
Require Import Notations.                   (* same dir. *)
Require Import Categories.                  (* same dir. *)
Require Import Functors.                    (* same dir. *)

(* 圏Cにおいて、同型射 f : a ~> b が存在するとき、a と b は同型である。 *)
(* 同型射とは、g \\o f === id かつ f \\o g === id なる f *)
Class Isomorphism `{C : Category} {a b : C} (f : a ~> b) (g : b ~> a) : Prop :=
  {
    iso_cmp1  : g \\o f === id;             (* id a *)
    iso_cmp2  : f \\o g === id              (* id b *)
  }.
(* TO DO: show isos are unique when they exist *)

(* f と g をメンバで定義した版 *)
Class Isomorphic `{C : Category} (a b : C) :=
  {
    iso_forward  :  a ~> b;
    iso_backward :  b ~> a;
    iso_comp1    :  iso_backward \\o iso_forward === id; (* id a *)
    iso_comp2    :  iso_forward \\o iso_backward === id  (* id b *)
(* TO DO: merge this with Isomorphism *)
}.
(* 同型射 f は、ひとつの同型(な関係にあるaとb)を与えないと決まらない。
   Isomorphic a b をexplicitに与えるようにする。 *)
Check @iso_forward : ∀Obj Hom C a b _, a ~> b.
Check iso_forward : _ ~> _.
Arguments iso_forward  {Obj Hom C a b} i : rename.
Arguments iso_backward {Obj Hom C a b} i : rename.
Arguments iso_comp1    {Obj Hom C a b} i : rename.
Arguments iso_comp2    {Obj Hom C a b} i : rename.
Check iso_forward _ : _ ~> _.                 (* 最初の _ は、Isomorphic a b *)
Check iso_forward : Isomorphic _ _ -> _ ~> _. (* _ は、圏Cの対象 a b *)

Notation "a ≅ b" := (Isomorphic a b) : isomorphism_scope.
(* the sharp symbol "casts" an isomorphism to the morphism in the forward direction *)
Notation "# f" := (iso_forward f) : isomorphism_scope.
Open Scope isomorphism_scope.

(* 同型a,bに対して、同型b,aを求めることができる。 *)
(* aに対してbが同型なら、bに対してaも同型である。 *)
(* the inverse of an isomorphism is an isomorphism *)
Definition iso_inv `{C : Category} (a b : C) (iso : Isomorphic a b) : Isomorphic b a.
Proof.
  Check iso_backward.
  Check @Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso).
  apply (@Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso)).
  - by apply iso_comp2.
  - by apply iso_comp1.
Defined.
Check @iso_inv : ∀Obj Hom C a b _, b ≅ a.
Arguments iso_inv {Obj Hom C a b} f : rename.
Check iso_inv _ : _ ≅ _.                    (* 最初の _ は a ≅ b *)
Check iso_inv : _ ≅ _ -> _ ≅ _.             (* _ は、圏Cの対象 a b *)
Notation "f '⁻¹'" := (iso_inv f) : isomorphism_scope.

(* 同型a,a *)
(* aとaは同型である。 *)
(* identity maps are isomorphisms *)
Definition iso_id `{C : Category} (a : C) : Isomorphic a a.
Proof.
  Check @Build_Isomorphic _ _ C a a id id.
  apply (@Build_Isomorphic _ _ C a a id id).
  now rewrite left_identity.
  now rewrite left_identity.
Defined.
Check @iso_id.
Arguments iso_id {Obj Hom C a} : rename.
Check iso_id : _ ≅ _.                       (* _ は、圏Cの対象a *)

(* 同型a,b と 同型b,c なら、同型a,c *)
(* the composition of two isomorphisms is an isomorphism *)
Definition iso_comp `{C : Category} {a b c : C}
           (i1 : Isomorphic a b) (i2 : Isomorphic b c) : Isomorphic a c.
Proof.
  Check #i1 : a ~> b.                       (* iso_forward i1 *)
  Check #i2 : b ~> c.                       (* iso_forward i2 *)
  Check #i2 \\o #i1 : a ~> c.
  Check #i1⁻¹ : b ~> a.                     (* iso_inv (iso_forward i1) *)
  Check #i2⁻¹ : c ~> b.                     (* iso_inv (iso_forward i2) *)
  Check iso_comp1 i1 : iso_backward i1 \\o #i1 === id.
  Check iso_comp2 i1 : #i1 \\o iso_backward i1 === id.
  Check iso_comp1 i2 : iso_backward i2 \\o #i2 === id.
  Check iso_comp2 i2 : #i2 \\o iso_backward i2 === id.

  Check (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  apply (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  - rewrite juggle3 (iso_comp1 i2).
    rewrite associativity left_identity (iso_comp1 i1).
    reflexivity.
  - rewrite juggle3 (iso_comp2 i1).
    rewrite associativity left_identity (iso_comp2 i2).
    reflexivity.
Defined.
Check @iso_comp : ∀Obj Hom C a b c _ _, a ≅ c.
Check iso_comp _ _ : _ ≅ _.
Arguments iso_comp {Obj Hom C} a b c i1 i2 : rename.
Check iso_comp : ∀a b c _ _, a ≅ c.
Notation "a >>≅>> b" := (iso_comp a b).

(* 関手は同型を保存する。 *)
Definition functors_preserve_isos `{C1 : Category} `{C2 : Category} {Fo : C1 -> C2}
           (F : Functor Fo) {a b : C1} (i : Isomorphic a b) : Isomorphic (F a) (F b).
Proof.
  (* 圏C1を関手で写した先の圏C2、C2の同型を作る。 *)
  Check F \ (iso_forward i) : F a ~> F b.
  Check F \ #i : F a ~> F b.
  Check F \ (iso_backward i) : F b ~> F a.
  Check {| iso_forward  := F \ (iso_forward  i);
           iso_backward := F \ (iso_backward i)
        |}.
  Check (@Build_Isomorphic).
  Check (@Build_Isomorphic Obj0 Hom0 C2 (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  Check (@Build_Isomorphic _ _ _ (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* Standard Coq の refine は、SSReflect の apply: である。 *)
  refine {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply: {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply (@Build_Isomorphic _ _ _ _ _
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* F \ iso_backward i \\o F \ #i === id *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp1.
    apply fmor_preserves_id.
  (* F \ #i \\o F \ iso_backward i === id *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp2.
    apply fmor_preserves_id.
Defined.

(* 圏Cの対象b,aが同型である（同型射 b ~> c がある）とき、
   圏Cの射f : b ~> c と、射g : a ~> c の関係を示す。
 *)
Lemma iso_shift_right `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic b a) :
  f \\o #i⁻¹ === g -> f === g \\o #i.
Proof.
  move=> H.
  rewrite -H associativity iso_comp1 right_identity.
  reflexivity.
Qed.

Lemma iso_shift_right' `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic a b) :
  f \\o #i === g -> f === g \\o #i⁻¹.
Proof.
  move=> H.
  rewrite -H.
  rewrite associativity.                    (* assoc の定義がオリジナルと異なる。 *)
  rewrite iso_comp2 right_identity.         (* あとは、少し証明が変わる。 *)
  reflexivity.
Qed.

Lemma iso_shift_left `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic c b) :
  #i⁻¹ \\o f === g -> f === #i \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp2 left_identity.
  reflexivity.
Qed.

Lemma iso_shift_left' `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic b c) :
  #i \\o f === g -> f === #i⁻¹ \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp1 left_identity.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）が同じなら、
b,aの同型（同型射 b ~> a）も同じである。 *)
Lemma isos_forward_equal_then_backward_equal `{C : Category} {a b : C}
      (i1 i2 : Isomorphic a b)  :  #i1 === #i2 ->  #i1⁻¹ === #i2⁻¹.
Proof.
  move=> H.
  rewrite -[#i1 ⁻¹]left_identity.
  rewrite -(iso_comp1 i2).
  rewrite associativity.
  rewrite -H.
  rewrite (iso_comp2 i1).
  rewrite right_identity.
  rewrite /=.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）の逆の逆は同じ *)
Lemma iso_inv_inv `{C : Category} {a b : C} (i : Isomorphic a b) :
  #(i⁻¹)⁻¹ === #i.
Proof.
  rewrite /iso_inv /=.
  reflexivity.
Qed.

(* the next four lemmas are handy for setoid_rewrite; they let you
avoid having to get the associativities right *)

Lemma iso_comp2_right  `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : b ~> c) :
  g \\o iso_forward i \\o iso_backward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp2.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp2_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> b) :
  iso_forward i \\o (iso_backward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp2.
  rewrite left_identity.
  reflexivity.
Qed.

Lemma iso_comp1_right `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : a ~> c) :
  g \\o iso_backward i \\o iso_forward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp1.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp1_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> a) :
  iso_backward i \\o (iso_forward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp1.
  rewrite left_identity.
  reflexivity.
Qed.

(* END *)


Set Implicit Arguments.
Require Import FinFun.
From Undecidability.HOU Require Import std.decidable.

Inductive diag: nat -> nat -> Type :=
  | diagB: diag 0 0
  | diagC: forall m, diag 0 m -> diag (S m) 0
  | diagS: forall n m, diag (S n) m -> diag n (S m).

Fixpoint diagStepR m n (d: diag m n) : diag m (S n) :=
  match d with
  | diagB => diagS (diagC diagB)
  | diagC H => diagS (diagC (diagStepR H))
  | diagS H => diagS (diagStepR H)
  end.

Fixpoint diagStepL m n (d: diag m n) : diag (S m) n :=
  match d with
  | diagB => diagC diagB
  | diagC H => diagC (diagS (diagStepL H))
  | diagS H => diagS (diagStepL H)
  end.

Fixpoint diagZero (a: nat) : diag 0 a :=
  match a with
  | 0 => diagB
  | S a => diagStepR (diagZero a)
  end.

Fixpoint diagId m n: diag m n :=
  match m with
  | O => diagZero n
  | S m => diagStepL (diagId m n)
  end.

Definition I__P (p: nat * nat) :=
  let (m, n) := p in
  diag_rect (fun _ _ _ => nat) 0 (fun _ _ => S)  (fun _ _ _ => S) (diagId m n): nat.

Fixpoint R__P (n: nat) : nat * nat  :=
  match n with
    | 0 =>  (0,0)
    | S n => match R__P n with
            | (0, b)  => (S b, 0)
            | (S a, b) => (a, S b)
      end
   end.

Lemma R__P_I__P p: R__P (I__P p) = p.
Proof.
  unfold I__P; destruct p as [m n]; induction (diagId m n); cbn.
  - reflexivity.
  - now rewrite IHd.
  - now rewrite IHd.
Qed.

Lemma R__P_injective n m: R__P n = R__P m -> n = m.
Proof.
  induction n in m |-*; destruct m; cbn; eauto.
  1: destruct (R__P m) as [[] b]; discriminate.
  1: destruct (R__P n) as [[] b]; discriminate.
  destruct (R__P n) as [[|k] p] eqn: H1, (R__P m) as [[|k'] p'] eqn: H2.
  all: injection 1; intros; subst.
  all: erewrite IHn; eauto.
  all: discriminate.
Qed.

Lemma I__P_R__P n: I__P (R__P n) = n.
Proof.
  eapply R__P_injective; now rewrite R__P_I__P.
Qed.

Require Import Arith Lia Nat Arith.Div2.

Definition I__S (s: nat + nat) :=
  match s with
  | inl n => double n
  | inr n => S (double n)
  end.

Definition R__S (n: nat) :=
  if even n then inl (div2 n) else inr (div2 n).

Lemma I__S_R__S n: I__S (R__S n) = n.
Proof.
  unfold I__S, R__S.
  destruct Nat.even eqn: H1.
  - symmetry. eapply even_double.
    now eapply Even.even_equiv, Nat.even_spec.
  - symmetry. eapply odd_double; eauto.
    eapply Even.odd_equiv, Nat.odd_spec.
    unfold odd; rewrite H1; eauto.
Qed.

Lemma R__S_I__S s: (R__S (I__S s)) = s.
Proof.
  unfold I__S, R__S.
  destruct s.
  - specialize (Nat.even_spec (Nat.double n)) as [_ H].
    rewrite H, Nat.double_twice, Nat.div2_double; eauto.
    eapply Nat.even_spec.
    unfold Nat.double.
    rewrite Nat.even_add.
    destruct (Nat.even n); reflexivity.
  - specialize (Nat.even_spec (Nat.double n)) as [_ H].
    rewrite Nat.even_succ, <-Nat.negb_even.
    rewrite H; cbn [negb].
    rewrite Nat.double_twice, Nat.div2_succ_double; eauto.
    eapply Nat.even_spec; unfold Nat.double;
      rewrite ?Nat.even_add; destruct (Nat.even n); reflexivity.
Qed.

Lemma injective_I__S : Injective I__S.
Proof.
  intros s s' H % (f_equal R__S). now rewrite !R__S_I__S in H.
Qed.

Lemma injective_I__P : Injective I__P.
Proof.
  intros s s' H % (f_equal R__P). now rewrite !R__P_I__P in H.
Qed.

Arguments I__P p : simpl never.
Arguments R__P n : simpl never.
Arguments I__S s : simpl never.
Arguments R__S n : simpl never.


From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Setoid.
From Coq Require Import Ensembles.
From Coq.Logic Require Import FunctionalExtensionality.
From Coq.Logic Require Import PropExtensionality ClassicalFacts.

From stdpp Require Import base list sets propset.

From MatchingLogic Require Import
  Syntax
  Semantics
  DerivedOperators_Syntax
  DerivedOperators_Semantics
  monotonic
  Utils.Lattice
  Utils.stdpp_ext
  IndexManipulation
.

Import MatchingLogic.Syntax.Notations.
Import MatchingLogic.Substitution.Notations.
Import MatchingLogic.DerivedOperators_Syntax.Notations.

Section with_signature.
  Context {Σ : Signature}.
  Open Scope ml_scope.

  Lemma eval_mu_lfp_fixpoint M ρ ϕ :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    let Sfix := @eval Σ M ρ (patt_mu ϕ) in
    F Sfix = Sfix.
  Proof.
    simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval _ M ρ (patt_mu ϕ)) as Sfix.
    pose (OS := PropsetOrderedSet (Domain M)).
    pose (L := PowersetLattice (Domain M)).
    intros Hwfp.

    assert (HFmono: MonotonicFunction F).
    { rewrite HeqF. rewrite /Fassoc. apply is_monotonic. apply Hwfp.
      rewrite HeqX. apply set_svar_fresh_is_fresh.
    }

    assert (Ffix : Lattice.isFixpoint F (Lattice.LeastFixpointOf F)).
    { apply Lattice.LeastFixpoint_fixpoint. apply HFmono.
    }

    unfold isFixpoint in Ffix.
    rewrite eval_mu_simpl in HeqSfix.
    simpl in HeqSfix.
    unfold Fassoc in HeqF.
    rewrite HeqX in HeqF.
    rewrite -HeqF in HeqSfix.
    rewrite -HeqSfix in Ffix.
    apply Ffix.
  Qed.

  Lemma eval_mu_lfp_least M ρ ϕ S:
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    let Sfix := @eval Σ M ρ (patt_mu ϕ) in
    (F S) ⊆ S ->
    Sfix ⊆ S.
  Proof.
    simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval _ M ρ (patt_mu ϕ)) as Sfix.
    pose (OS := PropsetOrderedSet (Domain M)).
    pose (L := PowersetLattice (Domain M)).
    intros Hwfp.

    assert (HFmono: MonotonicFunction F).
    { rewrite HeqF. rewrite /Fassoc. apply is_monotonic. apply Hwfp.
      rewrite HeqX. apply set_svar_fresh_is_fresh.
    }

    assert (Hlfp: LeastFixpointOf F = Sfix).
    { subst. rewrite eval_mu_simpl. simpl. unfold Fassoc. reflexivity. }

    intros Hincl.

    pose proof (Hleast := LeastFixpoint_LesserThanPrefixpoint _ _ _ F S).
    simpl in Hleast. specialize (Hleast Hincl).
    rewrite Hlfp in Hleast. apply Hleast.
  Qed.

  Lemma eval_mu_if_lfp M ρ ϕ Sfix :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    (F Sfix) ⊆ Sfix ->
    (∀ S, (F S) ⊆ S -> Sfix ⊆ S) ->
    Sfix = @eval Σ M ρ (patt_mu ϕ).
  Proof.
    intros Hwfp. simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    intros Hprefix Hleast.
    rewrite eval_mu_simpl. simpl.
    unfold Fassoc in HeqF. rewrite HeqX in HeqF. rewrite -HeqF.
    apply LeastFixpoint_unique. { apply Hprefix. } apply Hleast.
  Qed.

  Lemma eval_mu_lfp_iff M ρ ϕ Sfix :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    (
    (F Sfix) ⊆ Sfix /\
    (∀ S, (F S) ⊆ S -> Sfix ⊆ S)
    ) <-> Sfix = @eval Σ M ρ (patt_mu ϕ).
  Proof.
    intros Hwfp. simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval Σ M ρ (patt_mu ϕ)) as Sfix'.
    split.
    - intros [H1 H2]. subst.
      auto using eval_mu_if_lfp.
    - intros H. split.
      + subst.
        match goal with
        | |- ?L ⊆ ?R => assert (H: L = R)
        end.
        apply eval_mu_lfp_fixpoint. apply Hwfp.
        rewrite H. apply reflexivity.
      + intros S. subst. apply eval_mu_lfp_least. apply Hwfp.
  Qed.

  (* mu X. base \/ step X *)
  (* [Nats] = mu X. 0 \/ succ X *)
  (* [Nats] = \{ x | \ex x0,x1,..x_n . x0 \in 0 /\ x(i+1) \in succ xi }*)
  (*  0, 1, 2,... x*)
  Section inductive_generation.
    Context (base step : Pattern).

    Let patt_ind_gen_body := (patt_or (nest_mu base) (patt_app (nest_mu step) (patt_bound_svar 0))).
    Let patt_ind_gen_simple_body := (patt_or base (patt_app step (patt_free_svar (fresh_svar patt_ind_gen_body)))).

    Definition patt_ind_gen := patt_mu patt_ind_gen_body.

    Hypothesis (Hwfpbase : well_formed_positive base).
    Hypothesis (Hwfpstep : well_formed_positive step).

    Lemma patt_ind_gen_wfp:
      well_formed_positive patt_ind_gen.
    Proof.
      unfold patt_ind_gen. simpl.
      rewrite !andb_true_r.
      rewrite !well_formed_positive_nest_mu_aux.
      rewrite Hwfpbase.
      rewrite Hwfpstep.
      rewrite !andb_true_r.

      cbn. fold no_negative_occurrence_db_b.

      rewrite !no_negative_occurrence_db_nest_mu_aux. simpl.
      auto.
    Qed.

    Lemma svar_open_patt_ind_gen_body_simpl M ρ X:
      svar_is_fresh_in X patt_ind_gen_body ->
      @eval Σ M ρ (patt_ind_gen_body^{svar: 0 ↦ X})
      = @eval Σ M ρ (patt_or base (patt_app step (patt_free_svar X))).
    Proof.
      intros Hfr.
      unfold svar_is_fresh_in in Hfr. simpl in Hfr.
      rewrite !simpl_free_svars in Hfr.
      apply sets.not_elem_of_union in Hfr.
      destruct Hfr as [Hfr1 Hfr2].

      rewrite /patt_ind_gen_body.
      unfold svar_open.
      mlSimpl. simpl.
      rewrite 2!eval_or_simpl.
      unfold nest_mu. rewrite 2!nest_mu_same.
      reflexivity.
    Qed.

    Section with_eval.
      Context (M : @Model Σ).
      Context (ρ : @Valuation Σ M).

      Let F := let X := fresh_svar patt_ind_gen_body in
               @Fassoc Σ M ρ (patt_ind_gen_body^{svar: 0 ↦ X}) X.
      (*
      Lemma svar_open_patt_ind_gen_body_assoc S:
        let X := fresh_svar patt_ind_gen_body in
        eval ρₑ (update_svar_val X S ρₛ) (svar_open 0 X patt_ind_gen_body)
        = F S.
      Proof. reflexivity.
             (*
        cbv zeta.
        rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh. }
        subst F. unfold Fassoc.
        rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh.  }
        reflexivity.*)
      Qed.
       *)

      (* I can imagine this lemma to be proven automatically. *)
      Lemma F_interp: F = λ A, (eval ρ base)
                                 ∪ (app_ext (eval ρ step) A).
      Proof.
        unfold F. unfold Fassoc. apply functional_extensionality.
        intros A. rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh. }

        rewrite eval_or_simpl.
        rewrite eval_app_simpl.
        rewrite eval_free_svar_simpl.
        rewrite update_svar_val_same.
        rewrite eval_free_svar_independent.
        {
          eapply svar_is_fresh_in_richer.
          2: { apply set_svar_fresh_is_fresh. }
          solve_free_svars_inclusion 5.
        }
        rewrite eval_free_svar_independent.
        {
          eapply svar_is_fresh_in_richer.
          2: { apply set_svar_fresh_is_fresh. }
          solve_free_svars_inclusion 5.
        }
        reflexivity.
      Qed.

      Definition is_witnessing_sequence_old (m : Domain M) (l : list (Domain M)) :=
        (last l = Some m) /\
        (match l with
         | [] => False
         | m₀::ms => (m₀ ∈ @eval Σ M ρ base)
                     /\  (@Forall _
                                  (λ (x : (Domain M) * (Domain M)),
                                   let (old, new) := x in
                                   new ∈
                                  app_ext
                                    (@eval Σ M ρ step)
                                    {[ old ]}
                                 )
                                 (zip (m₀::ms) ms)
                         )

         end).

      Definition is_witnessing_sequence (m : Domain M) (l : list (Domain M)) :=
        (∃ lst, last l = Some lst /\ lst ∈ @eval Σ M ρ base)
          /\
          hd_error l = Some m
          /\
          ((@Forall _ (uncurry (λ new old,
                              new ∈
                     app_ext
                       (@eval Σ M ρ step)
                       {[old]}
                    ))
                    (zip l (tail l))
          )).

      (* If we have a witnessing sequence x₁ x₂ ... xₙ xₙ₊₁ ... xlast
         and xₙ matches `base`, then xₙ xₙ₊₁ is a witnessing sequence, too.
       *)
      Lemma witnessing_sequence_middle (m : Domain M) (l : list (Domain M)) (n : nat) (m' : Domain M) :
        is_witnessing_sequence m l ->
        l !! n = Some m' ->
        m' ∈ @eval Σ M ρ base ->
        is_witnessing_sequence m' (drop n l).
      Proof.
        intros [[lst [Hlst Hbase] ] [Hhd Hfa] ] Hm' Hbase'.
        split.
        { exists lst. split.
          rewrite -> last_drop with (x := lst).
          { reflexivity. }
          { apply Hlst. }
          { apply lookup_lt_is_Some_1.
            rewrite Hm'. exists m'. reflexivity.
          }
          apply Hbase.
        }
        split.
        { apply hd_drop_lookup. apply Hm'. }
        { rewrite tail_drop_comm.
          rewrite -zip_with_drop.
          apply Forall_drop.
          apply Hfa.
        }
      Qed.

      Lemma witnessing_sequence_tail (m : Domain M) (l : list (Domain M)) (m' : Domain M) :
        is_witnessing_sequence m l ->
        head (tail l) = Some m' ->
        is_witnessing_sequence m' (tail l).
      Proof.
        intros Hw Hhead.
        unfold is_witnessing_sequence in Hw.
        destruct Hw as [[lst [Hlst1 Hlst2] ] Hw].
        unfold is_witnessing_sequence.
        split.
        { exists lst.
          split. 2: apply Hlst2.
          eapply last_tail. 2: apply Hhead. apply Hlst1.
        }
        split.
        { apply Hhead. }
        rewrite -tail_zip.
        apply Forall_tail.
        destruct Hw as [Hw1 Hw2].
        apply Hw2.
      Qed.

      Lemma is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse (m : Domain M) (l : list (Domain M)) :
        is_witnessing_sequence m l <-> is_witnessing_sequence_old m (reverse l).
      Proof.
        assert (Feq: (uncurry
                        (flip
                           (λ new old : Domain M,
                                        new ∈
                                        app_ext
                                          (eval ρ step)
                                          {[old]})
                     ))
                     =  (λ x : Domain M * Domain M,
                               let (old, new) := x in
                               new ∈
                               app_ext
                                 (eval ρ step)
                                 {[old]})).

        { apply functional_extensionality. intros [x₁ x₂].
          reflexivity.
        }

        split.
        - intros [[m' [Hlast Hbase] ] [Hhd Hfa] ].
          destruct l as [|x l].
          { simpl in Hhd. inversion Hhd. }
          simpl in Hhd. inversion Hhd. subst. clear Hhd.
          split.
          { rewrite reverse_cons. rewrite last_app_singleton.
            reflexivity.
          }

          (* reverse (m::l) <> nil *)
          destruct (reverse (m::l)) eqn:Heq.
          { assert ( length (reverse (m::l)) = @length (Domain M) []).
            { rewrite Heq. reflexivity. }
            rewrite reverse_length in H.
            simpl in H. inversion H.
          }

          assert (Hm'd: m' = d).
          {
            rewrite reverse_cons in Heq.
            pose proof (H := last_reverse_head _ l m).
            rewrite Hlast in H.
            unfold reverse in Heq.
            rewrite Heq in H.
            simpl in H.
            inversion H. subst.
            reflexivity.
          }
          subst.
          split.
          { apply Hbase. }
          clear Hbase.

          pose proof (Heq' := f_equal reverse Heq).
          rewrite reverse_involutive in Heq'.
          assert (Heq'' : l0 = tail (d::l0)).
          { reflexivity. }
          rewrite -> Heq'' at 2. clear Heq''.
          rewrite -Heq.
          clear Heq' Heq l0.
          apply Forall_zip_flip_reverse in Hfa.
          clear Hlast.

          rewrite Feq in Hfa.
          apply Hfa.
        - intros H.
          destruct H as [Hlast H2].
          destruct l as [|x l].
          { simpl in Hlast. inversion Hlast. }

          destruct (reverse (x::l)) as [|y ys] eqn:Heq.
          { inversion H2. }
          destruct H2 as [Hbase Hfa].

          rewrite -(reverse_involutive (y::ys)) in Heq.
          apply (@inj _ _ (=) _ reverse) in Heq.
          2: typeclasses eauto.

          split.
          { exists y.
            split.
            rewrite Heq.
            rewrite last_reverse.
            reflexivity.
            apply Hbase.
          }

          split.
          {
            rewrite Heq.
            rewrite head_reverse.
            apply Hlast.
          }

          assert (Hfeq': (λ new old : Domain M, new ∈ app_ext (eval ρ step) {[old]}) = flip (flip (λ new old : Domain M, new ∈ app_ext (eval ρ step) {[old]}))).
          { apply functional_extensionality. intros x0.
            apply functional_extensionality. intros x1.
            reflexivity.
          }
          rewrite Hfeq'.
          rewrite Heq.
          rewrite -Forall_zip_flip_reverse.
          rewrite Feq.
          apply Hfa.
      Qed.

      Lemma witnessing_sequence_extend (m m' : Domain M) (l : list (Domain M)) :
        (is_witnessing_sequence m l
         /\ (∃ step', step' ∈ eval ρ step /\ m' ∈ app_interp _ step' m)
        ) <-> (is_witnessing_sequence m' (m'::l) /\ l ≠ []).
      Proof.
        split.
        - intros [[[lst [Hlst Hbase] ] [Hhd Hwit] ] [step' [Hstep' Hm'] ] ].
          split.
          2: { destruct l. simpl in Hhd. inversion Hhd. discriminate. }
          move: m Hhd m' step' Hm' Hstep'.
          induction l; intros m Hhd m' step' Hm' Hstep'.
          + simpl in Hhd. inversion Hhd.
          + simpl in Hhd. inversion Hhd. subst a. clear Hhd.
            unfold is_witnessing_sequence.
            destruct l.
            { simpl in Hlst. inversion Hlst. subst m. clear Hlst.
              split.
              { exists lst. simpl. split. reflexivity. apply Hbase. }
              simpl. split. reflexivity. apply Forall_cons.
              split. exists step'. exists lst. split.
              apply Hstep'. split. constructor. apply Hm'.
              apply Forall_nil. exact I.
            }
            split.
            { exists lst. split. simpl. simpl in Hlst. apply Hlst. apply Hbase. }
            split.
            { reflexivity. }
            simpl in Hwit. simpl.
            apply Forall_cons.
            simpl in IHl. simpl in Hlst.
            specialize (IHl Hlst).
            inversion Hwit. subst. clear Hwit.
            specialize (IHl H2). clear Hlst H2.
            split.
            { exists step'. exists m. split. apply Hstep'. split. constructor. apply Hm'. }
            apply Forall_cons.
            split.
            { apply H1. }
            specialize (IHl d erefl).
            destruct H1 as [step'' [d'' [Hstep'' [Hd'' Hstep''d''] ] ] ].
            inversion Hd''. subst d''. clear Hd''.
            specialize (IHl m step'' Hstep''d'' Hstep'').
            unfold is_witnessing_sequence in IHl.
            simpl in IHl.
            destruct IHl as [_ [_ Hforall] ].
            inversion Hforall. subst. apply H2.
        -
      Abort.

      Lemma witnessing_sequence_old_extend
            (m x m' : Domain M) (l : list (Domain M)):
        (is_witnessing_sequence_old m (x::l) /\
        ∃ step', (step' ∈ eval ρ step /\
        m' ∈ app_interp _ step' m)) <->
        (last (x::l) = Some m /\ is_witnessing_sequence_old m' ((x::l) ++ [m'])).
      Proof.
        split.
        -
          intros [Hwit [step' [Hstep' Hm'] ] ].
          destruct Hwit as [Hwit1 [Hwit2 Hwit3] ].
          split.
          { apply Hwit1. }
          split.
          { apply last_snoc. }
          simpl.
          split.
          { apply Hwit2. }

          destruct l.
          { simpl. apply Forall_cons. split. 2: { apply Forall_nil. exact I. }
            exists step'. exists x. split.
            { apply Hstep'. }
            split.
            { constructor. }
            simpl in Hwit1. inversion Hwit1. subst. apply Hm'.
          }
          simpl.
          apply Forall_cons.
          simpl in Hwit3. inversion Hwit3. subst. clear Hwit3.
          rename H1 into Hd. rename H2 into Hwit.
          split.
          { apply Hd. } clear Hd.

          move: d Hwit1 Hwit.
          induction l.
          + intros D Hm _.
            simpl. simpl in Hm. inversion Hm. subst.
            clear Hm.
            apply Forall_cons.
            split.
            2: { apply Forall_nil. exact I. }
            exists step'. exists m. split.
            { apply Hstep'. }
            split.
            { constructor. }
            apply Hm'.
          + intros d Hlast Hwit. simpl.
            inversion Hwit. subst.
            apply Forall_cons.
            split.
            { apply H1. }
            apply IHl. simpl in Hlast. simpl. apply Hlast.
            apply H2.
        - intros [Hlast H].
          unfold is_witnessing_sequence in H.
          destruct H as [_ H].
          remember (length l) as len.
          assert (Hlen: length l <= len).
          { lia. }
          clear Heqlen. simpl in H.
          destruct H as [Hbase Hall].
          unfold is_witnessing_sequence.
          apply and_assoc.
          split.
          { apply Hlast. }
          apply and_assoc.
          split.
          { apply Hbase. }
          clear Hbase.

          move: x l Hlast Hall Hlen.
          induction len.
          + intros x l Hlast Hall Hlen.
            destruct l.
            2: { simpl in Hlen. lia.  }
            simpl. simpl in Hall.
            split.
            { apply Forall_nil. exact I. }
            inversion Hall. subst. clear Hall. clear H2.
            destruct H1 as [step' [m'' [Hstep' [Hm'm'' Hstep'm''] ] ] ].
            inversion Hm'm''. subst. clear Hm'm''.
            exists step'. split. apply Hstep'.
            simpl in Hlast. inversion Hlast. subst.
            apply Hstep'm''.
          + intros x l Hlast Hall Hlen.
            destruct l as [|x' l'].
            { simpl in Hlast. inversion Hlast. clear Hlast. subst.
              simpl in Hall.
              inversion Hall. subst. clear Hall.
              clear H2.
              simpl.
              split.
              { apply Forall_nil. exact I. }
              destruct H1 as [step' Hstep'].
              exists step'.
              destruct Hstep' as [m'' [Hstep' [Hmm'' Hm''] ] ].
              split.
              { apply Hstep'. }
              inversion Hmm''. subst.
              apply Hm''.
            }
            simpl in Hall. simpl in IHlen. simpl in Hlast.
            inversion Hall. subst. clear Hall.
            specialize (IHlen x' l' Hlast H2).
            simpl.
            rewrite Forall_cons.
            apply and_assoc.
            split.
            { apply H1. }
            apply IHlen.
            simpl in Hlen. lia.
      Qed.

      Definition witnessed_elements_old : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence_old m l).

      Lemma witnessed_elements_old_prefixpoint : (F witnessed_elements_old) ⊆ witnessed_elements_old.
      Proof.
        rewrite elem_of_subseteq. intros x Hx.
        unfold F in Hx. unfold Fassoc in Hx. unfold svar_open in Hx. simpl in Hx.
        rewrite eval_or_simpl in Hx.
        fold ((nest_mu base)^{svar: 0 ↦ (fresh_svar patt_ind_gen_body)}) in Hx.
        fold ((nest_mu step)^{svar: 0 ↦ (fresh_svar patt_ind_gen_body)}) in Hx.
        destruct Hx.
        - unfold Ensembles.In in H.
          unfold witnessed_elements_old.
          exists [x]. unfold is_witnessing_sequence_old.
          simpl.
          split.
          { reflexivity. }
          split.
          2: { constructor. }
          rewrite eval_free_svar_independent in H.
          {
            eapply svar_is_fresh_in_richer. 2: { subst. auto. }
            unfold svar_open.
            solve_free_svars_inclusion 5.
          }
          simpl. unfold svar_open in H.
          rewrite nest_mu_same in H. auto.
        - unfold Ensembles.In in H.
          rewrite eval_app_simpl in H.
          rewrite eval_free_svar_simpl in H.
          rewrite update_svar_val_same in H.
          unfold app_ext in H.
          destruct H as [step' [m [H1 [H2 Happ] ] ] ].
          unfold witnessed_elements_old in H2.
          destruct H2 as [l Hl].

          unfold witnessed_elements_old.
          exists (l ++ [x]).

          (* `l` is not empty *)
          destruct l as [|m₀ l'] eqn:Heql.
          { unfold is_witnessing_sequence in Hl. destruct Hl. simpl in H. inversion H. }

          unfold svar_open in H1. rewrite nest_mu_same in H1.
          rewrite eval_free_svar_independent in H1.
          {
            eapply svar_is_fresh_in_richer.
            2: { apply set_svar_fresh_is_fresh. }
            solve_free_svars_inclusion 2.
          }

          epose proof (P := @witnessing_sequence_old_extend _ _ _ _).
          destruct P as [P _].
          specialize (P (conj Hl (@ex_intro _ _ step' (conj H1 Happ)))).
          apply P.
      Qed.

      Lemma interp_included_in_witnessed_elements_old:
        (@eval Σ M ρ patt_ind_gen) ⊆ witnessed_elements_old.
      Proof.
        apply eval_mu_lfp_least.
        { apply patt_ind_gen_wfp. }
        apply witnessed_elements_old_prefixpoint.
      Qed.

      Lemma eval_patt_ind_gen_fix :
        let Sfix := eval ρ patt_ind_gen in
        F Sfix = Sfix.
      Proof.
        apply eval_mu_lfp_fixpoint.
        apply patt_ind_gen_wfp.
      Qed.

      Definition witnessed_elements_old_of_max_len len : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence_old m l /\ length l <= len).

      Lemma witnessed_elements_old_of_max_len_included_in_interp len:
        (witnessed_elements_old_of_max_len (S len)) ⊆ (@eval Σ M ρ patt_ind_gen).
      Proof.
        induction len.
        - unfold Included. intros m.
          rewrite -eval_patt_ind_gen_fix.
          unfold Ensembles.In.
          intros H.
          unfold witnessed_elements_old_of_max_len.
          rewrite F_interp.
          destruct H as [l [Hwit Hlen] ].
          unfold is_witnessing_sequence in Hwit.
          destruct Hwit as [Hlast Hm].
          destruct l.
          { simpl in Hlast. inversion Hlast. }
          destruct l.
          2: { simpl in Hlen. lia. }
          simpl in Hlast. inversion Hlast. clear Hlast. subst.
          destruct Hm as [Hm _].
          left. unfold Ensembles.In. apply Hm.
        - unfold Included. intros m.
          rewrite -eval_patt_ind_gen_fix.
          unfold Ensembles.In. intros H.
          destruct H as [l [Hwit Hlen] ].
          unfold Included in IHlen. unfold Ensembles.In in IHlen.
          rewrite F_interp.
          pose proof (Hwit' := Hwit).
          unfold is_witnessing_sequence in Hwit.
          destruct Hwit as [Hlast Hl].
          destruct l.
          { contradiction. }

          simpl in Hlen.
          destruct Hl as [Hd Hl].
          destruct l.
          + simpl in Hlast. inversion Hlast. clear Hlast. subst.
            left. unfold Ensembles.In. apply Hd.
          + right. unfold Ensembles.In.
            pose proof (P := witnessing_sequence_old_extend).
            destruct l as [|x' l'].
            { simpl in Hlast. inversion Hlast. subst.
              specialize (P d d m []).
              destruct P as [_ P]. simpl in P.
              simpl in Hl.
              inversion Hl. subst. clear Hl.
              assert (Hsomed: Some d = Some d).
              { reflexivity. }
              specialize (P (conj Hsomed Hwit')).
              destruct P as [Hwitd [step' Hstep'] ].
              exists step'. exists d.
              destruct Hstep' as [Hstep' Hm].
              split.
              { apply Hstep'. }
              split.
              { apply IHlen. unfold witnessed_elements_old_of_max_len.
                exists [d].
                split.
                2: { simpl. lia. }
                unfold is_witnessing_sequence. simpl.
                split.
                { reflexivity. }
                split.
                { apply Hd. }
                apply Forall_nil.
                exact I.
              }
              apply Hm.
            }
            simpl in P.
            simpl in Hlast.
            simpl in Hl.
            inversion Hl. subst. clear Hl.
            inversion H2. subst. clear H2.
            pose (mp := (rev (d0 :: x' :: l')) !! 1).
            simpl in mp.
            epose proof (Htot := (list_lookup_lookup_total_lt (rev (d0 :: x' :: l')) 1 _)).
            Unshelve. 2: { constructor. exact d0. }
            2: { simpl. rewrite app_length. rewrite app_length. simpl.  lia.  }

            remember (@lookup_total nat (@Domain Σ M) (list (@Domain Σ M))
                 (@list_lookup_total (@Domain Σ M) {| inhabitant := d0 |}) (S O)
                 (@rev (@Domain Σ M) (@cons (@Domain Σ M) d0 (@cons (@Domain Σ M) x' l')))) as mprev.

            specialize (IHlen mprev).
            unfold witnessed_elements_old_of_max_len in IHlen.
            specialize (P mprev d m  (rev (tl (rev (d0::x'::l'))))).

            assert (Heq1: d::d0::x'::l' = d::(rev (tail (rev (d0::x'::l')))) ++ [m]).
            {
              apply f_equal.
              simpl.
              assert (Hx'r: [x'] = rev [x']).
              { reflexivity. }
              rewrite Hx'r.
              rewrite -rev_app_distr.
              assert (Hd0r: [d0] = rev [d0]).
              { reflexivity. }
              rewrite Hd0r.
              rewrite -rev_app_distr.
              rewrite rev_tail_rev_app_last.
              simpl.
              apply Hlast.
              reflexivity.
            }
            destruct P as [_ P].

            destruct (rev (tail (rev (d0 :: x' :: l')))) eqn:Heqrev.
            {
              apply length_zero_iff_nil in Heqrev.
              rewrite rev_length in Heqrev.
              apply length_tail_zero in Heqrev.
              rewrite rev_length in Heqrev.
              simpl in Heqrev. lia.
            }

            simpl in Heq1. inversion Heq1. subst d0. clear Heq1.
            simpl in P.
            rewrite -H2 in P.

            assert (Hm : (match l with [] => Some d1 | _ :: _ => last l end ) = Some mprev).
            {
              clear P Heqrev H1 H3 H4 mp.
              destruct l.
              { simpl in H2. inversion H2. subst. reflexivity. }
              simpl.
              simpl in H2.
              inversion H2. subst x' l'. clear H2.
              simpl in Htot.
              destruct (l ++ [m]) eqn:Hcontra.
              { pose proof (Hcontra' := @app_length _ l [m]).
                rewrite Hcontra in Hcontra'.
                simpl in Hcontra'. lia.
              }
              rewrite -Hcontra in Htot.
              rewrite rev_app_distr in Htot. simpl in Htot.

              destruct l.
              { simpl in Htot. apply Htot. }
              simpl in Htot.
              rewrite -Htot.
              rewrite hd_error_lookup.
              rewrite hd_error_app. rewrite hd_error_app.
              simpl.
              apply last_rev_head.
            }
            specialize (P (@conj _ _ Hm Hwit')). clear Hm Hwit'.
            destruct P as [Hwitmprev [step' [Hstep' Hm] ] ].
            exists step'. exists mprev.
            split.
            { apply Hstep'. }
            split.
            2: { apply Hm. }
            apply IHlen.
            exists (d::d1::l).
            split.
            { apply Hwitmprev. }
            simpl. simpl in Hlen.
            assert (Hlen': S (length l') <= len).
            { lia. }
            assert (length (l') = length (l)).
            { apply (@list_len_slice _ _ _ _ _ H2). }
            rewrite -H. lia.
      Qed.

      Lemma witnessed_elements_old_included_in_interp:
        witnessed_elements_old ⊆ (@eval Σ M ρ patt_ind_gen).
      Proof.
        intros x H.
        unfold Ensembles.In in H. unfold witnessed_elements_old in H.
        destruct H as [wit Hwit].
        assert (H': x ∈ (witnessed_elements_old_of_max_len (length wit))).
        { unfold Ensembles.In. exists wit. split. apply Hwit. lia. }
        destruct wit as [|y l'] eqn:Hl.
        { unfold is_witnessing_sequence in Hwit. destruct Hwit. contradiction. }
        eapply witnessed_elements_old_of_max_len_included_in_interp.
        simpl in H'.
        apply H'.
      Qed.

      Definition witnessed_elements : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence m l).

      Lemma witnessed_elements_old_eq_witnessed_elements :
        witnessed_elements_old = witnessed_elements.
      Proof.
        rewrite -> set_eq_subseteq.
        repeat rewrite -> elem_of_subseteq.
        split;
          unfold witnessed_elements_old; unfold witnessed_elements; intros m; intros [l H].
        + exists (reverse l).
          apply is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse.
          rewrite reverse_involutive.
          exact H.
        + exists (reverse l).
          apply is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse.
          apply H.
      Qed.

      Lemma patt_ind_gen_simpl:
        @eval Σ M ρ patt_ind_gen = witnessed_elements.
      Proof.
        rewrite -witnessed_elements_old_eq_witnessed_elements.
        rewrite -> set_eq_subseteq.
        split.
        + apply interp_included_in_witnessed_elements_old.
        + apply witnessed_elements_old_included_in_interp.
      Qed.

      Section injective.
        Hypothesis (Domain_eq_dec : EqDecision (Domain M)).
        Hypothesis (Hstep_total_function : @is_total_function _ M step witnessed_elements witnessed_elements ρ).
        Hypothesis (Hstep_injective : @total_function_is_injective _ M step witnessed_elements ρ).

        Hypothesis (Hbase_step_no_confusion
                    : (eval ρ base)
                        ∩ (app_ext (eval ρ step) witnessed_elements) = ∅).

        Lemma witnessed_elements_unique_seq :
          ∀ m l₁ l₂, is_witnessing_sequence m l₁ -> is_witnessing_sequence m l₂ -> l₁ = l₂.
        Proof.
          intros m l₁ l₂.
          wlog: l₁ l₂ / (length l₂ <= length l₁).
          { intros H Hw₁ Hw₂.
            destruct (decide (length l₁ <= length l₂)).
            - symmetry. apply H; auto.
            - apply H. lia. auto. auto.
          }
          intros Hlen12 Hw₁ Hw₂.

          assert (Hmwit: m ∈ witnessed_elements).
          { exists l₁. apply Hw₁. }

          assert (Hlcom:  (common_length l₁ l₂ = length l₂)).
          {
            destruct Hw₁ as [[lst₁ [Hlst₁ Hbase₁] ] [Hhd₁ Hfa₁] ].
            destruct l₁ as [|m₁ l₁].
            { simpl in Hlst₁. inversion Hlst₁. }
            simpl in Hhd₁. inversion Hhd₁. subst. clear Hhd₁.

            destruct Hw₂ as [[lst₂ [Hlst₂ Hbase₂] ] [Hhd₂ Hfa₂] ].
            destruct l₂ as [|m₂ l₂].
            { simpl in Hlst₂. inversion Hlst₂. }
            simpl in Hhd₂. inversion Hhd₂. subst. clear Hhd₂.

            simpl.
            destruct (decide (m=m)).
            2: { contradiction. }
            clear e.
            apply f_equal.

            simpl in Hlen12. rename Hlen12 into Hlen12'.
            assert (Hlen12: length l₂ <= length l₁).
            { lia. }
            clear Hlen12'.

            remember (length l₁) as len₁.
            rewrite Heqlen₁ in Hlen12.
            assert (Hlen₁ : length l₁ <= len₁).
            { lia. }
            clear Heqlen₁.

            move: m l₁ l₂ Hlen12 Hlen₁ Hlst₁ Hlst₂ Hfa₁ Hfa₂ Hmwit.
            induction len₁; intros m l₁ l₂ Hlen12 Hlen₁ Hlst₁ Hlst₂ Hfa₁ Hfa₂ Hmwit.
            - destruct l₁.
              2: { simpl in Hlen₁. lia. }
              destruct l₂.
              + reflexivity.
              + assert (length (d::l₂) = 0).
                { simpl in Hlen12. lia. }
                rewrite H. reflexivity.
            - destruct l₂ as [|b l₂].
              { rewrite common_length_l_nil. reflexivity. }

              destruct l₁ as [|a l'₁] eqn:Heq.
              { simpl in Hlen12. lia. }

              simpl in Hfa₁. inversion Hfa₁. subst. clear Hfa₁.
              rename H1 into Hma. rename H2 into Hfa₁.
              simpl in Hfa₂. inversion Hfa₂. subst. clear Hfa₂.
              rename H1 into Hmb. rename H2 into Hfa₂.

              assert (Hwita: a ∈ witnessed_elements).
              { exists (a::l'₁).
                split.
                { exists lst₁. split.
                  { simpl in Hlst₁. simpl. apply Hlst₁. }
                  apply Hbase₁.
                }
                split.
                { reflexivity. }
                simpl. apply Hfa₁.
              }

              assert (Hwitb: b ∈ witnessed_elements).
              { exists (b::l₂).
                split.
                { exists lst₂. split.
                  { simpl in Hlst₂. simpl. apply Hlst₂. }
                  apply Hbase₂.
                }
                split.
                { reflexivity. }
                simpl. apply Hfa₂.
              }

              simpl in Hma. simpl in Hmb.

              assert (Ham: app_ext (eval ρ step) {[a]} = {[m]}).
              {
                unfold is_total_function in Hstep_total_function.
                pose proof (Hstep_total_function _ Hwita).
                destruct H as [a' [_ Ha'] ].
                rewrite Ha' in Hma.
                inversion Hma. subst.
                apply Ha'.
              }

              assert (Hbm: app_ext (eval ρ step) {[b]} = {[m]}).
              {
                unfold is_total_function in Hstep_total_function.
                pose proof (Hstep_total_function _ Hwitb).
                destruct H as [b' [_ Hb'] ].
                rewrite Hb' in Hmb.
                inversion Hmb. subst.
                apply Hb'.
              }

              assert (Haeqb: a = b).
              { apply Hstep_injective.
                apply Hwita. apply Hwitb.
                unfold rel_of.
                rewrite Ham.
                rewrite Hbm.
                reflexivity.
              }
              subst.
              clear Ham Hbm Hwita Hma.

              simpl.
              destruct (decide (b=b)).
              2: { contradiction. }
              apply f_equal.

              apply IHlen₁ with (m := b).
              { simpl in Hlen12.  lia. }
              { simpl in Hlen₁. lia. }
              simpl in Hlst₁. simpl. apply Hlst₁.
              simpl in Hlst₂. simpl. apply Hlst₂.

              simpl. apply Hfa₁.
              simpl. apply Hfa₂.
              apply Hwitb.
          }

          assert (Hlast12: l₁ !! (length l₂ - 1) = l₂ !! (length l₂ - 1)).
          {
            eapply equal_up_to_common_length.
            erewrite Hlcom.
            assert (length l₂ > 0).
            {
              destruct l₂.
              { unfold is_witnessing_sequence in Hw₂.
                simpl in Hw₂. destruct Hw₂ as [_ [Contra _] ].
                inversion Contra.
              }
              simpl. lia.
            }
            lia.
          }

          (*assert (Hbasem': eval ρ base lst).*)

          assert (~ (length l₁ > length l₂)).
          {
            intros Hcontra.
            assert (Hlt : length l₂ - 1 < length l₁).
            { lia. }
            pose proof (Hexm := list_ex_elem l₁ (length l₂ - 1) Hlt). clear Hlt.
            destruct Hexm as [m' Hm'].
            pose proof (Hwsm := witnessing_sequence_middle _ _ _ _ Hw₁ Hm').
            pose proof (Hw₂' := Hw₂).
            unfold is_witnessing_sequence in Hw₂'.
            destruct Hw₂' as [[lst [Hlst1 Hlst2] ] _].
            rewrite list_last_length in Hlst1.
            assert (Hlsteqm' : m' = lst).
            {
              assert (Some m' = Some lst).
              { rewrite -Hm'. rewrite -Hlst1. apply Hlast12.  }
              inversion H. reflexivity.
            }
            subst lst.
            specialize (Hwsm Hlst2).
            clear Hm' Hlst1.

            destruct (drop (length l₂ - 1) l₁) eqn:Heq.
            {
              destruct Hwsm as [_ [Contra _] ].
              inversion Contra.
            }
            (* if `l` is empty, then length l₁ = length l₂ -> Contradiction *)
            destruct l.
            {
              assert (Hlendrop: length (drop (length l₂ - 1) l₁) = 1).
              { rewrite Heq. reflexivity. }
              rewrite drop_length in Hlendrop.
              assert (length l₂ <> 0).
              { intros Hcontra'.
                apply nil_length_inv in Hcontra'.
                subst l₂.
                destruct Hw₂ as [_ [HContra'' _] ].
                inversion HContra''.
              }
              lia.
            }
            (* `d0` is a member of `witnessed_elements` *)
            epose proof (Hwd0 := witnessing_sequence_tail _ _ _ Hwsm).
            simpl in Hwd0.
            assert (Htmp: Some d0 = Some d0).
            { reflexivity. }
            specialize (Hwd0 Htmp). clear Htmp.

            assert (Hd0we : d0 ∈ witnessed_elements).
            { exists (d0::l). apply Hwd0. }

            assert (Heqm'd : m' = d).
            { unfold is_witnessing_sequence in Hwsm.
              destruct Hwsm as [_ [H _] ].
              simpl in H. inversion H.
              reflexivity.
            }
            subst m'.

            (* `m'=d` matches `app_ext (eval ρ step) d0` *)
            assert (d ∈ app_ext
                      (eval ρ step)
                      {[d0]}).
            {
              unfold is_witnessing_sequence in Hwsm.
              simpl in Hwsm.
              destruct Hwsm as [_ [_ Hwsm] ].
              inversion Hwsm. subst.
              simpl in H1.
              apply H1.
            }
            rewrite -> set_eq_subseteq in Hbase_step_no_confusion.
            destruct Hbase_step_no_confusion as [H1 _].
            rewrite -> elem_of_subseteq in H1.
            specialize (H1 d).
            apply not_elem_of_empty in H1.
            { exact H1. }
            clear H1.
            split.
            - apply Hlst2.
            - unfold Ensembles.In.
              unfold app_ext.
              destruct H as [le' [re' [H1 [H2 H3] ] ] ].
              exists le'. exists d0.
              split.
              { apply H1. }
              split.
              { apply Hd0we. }
              inversion H2. subst. apply H3.
          }
          assert (Hlength12: length l₁ = length l₂).
          { lia. }
          clear Hlen12 H.

          apply (common_length_impl_eq _ _ Hlength12 Hlcom).
        Qed.

      End injective.

    End with_eval.

  End inductive_generation.

End with_signature.