(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-02-17
- Adam Koprowski and Hans Zantema, 2007-03
- Joerg Endrullis and Dimitri Hendriks, 2008-07

General definitions and results about relations.
*)

Set Implicit Arguments.

From Coq Require Import Setoid Basics Morphisms List.
From Coq Require Export Relations.
From Coq Require Import Lia.

From CoLoR Require Import LogicUtil.
From CoLoR Require Export RelMidex.

Arguments inclusion {A} R1 R2.
Arguments same_relation {A} R1 R2.
Arguments transp {A} R x y.
Arguments clos_refl_trans {A} R x y.
Arguments clos_trans {A} R x y.
Arguments reflexive {A} R.
Arguments transitive {A} R.
Arguments antisymmetric {A} R.
Arguments symmetric {A} R.
Arguments equiv {A} R.
Arguments union {A} R1 R2 x y.
Arguments lexprod [A B] _ _ _ _.
Arguments symprod [A B] _ _ _ _.

(***********************************************************************)
(** Notations for some relations and operations on relations. *)

Notation rel := relation.

Notation incl := inclusion.
Infix "<<" := incl (at level 50) : relation_scope.

Notation same := same_relation.
Infix "==" := same (at level 70).

Infix "U" := union (at level 45) : relation_scope.
Notation "x #" := (clos_refl_trans x) (at level 35) : relation_scope.
Notation "x !" := (clos_trans x) (at level 35) : relation_scope.

Open Scope relation_scope.

(***********************************************************************)
(** Properties of [incl]. *)

Instance incl_refl A : Reflexive (@incl A).

Proof. fo. Qed.

Ltac incl_refl := apply incl_refl.

Instance incl_trans A : Transitive (@incl A).

Proof. fo. Qed.

Ltac incl_trans S := apply incl_trans with S; try incl_refl.

Instance incl_same A : Proper (same ==> same ==> impl) (@incl A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Lemma incl_elim A (R S : rel A) : R << S -> forall x y, R x y -> S x y.

Proof. auto. Qed.

Arguments incl_elim [A R S] _ [x y] _.

(***********************************************************************)
(** Properties of [same]. *)

Lemma rel_eq A (R S : rel A) : R == S <-> forall x y, R x y <-> S x y.

Proof. fo. Qed.

Instance same_equiv A : Equivalence (@same A).

Proof. fo. Qed.

(***********************************************************************)
(** Basic meta-theorems. *)

Lemma eq_incl_refl_rel A (R : rel A) : Reflexive R -> eq << R.

Proof. intros hR x y xy. subst y. apply hR. Qed.

Lemma sym A (R : rel A) x y : Symmetric R -> (R x y <-> R y x).

Proof. split_all. Qed.

(***********************************************************************)
(** Morphisms wrt [incl] and [same]. *)

Instance refl_same A : Proper (same ==> impl) (@Reflexive A).

Proof. fo. Qed.

Instance sym_same A : Proper (same ==> impl) (@Symmetric A).

Proof. fo. Qed.

Instance trans_same A : Proper (same ==> impl) (@Transitive A).

Proof.
  intros R S e h x y z xy yz. rewrite rel_eq in e. rewrite <- e in *.
  apply h with y; hyp.
Qed.

Instance equiv_same A : Proper (same ==> impl) (@Equivalence A).

Proof. intros R S RS [hr hs ht]. constructor; rewrite <- RS; hyp. Qed.

(***********************************************************************)
(** Properties of [Proper]. *)

Lemma prop2_incl A B C (f : A -> B -> C) :
  Proper (incl --> incl --> incl ==> impl)
         (fun R S T => Proper (R ==> S ==> T) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' hf x x' xx' y y' yy'.
  apply TT'. apply hf; fo.
Qed.

Lemma prop3_incl A B C D (f : A -> B -> C -> D) :
  Proper (incl --> incl --> incl --> incl ==> impl)
         (fun R S T V => Proper (R ==> S ==> T ==> V) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' hf x x' xx' y y' yy' z z' zz'.
  apply VV'. apply hf; fo.
Qed.

Lemma prop4_incl A B C D E (f : A -> B -> C -> D -> E) :
  Proper (incl --> incl --> incl --> incl --> incl ==> impl)
         (fun R S T V W => Proper (R ==> S ==> T ==> V ==> W) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' W W' WW'
         hf x x' xx' y y' yy' z z' zz' a a' aa'.
  apply WW'. apply hf; fo.
Qed.

Instance prop_rel_same A (E : rel A) :
  Proper (same ==> impl) (Proper (E ==> E ==> impl)).

Proof.
  intros R S [RS SR] h x x' xx' y y' yy' xy.
  apply RS. eapply h. apply xx'. apply yy'. apply SR. hyp.
Qed.

Lemma prop_subrel A (R S : rel A) :
  Equivalence S -> subrelation R S -> Proper (R ==> R ==> impl) S.

Proof.
  intros S_eq RS u u' uu' v v' vv' uv. apply RS in uu'. apply RS in vv'.
  rewrite <- uu', <- vv'. hyp.
Qed.

Lemma prop_rel_sym A B (f : A -> B -> Prop) R S :
  Symmetric R -> Symmetric S
  -> Proper (R ==> S ==> impl) f -> Proper (R ==> S ==> iff) f.

Proof.
  intros R_sym S_sym f_prop x x' xx' y y' yy'. split; intro h.
  eapply f_prop. apply xx'. apply yy'. hyp.
  eapply f_prop. sym. apply xx'. sym. apply yy'. hyp.
Qed.

Instance equiv_prop A (R : rel A) :
  Transitive R -> Symmetric R -> Proper (R ==> R ==> impl) R.

Proof. intros R_trans R_sym t t' tt' u u' uu' tu. trans t. hyp. trans u; hyp. Qed.

(***********************************************************************)
(** Empty relation. *)

Definition empty_rel {A} : rel A := fun x y => False.

(***********************************************************************)
(** Relation associated to a boolean function. *)

Definition rel_of_bool A (f : A->A->bool) : rel A :=
  fun x y => f x y = true.

(***********************************************************************)
(** Boolean function associated to a decidable relation. *)

Section bool_of_rel.

  Variables (A : Type) (R : rel A) (R_dec : rel_dec R).

  Definition bool_of_rel t u := if R_dec t u then true else false.

  Lemma bool_of_rel_true x y : bool_of_rel x y = true <-> R x y.

  Proof.
    unfold bool_of_rel. split; destruct (R_dec x y).
    auto. discr. refl. tauto.
  Qed.

  Lemma bool_of_rel_false x y : bool_of_rel x y = false <-> ~R x y.

  Proof.
    unfold bool_of_rel. split; destruct (R_dec x y).
    discr. auto. tauto. refl.
  Qed.

  Lemma bool_of_rel_refl x : Reflexive R -> bool_of_rel x x = true.

  Proof.
    intro R_refl. unfold bool_of_rel. destruct (R_dec x x). refl.
    exfalso. apply n. refl.
  Qed.

  Global Instance bool_of_rel_prop :
    Symmetric R -> Transitive R -> Proper (R ==> R ==> Logic.eq) bool_of_rel.

  Proof.
    intros R_sym R_trans x x' xx' y y' yy'. unfold bool_of_rel.
    destruct (R_dec x y); destruct (R_dec x' y'); try refl.
    exfalso. apply n. trans x. hyp. trans y; hyp.
    exfalso. apply n. trans x'. hyp. trans y'; hyp.
  Qed.

End bool_of_rel.

Arguments bool_of_rel_true {A R} _ {x y}.
Arguments bool_of_rel_false {A R} _ {x y}.

(***********************************************************************)
(** Definition of some properties on relations. *)

Definition classic_left_total A B (R : A -> B -> Prop) :=
  forall x, exists y, R x y.

Definition left_total A B (R : A -> B -> Prop) :=
  forall x, {y | R x y}.

Definition functional A B (R : A -> B -> Prop) :=
  forall x y z, R x y -> R x z -> y = z.

Definition finitely_branching A B (R : A -> B -> Prop) :=
  forall x, {l | forall y, R x y <-> In y l}.

Definition irreflexive A (R : rel A) := forall x, ~R x x.

Definition asymmetric A (R : rel A) := forall x y, R x y -> ~R y x.

(** Predicate saying that [f] is an infinite sequence of [R]-steps. *)
Definition IS A (R : rel A) f := forall i, R (f i) (f (S i)).

Definition EIS A (R : rel A) := exists f, IS R f.

Definition NT A (R : rel A) x := exists f, f 0 = x /\ IS R f.

(** Predicate saying that [f] and [g] describe an infinite sequence
  of R-steps modulo E: for all i, f(i) E g(i) R f(i+1). *)
Definition ISMod A (E R : rel A) (f g : nat -> A) :=
  forall i, E (f i) (g i) /\ R (g i) (f (S i)).

(* Called PreOrder in Coq. *)
Definition quasi_ordering A (R : rel A) := reflexive R /\ transitive R.

Definition ordering A (R : rel A) :=
  reflexive R /\ transitive R /\ antisymmetric R.

Definition strict_ordering A (R : rel A) := irreflexive R /\ transitive R.

(***********************************************************************)
(** Strict part. *)

Definition strict_part A (R : rel A) : rel A := fun x y => R x y /\ ~R y x.

(***********************************************************************)
(** Intersection. *)

Definition intersection A (R S : rel A) : rel A := fun x y => R x y /\ S x y.

Lemma intersection_dec A (R S : rel A) (Rdec : rel_dec R) (Sdec : rel_dec S) :
  rel_dec (intersection R S).

Proof.
  intros x y. unfold intersection. case (Rdec x y); case (Sdec x y); intuition.
Defined.

(***********************************************************************)
(** Finitely branching relations. *)

Section finitely_branching.

  Variables (A : Type) (R : rel A) (FB : finitely_branching R).

  Definition sons x := proj1_sig (FB x).

  Lemma in_sons_R : forall x y, In y (sons x) -> R x y.

  Proof. intros x y. exact (proj2 (proj2_sig (FB x) y)). Qed.

  Lemma R_in_sons : forall x y, R x y -> In y (sons x).

  Proof. intros x y. exact (proj1 (proj2_sig (FB x) y)). Qed.

End finitely_branching.

Arguments in_sons_R [A R] _ [x y] _.
Arguments R_in_sons [A R] _ [x y] _.

(***********************************************************************)
(** Equivalence relation associated to a PreOrder. *)

Definition inter_transp A (R : rel A) : rel A := fun x y => R x y /\ R y x.

(*COQ: declaring these Lemma's as Instance's creates problems in
FSetUtil and FGraph *)

Lemma inter_transp_refl A (R : rel A) :
  Reflexive R -> Reflexive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_sym A (R : rel A) : Symmetric (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_trans A (R : rel A) :
  Transitive R -> Transitive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_incl A (R : rel A) : inter_transp R << R.

Proof. fo. Qed.

(***********************************************************************)
(** Properties of [IS]. *)

Instance IS_incl A : Proper (incl ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h i. subst. fo. Qed.

Instance IS_same A : Proper (same ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h. subst. fo. Qed.

Instance EIS_same A : Proper (same ==> impl) (@EIS A).

Proof. intros R S RS h. destruct h as [f h]. exists f. rewrite <- RS. hyp. Qed.

Lemma NT_IS_elt A (R : rel A) f k : IS R f -> NT R (f k).

Proof. intro hf. exists (fun i => f (i+k)). fo. Qed.

Lemma red_NT A (R : rel A) t u : R t u -> NT R u -> NT R t.

Proof.
  intros tu [f [f0 hf]]. subst.
  exists (fun k => match k with 0 => t | S k' => f k' end).
  intuition. intro k. destruct k. hyp. apply hf.
Qed.

(***********************************************************************)
(** Properties of [irreflexive]. *)

Instance irreflexive_incl A : Proper (incl --> impl) (@irreflexive A).

Proof. fo. Qed.

(***********************************************************************)
(** Monotony. *)

Definition monotone A B (R : rel A) (S : rel B) f :=
  forall x y, R x y -> S (f x) (f y).

Lemma monotone_transp A B (R : rel A) (S : rel B) f :
  monotone R S f -> monotone (transp R) (transp S) f.

Proof. unfold monotone, transp. auto. Qed.

(***********************************************************************)
(** Composition. *)

Definition compose A (R S : rel A) : rel A :=
  fun x y => exists z, R x z /\ S z y.

Infix "@" := compose (at level 40) : relation_scope.

Instance compose_incl A : Proper (incl ==> incl ==> incl) (@compose A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac comp := apply compose_incl; try incl_refl.

Instance compose_same A : Proper (same ==> same ==> same) (@compose A).

Proof. fo. Qed.

Definition absorbs_right A (R S : rel A) := R @ S << R.

Definition absorbs_left A (R S : rel A) := S @ R << R.

Lemma comp_assoc A (R S T : rel A) : (R @ S) @ T << R @ (S @ T).

Proof.
  unfold incl. intros. do 4 destruct H. exists x1; split. hyp.
  exists x0; split; hyp.
Qed.

Lemma comp_assoc' A (R S T : rel A) : R @ (S @ T) << (R @ S) @ T.

Proof.
  unfold incl. intros. do 2 destruct H. do 2 destruct H0.
  exists x1; split. exists x0; split; hyp. exact H1.
Qed.

Ltac assoc :=
  match goal with
    | |- (?s @ ?t) @ ?u << _ => incl_trans (s @ (t @ u)); try apply comp_assoc
    | |- ?s @ (?t @ ?u) << _ => incl_trans ((s @ t) @ u); try apply comp_assoc'
    | |- _ << (?s @ ?t) @ ?u => incl_trans (s @ (t @ u)); try apply comp_assoc'
    | |- _ << ?s @ (?t @ ?u) => incl_trans ((s @ t) @ u); try apply comp_assoc
  end.

Lemma absorbs_left_rtc A (R S : rel A) : R @ S << S -> R# @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma absorbs_right_rtc A (R S : rel A) : S @ R << S -> S @ R# << S.

Proof. intros h t v [u [tu uv]]. induction uv; fo. Qed.

(***********************************************************************)
(** Properties of [union]. *)

Instance union_incl A : Proper (incl ==> incl ==> incl) (@union A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac union := apply union_incl; try incl_refl.

Instance union_same A : Proper (same ==> same ==> same) (@union A).

Proof. fo. Qed.

Lemma union_commut A (R S : rel A) : R U S == S U R.

Proof. fo. Qed.

Lemma union_assoc A (R S T : rel A) : (R U S) U T == R U (S U T).

Proof. fo. Qed.

Lemma comp_union_l A (R S T : rel A) : (R U S) @ T == (R @ T) U (S @ T).

Proof. fo. Qed.

Lemma comp_union_r A (R S T : rel A) : T @ (R U S) == (T @ R) U (T @ S).

Proof. fo. Qed.

Lemma union_empty_r A (R : rel A) : R U empty_rel == R.

Proof. fo. Qed.

Lemma union_empty_l A (R : rel A) : empty_rel U R == R.

Proof. fo. Qed.

Lemma incl_union_l A (R S T : rel A) : R << S -> R << S U T.

Proof. fo. Qed.

Lemma incl_union_r A (R S T : rel A) : R << T -> R << S U T.

Proof. fo. Qed.

Lemma union_incl_eq A (R R' S : rel A) : R U R' << S <-> R << S /\ R' << S.

Proof. fo. Qed.

(***********************************************************************)
(** Reflexive closure. *)

Definition clos_refl A (R : rel A) : rel A := eq U R.

Notation "x %" := (clos_refl x) (at level 35) : relation_scope.

Instance rc_incl A : Proper (incl ==> incl) (@clos_refl A).

Proof. fo. Qed.

Instance rc_same A : Proper (same ==> same) (@clos_refl A).

Proof. fo. Qed.

Instance rc_refl A (R : rel A) : Reflexive (R%).

Proof. fo. Qed.

Instance rc_trans A (R : rel A) : Transitive R -> Transitive (R%).

Proof.
  intro. unfold Transitive, clos_refl, union. intros. decomp H0. subst y. hyp.
  decomp H1. subst z. auto. right. apply H with (y := y); hyp.
Qed.

Lemma incl_rc A (R : rel A) : R << R%.

Proof. fo. Qed.

(***********************************************************************)
(** Compatibility closure. *)

Section comp_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive comp_clos (R : rel A) : rel A :=
  | comp_clos_intro u u' v v' : E u u' -> E v v' -> R u' v' -> comp_clos R u v.

  Lemma comp_clos_intro_refl (R : rel A) t u : R t u -> comp_clos R t u.

  Proof. intro tu. eapply comp_clos_intro. refl. refl. hyp. Qed.

  Lemma comp_clos_eq R : same (comp_clos R) (E @ (R @ E)).

  Proof.
    split.
    intros t u tu. inversion_clear tu; subst. ex u'. intuition. ex v'. intuition.
    intros t u [t' [tt' [u' [t'u' u'u]]]]. eapply comp_clos_intro.
    apply tt'. sym. apply u'u. hyp.
  Qed.

  Lemma incl_comp_clos R : R << comp_clos R.

  Proof.
    intros u v uv. apply comp_clos_intro with (u':=u) (v':=v).
    refl. refl. hyp.
  Qed.

  Global Instance comp_clos_incl : Proper (incl ==> incl) comp_clos.

  Proof.
    intros R S RS u v uv. inversion uv; subst.
    apply comp_clos_intro with (u':=u') (v':=v'); fo.
  Qed.

  Global Instance comp_clos_same : Proper (same ==> same) comp_clos.

  Proof. intros R S [RS SR]. split. rewrite RS. refl. rewrite SR. refl. Qed.

  Lemma comp_clos_union R S :
    same (comp_clos (R U S)) (comp_clos R U comp_clos S).

  Proof.
    split.
    (* << *)
    induction 1.
    destruct H1 as [h|h]; [left|right];
      (eapply comp_clos_intro; [apply H | apply H0 | hyp]).
    (* >> *)
    intros t u [h|h].
    eapply comp_clos_incl. apply incl_union_l. refl. hyp.
    eapply comp_clos_incl. apply incl_union_r. refl. hyp.
  Qed.

  Global Instance comp_clos_prop R : Proper (E ==> E ==> impl) (comp_clos R).

  Proof.
    intros u u' uu' v v' vv' h. inversion h; subst.
    eapply comp_clos_intro.
    trans u. hyp. apply H.
    trans v. hyp. apply H0.
    hyp.
  Qed.

End comp_clos.

(***********************************************************************)
(** Properties of [clos_trans]. *)

Instance tc_trans A (R : rel A) : Transitive (R!).

Proof. unfold Transitive. intros. apply t_trans with y; hyp. Qed.

Instance tc_incl A : Proper (incl ==> incl) (@clos_trans A).

Proof.
  intros R R' H t u H0. elim H0; intros.
  apply t_step. apply H. hyp. trans y; hyp.
Qed.

Instance tc_same A : Proper (same ==> same) (@clos_trans A).

Proof. intros R S [RS SR]. split; apply tc_incl; hyp. Qed.

Lemma incl_tc A (R S : rel A) : R << S -> R << S!.

Proof. intros. unfold incl. unfold incl in H. intros. apply H in H0. apply t_step. trivial.  Qed.

Lemma trans_tc_incl A (R : rel A) : Transitive R -> R! << R.

Proof.
  unfold transitive, incl. intros. induction H0. hyp.
  apply H with y; hyp.
Qed.

Lemma trans_comp_incl A (R : rel A) : Transitive R -> R @ R << R.

Proof. fo. Qed.

Lemma absorbs_left_tc A (R S : rel A) : R @ S << S -> R! @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma tc_absorbs_left A (R S : rel A) : R @ S << S -> R @ S! << S!.

Proof.
  intro. unfold incl. intros. do 2 destruct H0. generalize x0 y H1 H0.
  induction 1; intros. apply t_step. apply H. exists x1; split; hyp.
  trans y0; auto.
Qed.

Lemma trans_intro A (R : rel A) : R @ R << R <-> Transitive R.

Proof.
  split. unfold Transitive. intros. apply H. exists y. intuition.
  intros h x z [y [xy yz]]. apply (h _ _ _ xy yz).
Qed.

Lemma comp_tc_idem A (R : rel A) : R! @ R! << R!.

Proof.
  unfold incl. intros. do 2 destruct H. trans x0; hyp.
Qed.

Lemma tc_min A (R S : rel A) : R << S -> Transitive S -> R! << S.

Proof.
  intros RS Strans. intros x y. induction 1. apply RS. hyp. trans y; hyp.
Qed.

Lemma trans_tc A (R : rel A) : Transitive R -> R! == R.

Proof. intro t. split. apply tc_min. refl. hyp. apply incl_tc. refl. Qed.

Lemma tc_idem A (R : rel A) : R!! == R!.

Proof.
  split. intros x y. induction 1. hyp. trans y; hyp.
  apply incl_tc. refl.
Qed.

Lemma tc_eq A (R S : rel A) : S << R -> R << S! -> R! == S!.

Proof.
  intros SR RSt. split; apply tc_min. hyp. apply tc_trans.
  trans R. hyp. apply incl_tc. refl. apply tc_trans.
Qed.

Lemma tc_incl_trans A (R S : rel A) : Transitive S -> R << S -> R! << S.

Proof. intros S_trans RS. intros t u tu; revert t u tu. induction 1; fo. Qed.

Instance tc_prop A (E R : rel A) : Reflexive E ->
  Proper (E ==> E ==> impl) R -> Proper (E ==> E ==> impl) (R!).

Proof.
  intros E_refl RE x x' xx' y y' yy' xy. revert x y xy x' xx' y' yy'.
  induction 1; intros x' xx' y' yy'.
  apply t_step. eapply RE. apply xx'. apply yy'. hyp.
  trans y. apply IHxy1. hyp. refl. apply IHxy2. refl. hyp.
Qed.

Lemma tc_prop_iff A (R E : rel A) : Equivalence E
  -> Proper (E ==> E ==> iff) R -> Proper (E ==> E ==> iff) (clos_trans R).

Proof.
  intros E_eq R_prop. apply prop_rel_sym; class. apply tc_prop; class.
  intros x x' xx' y y' yy' xy. rewrite <- xx', <- yy'. hyp.
Qed.

Lemma tc_step_l A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R x z & R! z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion IHxy1; inversion IHxy2; right; solve [eauto |
    inversion H; try inversion H0; exists x0;
    [trivial | constructor 2 with y; auto]].
Qed.

Lemma tc_step_r A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R! x z & R z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion_clear IHxy1; inversion_clear IHxy2; right;
    solve [eauto | inversion H0; exists x0;
    [constructor 2 with y; auto | trivial]].
Qed.

Lemma tc_transp A (R : rel A) : transp (R!) == (transp R)!.

Proof.
  intros; split; compute.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
Qed.

(***********************************************************************)
(** Symmetric closure of a relation. *)

Section clos_sym.

  Variable (A : Type) (R : rel A).

  Inductive clos_sym : rel A :=
  | s_step : forall x y, R x y -> clos_sym x y
  | s_sym : forall x y, clos_sym y x -> clos_sym x y.

  Global Instance sc_sym : Symmetric clos_sym.

  Proof. intros x y xy. apply s_sym. hyp. Qed.

End clos_sym.

(***********************************************************************)
(** Reflexive, transitive and symmetric closure of a relation. *)

Section clos_equiv.

  Variable (A : Type) (R : rel A).

  Inductive clos_equiv : rel A :=
  | e_step : forall x y, R x y -> clos_equiv x y
  | e_refl : forall x, clos_equiv x x
  | e_trans : forall x y z, clos_equiv x y -> clos_equiv y z -> clos_equiv x z
  | e_sym : forall x y, clos_equiv x y -> clos_equiv y x.

  Global Instance ec_equiv : Equivalence clos_equiv.

  Proof. exact (Build_Equivalence _ e_refl e_sym e_trans). Qed.

End clos_equiv.

Instance ec_incl A : Proper (incl ==> incl) (@clos_equiv A).

Proof.
  intros R S RS x y; revert x y; induction 1.
  apply e_step. fo. refl. trans y; fo. sym. fo.
Qed.

Lemma ec_min A (R S : rel A) : Equivalence S -> R << S -> clos_equiv R << S.

Proof.
  intros S_eq RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp. hyp.
Qed.

(***********************************************************************)
(** Properties of [clos_refl_trans]. *)

Instance rtc_refl A (R : rel A) : Reflexive (R#).

Proof. unfold Reflexive. apply rt_refl. Qed.

Instance rtc_trans A (R : rel A) : Transitive (R#).

Proof. unfold Transitive. intros. eapply rt_trans. apply H. hyp. Qed.

Instance rtc_incl A : Proper (incl ==> incl) (@clos_refl_trans A).

Proof.
  intro. unfold incl. intros. elim H0; intros.
  apply rt_step. apply H. hyp. refl. trans y1; hyp.
Qed.

Instance rtc_same A : Proper (same ==> same) (@clos_refl_trans A).

Proof. intros R S [RS SR]. split; apply rtc_incl; hyp. Qed.

Lemma incl_rtc A (R : rel A) : R << R#.

Proof. unfold inclusion. intros. Print clos_refl_trans. apply rt_step. trivial. Qed.

Lemma tc_incl_rtc A (R : rel A) : R! << R#.

Proof. induction 1. apply rt_step. hyp. trans y; hyp. Qed.

Lemma tc_split A (R : rel A) : R! << R @ R#.

Proof.
  unfold incl. induction 1. exists y. split. hyp. refl.
  destruct IHclos_trans1. destruct H1. exists x0. split. hyp.
  trans y. hyp. apply incl_elim with (R:=R!). apply tc_incl_rtc. hyp.
Qed.

Lemma rc_incl_rtc A (R : rel A) : R% << R#.

Proof.
  unfold incl, clos_refl. intros. destruct H.
  subst y. refl. apply rt_step. exact H.
Qed.

Lemma rtc_split A (R : rel A) : R# << eq U R!.

Proof.
  unfold incl, union. intros. elim H.
  intros. right. apply t_step. hyp.
  intro. left. refl.
  intros. destruct H1; destruct H3.
  left. trans y0; hyp.
  subst y0. right. hyp.
  subst y0. right. hyp.
  right. trans y0; hyp.
Qed.

Lemma rtc_split_eq A (R : rel A) : R# == eq U R!.

Proof.
  split. apply rtc_split. rewrite union_incl_eq. split.
  intros x y h. subst. refl. apply tc_incl_rtc.
Qed.

Lemma rtc_split2 A (R : rel A) : R# << eq U R @ R#.

Proof.
  unfold incl, union. intros. elim H; clear H x y; intros.
  right. exists y; split. exact H. refl. auto. destruct H0.
  subst y. destruct H2. auto. destruct H0. right. exists x0. auto.
  do 2 destruct H0. right. exists x0. split. exact H0.
  trans y; auto.
Qed.

Lemma tc_split_inv A (R : rel A) : R# @ R << R!.

Proof.
  intros x y RRxy. destruct RRxy as [z [Rxz Rzy]].
  destruct (rtc_split Rxz).
  rewrite H. intuition.
  constructor 2 with z. hyp.
  constructor 1. hyp.
Qed.

Lemma tc_merge A (R : rel A) : R @ R# << R!.

Proof.
  unfold incl. intros. destruct H. destruct H.
  ded (rtc_split H0). destruct H1; subst.
  apply t_step; hyp. trans x0. apply t_step. hyp. hyp.
Qed.

Lemma rtc_transp A (R : rel A) : transp (R#) << (transp R)#.

Proof.
  unfold incl. induction 1. apply rt_step. hyp. refl. trans y; hyp.
Qed.

Lemma incl_rtc_rtc A (R S : rel A) : R << S# -> R# << S#.

Proof. unfold incl. induction 2. apply H. hyp. refl. trans y; hyp. Qed.

Lemma comp_rtc_idem A (R : rel A) : R# @ R# << R#.

Proof. unfold incl. intros. do 2 destruct H. trans x0; hyp. Qed.

Lemma trans_rtc_incl A (R : rel A) : Reflexive R -> Transitive R -> R# << R.

Proof. intros R_refl R_trans x y. induction 1. hyp. refl. trans y; hyp. Qed.

Lemma rtc_invol A (R : rel A) : R # # == R #.

Proof.
  split. intros x y. induction 1. hyp. refl. trans y; hyp. apply incl_rtc.
Qed.

Lemma rtc_intro_seq A (R : rel A) f i : forall j, i <= j ->
  (forall k, i <= k < j -> R (f k) (f (1+k))) -> R# (f i) (f j).

Proof.
  cut (forall n, (forall k, i <= k < i + n -> R (f k) (f (1+k))) ->
    R# (f i) (f (n+i))).
  intros h j ij hij. assert (j = (j-i) + i). lia.
  rewrite H. apply h.
  intros k hk. apply hij. lia.
  induction n; intro h. refl. trans (f (n+i)).
  apply IHn. intros k hk. apply h. lia.
  apply rt_step. apply h. lia.
Qed.

Lemma rtc_min A (R S : rel A) : PreOrder S -> R << S -> R# << S.

Proof.
  intros S_PO RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp.
Qed.

Instance rtc_sym A (R : rel A) : Symmetric R -> Symmetric (R#).

Proof.
  intros R_sym x; revert x; induction 1.
  apply rt_step. hyp. refl. trans y; hyp.
Qed.

(***********************************************************************)
(** Quasi-ordering closure. *)

Section qo_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive qo_clos (R : rel A) : rel A :=
  | qo_step : R << qo_clos R
  | qo_refl : E << qo_clos R
  | qo_trans : Transitive (qo_clos R).

  Variable R : rel A.

  Global Instance qo_clos_preorder : PreOrder (qo_clos R).

  Proof. split. intro x. apply qo_refl. refl. apply qo_trans. Qed.

  Variable R_prop : Proper (E ==> E ==> impl) R.

  Global Instance qo_clos_prop : Proper (E ==> E ==> impl) (qo_clos R).

  Proof.
    intros x x' xx' y y' yy' h. revert x y h x' xx' y' yy'.
    induction 1; intros x' xx' y' yy'.
    apply qo_step. rewrite <- xx', <- yy'. hyp.
    apply qo_refl. rewrite <- xx', <- yy'. hyp.
    trans y. apply IHh1. hyp. refl. apply IHh2. refl. hyp.
  Qed.

  (*COQ: if removed, Coq fails in LComp*)
  Global Instance qo_clos_prop_iff : Proper (E ==> E ==> iff) (qo_clos R).

  Proof. apply prop_rel_sym; class. Qed.

  Lemma qo_clos_inv : forall t u,
      qo_clos R t u -> E t u \/ exists v, R t v /\ qo_clos R v u.

  Proof.
    induction 1.
    right. ex y. intuition. auto.
    destruct IHqo_clos1 as [h1|[a [i1 i2]]];
      destruct IHqo_clos2 as [h2|[b [j1 j2]]].
    left. trans y; hyp.
    right. ex b. rewrite h1. auto.
    right. ex a. rewrite <- h2. auto.
    right. ex a. intuition. trans b. trans y. hyp. apply qo_step. hyp. hyp.
  Qed.

End qo_clos.

(***********************************************************************)
(** Properties of [transp]. *)

Instance transp_incl A : Proper (incl ==> incl) (@transp A).

Proof. fo. Qed.

Instance transp_same A : Proper (same ==> same) (@transp A).

Proof. fo. Qed.

(*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

Lemma transp_refl A (R : rel A) : Reflexive R -> Reflexive (transp R).

Proof. auto. Qed.

Lemma transp_trans A (R : rel A) : Transitive R -> Transitive (transp R).

Proof. fo. Qed.

Lemma transp_sym A (R : rel A) : Symmetric R -> Symmetric (transp R).

Proof. fo. Qed.

Lemma transp_invol A (R : rel A) : transp (transp R) == R.

Proof. fo. Qed.

Lemma transp_union A (R S : rel A) : transp (R U S) == transp R U transp S.

Proof. fo. Qed.

(***********************************************************************)
(** Relations between closures, union and composition. *)

Lemma rtc_comp_permut A (R S : rel A) : R# @ (R# @ S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split2 H0). destruct H1.
  subst x0. exists x; split. refl. exact H.
  do 4 destruct H1. exists y; split. trans x1.
  apply rt_step. exists x2; split. trans x0; hyp.
  hyp. hyp. refl.
Qed.

Lemma rtc_union A (R S : rel A) : (R U S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. elim H; intros.
  (* step *)
  destruct H0. exists x0; split. refl. apply rt_step. exact H0.
  exists y0; split. apply rt_step. exists x0; split. refl. exact H0.
  refl.
  (* refl *)
  exists x0; split; refl.
  (* trans *)
  do 2 destruct H1. do 2 destruct H3.
  assert (h : ((R# @ S)# @ clos_refl_trans R) x1 x2).
  apply incl_elim with (R := (R# @ clos_refl_trans (R# @ S))).
  apply rtc_comp_permut. exists y0; split; hyp.
  destruct h. destruct H6. exists x3; split.
  trans x1; hyp. trans x2; hyp.
Qed.

Lemma rtc_comp A (R S : rel A) : R# @ S << S U R! @ S.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split H). destruct H1.
  subst x0. left. exact H0. right. exists x0; split; hyp.
Qed.

Lemma union_fact A (R S : rel A) : R U R @ S << R @ S%.

Proof.
  unfold incl. intros. destruct H.
  exists y; split; unfold clos_refl, union; auto.
  do 2 destruct H. exists x0; split; unfold clos_refl, union; auto.
Qed.

Lemma union_fact2 A (R S : rel A) : R @ S U R << R @ S%.

Proof. incl_trans (R U R @ S). apply union_commut. apply union_fact. Qed.

Lemma incl_rc_rtc A (R S : rel A) : R << S! -> R% << S#.

Proof.
  intro. unfold incl. intros. destruct H0. subst y. refl.
  apply incl_elim with (R := S!). apply tc_incl_rtc. apply H. exact H0.
Qed.

Lemma incl_tc_rtc A (R S : rel A) : R << S# -> R! << S#.

Proof. intro. unfold incl. induction 1. apply H. hyp. trans y; hyp. Qed.

Lemma rtc_comp_modulo A (R S : rel A) : R# @ (R# @ S)! << (R# @ S)!.

Proof.
  unfold incl. intros. do 2 destruct H.
  ded (tc_split H0). do 2 destruct H1. do 2 destruct H1.
  ded (rtc_split H2). destruct H4. subst x1.
  apply t_step. exists x2. intuition. trans x0; hyp.
  trans x1. apply t_step. exists x2. intuition.
  trans x0; hyp. exact H4.
Qed.

Lemma tc_union A (R S : rel A) : (R U S)! << R! U (R# @ S)! @ R#.

Proof.
  unfold incl. induction 1. destruct H. left. apply t_step. exact H.
  right. exists y. intuition. apply t_step. exists x. intuition.
  destruct IHclos_trans1. destruct IHclos_trans2.
  left. trans y; hyp.
  right. do 2 destruct H2. exists x0. intuition.
  apply rtc_comp_modulo. exists y. intuition. apply tc_incl_rtc. exact H1.
  right. do 2 destruct H1. destruct IHclos_trans2. exists x0.
  intuition. trans y. exact H2. apply tc_incl_rtc. exact H3.
  do 2 destruct H3. exists x1. intuition. trans x0. exact H1.
  apply rtc_comp_modulo. exists y. intuition.
Qed.

(***********************************************************************)
(** Commutation properties. *)

Section commut.

  Variables (A : Type) (R S : rel A) (commut : R @ S << S @ R).

  Lemma commut_rtc : R# @ S << S @ R#.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x x0 H y H0.
    clear H0 y H x0 x. induction 1; intros.
    assert ((S @ R) x y0). apply commut. exists y. intuition.
    do 2 destruct H1. exists x0. intuition.
    exists y. intuition.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    ded (IHclos_refl_trans1 _ H2). do 2 destruct H4.
    exists x1. intuition. trans x0; hyp.
  Qed.

  Lemma commut_rtc_inv : R @ S# << S# @ R.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x0 y H0 x H.
    clear H x x0 H0 y. induction 1; intros.
    assert ((S @ R) x0 y). apply commut. exists x. intuition.
    do 2 destruct H1. exists x1. intuition.
    exists x0. intuition.
    ded (IHclos_refl_trans1 _ H). do 2 destruct H0.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    exists x2. intuition. apply rtc_trans with x1; hyp.
  Qed.

  Lemma commut_tc : R! @ S << S @ R!.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj1 Hxy)) as [z' Hz'].
    assert (SE : (S @ R#) z' y). apply commut_rtc. exists z. intuition.
    destruct SE as [x' Rx'].
    assert (SRx : (S @ R) x x'). apply commut. exists z'. intuition.
    destruct SRx as [y' Sy']. exists y'. split. intuition.
    apply tc_merge. exists x'. intuition.
  Qed.

  Lemma commut_tc_inv : R @ S! << S! @ R.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj2 Hxy)) as [z' Hz'].
    assert (SRx : (S @ R) x z'). apply commut. exists z. intuition.
    destruct SRx as [y' Sy'].
    assert (SE : (S# @ R) y' y). apply commut_rtc_inv. exists z'. intuition.
    destruct SE as [x' Sx']. exists x'. split; try intuition.
    apply tc_merge. exists y'. intuition.
  Qed.

  Lemma commut_comp T : R @ (S @ T) << (S @ R) @ T.

  Proof. rewrite comp_assoc', commut. refl. Qed.

  Lemma comp_incl_assoc T V : R @ S << T -> R @ (S @ V) << T @ V.

  Proof. intro h. rewrite comp_assoc', h. refl. Qed.

End commut.

(***********************************************************************)
(** Inverse image. *)

Section inverse_image.

  Variables (A B : Type) (R : rel B) (f : A->B).

  Definition Rof : rel A := fun a a' => R (f a) (f a').

  (*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

  Lemma Rof_refl : Reflexive R -> Reflexive Rof.

  Proof. fo. Qed.

  Lemma Rof_trans : Transitive R -> Transitive Rof.

  Proof. fo. Qed.

  Lemma Rof_sym : Symmetric R -> Symmetric Rof.

  Proof. fo. Qed.

  Lemma Rof_preorder : PreOrder R -> PreOrder Rof.

  Proof. fo. Qed.

  Lemma Rof_equiv : Equivalence R -> Equivalence Rof.

  Proof. fo. Qed.

  Variable F : A -> B -> Prop.

  Definition RoF : rel A :=
    fun a a' => exists b', F a' b' /\ forall b, F a b -> R b b'.

End inverse_image.

Instance Rof_incl A B : Proper (incl ==> Logic.eq ==> incl) (@Rof A B).

Proof. intros R S RS f g fg. subst g. fo. Qed.

(***********************************************************************)
(** Alternative definition of the transitive closure, more convenient
for some inductive proofs. *)

Inductive clos_trans1 A (R : rel A) : rel A :=
| t1_step : forall x y, R x y -> clos_trans1 R x y
| t1_trans : forall x y z, R x y -> clos_trans1 R y z -> clos_trans1 R x z.

Notation "x !1" := (clos_trans1 x) (at level 35) : relation_scope.

Instance tc1_trans A (R : rel A) : Transitive (R!1).

Proof.
  induction 1; intro H1.
  exact (t1_trans x H H1).
  exact (t1_trans x H (IHclos_trans1 H1)).
Qed.

Lemma tc1_eq A (R : rel A) x y : R!1 x y <-> R! x y.

Proof.
  split; induction 1.
  apply t_step. hyp. trans y. apply t_step. hyp. hyp.
  apply t1_step. hyp. trans y; hyp.
Qed.

(***********************************************************************)
(** Alternative definition of the reflexive and transitive closure,
more convenient for some inductive proofs. *)

Inductive clos_refl_trans1 A (R : rel A) : rel A :=
| rt1_refl : forall x, clos_refl_trans1 R x x
| rt1_trans : forall x y z,
  R x y -> clos_refl_trans1 R y z -> clos_refl_trans1 R x z.

Notation "x #1" := (clos_refl_trans1 x) (at level 9) : relation_scope.

Instance rtc1_preorder A (R : rel A) : PreOrder (R#1).

Proof.
  split; intro x. apply rt1_refl.
  induction 1; intro H1. hyp.
  exact (rt1_trans x H (IHclos_refl_trans1 H1)).
Qed.

Lemma rtc1_eq A (R : rel A) x y : R#1 x y <-> R# x y.

Proof.
  split; induction 1.
  refl. trans y. apply rt_step. hyp. hyp.
  eapply rt1_trans. apply H. refl. refl. trans y; hyp.
Qed.

Lemma tc1_incl_rtc1 A (R : rel A) : R!1 << R#1.

Proof.
  induction 1.
  eapply rt1_trans. apply H. refl.
  eapply rt1_trans. apply H. hyp.
Qed.

Lemma rtc1_union A (R S : rel A) : (R U S)#1 << (S#1 @ R)#1 @ S#1.

Proof.
  intros x y xRSy. induction xRSy as [ | x y z xRSy yRSz].
  exists x. split; refl.
  destruct IHyRSz as [m [ym mz]].
  destruct ym as [m | m n o mn no].
  induction xRSy as [xRy | xSy].
  exists m. split; trivial. apply rt1_trans with m.
  exists x. split; trivial. refl. refl.
  exists x. split. refl. apply rt1_trans with m; trivial.
  exists o. split; trivial.
  induction xRSy as [xRy | xSy].
  apply rt1_trans with m.
  exists x. split. refl. hyp.
  apply rtc1_preorder with n; trivial.
  apply rt1_trans with n; trivial. refl.
  apply rt1_trans with n.
  destruct mn as [q [mq qn]]. exists q. split; trivial.
  apply rt1_trans with m; hyp. hyp.
Qed.

Lemma union_rel_rt1_left A (R S : rel A) : R#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. left. hyp. hyp.
Qed.

Lemma union_rel_rt1_right A (R S : rel A) : S#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. right. hyp. hyp.
Qed.

Lemma incl_rt1_union_union A (R S : rel A) : (R!1 U S!1)#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  apply union_rel_rt1_right. apply tc1_incl_rtc1. hyp.
Qed.

Lemma incl_union_rt1_union A (R S : rel A) : (R U S)#1 << (R!1 U S!1)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply rt1_trans with y.
  apply t1_step. hyp. refl.
  apply union_rel_rt1_right. apply rt1_trans with y.
  apply t1_step. hyp. refl.
Qed.

Lemma comm_s_rt1 A (R S : rel A) :
  S@(R!1) << (R!1)@(S!1) -> (S!1)@(R!1) << (R!1)@(S!1).

Proof.
  intros comm x y [z [H1 H2]].
  induction H1 as [x z H | x y' z H H0 IH].
  apply comm.
  exists z; split; hyp.
  assert (H1 := IH H2); clear IH H2.
  destruct H1 as [u [H2 H3]].
  assert ((R!1 @ S!1) x u).
  apply comm. exists y'; split; hyp.
  destruct H1 as [m [xRm mSu]].
  exists m; split. hyp.
  exact (tc1_trans mSu H3).
Qed.

Lemma comm_s_r A (R S : rel A) :
  S@R << (R!1)@(S#1) -> (R U S)#1 @ R @ (R U S)#1 << (R!1) @ (R U S)#1.

Proof.
  intros comm x y [z2 [[z1 [xRSz1 z1Rz2]] z2RSy]].
  induction xRSz1 as [ | m n z1 mRSn nRSz1 IH].
  exists z2. split. apply t1_step. hyp. hyp.
  (* m RUS n RUS# z1 R z2 RUS# y *)
  assert (((R!1) @ (R U S)#1) n y) as mRedy. apply IH. hyp.
  (* m RUS n R!1@RUS#1 y *)
  clear nRSz1 z1Rz2 z2RSy IH z1 z2.
  destruct mRedy as [o [nRo oRSy]].
  (* m RUS n R!1 o RUS#1 y *)
  induction mRSn.
  (* m R n *)
  exists o. split; auto. apply t1_trans with n; hyp.
  (* m S n *)
  destruct nRo as [o p oRp | o p q oRp pRq ];

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp. hyp.

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp. hyp.
  destruct mRedp as [n [mRn sSp]].
  exists n; split. hyp.
  apply rtc1_preorder with q.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  hyp.
Qed.

(***********************************************************************)
(** Extension to [option A] of a relation on [A] so that it is
reflexive on [None]. *)

Section opt_r.

  Variables (A : Type) (R : rel A).

  Inductive opt_r : rel (option A) :=
  | opt_r_None : opt_r None None
  | opt_r_Some : forall a b, R a b -> opt_r (Some a) (Some b).

  Global Instance opt_r_refl : Reflexive R -> Reflexive opt_r.

  Proof. intros h [x|]. apply opt_r_Some. refl. apply opt_r_None. Qed.

  Global Instance opt_r_sym : Symmetric R -> Symmetric opt_r.

  Proof.
    intros h x y xy. inversion xy; subst. hyp. apply opt_r_Some. sym. hyp.
  Qed.

  Global Instance opt_r_trans : Transitive R -> Transitive opt_r.

  Proof.
    intros h x y z xy yz. inversion xy; inversion yz; subst; try discr.
    apply opt_r_None. inversion H3; subst. apply opt_r_Some. trans b; hyp.
  Qed.

  Global Instance Some_prop : Proper (R ==> opt_r) (@Some A).

  Proof. intros x y xy. apply opt_r_Some. hyp. Qed.

End opt_r.

(****************************************************************************)
(** Extension of a relation on [A] to [option A] so that it is
irreflexive on [None]. *)

Section opt.

  Variables (A : Type) (R : rel A).

  Inductive opt : rel (option A) :=
  | opt_intro : forall x y, R x y -> opt (Some x) (Some y).

  Global Instance opt_trans : Transitive R -> Transitive opt.

  Proof.
    intros R_trans x y z xy yz. inversion xy; inversion yz; clear xy yz; subst.
    inversion H3; clear H3; subst. apply opt_intro. trans y0; hyp.
  Qed.

  Global Instance opt_sym : Symmetric R -> Symmetric opt.

  Proof.
    intros R_sym x y xy. inversion xy; clear xy; subst. apply opt_intro. hyp.
  Qed.

  Global Instance opt_opt_r E : Proper (E ==> E ==> impl) R ->
    Proper (opt_r E ==> opt_r E ==> impl) opt.

  Proof.
    intros R_E x x' xx' y y' yy' xy.
    inversion xy; inversion xx'; inversion yy'; clear xy xx' yy'; subst;
      try discr. inversion H6; inversion H3; clear H6 H3; subst.
    apply opt_intro. eapply R_E. apply H2. apply H5. hyp.
  Qed.

  Lemma opt_absorbs_right_opt_r E : R @ E << R -> opt @ opt_r E << opt.

  Proof.
    intros RE x z [y [xy yz]].
    inversion xy; clear xy; subst. inversion yz; clear yz; subst.
    apply opt_intro. apply RE. exists y0. fo.
  Qed.

  Lemma opt_absorbs_left_opt_r E : E @ R << R -> opt_r E @ opt << opt.

  Proof.
    intros ER x z [y [xy yz]].
    inversion yz; clear yz; subst. inversion xy; clear xy; subst.
    apply opt_intro. apply ER. exists x0. fo.
  Qed.

End opt.

Instance opt_incl A : Proper (incl ==> incl) (@opt A).

Proof.
  intros R S RS x y xy. inversion xy; clear xy; subst. apply opt_intro. fo.
Qed.

Instance opt_prop A (E1 E2 R : rel A) :
  Proper (E1 ==> E2 ==> impl) R -> Proper (opt E1 ==> opt E2 ==> impl) (opt R).

Proof.
  intros h x x' xx' y y' yy' xy. inversion xx'; clear xx'; subst.
  inversion yy'; clear yy'; subst. inversion xy; clear xy; subst.
  apply opt_intro. eapply h. apply H. apply H0. hyp.
Qed.

Lemma opt_absorbs_right A (R E : rel A) :
  R @ E << R -> opt R @ opt E << opt R.

Proof.
  intros RE x z [y [xy yz]].
  inversion xy; clear xy; subst. inversion yz; clear yz; subst.
  apply opt_intro. apply RE. exists y0. fo.
Qed.

Lemma opt_absorbs_left A (R E : rel A) :
  E @ R << R -> opt E @ opt R << opt R.

Proof.
  intros ER x z [y [xy yz]].
  inversion yz; clear yz; subst. inversion xy; clear xy; subst.
  apply opt_intro. apply ER. exists x0. fo.
Qed.

(***********************************************************************)
(** Restriction of a relation to some set. *)

Section restrict.

  Variables (A : Type) (P : A -> Prop) (R : rel A).

  Definition restrict : rel A := fun x y => P x /\ R x y.

  Global Instance restrict_prop E :
    Proper (E ==> impl) P -> Proper (E ==> E ==> impl) R ->
    Proper (E ==> E ==> impl) restrict.

  Proof.
    intros PE RE x x' xx' y y' yy' [hxy xy]. split.
    rewrite <- xx'. hyp. eapply RE. apply xx'. apply yy'. hyp.
  Qed.

End restrict.

Lemma restrict_union A (P : A -> Prop) R S :
  restrict P (R U S) == restrict P R U restrict P S.

Proof. fo. Qed.


(** Proof Reflection in Coq ; ND_subst_lems.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export ND_lift_lems.

Set Implicit Arguments.

Section ND_substitution_lemmas.

Variable l1 l2 : list nat.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.
Let Ts := trms l1.
Let C := list F.

Lemma subst_var_hyp_ok :
 forall (i n : nat) (G D : C) (p : F) (t : T),
 ND (D ++ lift_cxt n G) (hyp _ _ i) p ->
 ND (subst_cxt n D t ++ G) (hyp _ _ i) (subst_frm n p t).
Proof.
simple induction i.
(*i=O*)
intros n G D p t.
case D; simpl in |- *.
(*D=nil*)
case G; simpl in |- *.
(*G=nil*)
intro H.
elim (nohyp_inv H).
(*G=q,G'*)
intros q G' H.
rewrite (hypO_inv H).
rewrite simpl_subst_frm.
exact (ND_hypO G' q).
(*D=q,D'*)
intros q D' H.
rewrite (hypO_inv H).
exact (ND_hypO (subst_cxt n D' t ++ G) (subst_frm n q t)).
(*i=Si'*)
intros i' IH n G D p t.
case D; simpl in |- *.
(*D=nil*)
case G; simpl in |- *.
(*G=nil*)
intro H.
elim (nohyp_inv H).
(*G=q,G'*)
intros q G' H.
cut (ND G' (hyp _ _ i') (subst_frm n p t)).
exact (fun h => ND_hypS q h).
exact (IH n G' nil p t (hypS_inv H)).
(*D=q,D'*)
intros q D' H.
cut (ND (subst_cxt n D' t ++ G) (hyp _ _ i') (subst_frm n p t)).
exact (fun h => ND_hypS (subst_frm n q t) h).
exact (IH n G D' p t (hypS_inv H)).
Qed.

Lemma subst_var_prf_ok :
 forall (d : P) (n : nat) (G D : C) (p : F) (t : T),
 ND (D ++ lift_cxt n G) d p ->
 ND (subst_cxt n D t ++ G) (subst_var_prf n d t) (subst_frm n p t).
Proof.
simple induction d; clear d; simpl in |- *.
(*top+*)
intros n G D p t H.
rewrite (top_inv H).
simpl in |- *.
apply ND_top_intro.
(*hyp i*)
exact subst_var_hyp_ok.
(*bot-*)
intros d IHd q n G D p t H.
elim (bot_inv H).
intros H1 H2.
rewrite H1.
apply ND_bot_elim.
exact (IHd n G D (bot _ _) t H2).
(*imp+*)
intros q d IHd n G D p t H.
elim (imp_intro_inv H).
intros r H0.
elim H0.
intros H1 H2.
rewrite H1.
simpl in |- *.
apply ND_imp_intro.
exact (IHd n G (q :: D) r t H2).
(*imp-*)
intros d IHd e IHe n G D p t H.
elim (imp_elim_inv H).
intros r H0.
elim H0.
intros H1 H2.
exact (ND_imp_elim (IHd n G D (imp r p) t H1) (IHe n G D r t H2)).
(*cnj+*)
intros d IHd e IHe n G D p t H.
(* e.g. the next 9 lines  iso. "Inversion H." *)
elim (cnj_intro_inv H).
intros p1 H0.
elim H0.
intros p2 H1.
elim H1.
intros H2 H3.
elim H3.
intros H4 H5.
rewrite H2.
exact (ND_cnj_intro (IHd n G D p1 t H4) (IHe n G D p2 t H5)).
(*cnj-1*)
intros d IHd n G D p t H.
elim (cnj_elim1_inv H).
intros q H0.
exact (ND_cnj_elim1 (IHd n G D (cnj p q) t H0)).
(*cnj-2*)
intros d IHd n G D p t H.
elim (cnj_elim2_inv H).
intros q H0.
exact (ND_cnj_elim2 (IHd n G D (cnj q p) t H0)).
(*dsj+1*)
intros q d IHd n G D p t H.
elim (dsj_intro1_inv H).
intros r H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_dsj_intro1 (subst_frm n q t) (IHd n G D r t H2)).
(*dsj+2*)
intros q d IHd n G D p t H.
elim (dsj_intro2_inv H).
intros r H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_dsj_intro2 (subst_frm n q t) (IHd n G D r t H2)).
(*dsj-*)
intros d IHd e IHe f IHf n G D p t H.
elim (dsj_elim_inv H).
intros r1 H0; elim H0; clear H0; intros r2 H0; elim H0; clear H0;
 intros H0 H1; elim H1; clear H1; intros H1 H2.
exact
 (ND_dsj_elim (IHd n G D (dsj r1 r2) t H0) (IHe n G (r1 :: D) p t H1)
    (IHf n G (r2 :: D) p t H2)).
(*uvq+*)
intros d IHd n G D p t H.
elim (uvq_intro_inv H).
intros q H0.
elim H0.
intros H1 H2.
rewrite H1.
simpl in |- *.
apply ND_uvq_intro.
replace (lift_cxt 0 (subst_cxt n D t ++ G)) with
 (subst_cxt (S n) (lift_cxt 0 D) t ++ lift_cxt 0 G).
replace (lift_cxt 0 (subst_cxt n D t ++ G)) with
 (subst_cxt (S n) (lift_cxt 0 D) t ++ lift_cxt 0 G).
apply (IHd (S n) (lift_cxt 0 G) (lift_cxt 0 D) q t).
rewrite <- permute_lift_cxt.
unfold lift_cxt in |- *.
rewrite <- map_app.
exact H2.
exact (le_O_n n).
rewrite <- commute_lift_subst_cxt.
unfold lift_cxt in |- *.
rewrite map_app.
reflexivity.
exact (le_O_n n).
rewrite <- commute_lift_subst_cxt.
unfold lift_cxt in |- *.
rewrite map_app.
reflexivity.
exact (le_O_n n).
(*uvq-*)
intros t d IHd n G D p u H.
elim (uvq_elim_inv H).
intros q H0.
elim H0.
intros H1 H2.
rewrite H1.
pattern n at 4 in |- *.
rewrite <- (plusO n).
rewrite (distr_subst_frm q t u 0 n).
apply ND_uvq_elim.
rewrite (plusO n).
exact (IHd n G D (uvq q) u H2).
(*exq+*)
intros q t d IHd n G D p u H.
elim (exq_intro_inv H).
intros H0 H1.
rewrite H0.
simpl in |- *.
apply ND_exq_intro.
pattern n at 3 in |- *.
rewrite <- (plusO n).
rewrite <- (distr_subst_frm q t u 0 n).
rewrite (plusO n).
apply IHd.
exact H1.
(*exq-*)
intros d IHd e IHe n G D p t H.
elim (exq_elim_inv H).
intros r H0; elim H0; clear H0; intros H0 H1.
cut
 (ND (subst_frm (S n) r t :: lift_cxt 0 (subst_cxt n D t ++ G))
    (subst_var_prf (S n) e t) (lift_frm 0 (subst_frm n p t))).
intro He.
apply (ND_exq_elim (e:=(subst_var_prf (S n) e t)) (subst_frm n p t) (IHd n G D (exq r) t H0)).
exact He.
unfold lift_cxt in |- *.
rewrite map_app.
replace (map (lift_frm 0) (subst_cxt n D t)) with
 (subst_cxt (S n) (lift_cxt 0 D) t).
rewrite commute_lift_subst_frm.
apply (IHe (S n) (lift_cxt 0 G) (r :: lift_cxt 0 D) (lift_frm 0 p) t).
rewrite <- permute_lift_cxt.
simpl in |- *. unfold lift_cxt in |- *.
rewrite <- map_app.
exact H1.
exact (le_O_n n).
exact (le_O_n n).
symmetry  in |- *.
exact (commute_lift_subst_cxt D t (le_O_n n)).
Qed.

Lemma substO_var_prf_ok :
 forall (G : C) (d : P) (p : F) (t : T),
 ND (lift_cxt 0 G) d p -> ND G (subst_var_prf 0 d t) (subst_frm 0 p t).
Proof.
intros G d p t H.
exact (subst_var_prf_ok 0 G nil t H).
Qed.

Lemma subst_hyp_ok :
 forall (G : C) (d : P) (p q : F),
 ND G d p ->
 forall (i : nat) (D : C),
 ND (D ++ p :: G) (hyp _ _ i) q -> ND (D ++ G) (subst_hyp (length D) i d) q.
Proof.
intros G d p q H i.
elim i.
(*i=0*)
simple destruct D; simpl in |- *.
(*D=nil*)
intro H0.
rewrite (hypO_inv H0).
exact H.
(*D=cons r D'*)
intros r D' H0.
rewrite (hypO_inv H0).
exact (ND_hypO (D' ++ G) r).
(*i=(S i')*)
intros i' IH D.
case D; simpl in |- *.
(*D=nil*)
intro H0.
exact (hypS_inv H0).
(*D=cons r D'*)
intros r D' H0.
exact
 (ND_weakening (d:=subst_hyp (length D') i' d) (D' ++ G) nil r (IH D' (hypS_inv H0))).
Qed.

Lemma subst_hyp_prf_ok :
 forall (e : P) (G D : C) (d : P) (p q : F),
 ND G d p ->
 ND (D ++ p :: G) e q -> ND (D ++ G) (subst_hyp_prf (length D) e d) q.
Proof.
simple induction e; clear e; simpl in |- *.
(*top+*)
intros G D d p q Hd H.
rewrite (top_inv H).
apply ND_top_intro.
(*hyp*)
intros i G D d p q Hd H.
exact (subst_hyp_ok Hd D H).
(*bot-*)
intros e IHe r G D d p q Hd H.
elim (bot_inv H).
intros H0 H1.
rewrite H0.
apply ND_bot_elim.
exact (IHe G D d p (bot _ _) Hd H1).
(*imp+*)
intros r e IHe G D d p q Hd H.
elim (imp_intro_inv H).
intros s H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_imp_intro (IHe G (r :: D) d p s Hd H2)).
(*imp-*)
intros e IHe f IHf G D d p q Hd H.
elim (imp_elim_inv H).
intros r H0.
elim H0.
intros H1 H2.
exact (ND_imp_elim (IHe G D d p (imp r q) Hd H1) (IHf G D d p r Hd H2)).
(*cnj+*)
intros e IHe f IHf G D d p q Hd H.
elim (cnj_intro_inv H).
intros p1 H0.
elim H0.
intros p2 H1.
elim H1.
intros H2 H3.
rewrite H2.
elim H3.
intros H4 H5.
exact (ND_cnj_intro (IHe G D d p p1 Hd H4) (IHf G D d p p2 Hd H5)).
(*cnj-1*)
intros e IHe G D d p q Hd H.
elim (cnj_elim1_inv H).
intros r H0.
exact (ND_cnj_elim1 (IHe G D d p (cnj q r) Hd H0)).
(*cnj-2*)
intros e IHe G D d p q Hd H.
elim (cnj_elim2_inv H).
intros r H0.
exact (ND_cnj_elim2 (IHe G D d p (cnj r q) Hd H0)).
(*dsj+1*)
intros r e IHe G D d p q Hd H.
elim (dsj_intro1_inv H).
intros s H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_dsj_intro1 r (IHe G D d p s Hd H2)).
(*dsj+2*)
intros r e IHe G D d p q Hd H.
elim (dsj_intro2_inv H).
intros s H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_dsj_intro2 r (IHe G D d p s Hd H2)).
(*dsj-*)
intros e IHe f IHf g IHg G D d p q Hd H.
elim (dsj_elim_inv H).
intros r1 H0; elim H0; clear H0; intros r2 H0; elim H0; clear H0;
 intros H0 H1; elim H1; clear H1; intros H1 H2.
exact
 (ND_dsj_elim (IHe G D d p (dsj r1 r2) Hd H0) (IHf G (r1 :: D) d p q Hd H1)
    (IHg G (r2 :: D) d p q Hd H2)).
(*uvq+*)
intros e IHe G D d p q Hd H.
elim (uvq_intro_inv H).
intros p' H0.
elim H0.
intros H1 H2.
rewrite H1.
apply ND_uvq_intro.
unfold lift_cxt in |- *.
rewrite map_app.
simpl in |- *.
replace (length D) with (length (map (lift_frm 0) D)).
apply
 (IHe (lift_cxt 0 G) (lift_cxt 0 D) (lift_var_prf 0 d)
    (lift_frm 0 p) p' (ND_lift_var Hd 0)).
exact (rewr_cxt (map_app (lift_frm 0) D (p :: G)) H2).
symmetry  in |- *.
apply length_map.
(*uvq-*)
intros t e IHe G D d p q Hd H.
elim (uvq_elim_inv H).
intros p' H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_uvq_elim t (IHe G D d p (uvq p') Hd H2)).
(*exq+*)
intros r t e IHd G D d p q Hd H.
elim (exq_intro_inv H).
intros H0 H1.
rewrite H0.
apply ND_exq_intro.
exact (IHd G D d p (subst_frm 0 r t) Hd H1).
(*exq-*)
intros e IHe f IHf G D d p q Hd H.
elim (exq_elim_inv H).
intros r H0; elim H0; clear H0; intros H0 H1.
assert
 (H2 :
  ND (r :: lift_cxt 0 (D ++ G))
    (subst_hyp_prf (S (length D)) f (lift_var_prf 0 d))
    (lift_frm 0 q)).

unfold lift_cxt in |- *.
rewrite map_app.
replace (length D) with (length (lift_cxt 0 D)).
apply
 (IHf (lift_cxt 0 G) (r :: lift_cxt 0 D) (lift_var_prf 0 d)
    (lift_frm 0 p) (lift_frm 0 q) (ND_lift_var Hd 0)).
apply
 (rewr_cxt (G:=r :: lift_cxt 0 (D ++ p :: G))
    (G':=(r :: lift_cxt 0 D) ++ lift_frm 0 p :: lift_cxt 0 G)).
unfold lift_cxt in |- *.
simpl in |- *.
replace (map (lift_frm 0) D ++ lift_frm 0 p :: map (lift_frm 0) G) with
 (map (lift_frm 0) (D ++ p :: G));
 [ reflexivity | exact (map_app (lift_frm 0) D (p :: G)) ].
exact H1.
symmetry  in |- *.
unfold lift_cxt in |- *.
apply length_map.
apply ND_exq_elim with (1:=IHe G D d p (exq r) Hd H0) (2:=H2).
Qed.

Lemma substO_hyp_prf_ok :
 forall (G : C) (d e : P) (p q : F),
 ND G d p -> ND (p :: G) e q -> ND G (subst_hyp_prf 0 e d) q.
Proof.
intros G d e p q H H0.
exact (subst_hyp_prf_ok nil H H0).
Qed.

End ND_substitution_lemmas.


Set Implicit Arguments.

Require Import FunctionalExtensionality.

Definition EqDec A := forall (x y:A), {x=y}+{x<>y}.
Existing Class EqDec.

Definition eq_dec {A} {dec:EqDec A} x y : {x=y}+{x<>y}
  := dec x y.

Definition pfun A V := A -> option V.

Definition upd A {AEQ: EqDec A} V (m: pfun A V) a v : pfun A V :=
  fun a' => if AEQ a a' then Some v else m a'.

Ltac destruct_match :=
  match goal with
  | [ H: context[match ?d with | _ => _ end] |- _ ] =>
    let Heq := fresh in
    destruct d eqn:Heq; simpl in H; subst; try congruence
  | [ |- context[match ?d with | _ => _ end] ] =>
    let Heq := fresh in
    destruct d eqn:Heq; simpl; subst; try congruence
  end.

Theorem upd_eq : forall A {AEQ: EqDec A} V (m: pfun A V) a v,
    upd m a v a = Some v.
Proof.
  unfold upd; intros.
  destruct_match; auto.
Qed.

Theorem upd_neq : forall A {AEQ: EqDec A} V (m: pfun A V) a v a',
    a <> a' ->
    upd m a v a' = m a'.
Proof.
  unfold upd; intros.
  destruct_match; auto.
Qed.

Hint Rewrite upd_eq  : upd.
Hint Rewrite upd_neq using (solve [ auto ]) : upd.

Theorem upd_commute : forall A {AEQ:EqDec A} V (m: pfun A V) a v a' v',
    a <> a' ->
    upd (upd m a v) a' v' = upd (upd m a' v') a v.
Proof.
  unfold upd; intros.
  extensionality a''.
  repeat destruct_match.
Qed.

Theorem upd_repeat : forall A {AEQ:EqDec A} V (m: pfun A V) a v v',
    upd (upd m a v) a v' = upd m a v'.
Proof.
  unfold upd; intros.
  extensionality a''.
  destruct_match.
Qed.

Hint Rewrite upd_repeat : upd.

Definition remove A {AEQ: EqDec A} V (m: pfun A V) a : pfun A V :=
  fun a' => if AEQ a a' then None else m a'.

Lemma remove_eq : forall A {AEQ: EqDec A} V (m: pfun A V) a,
    remove m a a = None.
Proof.
  unfold remove; intros.
  destruct_match; auto.
Qed.

Lemma remove_neq : forall A {AEQ: EqDec A} V (m: pfun A V) a a',
    a <> a' ->
    remove m a a' = m a'.
Proof.
  unfold remove; intros.
  destruct_match; auto.
Qed.

Hint Rewrite remove_eq : upd.
Hint Rewrite remove_neq using (solve [ auto ]) : upd.

Theorem remove_upd : forall A {AEQ:EqDec A} V (m: pfun A V) a v,
    m a = Some v ->
    m = upd (remove m a) a v.
Proof.
  intros.
  extensionality a'.
  destruct (AEQ a a'); subst; autorewrite with upd; auto.
Qed.

Theorem remove_none : forall A {AEQ:EqDec A} V (m: pfun A V) a,
    m a = None ->
    remove m a = m.
Proof.
  unfold remove; intros.
  extensionality a'.
  destruct_match.
Qed.

Theorem upd_remove : forall A {AEQ:EqDec A} V (m: pfun A V) a v,
    remove (upd m a v) a = remove m a.
Proof.
  unfold remove; intros; extensionality a'.
  destruct_match; autorewrite with upd; auto.
Qed.

Hint Rewrite upd_remove : upd.
Hint Rewrite remove_none using (solve [ auto ]) : upd.

Theorem upd_remove_commute : forall A {AEQ:EqDec A} V (m: pfun A V) a v a',
    a <> a' ->
    upd (remove m a) a' v = remove (upd m a' v) a.
Proof.
  unfold upd, remove; intros; extensionality a''.
  repeat destruct_match.
Qed.


Require Import String.
Require Import Vectors.Vector.
Require Import Fixtranslation.Fixtoelim.

(*
 * Test for type aliases.
 *)

Module V.

  Definition Vec (n : nat) (a : Type) : Type := VectorDef.t a n.

  Fixpoint atWithDefault (n : nat) (a : Type) (default : a) (v : Vec n a) (index : nat) : a.
    refine (
        match v with
        | Vector.nil _ => default
        | Vector.cons _ h n' t =>
          match index with
          | O => h
          | S index' => atWithDefault n' _ default t index'
          end
        end
      ).
  Defined.

End V.

Preprocess Module V as V'.


(** * Decidability *)

From Coq Require
  Classes.DecidableClass Classes.EquivDec Classes.SetoidDec.
From DEZ.Has Require Export
  EquivalenceRelations.
From DEZ.Is Require Export
  Equivalence.
From DEZ.Supports Require Import
  EquivalenceNotations.

(** ** Decidable Proposition *)

Class HasDec (A : Prop) : Type := dec : {A} + {~ A}.

Arguments dec _ {_}.

#[export] Typeclasses Transparent HasDec.

(** We supplement the [decide] tactic with a form
    that accepts a disjunctive pattern with two branches. *)

Tactic Notation "decide" constr(A) "as" "[" ident(x) "|" ident(f) "]" :=
  let a := fresh in
  DecidableClass._decide_ A a; [rename a into x | rename a into f].

(** We need some instances to bridge the gap between our definitions,
    standard library definitions and equations plugin definitions.
    We explicitly export instances of existing classes,
    so that we can invoke existing tactics,
    such as [decide (tt = tt)]. *)

Section Context.

Import Classes.DecidableClass.

Context (A : Prop).

(** Our decidability implies standard library decidability. *)

#[local] Instance dec_decidable {d : HasDec A} : Decidable A.
Proof.
  destruct d as [x | f].
  - exists true. intuition.
  - exists false. intuition.
Defined.

(** Standard library decidability implies our decidability. *)

#[local] Instance decidable_has_dec {d : Decidable A} : HasDec A.
Proof.
  destruct d as [[] a].
  - left. intuition.
  - right. intuition.
Defined.

End Context.

(** ** Decidable Equivalence *)

Class HasEquivDec (A : Type) {X : HasEquivRel A} : Type :=
  equiv_dec (x y : A) : {x == y} + {~ x == y}.

Arguments HasEquivDec _ {_}.

#[export] Typeclasses Transparent HasEquivDec.

Section Context.

Import Classes.EquivDec.

Context (A : Type) {X : HasEquivRel A} `{!IsEquiv X}.

(** Our decidable equivalence implies
    standard library decidable equivalence. *)

#[local] Instance equiv_dec_eq_dec
  {e : HasEquivDec A} : EqDec A _==_ := e.

(** Standard library decidable equivalence implies
    our decidable equivalence. *)

#[local] Instance eq_dec_has_equiv_dec
  {e : EqDec A _==_} : HasEquivDec A := e.

End Context.

Section Context.

Import Classes.SetoidDec.

Context (A : Type) {X : HasEquivRel A} `{!IsEquiv X}.

(** Our decidable equivalence implies
    standard library decidable equivalence. *)

#[local] Instance equiv_dec_eq_dec_equiv
  {e : HasEquivDec A} : EqDec {| equiv := _==_ |} := e.

(** Standard library decidable equivalence implies
    our decidable equivalence. *)

#[local] Instance eq_dec_equiv_has_equiv_dec
  {e : EqDec {| equiv := _==_ |}} : HasEquivDec A := e.

End Context.

Section Context.

Context (A : Type) {X : HasEquivRel A}.

(** Decidable equivalence implies decidability of equivalences. *)

#[export] Instance equiv_dec_has_dec_equiv
  {e : HasEquivDec A} (x y : A) : HasDec (x == y) := equiv_dec x y.

(** Decidability of equivalences implies decidable equivalence. *)

#[local] Instance dec_equiv_has_equiv_dec
  {d : forall x y : A, HasDec (x == y)} : HasEquivDec A :=
  fun x y : A => dec (x == y).

End Context.

(** ** Decidable Equality *)

Fail Fail Class HasEqDec (A : Type) : Type :=
  eq_dec (x y : A) : {x = y} + {x <> y}.

Arguments eq_dec {_ _} _ _.

Notation HasEqDec := EqDec.
Notation eq_dec := eq_dec.

#[export] Typeclasses Transparent HasEqDec.

Section Context.

Context (A : Type).

(** Decidable equality implies decidability of equalities. *)

#[export] Instance eq_dec_has_dec_eq
  {e : HasEqDec A} (x y : A) : HasDec (x = y) := eq_dec x y.

(** Decidability of equalities implies decidable equality. *)

#[local] Instance dec_eq_has_eq_dec
  {d : forall x y : A, HasDec (x = y)} : HasEqDec A :=
  fun x y : A => dec (x = y).

End Context.

Section Context.

Context (A : Type).

(** Decidable equality implies decidable equivalence over equality. *)

#[export] Instance eq_dec_has_equiv_dec_eq
  {e : HasEqDec A} : HasEquivDec A (X := _=_) := eq_dec.

(** Decidable equivalence over equality implies decidable equality. *)

#[local] Instance equiv_dec_eq_has_eq_dec
  {e : HasEquivDec A (X := _=_)} : HasEqDec A := equiv_dec.

End Context.


From stdpp Require Import tactics.
From discprob.basic Require Import base order nify.
Require Import Ranalysis5.
Require Import Reals Fourier FunctionalExtensionality.
From Coquelicot Require Export Rcomplements Rbar Series Lim_seq Hierarchy Markov Continuity ElemFct.
Require Import List.
Require Import Psatz Omega.

Local Notation "x ≤ y" := (Rle x y) (at level 70, no associativity).
Local Notation "x ≥ y" := (Rge x y) (at level 70, no associativity).

Lemma Rmult_eq_0_inv_r: ∀ r r1 r2 : R, (r ≠ 0 → r1 = r2) → r * r1 = r * r2.
Proof.
  intros r r1 r2; case (Req_dec r 0).
  - intros ->. by rewrite !Rmult_0_l.
  - intros Hneq Heq. rewrite Heq //.
Qed.

Lemma Rmult_eq_0_inv_l: ∀ r r1 r2 : R, (r ≠ 0 → r1 = r2) → r1 * r = r2 * r.
Proof.
  intros r r1 r2; case (Req_dec r 0).
  - intros ->. by rewrite !Rmult_0_r.
  - intros Hneq Heq. rewrite Heq //.
Qed.

Lemma Rmult_neq_0_compat: ∀ r1 r2 : R, r1 ≠ 0 → r2 ≠ 0 → r1 * r2 ≠ 0.
Proof. intros r1 r2 ?? [?|?]%Rmult_integral; congruence. Qed.

Lemma Rdiv_le_compat_contra: ∀ r1 r2 r3 r4 : R,
    0 ≤ r1 → 0 < r4 → r1 ≤ r2 → r4 ≤ r3 → r1 / r3 ≤ r2 / r4.
Proof.
  intros. rewrite /Rdiv. apply Rmult_le_compat; auto.
  rewrite -(Rmult_1_l (/ r3)). apply Rle_mult_inv_pos; fourier.
    by apply Rinv_le_contravar.
Qed.

Lemma Rmult_le_0_compat x y: 0 ≤ x → 0 ≤ y → 0 ≤ x * y.
Proof.
  intros. rewrite -[a in a ≤ _](Rmult_0_l 0).
  apply Rmult_le_compat; eauto; try reflexivity.
Qed.

Lemma fold_right_plus_mult (l: list R) v :
  (fold_right Rplus 0 l) * v = fold_right Rplus 0 (map (λ x, x * v) l).
Proof.
  induction l => //=; first nra.
  ring_simplify. rewrite IHl. done.
Qed.

Lemma fold_right_map_Rmult_le {A} (l: list A) f f':
  (∀ x, In x l → 0 <= f x ∧ f x <= f' x) →
  fold_right Rmult 1 (map f l) <= fold_right Rmult 1 (map f' l).
Proof.
  intros Hin.
  cut (0 <= fold_right Rmult 1 (map f l) ∧
       fold_right Rmult 1 (map f l) <= fold_right Rmult 1 (map f' l)).
  { intros [? ?]; done. }
  induction l.
  - rewrite //=; intros; nra.
  - rewrite //=. destruct IHl.
    { intros a' Hin'. apply Hin. by right. }
    split.
    * apply Rmult_le_0_compat; eauto.
      edestruct (Hin a); eauto; first by left.
    * apply Rmult_le_compat; auto.
      ** edestruct (Hin a); eauto; first by left.
      ** edestruct (Hin a); eauto; first by left.
Qed.

Hint Resolve Rabs_pos Rle_ge.

Lemma Rabs_case r (P : R → Type):
  (0 <= r → P r) → (0 <= -r → P (-r)) → P (Rabs r).
Proof.
  intros Hcase1 Hcase2.
  destruct (Rle_dec 0 r) as [?|?%Rnot_le_gt].
  * rewrite Rabs_right //=; eauto; try nra.
  * rewrite Rabs_left1 //=.
    ** eapply Hcase2. apply Ropp_le_cancel.
       rewrite Ropp_0 Ropp_involutive. left. auto.
    ** left. auto.
Qed.

Lemma open_interval_open x y :
  open (open_interval x y).
Proof.
  rewrite /open => z [? ?].
  rewrite /locally.
  unshelve (eexists).
  { exists (Rmin (z - x) (y - z)). abstract (apply Rmin_pos; nra).  }
  intros z' => //=. rewrite /ball//=/AbsRing_ball//=/abs//=.
  apply Rmin_case_strong; apply Rabs_case;
    rewrite /open_interval/minus//=/plus//=/opp//=; intros; split; nra.
Qed.

Lemma disc_ball z Δ x:
  disc z Δ x ↔ ball z Δ x.
Proof. rewrite /disc/ball//=. Qed.

Lemma open_included_disc U z:
  open U → U z → ∃ delta : posreal, included (disc z delta) U.
Proof.
  intros Hopen Hz. edestruct Hopen as (delta&Hdelta); eauto.
  exists delta. intros ??. apply Hdelta; eauto.
Qed.

Lemma open_open_set U:
  open U → open_set U.
Proof. done. Qed.

Lemma disc_neighbourhood x (δ: posreal):
  neighbourhood (disc x δ) x.
Proof.
  rewrite /neighbourhood; exists δ. rewrite /included. done.
Qed.

Lemma ball_neighbourhood x (δ: R):
  δ > 0 →
  neighbourhood (ball x δ) x.
Proof.
  rewrite /neighbourhood. unshelve (eexists).
  { exists δ.  nra. }
  rewrite //=.
Qed.

Lemma pos_INR': ∀ n : nat, (0 < n)%nat → 0 < INR n.
Proof. intros n Hlt. replace 0 with (INR 0) by auto. by apply lt_INR.  Qed.

Lemma archimed_rat_dense1 eps r:
  0 < eps →
  0 <= r →
  ∃ n m, r < INR n / INR m < r + eps ∧ (0 < m)%nat.
Proof.
  intros Hpos1 Hpos2.
  edestruct (archimed_cor1 eps) as (m&Hm1&Hm2); auto.
  edestruct (archimed (r * (INR m))) as (Hup1&Hup2).
  assert (0 < INR m) by (apply pos_INR'; done).
  assert (0 <= r * INR m).
  { apply (pos_INR') in Hm2. rewrite /Rdiv.
    apply Rmult_le_pos; auto. nra.
  }
  assert (0 <= up (r * INR m))%Z.
  { apply le_IZR. nra. }
  exists (Z.to_nat (up (r * INR m))).
  exists m.
  split; first split; auto.
  *  rewrite INR_IZR_INZ.
     rewrite Z2Nat.id //=. apply (Rmult_lt_reg_r (INR m)); auto.
     rewrite /Rdiv Rmult_assoc. rewrite Rinv_l; last by nra.
     rewrite Rmult_1_r. done.
  *  rewrite INR_IZR_INZ.
     rewrite Z2Nat.id //=. apply (Rmult_lt_reg_r (INR m)); auto.
     rewrite /Rdiv Rmult_assoc. rewrite Rinv_l; last by nra.
     rewrite Rmult_1_r. rewrite Rmult_plus_distr_r.
     apply (Rle_lt_trans _ (r * INR m + 1)); first by nra.
     cut (1 < eps * INR m); first by nra.
     rewrite -(Rinv_l (INR m)); last by nra. apply Rmult_lt_compat_r; nra.
Qed.

Lemma archimed_rat_dense2 eps r:
  0 < eps →
  r < 0 →
  ∃ n m, r < - INR n / INR m < r + eps ∧ (0 < m)%nat.
Proof.
  intros Hpos Hneg.
  assert (∃ eps', 0 < eps' <= eps ∧ r + eps' < 0) as (eps'&Hr&?).
  { destruct (Rlt_dec eps (-r)) as [Hlt|Hnlt].
    { exists eps; split; auto; try nra. }
    apply Rnot_lt_ge in Hnlt.
    exists (-r / 2); split; nra.
  }
  cut (∃ n m, r < - INR n / INR m < r + eps' ∧ (0 < m)%nat).
  { intros (n&m&?&?). exists n, m; split; auto. nra. }
  set (r' := -r - eps').
  edestruct (archimed_rat_dense1 eps' (-r - eps')) as (n&m&?&?); try nra.
  exists n, m; split; auto; try nra.
Qed.

Lemma is_lim_seq_plus_inv un vn u v:
  is_lim_seq (λ n, un n + vn n) (u + v) →
  is_lim_seq (λ n, vn n) v →
  is_lim_seq (λ n, un n) u.
Proof.
  intros Hlim1 Hlim2.
  apply (is_lim_seq_scal_l _ (-1)) in Hlim2. rewrite //= in Hlim2.
  eapply is_lim_seq_plus' in Hlim1; eauto.
  replace (-1 * v + (u + v)) with u in Hlim1 by nra.
  eapply is_lim_seq_ext; last by apply Hlim1.
  intros. nra.
Qed.

Lemma is_lim_seq_opp_inv un u:
  is_lim_seq (λ n, - un n) (- u) →
  is_lim_seq (λ n, un n) u.
Proof.
  intros Hlim.
  apply (is_lim_seq_scal_l _ (-1)) in Hlim. rewrite //= in Hlim.
  replace (-1 * -u) with u in Hlim by nra.
  eapply is_lim_seq_ext; try eassumption.
  intros n; nra.
Qed.

Lemma Rmin_diff_eq x y:
  Rmin x y = (x + y) / 2 - Rabs(x - y) / 2.
Proof.
  apply Rmin_case_strong; apply Rabs_case; nra.
Qed.

Lemma Rmax_diff_eq x y:
  Rmax x y = (x + y) / 2 + Rabs(x - y) / 2.
Proof.
  apply Rmax_case_strong; apply Rabs_case; nra.
Qed.

Lemma continuous_Rmin_l x y: continuous (Rmin x) y.
Proof.
  eapply continuous_ext.
  { intros x'. rewrite Rmin_diff_eq; done. }
  apply: continuous_minus.
  * apply: continuous_scal.
    ** apply: continuous_plus.
       *** apply: continuous_const.
       *** apply: continuous_id.
    ** apply: continuous_const.
  * apply: continuous_scal.
    ** apply: continuous_comp.
       *** apply: continuous_minus.
           **** apply: continuous_const.
           **** apply: continuous_id.
       *** apply: continuous_abs.
    ** apply: continuous_const.
Qed.

Lemma continuous_Rmax_l x y: continuous (Rmax x) y.
Proof.
  eapply continuous_ext.
  { intros x'. rewrite Rmax_diff_eq; done. }
  apply: continuous_plus.
  * apply: continuous_scal.
    ** apply: continuous_plus.
       *** apply: continuous_const.
       *** apply: continuous_id.
    ** apply: continuous_const.
  * apply: continuous_scal.
    ** apply: continuous_comp.
       *** apply: continuous_minus.
           **** apply: continuous_const.
           **** apply: continuous_id.
       *** apply: continuous_abs.
    ** apply: continuous_const.
Qed.

Lemma archimed_pos r: 0 <= r → ∃ n, INR n <= r < INR (S n).
Proof.
  intros Hpos. exists (Z.to_nat (up r - 1)).
  cut (INR (Z.to_nat (up r - 1)) = IZR (up r)- 1).
  { rewrite S_INR => ->. specialize (archimed r). nra. }
  rewrite Z2Nat.inj_sub; last omega.
  rewrite minus_INR.
  * rewrite //=. f_equal.
    rewrite INR_IZR_INZ.  f_equal.
    apply Z2Nat.id.
    apply le_IZR. specialize (archimed r); nra.
  * apply Z2Nat.inj_le; try omega.
    ** apply le_IZR. specialize (archimed r); nra.
    ** apply le_IZR. specialize (archimed r). intros (Hgt&?).
       assert (0 < up r)%Z.
       { apply lt_IZR. nra. }
       apply IZR_le. omega.
Qed.

Lemma pow_INR n k: INR (n^k) = INR n^k.
Proof.
  induction k => //=. rewrite ?plus_INR mult_INR -IHk.
  replace (INR 0) with 0 by auto. nra.
Qed.

Lemma INR_diff_lt_1_eq n k: 0 <= INR n - INR k < 1 → n = k.
Proof.
  intros (?&Hdiff).
  assert (Hpos:INR k <= INR n) by nra.
  apply INR_le in Hpos.
  rewrite -minus_INR in Hdiff; auto.
  replace 1 with (INR 1) in Hdiff; auto.
  apply INR_lt in Hdiff.
  omega.
Qed.

Lemma Sup_seq_const k: Sup_seq (λ n, k) = k.
Proof.
  rewrite Rbar_sup_eq_lub.
  apply Lub.Rbar_is_lub_unique => //=.
  split.
  * intros ? (?&->) => //=. apply Rbar_le_refl.
  * intros ? Hub. apply Hub; exists O; eauto.
Qed.

Lemma Sup_seq_real (xn: nat → R): Rbar_lt m_infty (Sup_seq xn).
Proof.
  apply (Rbar_lt_trans _ (xn O - 1)); first done.
  apply Sup_seq_minor_lt. exists O => //=. nra.
Qed.

Lemma Sup_seq_real_p_infty (xn: nat → R):
  Sup_seq xn = p_infty ↔ ∀ k, ∃ n, k <= xn n.
Proof.
  split.
  - rewrite /Sup_seq. destruct (ex_sup_seq) as (v&Hsup) => //=.
    apply is_sup_seq_lub in Hsup. intros; subst.
    destruct Hsup as (Hub&Hlub).
    apply Classical_Pred_Type.not_all_not_ex => Hall.
    cut (Rbar_le p_infty k); first done.
    apply Hlub. intros ? (n&->). rewrite //=.
    specialize (Hall n). nra.
  - intros Hunbounded. specialize (Sup_seq_real xn).
    rewrite /Sup_seq. destruct (ex_sup_seq) as ([ | |]&His) => //=.
    exfalso. apply is_sup_seq_lub in His.
    destruct His as (Hub&?).
    destruct (Hunbounded (r+1)) as (n&Hle).
    feed pose proof (Hub (xn n)) as Hle'.
    { exists n. auto. }
    rewrite //= in Hle'. nra.
Qed.

Definition Rbar_max (x y: Rbar) : Rbar :=
  match x, y with
  | Finite x', Finite y' => Rmax x' y'
  | m_infty, _ => y
  | _, m_infty => x
  | p_infty, _ => p_infty
  | _, p_infty => p_infty
  end.

Lemma Rbar_max_l: ∀ x y : Rbar, Rbar_le x (Rbar_max x y).
Proof.
  destruct x, y => //=; try apply Rmax_l; reflexivity.
Qed.

Lemma Rbar_max_r: ∀ x y : Rbar, Rbar_le y (Rbar_max x y).
  destruct x, y => //=; try apply Rmax_r; reflexivity.
Qed.

Lemma Rbar_max_comm: ∀ x y : Rbar, Rbar_max x y = Rbar_max y x.
Proof. destruct x, y => //=; by rewrite Rmax_comm. Qed.

Lemma Rbar_max_case: ∀ (x y : Rbar) (P : Rbar → Type), P x → P y → P (Rbar_max x y).
Proof. destruct x, y => //=; by apply Rmax_case. Qed.

Lemma Rbar_max_case_strong:
  ∀ (x y : Rbar) (P : Rbar → Type),
  (Rbar_le y x → P x) → (Rbar_le x y → P y) → P (Rbar_max x y).
Proof. destruct x, y => //=; try apply Rmax_case_strong; eauto. Qed.

Lemma norm_Rabs r: norm r = Rabs r.
Proof.
  rewrite /norm//=/abs.
Qed.


Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Logic.FunctionalExtensionality.
Import ListNotations.
From PLF Require Import Imp.

Definition aequiv (a1 a2: aexp): Prop :=
  forall (st: state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2: bexp): Prop :=
  forall (st:state),
    beval st b1 = beval st b2.

Theorem aequiv_example: aequiv (X - X) 0.
Proof.
  intros st.
  simpl.
  omega.
Qed.

Print bequiv.

Theorem bequiv_example: bequiv (X - X = 0)%imp true.
Proof.
  intros st.
  unfold beval.
  rewrite aequiv_example.
  simpl. reflexivity.
Qed.

Definition cequiv (c1 c2: com): Prop :=
  forall (st st': state),
    (st =[ c1 ]=> st') <->
    (st =[ c2 ]=> st').

Check E_Seq.

Theorem skip_left: forall c,
    cequiv
      (SKIP;; c)
      c.
Proof.
  intros c st st'.
  split.
  intros H.
  - inversion H.
    inversion H; subst.
    inversion H2; subst.
    assumption.
  - Check E_Seq.
    apply E_Seq. apply E_Skip.
Qed.

Theorem skip_right : forall c,
    cequiv
      (c ;; SKIP)
      c.
Proof.
  unfold cequiv.
  intros.
  split.
  - intros H.
    inversion H; subst.
    inversion H5; subst.
    apply H2.
  - intros H.
    Check E_Seq.
    apply E_Seq with st'. apply H.
    apply E_Skip.
Qed.

Theorem TEST_true_simple: forall c1 c2,
    cequiv
      (TEST true THEN c1 ELSE c2 FI)
      c1.
Proof.
  intros.
  split. intros H.
  inversion H; subst. assumption.
  discriminate H5.
  apply E_IfTrue. auto.
Qed.

Theorem  TEST_true: forall b c1 c2,
    bequiv b BTrue ->
    cequiv
      (TEST b THEN c1 ELSE c2 FI)
      c1.
Proof.
  unfold bequiv.
  simpl.
  intros b c1 c2 Hb.
  split; intros H.
  - inversion H. subst.
    assumption.
    rewrite Hb in H5. inversion H5.
  - apply E_IfTrue. apply Hb.
    auto.
Qed.

Theorem TEST_false: forall b c1 c2,
    bequiv b BFalse ->
    cequiv
      (TEST b THEN c1 ELSE c2 FI)
      c2.
Proof.
  unfold bequiv.
  simpl.
  intros b c1 c2 Hb.
  split; intros H.
  - inversion H; subst.
    + rewrite Hb in H5.
      inversion H5.
    + assumption.
  - apply E_IfFalse; auto.
Qed.

Theorem WHILE_false : forall b c,
  bequiv b BFalse ->
  cequiv
    (WHILE b DO c END)
    SKIP.
Proof.
  intros b c Hb. split; intros H.
  - (* -> *)
    inversion H; subst.
    + (* E_WhileFalse *)
      apply E_Skip.
    + (* E_WhileTrue *)
      rewrite Hb in H2. inversion H2.
  - (* <- *)
    inversion H; subst.
    apply E_WhileFalse.
    rewrite Hb.
    reflexivity.  Qed.

Lemma WHILE_true_nonterm: forall b c st st',
    bequiv b BTrue ->
    ~(st =[ WHILE b DO c END ]=> st').
Proof.
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END)%imp as cw eqn:Heqcw.
  induction H;
    inversion Heqcw; subst; clear Heqcw.
  - unfold bequiv in Hb.
    rewrite Hb in H. inversion H.
  - apply IHceval2. reflexivity.
Qed.

Theorem WHILE_true: forall b c,
    bequiv b true ->
    cequiv
      (WHILE b DO c END)
      (WHILE true DO SKIP END).
Proof.
  intros b c Hb.
  split; intros.
  inversion H; subst. unfold bequiv in Hb.
  rewrite Hb in H4. inversion H4.
  apply WHILE_true_nonterm with b c st st' in Hb.
  contradiction.
  assert (~(st =[ WHILE true DO SKIP END ]=> st')).
  apply WHILE_true_nonterm.
  unfold bequiv. auto.
  contradiction.
Qed.

Theorem seq_assoc: forall c1 c2 c3,
    cequiv ((c1 ;; c2) ;; c3) (c1 ;; (c2 ;; c3)).
Proof.
  intros.
  split; intros.
  inversion H; subst.
  inversion H2; subst.
  apply E_Seq with st'1; auto.
  apply E_Seq with st'0; auto.
  inversion H; subst.
  inversion H5; subst.
  apply E_Seq with st'1.
  apply E_Seq with st'0; auto.
  auto.
Qed.

Theorem identity_assignment : forall x,
  cequiv
    (x ::= x)
    SKIP.
Proof.
  intros.
  split; intro H; inversion H; subst.
  - (* -> *)
    rewrite t_update_same.
    apply E_Skip.
  - (* <- *)
    assert (Hx : st' =[ x ::= x ]=> (x !-> st' x ; st')).
    { apply E_Ass. reflexivity. }
    rewrite t_update_same in Hx.
    apply Hx.
Qed.

Theorem assign_aequiv : forall(x : string) e,
  aequiv x e ->
  cequiv SKIP (x ::= e).
Proof.
  intros x e Ha.
  split; intros; unfold aequiv in Ha; inversion H; subst.
  assert (Hx : st' =[ x ::= e ]=> (x !-> st' x ; st')).
  apply E_Ass. eauto.
  rewrite t_update_same in Hx.
  auto.
  rewrite <- Ha. rewrite t_update_same.
  apply E_Skip.
Qed.

Definition prog_a : com :=
  (WHILE ~(X <= 0) DO
    X ::= X + 1
  END)%imp.
Definition prog_b : com :=
  (TEST X = 0 THEN
    X ::= X + 1;;
    Y ::= 1
  ELSE
    Y ::= 0
  FI;;
  X ::= X - Y;;
  Y ::= 0)%imp.
Definition prog_c : com :=
  SKIP%imp.
Definition prog_d : com :=
  (WHILE ~(X = 0) DO
    X ::= (X * Y) + 1
  END)%imp.
Definition prog_e : com :=
  (Y ::= 0)%imp.
Definition prog_f : com :=
  (Y ::= X + 1;;
  WHILE ~(X = Y) DO
    Y ::= X + 1
  END)%imp.
Definition prog_g : com :=
  (WHILE true DO
    SKIP
  END)%imp.
Definition prog_h : com :=
  (WHILE ~(X = X) DO
    X ::= X + 1
  END)%imp.
Definition prog_i : com :=
  (WHILE ~(X = Y) DO
    X ::= Y + 1
  END)%imp.
Definition equiv_classes : list (list com)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(* Do not modify the following line: *)
Definition manual_grade_for_equiv_classes : option (nat*string) := None.

Lemma refl_aequiv : forall (a: aexp), aequiv a a.
Proof. intros a st. reflexivity. Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
      aequiv a1 a2 -> aequiv a2 a1.
Proof.
   intros a1 a2 H. intros st. symmetry. apply H. Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
      aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
   unfold aequiv. intros a1 a2 a3 H12 H23 st.
   rewrite (H12 st). rewrite (H23 st). reflexivity. Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
   unfold bequiv. intros b st. reflexivity. Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
      bequiv b1 b2 -> bequiv b2 b1.
Proof.
   unfold bequiv. intros b1 b2 H. intros st.
   symmetry. apply H. Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
      bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
   unfold bequiv. intros b1 b2 b3 H12 H23 st.
   rewrite (H12 st). rewrite (H23 st). reflexivity. Qed.

Lemma refl_cequiv: forall (c : com), cequiv c c.
Proof.
   unfold cequiv. intros c st st'. apply iff_refl. Qed.

Lemma sym_cequiv: forall (c1 c2 : com),
      cequiv c1 c2 -> cequiv c2 c1.
Proof.
   unfold cequiv. intros c1 c2 H st st'.
   assert(st =[ c1 ]=> st' <-> st =[ c2 ]=> st') as H'.
   apply H.
   apply iff_sym. assumption.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
      (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
      intros P1 P2 P3 H12 H23.
      inversion H12. inversion H23.
      split; intros A.
         apply H1. apply H. apply A.
         apply H0. apply H2. apply A. Qed.

Lemma trans_cequiv: forall (c1 c2 c3 : com),
      cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
   unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
   apply iff_trans with (st =[ c2 ]=> st'). apply H12. apply H23. Qed.

Theorem CAss_congruence : forall x a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss x a1) (CAss x a1').
Proof.
  intros.
  split; intros;
  inversion H0; subst;
  unfold aequiv in H.
  - rewrite H.
    apply E_Ass. auto.
  - rewrite <- H.
    apply E_Ass. auto.
Qed.

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  (* WORKED IN CLASS *)
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  - (* -> *)
    remember (WHILE b1 DO c1 END)%imp as cwhile
      eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileFalse *)
      apply E_WhileFalse. rewrite <- Hb1e. apply H.
    + (* E_WhileTrue *)
      apply E_WhileTrue with (st' := st').
      * (* show loop runs *) rewrite <- Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st'). apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity.
  - (* <- *)
    remember (WHILE b1' DO c1' END)%imp as c'while
      eqn:Heqc'while.
    induction Hce; inversion Heqc'while; subst.
    + (* E_WhileFalse *)
      apply E_WhileFalse. rewrite -> Hb1e. apply H.
    + (* E_WhileTrue *)
      apply E_WhileTrue with (st' := st').
      * (* show loop runs *) rewrite -> Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st'). apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity. Qed.

Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
(* FILL IN HERE *) Admitted.

Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (TEST b THEN c1 ELSE c2 FI)
         (TEST b' THEN c1' ELSE c2' FI).
Proof.
  intros.
  split; intros;
    unfold bequiv in H; unfold cequiv in H0; unfold cequiv in H1;
    inversion H2; subst.
  - apply E_IfTrue. rewrite <- H. auto.
    rewrite <- H0. auto.
  - apply E_IfFalse. rewrite <- H. auto.
    rewrite <- H1. auto.
  - apply E_IfTrue. rewrite H. auto.
    rewrite H0. auto.
  - apply E_IfFalse. rewrite H. auto.
    rewrite H1. auto.
Qed.

Example congruence_example:
  cequiv
    (* Program 1: *)
    (X ::= 0;;
     TEST X = 0
     THEN
       Y ::= 0
     ELSE
       Y ::= 42
     FI)
    (* Program 2: *)
    (X ::= 0;;
     TEST X = 0
     THEN
       Y ::= X - X (* <--- Changed here *)
     ELSE
       Y ::= 42
     FI).
Proof.
  apply CSeq_congruence.
  - apply refl_cequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + apply CAss_congruence. unfold aequiv. simpl.
      * symmetry. apply minus_diag.
    + apply refl_cequiv.
Qed.

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall(a : aexp),
    aequiv a (atrans a).
Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall(b : bexp),
    bequiv b (btrans b).
Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall(c : com),
    cequiv c (ctrans c).

(* constants folding *)

Fixpoint fold_constants_aexp (a: aexp): aexp :=
  match a with
  | ANum n => ANum n
  | AId x => AId x
  | APlus a1 a2 =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2 =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp ((1 + 2) * X)
  = (3 * X)%imp.
Proof. reflexivity. Qed.

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 =? n2 then BTrue else BFalse
      | (a1', a2') =>
          BEq a1' a2'
      end
  | BLe a1 a2 =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 <=? n2 then BTrue else BFalse
      | (a1', a2') =>
          BLe a1' a2'
      end
  | BNot b1 =>
      match (fold_constants_bexp b1) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b1' => BNot b1'
      end
  | BAnd b1 b2 =>
      match (fold_constants_bexp b1,
             fold_constants_bexp b2) with
      | (BTrue, BTrue) => BTrue
      | (BTrue, BFalse) => BFalse
      | (BFalse, BTrue) => BFalse
      | (BFalse, BFalse) => BFalse
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Open Scope imp.

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP =>
      SKIP
  | x ::= a =>
      x ::= (fold_constants_aexp a)
  | c1 ;; c2 =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | TEST b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => TEST b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.
Close Scope imp.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound.
  unfold aequiv. intros.
  induction a; simpl; auto;
    destruct (fold_constants_aexp a1);
    destruct (fold_constants_aexp a2); simpl; auto.
Qed.

Lemma beq_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply beq_nat_true_iff.
Qed.
Lemma blt_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.
Lemma ble_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.leb_le.
Qed.

Hint Resolve blt_reflect ble_reflect beq_reflect : bdestruct.
Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  induction b;
    (* BTrue and BFalse are immediate *)
    try reflexivity.
  - (* BEq *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
    (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. destruct (n =? n0); reflexivity.
  - (* BLe *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
        (subst a1'; rewrite <- fold_constants_aexp_sound; auto).
    replace (aeval st a2) with (aeval st a2') by
        (subst a2'; rewrite <- fold_constants_aexp_sound; auto).
    destruct a1'; destruct a2'; auto. simpl.
    bdestruct (n <=? n0). induction n; auto. simpl. auto.
  - (* BNot *)
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - (* BAnd *)
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.
Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c; simpl.
  - (* SKIP *) apply refl_cequiv.
  - (* ::= *) apply CAss_congruence.
              apply fold_constants_aexp_sound.
  - (* ;; *) apply CSeq_congruence; assumption.
  - (* TEST *)
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
      (* (If the optimization doesn't eliminate the if, then the
          result is easy to prove from the IH and
          fold_constants_bexp_sound.) *)
    + (* b always true *)
      apply trans_cequiv with c1; try assumption.
      apply TEST_true; assumption.
    + (* b always false *)
      apply trans_cequiv with c2; try assumption.
      apply TEST_false; assumption.
  - (* WHILE *)
    remember (fold_constants_bexp b) as b'.
    assert (bequiv b b').
    rewrite Heqb'. apply fold_constants_bexp_sound.
    destruct b';
      (* some thing happened here so I can't finish this in auto *)
      try (apply CWhile_congruence;assumption; assumption).
    apply WHILE_true. assumption.
    apply WHILE_false. assumption.
Qed.

Fixpoint optimize_0plus (e:aexp) : aexp :=
  match e with
  | AId n => AId n
  | ANum n =>
    ANum n
  | APlus (ANum 0) e2 =>
    optimize_0plus e2
  | APlus e1 e2 =>
    APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
    AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
    AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Fixpoint subst_aexp (x : string) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | AId x' =>
      if eqb_string x x' then u else AId x'
  | APlus a1 a2 =>
      APlus (subst_aexp x u a1) (subst_aexp x u a2)
  | AMinus a1 a2 =>
      AMinus (subst_aexp x u a1) (subst_aexp x u a2)
  | AMult a1 a2 =>
      AMult (subst_aexp x u a1) (subst_aexp x u a2)
  end.

Definition subst_equiv_property := forall x1 x2 a1 a2,
  cequiv (x1 ::= a1;; x2 ::= a2)
         (x1 ::= a1;; x2 ::= subst_aexp x1 a1 a2).

Theorem subst_inequiv:
  not subst_equiv_property.
Proof.
  unfold subst_equiv_property.
  intros Contra.
  remember (X ::= X + 1 ;; Y ::= X)%imp as c1.
  remember (X ::= X + 1 ;; Y ::= X + 1)%imp as c2.
  assert (cequiv c1 c2).
  { subst; apply Contra. }
  remember (Y !-> 1 ; X !-> 1) as st1.
  remember (Y !-> 2 ; X !-> 1) as st2.
  assert (H1 : empty_st =[ c1 ]=> st1);
  assert (H2 : empty_st =[ c2 ]=> st2);
  try (subst;
       apply E_Seq with (st' := (X !-> 1));
       apply E_Ass; reflexivity).
  apply H in H1.
  (* Finally, we use the fact that evaluation is deterministic
     to obtain a contradiction. *)
  assert (Hcontra : st1 = st2)
    by (apply (ceval_deterministic c2 empty_st); assumption).
  assert (Hcontra' : st1 Y = st2 Y)
    by (rewrite Hcontra; reflexivity).
  subst. inversion Hcontra'.
Qed.

Inductive var_not_used_in_aexp (x : string) : aexp -> Prop :=
  | VNUNum : forall n, var_not_used_in_aexp x (ANum n)
  | VNUId : forall y, x <> y -> var_not_used_in_aexp x (AId y)
  | VNUPlus : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (APlus a1 a2)
  | VNUMinus : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (AMinus a1 a2)
  | VNUMult : forall a1 a2,
      var_not_used_in_aexp x a1 ->
      var_not_used_in_aexp x a2 ->
      var_not_used_in_aexp x (AMult a1 a2).
Lemma aeval_weakening : forall x st a ni,
  var_not_used_in_aexp x a ->
  aeval (x !-> ni ; st) a = aeval st a.
Proof.
  intros.
  induction H; simpl; try auto.
  apply t_update_neq. assumption.
Qed.

(* Lemma subst_aexp_weak : forall x a1 a2, *)
(*     var_not_used_in_aexp x a1 -> *)
(*     x  *)

Theorem subst_equiv : forall x1 x2 a1 a2,
   var_not_used_in_aexp x1 a1 ->
     cequiv (x1 ::= a1 ;; x2 ::= a2)
         (x1 ::= a1 ;; x2 ::= subst_aexp x1 a1 a2).
Proof.
  split; intros.
  remember (subst_aexp x1 a1 a2) as subx1.
  inversion H0; subst.
  apply E_Seq with (st' := st'0).
  assumption.
Admitted.


Require Import Data.OldList.

(* -------------------------------------------------------------------- *)

(* Haskell-Coq equivalence *)

Require Coq.Lists.List.

Theorem hs_coq_partition {A} (p : A -> bool) (l : list A) :
  partition p l = Coq.Lists.List.partition p l.
Proof.
  unfold partition; induction l; simpl; auto.
Qed.


From isla Require Import opsem.

Definition a7438 : isla_trace :=
  Smt (DeclareConst 42%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R5" [] (RegVal_Base (Val_Symbolic 42%Z)) Mk_annot :t:
  Smt (DeclareConst 44%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R6" [] (RegVal_Base (Val_Symbolic 44%Z)) Mk_annot :t:
  Smt (DefineConst 74%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 42%Z) Mk_annot) Mk_annot) Mk_annot; Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Unop (Bvnot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R5" [] (RegVal_Base (Val_Symbolic 74%Z)) Mk_annot :t:
  Smt (DeclareConst 75%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 75%Z)) Mk_annot :t:
  Smt (DefineConst 76%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 75%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 76%Z)) Mk_annot :t:
  tnil
.