Require Import Contractive ContractiveFacts Env Free FreeFacts Sty StyInd Shape
  ShapeFacts Subst Tac Var Wf.
Require Import Coq.Bool.DecBool.

Lemma subst_preserves_shape :
  forall S X r,
  shape S <> varS ->
  shape (subst X r S) = shape S.
Proof.
  induction S; introv Hvarsh; simpl in *; auto;
    destruct (eq_Var_dec X v); auto.
    exfalso; auto.
Qed.

Lemma subst_preserves_Contractive :
  forall S X R,
  Contractive S ->
  Contractive R ->
  shape R <> varS ->
  Contractive (subst X R S).
Proof.
  introv HcontrS HcontrT HshapeT. induction HcontrS; simpl;
    auto with contractive.
  - destruct (eq_Var_dec X X0).
    * simpl. auto with contractive.
    * constructor; auto with contractive.
      + rewrite subst_preserves_shape; assumption.
  - destruct (eq_Var_dec X X0); simpl; auto with contractive.
Qed.
Hint Resolve subst_preserves_Contractive : subst.

Lemma mu_unfold_preserves_Contractive :
  forall S X,
  Contractive (mu X S) ->
  Contractive (subst X (mu X S) S).
Proof.
  introv H. apply subst_preserves_Contractive; auto with contractive.
  - simpl. autodiscriminate.
Qed.
Hint Resolve mu_unfold_preserves_Contractive : contractive.

Lemma subst_neutral :
  forall S X R,
  ~ Free X S ->
  subst X R S = S.
Proof.
  induction S; introv Hfree; simpl; auto; try solve
    [first [rewrite IHS | rewrite IHS1, IHS2]; auto with free];
    destruct (eq_Var_dec X v); try reflexivity.
  - rewrite IHS; auto with free.
  - subst. exfalso; auto with free.
Qed.

Lemma subst_preserves_Free :
  forall S X Y R,
  X <> Y ->
  Free X S ->
  Free X (subst Y R S).
Proof.
  induction S; introv Hneq Hfree; simpl; try solve
    [inverts1 Hfree; try decompose_or Hfree; auto with free].
  - destruct (eq_Var_dec Y v); simpl; auto with free.
  - inverts Hfree. rewrite ifdec_right; auto with free.
Qed.

Lemma subst_Nonfree :
  forall S X R,
  ~ Free X R ->
  ~ Free X (subst X R S).
Proof.
  introv HR. destruct (Free_dec S X) as [HS | HS].
  - gen S. induction S; introv HS; auto with free.
    * introv H. simpl in H. inverts1 H. destruct H;
        [destruct (Free_dec S1 X) | destruct (Free_dec S2 X)]; unfold not in *;
          auto; rewrite subst_neutral in H; auto.
    * introv H. simpl in H. inverts1 H. destruct H;
        [destruct (Free_dec S1 X) | destruct (Free_dec S2 X)]; unfold not in *;
          auto; rewrite subst_neutral in H; auto.
    * inverts HS. simpl. rewrite ifdec_right; auto with free.
    * inverts HS. simpl. rewrite ifdec_left; auto.
  - introv H. rewrite subst_neutral in H; auto with free.
Qed.

Lemma Free_subst_inversion :
  forall S X Y R,
  Free X (subst Y R S) ->
  Free X R \/ (X <> Y /\ Free X S).
Proof.
  induction S; introv H; simpl in *.
  - auto with free.
  - inverts1 H. apply IHS in H; destruct H; auto with free.
  - inverts1 H. apply IHS in H; destruct H; auto with free.
  - inverts1 H. destruct H; [apply IHS1 in H | apply IHS2 in H]; destruct H;
      intuition (auto with free).
  - inverts1 H. destruct H; [apply IHS1 in H | apply IHS2 in H]; destruct H;
      intuition (auto with free).
  - destruct (eq_Var_dec Y v).
    * subst. inverts H. auto with free.
    * inverts1 H. apply IHS in H. destruct H; auto with free.
  - destruct (eq_Var_dec Y v).
    * auto.
    * inverts1 H. auto with free.
Qed.

Lemma subst_preserves_Closed :
  forall S X R,
  Closed S ->
  Closed R ->
  Closed (subst X R S).
Proof.
  introv HS HR. unfold Closed in *. introv Hfree.
  apply Free_subst_inversion in Hfree. norm_hyp_auto; [eapply HR | eapply HS];
    eauto.
Qed.
Hint Resolve subst_preserves_Closed : subst.

Lemma subst_preserves_Wf :
  forall S X R,
  Wf S ->
  Wf R ->
  Wf (subst X R S).
Proof.
  unfold Wf. introv HS HR. norm_hyp_auto. split.
  - assert (shape R <> varS) by (
      destruct R; simpl; try autodiscriminate; auto with free).
    auto with subst.
  - auto with subst.
Qed.

Lemma mu_unfold_preserves_Closed :
  forall S X,
  Closed (mu X S) ->
  Closed (subst X (mu X S) S).
Proof.
  unfold Closed; introv H; intro Y; specialize H with Y; contradict H;
  apply Free_subst_inversion in H; auto with free.
Qed.
Hint Resolve mu_unfold_preserves_Closed : free.

Lemma mu_unfold_preserves_Wf :
  forall S X,
  Wf (mu X S) ->
  Wf (subst X (mu X S) S).
Proof. unfold Wf. auto with contractive free. Qed.
Hint Resolve mu_unfold_preserves_Wf : wf.

Lemma lt_Sty_mu_prefix_subst :
  forall S X R,
  Contractive S ->
  shape S <> varS ->
  lt_Sty_mu_prefix (subst X R S) (mu X S).
Proof.
  intros S X R; induction S; introv Hcontr Hsh; try solve [constructor].
  - simpl. destruct (eq_Var_dec X v).
    * constructor.
    * simpl. inverts Hcontr. unfold lt_Sty_mu_prefix, Wf_nat.ltof in *.
      apply Lt.lt_n_S. eauto.
  - exfalso; auto.
Qed.

Lemma lt_Sty_mu_prefix_subst_mu :
  forall S X,
  Contractive (mu X S) ->
  lt_Sty_mu_prefix (subst X (mu X S) S) (mu X S).
Proof. intros. apply lt_Sty_mu_prefix_subst; auto with contractive. Qed.
Hint Resolve lt_Sty_mu_prefix_subst_mu : subst.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * ltState

Pierre Letouzey & Laurent Thery

Define a well-founded order on state looking at the number
of valid equations where variables belong to a given list
*)

From Stalmarck Require Import state.
From Coq Require Import Arith.
From Stalmarck Require Import stateDec.
From Coq Require Import Inverse_Image.
From Coq Require Import Compare.
From Coq Require Import Relation_Definitions.

Section lt.
Variable L : list rNat.

(** returns 0 if a=b, 1 otherwise *)
Definition oneState (S : State) (a b : rZ) :=
  match eqStateRzDec S a b with
  | left _ => 0
  | right _ => 1
  end.

(** [oneState] is monotone for inclusion *)
Theorem oneStateLe :
 forall (a b : rZ) (S1 S2 : State),
 inclState S1 S2 -> oneState S2 a b <= oneState S1 a b.
Proof.
intros a b S1 S2 H'; unfold oneState in |- *.
case (eqStateRzDec S1 a b); case (eqStateRzDec S2 a b); auto with stalmarck.
intros H'0 H'1; case H'0; auto with stalmarck.
Qed.

#[local] Hint Resolve oneStateLe : stalmarck.

(** It is strict if inclusion is strict *)
Theorem oneStateLt :
 forall (a b : rZ) (S1 S2 : State),
 inclState S1 S2 ->
 eqStateRz S2 a b -> ~ eqStateRz S1 a b -> oneState S2 a b < oneState S1 a b.
Proof.
intros a b S1 S2 H'; unfold oneState in |- *.
case (eqStateRzDec S1 a b); case (eqStateRzDec S2 a b); auto with stalmarck.
intros H'0 H'1 H'2 H'3; case H'3; auto with stalmarck.
intros H'0 H'1 H'2 H'3; case H'0; auto with stalmarck.
intros H'0 H'1 H'2 H'3; case H'0; auto with stalmarck.
Qed.

#[local] Hint Resolve oneStateLt : stalmarck.

(* Returns 1 if +/- a = +/- b (if the state is not contradictory then 4), O otherwise *)

Definition oneStateAll (S : State) (a b : rNat) :=
  oneState S (rZPlus a) (rZPlus b) + oneState S (rZPlus a) (rZMinus b) +
  (oneState S (rZMinus a) (rZPlus b) + oneState S (rZMinus a) (rZMinus b)).

Theorem lePlusComp : forall a b c d : nat, a <= b -> c <= d -> a + c <= b + d.
Proof.
intros a b c d H' H'0.
apply Nat.le_trans with (m := a + d); auto with stalmarck.
apply Nat.add_le_mono_l; auto with stalmarck.
apply Nat.add_le_mono_r; auto with stalmarck.
Qed.

#[local] Hint Resolve lePlusComp : stalmarck.

(** Monotonicity *)
Theorem oneStateAllLe :
 forall (a b : rNat) (S1 S2 : State),
 inclState S1 S2 -> oneStateAll S2 a b <= oneStateAll S1 a b.
Proof.
intros a b S1 S2 H'; unfold oneStateAll in |- *; generalize oneStateLe;
 intros H'1; auto with stalmarck.
Qed.

#[local] Hint Resolve oneStateAllLe : stalmarck.

Theorem ltlePlusCompL :
 forall a b c d : nat, a < b -> c <= d -> a + c < b + d.
Proof.
intros a b c d H' H'0; apply Nat.lt_le_trans with (m := b + c); auto with stalmarck.
apply Nat.add_lt_mono_r; auto with stalmarck.
Qed.

#[local] Hint Resolve ltlePlusCompL : stalmarck.

Theorem ltlePlusCompR :
 forall a b c d : nat, a <= b -> c < d -> a + c < b + d.
Proof.
intros a b c d H' H'0; apply Nat.le_lt_trans with (m := b + c); auto with stalmarck.
apply Nat.add_lt_mono_l; auto with stalmarck.
Qed.

#[local] Hint Resolve ltlePlusCompR : stalmarck.

(** Strict monotony *)
Theorem oneStateAllLt :
 forall (a b : rZ) (S1 S2 : State),
 inclState S1 S2 ->
 eqStateRz S2 a b ->
 ~ eqStateRz S1 a b ->
 oneStateAll S2 (valRz a) (valRz b) < oneStateAll S1 (valRz a) (valRz b).
Proof.
intros a b S1 S2 H'; unfold oneStateAll in |- *.
case a; case b; simpl in |- *; auto with stalmarck.
Qed.

#[local] Hint Resolve oneStateAllLt : stalmarck.

(** Adds oneStateAll for a list of variable *)
Fixpoint Nrel (S1 : State) (a : rNat) (L1 : list rNat) {struct L1} : nat :=
  match L1 with
  | nil => 0
  | b :: L2 => oneStateAll S1 a b + Nrel S1 a L2
  end.

(** Monotony *)
Theorem NrelLe :
 forall (L1 : list rNat) (a : rNat) (S1 S2 : State),
 inclState S1 S2 -> Nrel S2 a L1 <= Nrel S1 a L1.
Proof.
intros L1 a S1 S2 H'; elim L1; simpl in |- *; auto with stalmarck.
Qed.

#[local] Hint Resolve NrelLe : stalmarck.

(** Strict monotony *)
Theorem NrelLt :
 forall (L1 : list rNat) (a : rNat) (b : rZ) (S1 S2 : State),
 inclState S1 S2 ->
 eqStateRz S2 (rZPlus a) b ->
 ~ eqStateRz S1 (rZPlus a) b ->
 In (valRz b) L1 -> Nrel S2 a L1 < Nrel S1 a L1.
Proof.
intros L1; elim L1; simpl in |- *; auto with stalmarck.
intros a b S1 S2 H' H'0 H'1 H'2; elim H'2; auto with stalmarck.
intros a l H' a0 b S1 S2 H'0 H'1 H'2 H'3; Elimc H'3; intros H'3; auto with stalmarck.
rewrite H'3; auto with stalmarck.
apply ltlePlusCompL; auto with stalmarck.
change
  (oneStateAll S2 (valRz (rZPlus a0)) (valRz b) <
   oneStateAll S1 (valRz (rZPlus a0)) (valRz b)) in |- *;
 auto with stalmarck.
apply ltlePlusCompR; auto with stalmarck.
apply H' with (b := b); auto with stalmarck.
Qed.

#[local] Hint Resolve NrelLt : stalmarck.

(** We do a product between two lists *)
Fixpoint Ncount (S1 : State) (L2 L1 : list rNat) {struct L1} : nat :=
  match L1 with
  | nil => 0
  | a :: L3 => Nrel S1 a L2 + Ncount S1 L2 L3
  end.

Theorem NcountLe :
 forall (L1 L2 : list rNat) (S1 S2 : State),
 inclState S2 S1 -> Ncount S1 L2 L1 <= Ncount S2 L2 L1.
Proof.
intros L1; elim L1; simpl in |- *; auto with stalmarck.
Qed.

#[local] Hint Resolve NcountLe : stalmarck.

Theorem NcountLt :
 forall (L1 L2 : list rNat) (a : rNat) (b : rZ),
 In a L1 ->
 In (valRz b) L2 ->
 forall S1 S2 : State,
 inclState S1 S2 ->
 eqStateRz S2 (rZPlus a) b ->
 ~ eqStateRz S1 (rZPlus a) b -> Ncount S2 L2 L1 < Ncount S1 L2 L1.
Proof.
intros L1; elim L1; simpl in |- *; auto with stalmarck.
intros L2 a b H'; elim H'; auto with stalmarck.
intros a l H' L2 a0 b H'0; Elimc H'0; intros H'0; [ rewrite <- H'0 | idtac ];
 auto with stalmarck.
intros H'1 S1 S2 H'2 H'3 H'4.
apply ltlePlusCompL; auto with stalmarck.
apply NrelLt with (b := b); auto with stalmarck.
intros H'1 S1 S2 H'2 H'3 H'4.
apply ltlePlusCompR; auto with stalmarck.
apply H' with (a := a0) (b := b); auto with stalmarck.
Qed.

(** The value of a state is then the number of non-trivial equations that are not valid *)
Definition valState (S : State) := Ncount S L L.

Theorem vallStateLe :
 forall S1 S2 : State, inclState S1 S2 -> valState S2 <= valState S1.
Proof.
unfold valState in |- *; auto with stalmarck.
Qed.

#[local] Hint Resolve vallStateLe : stalmarck.

(** This number decreases for strict inclusion *)
Theorem vallStateLt :
 forall a b : rZ,
 In (valRz a) L ->
 In (valRz b) L ->
 forall S1 S2 : State,
 inclState S1 S2 ->
 eqStateRz S2 a b -> ~ eqStateRz S1 a b -> valState S2 < valState S1.
intros a; case a; auto with stalmarck.
intros a' b H' H'0 S1 S2 H'1 H'2 H'3; unfold valState in |- *.
apply NcountLt with (a := a') (b := b); auto with stalmarck.
intros a' b H' H'0 S1 S2 H'1 H'2 H'3; unfold valState in |- *.
apply NcountLt with (a := a') (b := rZComp b); auto with stalmarck.
generalize H'0; case b; auto with stalmarck.
apply eqStateRzSym; auto with stalmarck.
Qed.

(** Using [valState] and [lt] we get our order *)
Definition ltState (S1 S2 : State) := valState S1 < valState S2.

Theorem ltStateTrans : transitive State ltState.
Proof.
red in |- *; unfold ltState in |- *; auto with stalmarck.
intros S1 S2 S3 H' H'0.
apply Nat.lt_trans with (m := valState S2); auto with stalmarck.
Qed.

Theorem ltStateEqComp :
 forall S1 S2 S3 S4 : State,
 eqState S1 S3 -> eqState S2 S4 -> ltState S1 S2 -> ltState S3 S4.
Proof.
unfold eqState, ltState in |- *.
intros S1 S2 S3 S4 H' H'0 H'1.
Elimc H'0; intros H'0 H'2.
Elimc H'; intros H' H'3.
apply Nat.lt_le_trans with (m := valState S2); auto with stalmarck.
apply Nat.le_lt_trans with (m := valState S1); auto with stalmarck.
Qed.

Theorem ltStateLt :
 forall a b : rZ,
 In (valRz a) L ->
 In (valRz b) L ->
 forall S1 S2 : State,
 inclState S1 S2 -> eqStateRz S2 a b -> ~ eqStateRz S1 a b -> ltState S2 S1.
Proof.
intros a b H' H'0 S1 S2 H'1 H'2 H'3; red in |- *.
apply vallStateLt with (a := a) (b := b); auto with stalmarck.
Qed.

(** It is well founded *)
Theorem ltStateWf : well_founded ltState.
Proof.
unfold ltState in |- *; apply wf_inverse_image with (B := nat); auto with stalmarck.
try exact lt_wf.
Qed.

End lt.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 311 to 314, whose indices in         *)
(* the_configs range over segment [310, 314).                                 *)
(******************************************************************************)

Lemma red310to314 : reducible_in_range 310 314 the_configs.
Proof. CheckReducible. Qed.


From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Id.
Require Import Core. (* For [Var] only *)
Require Import Unique.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Structures.Equalities.
Require Import Coq.Classes.Morphisms.

Require Import GHC.Base.

Require Import Proofs.GHC.Base.
Require Import Proofs.Data.Foldable.
Require Import Proofs.Data.Traversable.

Require Import Proofs.Axioms.
Require Import Proofs.Unique.

Ltac unfold_zeze :=
  repeat (GHC.Base.unfold_zeze; unfold Core.Eq___Var, Core.Eq___Var_op_zeze__).
Ltac unfold_zsze :=
  repeat (GHC.Base.unfold_zsze; unfold Core.Eq___Var, Core.Eq___Var_op_zsze__).

(** ** Stuff about [Var] and [Unique] *)

Lemma getUnique_varUnique:
    (Unique.getUnique : Var -> Unique.Unique) = varUnique.
Proof.
  unfold Unique.getUnique, Unique.getUnique__,Uniquable__Var,
     Core.Uniquable__Var_getUnique.
  auto.
Qed.

(** ** Properties about [GHC.Base.==] for Var. *)

(* Equal vars have equal keys *)
Lemma eq_unique : forall (v1 v2: Var),
    (v1 == v2) <->
    Unique.getWordKey (Unique.getUnique v1) =
    Unique.getWordKey (Unique.getUnique v2).
Proof.
  intros v1 v2.
  unfold_zeze.
  unfold Unique.getUnique.
  unfold Uniquable__Var, getUnique__, Core.Uniquable__Var_getUnique,
  varUnique.
  destruct v1; destruct v2; simpl;
  apply N.eqb_eq.
Qed.

Instance EqLaws_Var : EqLaws Var := {}.
Proof.
  - unfold ssrbool.reflexive.
    unfold_zeze.
    intros. unfold is_true.
    apply N.eqb_refl.
  - unfold ssrbool.symmetric.
    intros. unfold_zeze.
    rewrite N.eqb_sym; auto.
  - unfold ssrbool.transitive.
    unfold_zeze.
    unfold is_true.
    intros x y z.
    destruct x; destruct y; destruct z; simpl;
    repeat erewrite N.eqb_eq; intro h; rewrite h; auto.
  - intros.
    unfold_zsze.
    unfold_zeze.
    rewrite negb_involutive.
    reflexivity.
Qed.

(** ** [varUnique] *)

Lemma varUnique_iff :
  forall v1 v2,
    v1 == v2 <-> varUnique v1 = varUnique v2.
Proof.
  intros.
  unfold_zeze.
  unfold varUnique.
  set (n1 := realUnique v1).
  set (n2 := realUnique v2).
  unfold is_true.
  rewrite N.eqb_eq.
  unfold Unique.mkUniqueGrimily in *.
  intuition congruence.
Qed.

Lemma In_varUnique_elem : forall a l,
    In (varUnique a) (map varUnique l) <->
    Foldable.elem a l.
Proof.
  intros.
  induction l.
  - simpl. rewrite elem_nil.
    split; intro. contradiction. discriminate.
  - rewrite elem_cons.
    unfold is_true.
    rewrite orb_true_iff.
    split.
    intro h. inversion h.
    left.
    rewrite <- varUnique_iff in *.
    apply Eq_Symmetric in H.
    auto.
    right. tauto.
    intro h.
    rewrite <- IHl in h.
    simpl.
    destruct h.
    left.
    rewrite <- varUnique_iff in *.
    symmetry. auto.
    right. auto.
Qed.

Lemma var_eq_realUnique v1 v2 :
  (v1 == v2) = (realUnique v1 == realUnique v2).
Proof.
  repeat unfold op_zeze__, op_zeze____,Core.Eq___Var_op_zeze__,Core.Eq___Var.
  auto.
Qed.

(** ** A DecidableType structure based on  [GHC.Base.==]. *)

(* Define the Var type as a decidable type by using the Eq instance.
   (This instance only looks at the Unique components of the Var *)

Module Var_as_DT <: BooleanDecidableType <: DecidableType.
  Definition t := Var.

  Definition eqb : t -> t -> bool := _==_.

  Definition eq : t -> t -> Prop := fun x y => eqb x y.

  Definition eq_equiv : Equivalence eq.
  Proof.
  split.
  - unfold eq, eqb, Reflexive.
    apply Eq_refl.
  - unfold eq, eqb, Symmetric.
    eauto using Eq_sym.
  - unfold eq, eqb, Transitive.
    intros x y z h1 h2.
    eapply  Eq_trans; eauto.
  Defined.

  Definition eq_dec : forall x y : t, { eq x y } + { ~ (eq x y) }.
  Proof.
  intros x y.
  unfold eq, eqb.
  unfold_zeze.
  destruct x eqn:X; destruct y eqn:Y;  simpl.
  all: destruct (N.eqb realUnique realUnique0) eqn:EQ ; [left; auto | right; auto].
  Defined.

  Lemma eqb_eq : forall x y, eqb x y = true <-> eq x y.
    unfold eq. tauto.
  Qed.

 Definition eq_refl := eq_equiv.(@Equivalence_Reflexive _ _).
 Definition eq_sym := eq_equiv.(@Equivalence_Symmetric _ _).
 Definition eq_trans := eq_equiv.(@Equivalence_Transitive _ _).

End Var_as_DT.

Lemma realUnique_eq: forall v v',
    (realUnique v =? realUnique v')%N = Var_as_DT.eqb v v'.
Proof.
  intros.
  unfold Var_as_DT.eqb. cbn. reflexivity.
Qed.

(** ** [almostEqual] *)

(* Two [Var]s are almostEqual if they differ only in
   their IdInfo. All other components must be identitical.

   We define this as a [Prop] rather than a bool because
   we do not have a function that determines structural
   equality.
*)

Inductive almostEqual : Var -> Var -> Prop :=
 | AE_TyVar   : forall n u ty,
   almostEqual (Mk_TyVar n u ty)
               (Mk_TyVar n u ty)
 | AE_TcTyVar : forall n u ty1 ty2,
   almostEqual (Mk_TcTyVar n u ty1 ty2)
               (Mk_TcTyVar n u ty1 ty2)
 | AE_Id : forall n u ty ids idd id1 id2,
   almostEqual (Mk_Id n u ty ids idd id1)
               (Mk_Id n u ty ids idd id2).

Lemma almostEqual_refl:
  forall v, almostEqual v v.
Proof. intros. destruct v; constructor. Qed.

Lemma almostEqual_sym:
  forall v1 v2,
    almostEqual v1 v2 -> almostEqual v2 v1.
Proof.
  intros v1 v2 H.
  inversion H; subst; eauto.
  econstructor.
Qed.

Lemma almostEqual_trans:
  forall v1 v2 v3,
    almostEqual v1 v2 -> almostEqual v2 v3 -> almostEqual v1 v3.
Proof.
  intros v1 v2 v3 H1 H2.
  inversion H1; inversion H2; subst; inversion H3; eauto.
  econstructor.
Qed.

Lemma almostEqual_eq :
  forall v1 v2,
    almostEqual v1 v2 -> (v1 == v2).
Proof.
  intros v1 v2 H.
  inversion H; unfold_zeze; simpl; apply N.eqb_refl.
Qed.

(** ** [isJoinId] etc. *)

Lemma isJoinId_eq : forall v,
  isJoinId v = match isJoinId_maybe v with | None => false |Some _ => true end.
Proof.
  unfold isJoinId.
  induction v; auto.
  now destruct id_details.
Qed.

Lemma isJoinId_ae: forall v1 v2,
  almostEqual v1 v2 ->
  isJoinId v1 = isJoinId v2.
Proof.
  intros.
  induction H; reflexivity.
Qed.

Lemma isJoinId_isJoinId_maybe: forall v,
  isJoinId v = true ->
  isJoinId_maybe v = Some (idJoinArity v).
Proof.
  unfold isJoinId.
  induction v; simpl; intros; auto; try discriminate.
  now destruct id_details.
Qed.

Lemma idJoinArity_join: forall v a,
  isJoinId_maybe v = Some a -> idJoinArity v = a.
Proof.
  unfold isJoinId, isJoinId_maybe, idJoinArity.
  induction v; simpl; intros; auto; try discriminate.
  destruct id_details; simpl; try discriminate.
  now inversion H.
Qed.

(** ** [isLocalId] and [isLocalVar] *)

(* Local Vars include localIds as well as type/coercion vars *)

Lemma isLocalId_isLocalVar :
  forall var, isLocalVar var = false -> isLocalId var = false.
Proof.
  intros var.
  unfold isLocalVar.
  unfold isGlobalId.
  unfold isLocalId.
  destruct var.
  simpl. tauto.
  tauto.
  destruct idScope; simpl; tauto.
Qed.

Lemma isLocalVar_isLocalId :
  forall var, isLocalId var = true -> isLocalVar var = true.
Proof.
  intros var.
  unfold isLocalVar.
  unfold isGlobalId.
  unfold isLocalId.
  destruct var.
  simpl. tauto.
  tauto.
  destruct idScope; simpl; tauto.
Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

(** Tactics related to (dependent) equality and proof irrelevance. *)

Set Warnings "-notation-overridden".

Require Import Coq.Program.Tactics.
Require Export Equations.Init.
Require Import Equations.Signature Equations.CoreTactics.
Require Import Equations.Type.Logic.
Require Import Equations.Type.Classes.
Require Import Equations.Type.EqDec.

Set Universe Polymorphism.

Import Sigma_Notations.
Import Id_Notations.
Local Open Scope equations_scope.

Local Set Keyed Unification.

(** Support for the [Equations] command.
   These tactics implement the necessary machinery to solve goals produced by the
   [Equations] command relative to dependent pattern-matching.
   It is inspired from the "Eliminating Dependent Pattern-Matching" paper by
   Goguen, McBride and McKinna. *)

(** The [DependentEliminationPackage] provides the default dependent elimination principle to
   be used by the [equations] resolver. It is especially useful to register the dependent elimination
   principles for things in [Prop] which are not automatically generated, but it can be used for
   modified eliminators too. *)

Polymorphic
Class DependentEliminationPackage (A : Type) :=
  { elim_type : Type ; elim : elim_type }.

(** A higher-order tactic to apply a registered eliminator. *)

Ltac elim_tac tac p :=
  let ty := type of p in
  let eliminator := eval simpl in (elim (A:=ty)) in
    tac p eliminator.

(** Specialization to do case analysis or induction.
   Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register
   generated induction principles. *)

Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p.
Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p.

(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *)

Lemma solution_left@{i j|} : forall {A : Type@{i}} {B : A -> Type@{j}} (t : A), B t -> (forall x, Id x t -> B x).
Proof. intros A B t H x eq. destruct eq. apply H. Defined.

Notation " e # t " := (Id_case _ _ t _ e) (right associativity, at level 65) : equations_scope.
Notation " e # [ P ] t " := (Id_rect_r _ P t _ e) (right associativity, at level 65) : equations_scope.

Lemma Id_sym_invol {A} (x y : A) (e : x = y) : id_sym (id_sym e) = e.
Proof. destruct e. reflexivity. Defined.

Lemma Id_symmetry_dep {A} {t : A} {B : forall (x : A), x = t -> Type} :
  (forall (x : A) (eq : t = x), B x (id_sym eq)) ->
  (forall (x : A) (eq : x = t), B x eq).
Proof.
  intros. rewrite <- Id_sym_invol.
  generalize (id_sym eq). apply X.
Defined.

(* Carefully crafted to avoid introducing commutative cuts. *)
Lemma solution_left_dep@{i j|} : forall {A : Type@{i}} (t : A) {B : forall (x : A), (x = t -> Type@{j})},
    B t 1 -> (forall x (Heq : x = t), B x Heq).
Proof.
  intros A t B H x eq. apply Id_symmetry_dep. clear eq. intros.
  destruct eq. exact H.
Defined.

Lemma solution_right@{i j|} : forall {A : Type@{i}} {B : A -> Type@{j}} (t : A), B t -> (forall x, t = x -> B x).
Proof. intros A B t H x eq. destruct eq. apply H. Defined.

Lemma solution_right_dep@{i j|} : forall {A : Type@{i}} (t : A) {B : forall (x : A), (t = x -> Type@{j})},
    B t 1 -> (forall x (Heq : t = x), B x Heq).
Proof. intros A t B H x eq. destruct eq. apply H. Defined.

Lemma solution_left_let@{i j|} : forall {A : Type@{i}} {B : A -> Type@{j}} (b : A) (t : A),
  (b = t -> B t) -> (let x := b in x = t -> B x).
Proof. intros A B b t H x eq. subst x. destruct eq. apply H. reflexivity. Defined.

Lemma solution_right_let@{i j|} : forall {A : Type@{i}} {B : A -> Type@{j}} (b t : A),
  (t = b -> B t) -> (let x := b in t = x -> B x).
Proof. intros A B b t H x eq. subst x. destruct eq. apply H. reflexivity. Defined.

Lemma deletion@{i j|} : forall {A : Type@{i}} {B : Type@{j}} (t : A), B -> (t = t -> B).
Proof. intros; assumption. Defined.

Lemma simplification_sigma1@{i j|} {A : Type@{i}} {P : Type@{i}} {B : Type@{j}}
  (p q : A) (x : P) (y : P) :
  (p = q -> x = y -> B) -> ((p, x) = (q, y) -> B).
Proof.
  intros * prf eq; revert prf.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 2.
  change y with (pr2 (q, y)) at 2.
  destruct eq. intros eq.
  exact (eq 1 1).
Defined.

Lemma simplification_sigma1_dep@{i j|} {A : Type@{i}} {P : A -> Type@{i}} {B : Type@{j}}
  (p q : A) (x : P p) (y : P q) :
  (forall e : Id@{i} p q, Id (@Id_rew@{i i} A p P x q e) y -> B) ->
  (Id ((p, x)) ((q, y)) -> B).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 3.
  change y with (pr2 (q, y)) at 4.
  destruct X0.
  intros X. eapply (X id_refl). apply id_refl.
Defined.

Definition pack_sigma_nondep@{i} {A : Type@{i}} {P : Type@{i}} {p q : A} {x : P} {y : P}
  (e' : Id p q) (e : Id x y) : Id (p, x) (q, y).
Proof. destruct e'. simpl in e. destruct e. apply id_refl. Defined.

 Lemma simplification_sigma1_nondep_dep@{i j|} {A : Type@{i}} {P : Type@{i}}
  (p q : A) (x : P) (y : P) {B : Id (p, x) (q, y) -> Type@{j}} :
  (forall e' : Id p q, forall e : Id x y, B (pack_sigma_nondep e' e)) ->
  (forall e : Id (sigmaI (fun _ => P) p x) (sigmaI (fun _ => P) q y), B e).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 2 4.
  change y with (pr2 (q, y)) at 2 4.
  destruct e.
  intros X. simpl in *.
  apply (X id_refl id_refl).
Defined.

Definition pack_sigma@{i} {A : Type@{i}} {P : A -> Type@{i}} {p q : A} {x : P p} {y : P q}
  (e' : Id p q) (e : Id (@Id_rew A p P x q e') y) : Id (p, x) (q, y).
Proof. destruct e'. simpl in e. destruct e. apply id_refl. Defined.

Lemma simplification_sigma1_dep_dep@{i j|} {A : Type@{i}} {P : A -> Type@{i}}
  (p q : A) (x : P p) (y : P q) {B : Id (p, x) (q, y) -> Type@{j}} :
  (forall e' : Id p q, forall e : Id (@Id_rew A p P x q e') y, B (pack_sigma e' e)) ->
  (forall e : Id ((p, x)) ((q, y)), B e).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 3 5.
  change y with (pr2 (q, y)) at 4 6.
  destruct e.
  intros X. simpl in *.
  apply (X id_refl id_refl).
Defined.

(*  Lemma simplification_sigma1'@{i j} {A : Type@{i}} {P : A -> Type@{i}} {B : Type@{j}} (p q : A) (x : P p) (y : P q) : *)
(*   (forall e : Id p q, Id (Id_rew A p P x q e) y -> B) -> *)
(*   (Id ((p, x)) ((q, y)) -> B). *)
(* Proof. *)
(*   intros. revert X. *)
(*   change p with (pr1 (p, x)). *)
(*   change q with (pr1 (q, y)). *)
(*   change x with (pr2 (p, x)) at 3. *)
(*   change y with (pr2 (q, y)) at 4. *)
(*   destruct X0. *)
(*   intros X. eapply (X id_refl). apply id_refl. *)
(* Defined. *)

Lemma pr2_inv_uip@{i|} {A : Type@{i}}
            {P : A -> Type@{i}} {x : A} {y y' : P x} :
  y = y' -> sigmaI@{i} P x y = sigmaI@{i} P x y'.
Proof. exact (solution_right (B:=fun y' => (x, y) = (x, y')) y 1 y'). Defined.

Lemma pr2_uip@{i|} {A : Type@{i}}
            {E : UIP A} {P : A -> Type@{i}} {x : A} {y y' : P x} :
  sigmaI@{i} P x y = sigmaI@{i} P x y' -> y = y'.
Proof.
  refine (simplification_sigma1_dep_dep@{i i} _ _ _ _ _).
  intros e'. destruct (uip 1 e'). intros e ; exact e.
Defined.

Lemma pr2_uip_refl@{i|} {A : Type@{i}}
      {E : UIP A} (P : A -> Type@{i}) (x : A) (y : P x) :
  pr2_uip@{i} (@id_refl _ (x, y)) = 1.
Proof.
  unfold pr2_uip, simplification_sigma1_dep_dep.
  now rewrite uip_refl_refl.
Defined.

(** If we have decidable equality on [A] we use this version which is
   axiom-free! *)
Lemma simplification_sigma2_uip@{i j |} {A : Type@{i}} {uip : UIP A} {P : A -> Type@{i}}
      {B : Type@{j}} (p : A) (x y : P p) :
  (x = y -> B) -> ((p , x) = (p, y) -> B).
Proof. intros t e. apply t. exact (pr2_uip@{i} e). Defined.

 Lemma simplification_sigma2_uip_refl@{i j|} :
  forall {A : Type@{i}} {uip:UIP A} {P : A -> Type@{i}} {B : Type@{j}}
    (p : A) (x : P p) (G : x = x -> B),
      @simplification_sigma2_uip A uip P B p x x G 1 = G 1.
Proof.
  intros. unfold simplification_sigma2_uip. now rewrite pr2_uip_refl.
Defined.

Arguments simplification_sigma2_uip : simpl never.

 Lemma simplification_K_uip@{i j|} {A : Type@{i}} `{UIP A} (x : A) {B : x = x -> Type@{j}} :
  B 1 -> (forall p : x = x, B p).
Proof. apply UIP_K. Defined.

Arguments simplification_K_uip : simpl never.

Lemma simplification_K_uip_refl@{i j|} :
  forall {A : Type@{i}} `{UIP A} (x : A) {B : x = x -> Type@{j}}
         (p : B 1),
  simplification_K_uip x p 1 = p.
Proof.
  intros.
  unfold simplification_K_uip, UIP_K. now rewrite uip_refl_refl.
Defined.

Definition ind_pack@{i|} {A : Type@{i}} {B : A -> Type@{i}} {x : A} {p q : B x} (e : p = q) :
  @Id (sigma (fun x => B x)) (x, p) (x, q) := (pr2_inv_uip e).

Definition ind_pack_inv_equiv@{i|} {A : Type@{i}} {uip : UIP A}
           {B : A -> Type@{i}} {x : A} (p q : B x) (e : p = q) :
  pr2_uip (pr2_inv_uip e) = e.
Proof.
  destruct e. apply pr2_uip_refl.
Defined.

Definition opaque_ind_pack_inv@{i j|} {A : Type@{i}} {uip : UIP A}
  {B : A -> Type@{i}} {x : A} {p q : B x} (G : p = q -> Type@{j}) (e : (x, p) = (x, q)) :=
  G (pr2_uip@{i} e).
Arguments opaque_ind_pack_inv : simpl never.
Arguments pr2_uip : simpl never.
Arguments pr2_inv_uip : simpl never.

Lemma simplify_ind_pack@{i j|} {A : Type@{i}} {uip : UIP A}
      (B : A -> Type@{i}) (x : A) (p q : B x) (G : p = q -> Type@{j}) :
      (forall e : (x, p) = (x, q), opaque_ind_pack_inv G e) ->
  (forall e : p = q, G e).
Proof.
  intros H. intros e.
  specialize (H (ind_pack e)). unfold opaque_ind_pack_inv in H.
  rewrite ind_pack_inv_equiv in H. apply H.
Defined.
Arguments simplify_ind_pack : simpl never.

Lemma simplify_ind_pack_inv@{i j|} {A : Type@{i}} {uip : UIP A}
      (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j}) :
  G 1 -> opaque_ind_pack_inv G 1.
Proof.
  intros H. unfold opaque_ind_pack_inv. destruct (pr2_uip_refl B x p). exact H.
Defined.
Arguments simplify_ind_pack_inv : simpl never.

Definition simplified_ind_pack@{i j|} {A : Type@{i}} {uip : UIP A}
  (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
  (t : opaque_ind_pack_inv G 1) :=
  Id_rew _ G t _ (@pr2_uip_refl A uip B x p).
Arguments simplified_ind_pack : simpl never.

Lemma simplify_ind_pack_refl@{i j|} {A : Type@{i}} {uip : UIP A}
(B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
(t : forall (e : (x, p) = (x, p)), opaque_ind_pack_inv G e) :
  simplify_ind_pack B x p p G t 1 =
  simplified_ind_pack B x p G (t 1).
Proof. reflexivity. Qed.

Lemma simplify_ind_pack_elim@{i j|} {A : Type@{i}} {uip : UIP A}
  (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
  (t : G 1) :
  simplified_ind_pack B x p G (simplify_ind_pack_inv B x p G t) = t.
Proof.
  unfold simplified_ind_pack, simplify_ind_pack_inv.
  now destruct (pr2_uip_refl B x p).
Qed.

(** All the simplification rules involving UIP are treated as opaque
  when proving lemmas about definitions. To actually compute with these
  inside Coq, one has to make them transparent again. *)

Global Opaque simplification_sigma2_uip
       (* simplification_sigma2_dec_point *)
       simplification_K_uip
       simplify_ind_pack simplified_ind_pack.
Global Opaque opaque_ind_pack_inv.

Ltac rewrite_sigma2_refl_noK :=
  match goal with
  | |- context [@inj_right_sigma ?A ?H ?x ?P ?y ?y' _] =>
    rewrite (@inj_right_sigma_refl A H x P y)

  | |- context [@simplification_sigma2_uip ?A ?H ?P ?B ?p ?x ?y ?X 1] =>
    rewrite (@simplification_sigma2_uip_refl A H P B p x X); simpl

  (* | |- context [@simplification_sigma2_dec_point ?A ?p ?H ?P ?B ?x ?y ?X 1] => *)
  (*   rewrite (@simplification_sigma2_dec_point_refl A p H P B x X); simpl *)

  | |- context [@simplification_K_uip ?A ?dec ?x ?B ?p 1] =>
    rewrite (@simplification_K_uip_refl A dec x B p); simpl eq_rect

  | |- context [@simplify_ind_pack ?A ?uip ?B ?x ?p _ ?G _ 1] =>
    rewrite (@simplify_ind_pack_refl A uip B x p G _)

  | |- context [@simplified_ind_pack ?A ?uip ?B ?x ?p ?G
        (simplify_ind_pack_inv _ _ _ _ ?t)] =>
    rewrite (@simplify_ind_pack_elim A uip B x p G t)
  end.

Ltac rewrite_sigma2_refl := rewrite_sigma2_refl_noK.

(** This hint database and the following tactic can be used with [autounfold] to
   unfold everything to [eq_rect]s. *)

#[global]
Hint Unfold solution_left solution_right
  Id_sym_invol Id_symmetry_dep
  solution_left_dep solution_right_dep deletion
  simplification_sigma1
  simplification_sigma1_dep
  apply_noConfusion
  Id_rect_r Id_rec Id_ind Id_rew Id_rew_r Id_case : equations.

(** Makes these definitions disappear at extraction time *)
Extraction Inline solution_right_dep solution_right solution_left solution_left_dep.
Extraction Inline Id_sym_invol Id_symmetry_dep.
Extraction Inline solution_right_let solution_left_let deletion.
Extraction Inline simplification_sigma1 simplification_sigma2_uip.
Extraction Inline simplification_K_uip.
Extraction Inline simplification_sigma1 simplification_sigma1_dep.
Extraction Inline simplification_sigma1_nondep_dep simplification_sigma1_dep_dep.

(** Simply unfold as much as possible. *)

Ltac unfold_equations := repeat progress autounfold with equations.
Ltac unfold_equations_in H := repeat progress autounfold with equations in H.

Ltac rewrite_refl_id :=
  repeat (progress (autorewrite with refl_id) || (try rewrite_sigma2_refl)).

Ltac simplify_equations_in e :=
  repeat progress (autounfold with equations in e ; simpl in e).

(** Using these we can make a simplifier that will perform the unification
   steps needed to put the goal in normalised form (provided there are only
   constructor forms). Compare with the lemma 16 of the paper.
   We don't have a [noCycle] procedure yet. *)

Ltac block_equality id :=
  match type of id with
    | @eq ?A ?t ?u => change (let _ := block in (@eq A t u)) in id
    | _ => idtac
  end.

Ltac revert_blocking_until id :=
  Tactics.on_last_hyp ltac:(fun id' =>
    match id' with
      | id => idtac
      | _ => block_equality id' ; revert id' ; revert_blocking_until id
    end).

Ltac not_var x := try (is_var x; fail 1).

(** These two tactics are dangerous as they can try to reduce terms
    to head-normal-form and take ages to fail. *)
Ltac try_discriminate := discriminate.
Ltac try_injection H := injection H.

Ltac simplify_one_dep_elim :=
  match goal with
    | [ |- context [Id_rect _ _ _ _ _ 1]] => simpl Id_rect
    | [ |- context [Id_rew _ _ _ _ 1]] => simpl Id_rew
    | [ |- context [Id_rew_r _ _ _ _ 1]] => simpl Id_rew_r
    | [ |- context [@Id_rect_r _ _ _ _ _ id_refl]] => simpl Id_rect_r
    | [ |- context [noConfusion_inv _]] => simpl noConfusion_inv
    | [ |- @opaque_ind_pack_inv ?A ?uip ?B ?x ?p _ ?G 1] =>
            apply (@simplify_ind_pack_inv A uip B x p G)
    | [ |- let _ := block in _ ] => fail 1
    | [ |- _ ] => (simplify * || simplify ?); cbv beta
    | [ |- _ -> ?B ] => let ty := type of B in (* Works only with non-dependent products *)
      intro || (let H := fresh in intro H)
    | [ |- forall x, _ ] => let H := fresh x in intro H
    | [ |- _ ] => intro
  end.

(** Repeat until no progress is possible. By construction, it should leave the goal with
   no remaining equalities generated by the [generalize_eqs] tactic. *)

Ltac simplify_dep_elim := repeat simplify_one_dep_elim.

(** Apply [noConfusion] on a given hypothsis. *)

Ltac noconf H :=
  block_goal; revert_until H; block_goal;
  on_last_hyp ltac:(fun H' => revert H');
  simplify_dep_elim;
  intros_until_block;
  intros_until_block.

(** Reverse and simplify. *)

Ltac simpdep := reverse; simplify_dep_elim.

(** Decompose existential packages. *)

Ltac decompose_exists id id' := hnf in id ;
  match type of id with
    | @sigma _ _ => let xn := fresh id "'" in
      destruct id as [xn id]; decompose_exists xn id;
        cbv beta delta [ pr1 pr2 ] iota in id, id';
          decompose_exists id id'
    | _ => cbv beta delta [ pr1 pr2 ] iota in id, id'
  end.

(** Dependent generalization using existentials only. *)

Ltac generalize_sig_gen id cont :=
  let id' := fresh id in
  get_signature_pack id id';
  hnf in (value of id'); hnf in (type of id');
  lazymatch goal with
  | id' := ?v |- context[ id ] =>
    generalize (@id_refl _ id' : v = id') ;
    clearbody id'; simpl in id';
    cont id id' id v
  | id' := ?v |- _ =>
    let id'1 := fresh id' in let id'2 := fresh id' in
    set (id'2 := pr2 id'); set (id'1 := pr1 id') in id'2;
    hnf in (value of id'1), (value of id'2);
    try red in (type of id'2);
    match goal with
      [ id'1 := ?t |- _ ] =>
      generalize (@id_refl _ id'1 : t = id'1);
        clearbody id'2 id'1; clear id' id;
        try unfold signature in id'2; hnf in id'2; simpl in id'2;
        rename id'2 into id; cont id id id'1 t
    end
  end.

Ltac generalize_sig id cont :=
  generalize_sig_gen id
    ltac:(fun id id' id'1 t => (* Fails if id = id' *)
            try rename id into id', id' into id;
          cont id'1 id).

Ltac generalize_sig_vars id cont :=
  generalize_sig_gen id
    ltac:(fun id id' id'1 t => move_after_deps id' t; revert_until id';
          rename id' into id; cont id'1 id).

Ltac Id_generalize_sig_gen id cont :=
  let id' := fresh id in
  get_signature_pack id id';
  hnf in (value of id'); hnf in (type of id');
  lazymatch goal with
  | id' := ?v |- context[ id ] =>
    generalize (@id_refl _ id' : Id id' id') ;
    unfold id' at 1;
    clearbody id'; simpl in id';
    cont id id' id' v
  | id' := ?v |- _ =>
    let id'1 := fresh id' in let id'2 := fresh id' in
    set (id'2 := pr2 id'); set (id'1 := pr1 id') in id'2;
    hnf in (value of id'1), (value of id'2);
    match goal with
    | [ id'1 := ?t |- _ ] =>
      generalize (@id_refl _ id'1 : Id t id'1);
        clearbody id'2 id'1;
        clear id' id; compute in id'2;
        rename id'2 into id; cont id id id'1 v
    end
  end.

Ltac Id_generalize_sig id cont :=
  Id_generalize_sig_gen id
    ltac:(fun id id' id'1 t => (* Fails if id = id' *)
            try rename id into id', id' into id;
          cont id'1 id).

Ltac Id_generalize_sig_vars id cont :=
  Id_generalize_sig_gen id
    ltac:(fun id id' id'1 t => move_after_deps id' t; revert_until id';
          rename id' into id; cont id'1 id).

Ltac generalize_sig_dest id :=
  generalize_sig id ltac:(fun id id' => decompose_exists id id').

Ltac generalize_sig_vars_dest id :=
  generalize_sig_vars id ltac:(fun id id' => decompose_exists id id').

Ltac generalize_eqs_sig id :=
  (needs_generalization id ; generalize_sig_dest id)
    || idtac.

Ltac generalize_eqs_vars_sig id :=
  (needs_generalization id ; generalize_sig_vars_dest id)
    || idtac.

(** The default implementation of generalization using sigma types. *)

Ltac generalize_by_eqs id := generalize_eqs_sig id.
Ltac generalize_by_eqs_vars id := generalize_eqs_vars_sig id.

(** Do dependent elimination of the last hypothesis, but not simplifying yet
   (used internally). *)

Ltac destruct_last :=
  on_last_hyp ltac:(fun id => simpl in id ; generalize_by_eqs id ; destruct id).

(** The rest is support tactics for the [Equations] command. *)

Definition hide_pattern {A : Type} (t : A) := t.

Definition add_pattern {B} (A : Type) (b : B) := A.

(** To solve a goal by inversion on a particular target. *)

Ltac do_empty id :=
  exfalso ; simpl in id ;
  solve [ generalize_by_eqs id ; destruct id ; simplify_dep_elim
    | apply id ; eauto with Below ].

(** If defining recursive functions, the prototypes come first. *)

Ltac introduce p := first [
  match p with _ => (* Already there, generalize dependent hyps *)
    generalize dependent p ; intros p
  end
  | intros until p | intros until 1 | intros ].

Ltac do_case p := introduce p ; (elim_case p || destruct p || (case p ; clear p)).
Ltac do_ind p := introduce p ; (elim_ind p || induction p).

(** The following tactics allow to do induction on an already instantiated inductive predicate
   by first generalizing it and adding the proper equalities to the context, in a maner similar to
   the BasicElim tactic of "Elimination with a motive" by Conor McBride. *)

(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis
   and starts a dependent elimination using this tactic. *)

Ltac is_introduced H :=
  match goal with
    | [ H' : _ |- _ ] => match H' with H => idtac end
  end.

Tactic Notation "intro_block" hyp(H) :=
  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Tactic Notation "intro_block_id" ident(H) :=
  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Ltac unblock_dep_elim :=
  match goal with
    | |- let _ := block in ?T =>
      match T with context [ block ] =>
        change T ; intros_until_block
      end
    | _ => unblock_goal
  end.

(** A tactic that tries to remove trivial equality guards in induction hypotheses coming
   from [dependent induction]/[generalize_eqs] invocations. *)

  Ltac simplify_IH_hyps := repeat
   match goal with
     | [ hyp : context [ block ] |- _ ] =>
     cbn beta in hyp; eqns_specialize_eqs_block hyp;
     cbn beta iota delta[eq_rect_r eq_rect] zeta in hyp
   end.

Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim.

Ltac do_intros H :=
  (try intros until H) ; (intro_block_id H || intro_block H) ;
  (try simpl in H ; simplify_equations_in H).

Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_by_eqs H ; tac H.

Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim; unblock_goal.

Ltac do_depind tac H :=
  (try intros until H) ; intro_block H ; (try simpl in H ; simplify_equations_in H) ;
  generalize_by_eqs_vars H ; tac H ; simpl_dep_elim; unblock_goal.

(** To dependent elimination on some hyp. *)

Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id.

Ltac depelim_term c :=
  let H := fresh "term" in
    set (H:=c) in *; clearbody H ; depelim H.

(** Used internally. *)

Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id.

(** To dependent induction on some hyp. *)

Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.

(** A variant where generalized variables should be given by the user. *)

Ltac do_depelim' tac H :=
  (try intros until H) ; block_goal ; generalize_by_eqs H ; tac H ; simplify_dep_elim ;
    simplify_IH_hyps ; unblock_goal.

(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
   By default, we don't try to generalize the hyp by its variable indices.  *)

Tactic Notation "dependent" "destruction" ident(H) :=
  do_depelim' ltac:(fun hyp => do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => destruct hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the elimination. *)

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => revert l ; do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H.

(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by
   writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before
   calling [induction]. *)

Tactic Notation "dependent" "induction" ident(H) :=
  do_depind ltac:(fun hyp => do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "using" constr(c) :=
  do_depind ltac:(fun hyp => induction hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the induction. *)

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H.

(** [solve_equation] is used to prove the equation lemmas for an existing definition.  *)

Ltac find_empty := simpl in * ; exfalso ;
  match goal with
    | [ H : _ |- _ ] => solve [ clear_except H ; dependent elimination H | eqns_specialize_eqs H ; assumption ]
    | [ H : _ <> _ |- _ ] => solve [ red in H ; eqns_specialize_eqs H ; assumption ]
  end.

Ltac make_simplify_goal :=
  match goal with
  | [ |- ?R ?A ?T ?U ] => let eqP := fresh "eqP" in
      set (eqP := fun x : A => R A x U) ; change (eqP T)
  end.

Ltac hnf_gl :=
  match goal with
    [ |- ?P ?T ] => let T' := eval hnf in T in
      change_no_check (P T')
  end.

Ltac hnf_eq :=
  match goal with
  | |- ?R ?x ?y =>
    let x' := eval hnf in x in
    let y' := eval hnf in y in
        change_no_check (R x' y')
  end.

Ltac red_one_eq :=
  match goal with
  |- ?R ?x ?y =>
    let x' := eval red in x in
    let y' := eval red in y in
    change_no_check (R x' y')
  end.

Ltac red_eq :=
  match goal with
    |- ?R ?x ?y =>
    let rec reduce_eq x y :=
      let x' := eval red in x in
      let y' := eval red in y in
      (reduce_eq x' y' || change_no_check (R x' y'))
      in reduce_eq x y
  end.

Ltac red_eq_lhs :=
  match goal with
    |- ?R ?x ?y =>
      let x' := eval red in x in
      change_no_check (R x' y)
  end.

Ltac red_gl :=
  match goal with
    |- ?P ?x =>
    let rec reduce x :=
      let x' := eval red in x in
      (reduce x' || change_no_check (P x'))
      in reduce x
  end.

Ltac rewrite_sigma2_rule_noK c :=
  match c with
  | @inj_right_sigma ?A ?H ?x ?P ?y ?y' _ =>
    rewrite (@inj_right_sigma_refl A H x P y)
  | @simplify_ind_pack ?A ?uip ?B ?x ?p _ ?G _ 1 =>
    rewrite (@simplify_ind_pack_refl A uip B x p G _)
  | @simplification_sigma2_uip ?A ?H ?P ?B ?p ?x ?y ?X 1=>
    rewrite (@simplification_sigma2_uip_refl A H P B p x X); simpl
  (* | @simplification_sigma2_dec_point ?A ?p ?H ?P ?B ?x ?y ?X 1=> *)
  (*   rewrite (@simplification_sigma2_dec_point_refl A p H P B x X); simpl *)
  | @simplification_K_uip ?A ?dec ?x ?B ?p 1=>
    rewrite (@simplification_K_uip_refl A dec x B p); simpl eq_rect
  end.

Ltac rewrite_sigma2_rule c :=
  rewrite_sigma2_rule_noK c.

Ltac rewrite_sigma2_term x :=
  match x with
   | ?f _ _ _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ => rewrite_sigma2_rule f
   | ?f _ => rewrite_sigma2_rule f
   | ?f => rewrite_sigma2_rule f
  end.

Ltac rewrite_sigma2_refl_eq :=
  match goal with
    |- ?x = ?y => rewrite_sigma2_term x || rewrite_sigma2_term y
  end.

Ltac rewrite_sigma2_refl_goal :=
  match goal with
  | |- ?P ?x => rewrite_sigma2_term x
  end.

(* Ltac simpl_equations :=  *)
(*   repeat (repeat (simpl; (hnf_eq || rewrite_sigma2_refl_eq || autorewrite with refl_id); simpl); *)
(*           try progress autounfold with equations). *)

(* Ltac simplify_equation c := *)
(*   make_simplify_goal ; simpl ; *)
(*   repeat (try autounfoldify c; *)
(*           try (red_gl || rewrite_sigma2_refl_goal || autorewrite with refl_id) ; simpl). *)

Ltac simpl_equations :=
  repeat (repeat (simpl; hnf_eq; rewrite_refl_id);
          try progress autounfold with equations).

Ltac simpl_equation_impl :=
  repeat (unfold_equations; rewrite_refl_id).

Ltac simplify_equation c :=
  make_simplify_goal; simpl;
  repeat (try autounfold_ref c;
          progress (simpl; unfold_equations) ||
          (progress (autorewrite with refl_id)) ||
          reflexivity ||
          (progress (rewrite_sigma2_refl))).

Ltac solve_equation c :=
  intros ; try simplify_equation c ; try
    (match goal with
       | [ |- ImpossibleCall _ ] => find_empty
       | _ => try red; try (reflexivity || discriminates)
     end).

Definition depelim_module := tt.

Register depelim_module as equations.depelim.module.


Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Arith.EqNat.
Require Import Ascii.
Require Import Keys.

Definition empty_set `{T: Type} := Empty_set T.
Definition singleton_set `{T: Type} (e: T) := Singleton T e.
Definition set_union `{T: Type} (s1 s2: Ensemble T) := Union T s1 s2.
Definition set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.In T s e.
Definition not_set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.Complement T s e.
Definition included `{T: Type} (s1 s2: Ensemble T) := Ensembles.Included T s1 s2.
Definition set_minus `{T: Type} (s: Ensemble T) (e: T)  := Ensembles.Subtract T s e.

(* Static Labels *)
Definition Region :=  nat.

(* Program Variables *)
Definition Name := ascii.

Inductive rgn2 : bool * bool * bool -> Set :=
  | Rgn2_Const : forall fv bv, Region -> rgn2 (true, fv, bv)
  | Rgn2_FVar : forall c bv, Name -> rgn2 (c, true, bv)
  | Rgn2_BVar : forall c fv, nat -> rgn2 (c, fv, true).
Definition rgn2_in_exp := rgn2 (true, true, false).
Definition rgn2_in_typ := rgn2 (true, true, true).

Definition mk_rgn_type (u: rgn2_in_exp) : rgn2_in_typ
 := match u with
      | Rgn2_Const fv bv n => Rgn2_Const true true n
      | Rgn2_FVar c bv n => Rgn2_FVar true true n
      | Rgn2_BVar c fv n => Rgn2_BVar true true n
    end.

(* Static Actions; for type-and-effect system *)
Inductive StaticAction2 : Set :=
| SA2_Alloc : rgn2_in_typ -> StaticAction2
| SA2_Read  : rgn2_in_typ -> StaticAction2
| SA2_Write : rgn2_in_typ -> StaticAction2.

Definition Epsilon2 := Ensemble StaticAction2. (* FSetWeakList.Make (Epsilon2Decidable). *)

(* substitute for type *)
Inductive type2 :=
  | Ty2_Natural : type2
  | Ty2_Boolean : type2
  | Ty2_Effect  : type2
  | Ty2_Unit    : type2
  | Ty2_Ref     : rgn2_in_typ -> type2 -> type2
  | Ty2_Arrow   : type2 -> Epsilon2 -> type2 -> Epsilon2 -> type2 -> type2
  | Ty2_ForallRgn : Epsilon2 -> type2 -> type2.

(** begin of openings **)
Definition opening_rgn_in_rgn2 (k : nat) (u: rgn2_in_typ) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ _ => t
    | Rgn2_BVar _ _ n => if (beq_nat n k) then u else t
    end.

Definition opening_rgn_in_sa2 (k : nat) (u: rgn2_in_typ) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (opening_rgn_in_rgn2 k u rgn)
  | SA2_Read rgn  => SA2_Read (opening_rgn_in_rgn2 k u rgn)
  | SA2_Write rgn => SA2_Write (opening_rgn_in_rgn2 k u rgn)
  end.

Definition opening_rgn_in_eps2 (k : nat) (u: rgn2_in_typ) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists sa', eps sa' /\ opening_rgn_in_sa2 k u sa' = sa.

Fixpoint opening_rgn_exp (k: nat) (u: rgn2_in_typ) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural => t
  | Ty2_Boolean => t
  | Ty2_Effect  => t
  | Ty2_Unit    => t
  | Ty2_Ref rgn ty => Ty2_Ref (opening_rgn_in_rgn2 k u rgn) (opening_rgn_exp k u ty)
  | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (opening_rgn_exp k u aty)
                                                   (opening_rgn_in_eps2 k u ceff) (opening_rgn_exp k u crty)
                                                   (opening_rgn_in_eps2 k u eeff) (opening_rgn_exp k u erty)
  | Ty2_ForallRgn eff rty => Ty2_ForallRgn (opening_rgn_in_eps2 (S k) u eff) (opening_rgn_exp (S k) u rty)
  end.

Definition open_rgn_eff (u: rgn2_in_typ)  (eps: Epsilon2) : Epsilon2 := opening_rgn_in_eps2 0 u eps.
Definition open (u: rgn2_in_typ)  (t: type2) : type2 := opening_rgn_exp 0 u t.
Definition open_var (t : type2) (x : Name) : type2 :=
  let rgn_fvar := Rgn2_FVar true true x
  in opening_rgn_exp 0 (rgn_fvar) t.

(** end of openings **)

(** begin of substitutions **)
Definition subst_rgn  (z : Name) (u : rgn2_in_exp) (t: rgn2_in_typ) : rgn2_in_typ :=
  match t with
    | Rgn2_Const _ _ r => t
    | Rgn2_FVar _ _ r  => if (AsciiVars.eq_dec z r) then mk_rgn_type u else t
    | Rgn2_BVar _ _ _  => t
  end.

Definition subst_sa (z : Name) (u : rgn2_in_exp) (t: StaticAction2) : StaticAction2 :=
 match t with
  | SA2_Alloc rgn => SA2_Alloc (subst_rgn z u rgn)
  | SA2_Read rgn  => SA2_Read  (subst_rgn z u rgn)
  | SA2_Write rgn => SA2_Write (subst_rgn z u rgn)
 end.

Definition subst_eps  (z : Name) (u : rgn2_in_exp) (t: Epsilon2) : Epsilon2 :=
   fun sa => exists sa', t sa' /\ subst_sa z u sa' = sa.

Reserved Notation "'[' x ':=' u ']' t" (at level 20).
Fixpoint subst_type (z : Name) (u : rgn2_in_exp) (t : type2) {struct t} : type2 :=
  match t with
    | Ty2_Natural => Ty2_Natural
    | Ty2_Boolean => Ty2_Boolean
    | Ty2_Effect  => Ty2_Effect
    | Ty2_Unit    => Ty2_Unit
    | Ty2_Ref r t => Ty2_Ref (subst_rgn z u r) (subst_type z u t)
    | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (subst_type z u aty) (subst_eps z u ceff) (subst_type z u crty)
                                                     (subst_eps z u eeff) (subst_type z u erty)
    | Ty2_ForallRgn eff rty => Ty2_ForallRgn (subst_eps z u eff) (subst_type z u rty)
  end
where "'[' x ':=' u ']' t" := (subst_type x u t).

(** end of substitutions **)

(** begin of free regions **)
Definition free_rgn_vars_in_rgn2 (rgn: rgn2_in_typ) : Ensemble Name :=
  match rgn with
  | Rgn2_Const _ _ _ => empty_set
  | Rgn2_FVar _ _ n => singleton_set n
  | Rgn2_BVar _ _ _ => empty_set
  end.

Definition free_region (rgn: rgn2_in_typ) : Ensemble Name := free_rgn_vars_in_rgn2 rgn.

Definition free_rgn_vars_in_sa2 (sa: StaticAction2) : Ensemble Name :=
  match sa with
  | SA2_Alloc rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Read rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Write rgn => free_rgn_vars_in_rgn2 rgn
  end.

Definition free_rgn_vars_in_eps2 (eps: Epsilon2) : Ensemble Name :=
  fun n => exists sa, eps sa -> (free_rgn_vars_in_sa2 sa) n.

Fixpoint frv (t: type2) : Ensemble Name :=
  match t with
  | Ty2_Natural    => empty_set
  | Ty2_Boolean    => empty_set
  | Ty2_Effect     => empty_set
  | Ty2_Unit       => empty_set
  | Ty2_Ref rgn ty => set_union (free_rgn_vars_in_rgn2 rgn) (frv ty)
  | Ty2_Arrow aty ceff crty eeff erty =>
                      set_union (frv aty)
                                (set_union (set_union (free_rgn_vars_in_eps2 ceff)
                                                      (free_rgn_vars_in_eps2 eeff))
                                           (set_union (frv crty)
                                                      (frv erty)))
  | Ty2_ForallRgn eff rty => set_union (free_rgn_vars_in_eps2 eff)
                                       (frv rty)
  end.

Notation "x '#' t" := (not_set_elem (frv t) x) (at level 60).

(** end of free regions **)

(** begin of closings **)
Definition closing_rgn_in_rgn2 (k : nat) (x: Name) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ n  => if AsciiVars.eq_dec n x then (Rgn2_BVar true true k) else t
    | Rgn2_BVar _ _ _  => t
    end.

Definition closing_rgn_in_sa2 (k : nat) (x: Name) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (closing_rgn_in_rgn2 k x rgn)
  | SA2_Read rgn  => SA2_Read (closing_rgn_in_rgn2 k x rgn)
  | SA2_Write rgn => SA2_Write (closing_rgn_in_rgn2 k x rgn)
  end.

Definition closing_rgn_in_eps2 (k : nat) (x: Name) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists sa', eps sa' /\ closing_rgn_in_sa2 k x sa' = sa.

Fixpoint closing_rgn_exp (k: nat) (x: Name) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural => t
  | Ty2_Boolean => t
  | Ty2_Effect  => t
  | Ty2_Unit    => t
  | Ty2_Ref rgn ty => Ty2_Ref (closing_rgn_in_rgn2 k x rgn) (closing_rgn_exp k x ty)
  | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (closing_rgn_exp k x aty)
                                                   (closing_rgn_in_eps2 k x ceff) (closing_rgn_exp k x crty)
                                                   (closing_rgn_in_eps2 k x eeff) (closing_rgn_exp k x erty)
  | Ty2_ForallRgn eff rty => Ty2_ForallRgn (closing_rgn_in_eps2 (S k) x eff) (closing_rgn_exp (S k) x rty)
  end.

Definition close_var (x : Name) (t : type2) := closing_rgn_exp 0 x t.
Definition close_var_eff (x : Name) (eps : Epsilon2) := closing_rgn_in_eps2 0 x eps.
(** end of closings **)

(** locally closed **)
Inductive lc_type_rgn : rgn2_in_typ -> Prop :=
     | lc_rgn_const : forall r, lc_type_rgn (Rgn2_Const true true r)
     | lc_rgn_fvar  : forall r, lc_type_rgn (Rgn2_FVar true true r).

Inductive lc_type_sa : StaticAction2 -> Prop :=
     | lc_sa_alloc : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Alloc r)
     | lc_sa_read  : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Read r)
     | lc_sa_write : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Write r).

Inductive lc_type_eps : Epsilon2 -> Prop :=
     | lc_eps : forall eps, (forall (sa : StaticAction2), eps sa /\ lc_type_sa (sa)) ->
                            lc_type_eps (eps).

Definition lc u := lc_type_rgn (mk_rgn_type u).

Inductive lc_type : type2 -> Prop :=
  | lc_natural : lc_type Ty2_Natural
  | lc_ref     : forall r t,
                   lc_type_rgn r -> lc_type t -> lc_type (Ty2_Ref r t)
  | lc_arrow   : forall aty ceff crty eeff erty,
                   lc_type aty -> lc_type_eps ceff -> lc_type crty ->
                   lc_type_eps eeff -> lc_type erty ->
                   lc_type (Ty2_Arrow aty ceff crty eeff erty)
  | lc_forall  : forall L eff rty,
                   (forall x, not_set_elem L x -> lc_type (open_var rty x)) ->
                   lc_type_eps eff ->
                   lc_type rty ->
                   lc_type (Ty2_ForallRgn eff rty).
(** end of locally closed **)

(** definitions of lemmas **)

Definition close_open_var := forall t x, x # t -> close_var x (open_var t x) = t.

Definition open_close_var := forall x t, lc_type t -> open_var (close_var x t) x = t.

Definition open_var_inj := forall x t1 t2, x # t1 -> x # t2 -> open_var t1 x = open_var t2 x -> t1 = t2.

Definition open_lc := forall u t, lc_type t -> open u t = t.

Definition subst_open := forall x u t v, lc u -> [x := u] (open v t) = open (subst_rgn x u v) ([x := u] t).

Definition subst_open_var := forall x y u t, x <> y -> lc u -> [x := u] (open_var t y) = open_var ([x := u] t) y.

Definition subst_fresh := forall x t u, x # t -> [x := u] t = t.

Definition subst_intro := forall x t u, x # t -> lc u -> open (mk_rgn_type u) t = [x := u] (open_var t x).

Definition subst_as_close_open := forall x t u, lc_type t ->
                                                [x := u] t = open  (mk_rgn_type u) (close_var x t).

(** end of lemmas **)

Lemma subst_as_close_open_rgn : forall n r x u, lc_type_rgn r ->
                                               subst_rgn x u r = opening_rgn_in_rgn2 n (mk_rgn_type u) (closing_rgn_in_rgn2 n x r).
Proof.
  intros n r x u H. inversion H; subst; simpl.
  - reflexivity.
  - destruct (AsciiVars.eq_dec x r0).
    + inversion e. destruct (AsciiVars.eq_dec r0 r0); simpl.
      * rewrite NPeano.Nat.eqb_refl. reflexivity.
      * unfold AsciiVars.eq in *. contradict n0. reflexivity.
    + destruct (AsciiVars.eq_dec r0 x); unfold AsciiVars.eq in *.
      * symmetry in e. contradiction.
      * simpl. reflexivity.
Qed.

Lemma subst_as_close_open_sa : forall n x u sa, lc_type_sa sa ->
                                                subst_sa x u sa =
                                                opening_rgn_in_sa2 n (mk_rgn_type u) (closing_rgn_in_sa2 n x sa).
Proof.
  intros n x u sa H.
  inversion H; subst;
  unfold subst_sa, opening_rgn_in_sa2, closing_rgn_in_sa2;
  f_equal; now apply subst_as_close_open_rgn.
Qed.

Lemma subst_as_close_open_eps : forall n x u e, lc_type_eps e ->
                                                subst_eps x u e =
                                                opening_rgn_in_eps2 n (mk_rgn_type u) (closing_rgn_in_eps2 n x e).
Proof.
  intros n x u e H .
  apply Extensionality_Ensembles.
  unfold Same_set, Included. intuition; unfold In in *.
  - unfold subst_eps in H0. inversion H; subst.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2.
    destruct H0 as [sa [H2 H3]]. subst.
    exists (closing_rgn_in_sa2 n x sa). split.
    + exists sa. intuition.
    + rewrite <- subst_as_close_open_sa; auto.
      destruct (H1 sa). assumption.
  - unfold subst_eps. inversion H; subst.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
    destruct H0 as [x' [[x'' [H2 H3]] H4]]. subst.
    destruct (H1 x''). exists x''. intuition.
    rewrite <- subst_as_close_open_sa; auto.
Qed.

Lemma SUBST_AS_CLOSE_OPEN : subst_as_close_open.
Proof.
  intros x t u H. unfold open, close_var. generalize 0.
  dependent induction t; intros; simpl; try (solve [reflexivity]).
  - f_equal;[ | apply IHt]. unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
    unfold rgn2_in_typ in r. dependent induction r.
    + reflexivity.
    + destruct (AsciiVars.eq_dec n x); destruct (AsciiVars.eq_dec x n).
      * rewrite NPeano.Nat.eqb_refl. reflexivity.
      * unfold  AsciiVars.eq in *. symmetry in e. contradiction.
      * unfold  AsciiVars.eq in *. symmetry in e. contradiction.
      * reflexivity.
    + inversion H; subst. inversion H2.
    + now inversion H.
  - f_equal;[apply IHt1 | | apply IHt2 | | apply IHt3]; inversion H; subst; auto.
    + now apply subst_as_close_open_eps.
    + now apply subst_as_close_open_eps.
  - f_equal;[ | apply IHt]; inversion H; subst; auto.
    + now apply subst_as_close_open_eps.
Qed.

Lemma close_open_rgn :
  forall r n x, (In Name (free_rgn_vars_in_rgn2 r) x -> False) ->
                closing_rgn_in_rgn2 n x (opening_rgn_in_rgn2 n (Rgn2_FVar true true x) r) = r.
Proof.
  intros r n x H.
  unfold closing_rgn_in_rgn2, opening_rgn_in_rgn2.
  unfold rgn2_in_typ in r; dependent induction r; intros.
  - reflexivity.
  - case (AsciiVars.eq_dec n x); intros.
    + contradict H. inversion e; subst. unfold free_rgn_vars_in_rgn2. apply In_singleton.
    + reflexivity.
  - case_eq (beq_nat n n0); intros; simpl; [ | reflexivity].
    destruct (AsciiVars.eq_dec x x); [apply beq_nat_true in H0; subst; reflexivity | intuition].
Qed.

Lemma close_open_sa :
  forall sa n x, (In Name (free_rgn_vars_in_sa2 sa) x -> False) ->
                 closing_rgn_in_sa2 n x (opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa) = sa.
Proof.
  intros sa n x H.
  unfold closing_rgn_in_sa2, opening_rgn_in_sa2.
  destruct sa; rewrite close_open_rgn; auto.
Qed.

Lemma close_open_eps :
  forall e x n , (In Name (free_rgn_vars_in_eps2 e) x -> False) ->
                 closing_rgn_in_eps2 n x (opening_rgn_in_eps2 n (Rgn2_FVar true true x) e) = e.
Proof.
  intros e x n H.
  apply Extensionality_Ensembles.
  split.
  + intro sa. unfold In in *.
    unfold closing_rgn_in_eps2; unfold opening_rgn_in_eps2; simpl.

    intros [sa' [[sa'' [H2 H3]] H1]]. subst.
    rewrite close_open_sa; eauto.
    intro. apply H.
    unfold free_rgn_vars_in_eps2; unfold In.
    exists sa''; auto.
  + intro sa. unfold In in *.
    unfold closing_rgn_in_eps2; unfold opening_rgn_in_eps2; simpl.
    intro H1.
    exists (opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa).
    rewrite close_open_sa.
    split; [exists sa; auto | reflexivity].
    intro. apply H.
    unfold free_rgn_vars_in_eps2; unfold In.
    exists sa; auto.
Qed.

Lemma CLOSE_OPEN_VAR : close_open_var.
Proof.
  intros t x H.  unfold close_var, open_var. generalize 0.
  induction t; simpl; intuition;
  unfold not_set_elem, set_union, empty_set, Complement, not in *.
  - simpl in H. assert (H' : In Name (free_rgn_vars_in_rgn2 r) x -> False)
      by (intros; apply H; now apply Union_introl).
    f_equal; unfold rgn2_in_typ in r; dependent induction r; subst; simpl.
    + reflexivity.
    + case (AsciiVars.eq_dec n x); intros. unfold AsciiVars.eq in e; subst.
      * contradict H'. unfold free_rgn_vars_in_rgn2. apply In_singleton.
      * reflexivity.
    + case_eq (beq_nat n n0); intros; simpl.
      * apply beq_nat_true in H0; subst.
        destruct (AsciiVars.eq_dec x x);  [reflexivity | contradict n; reflexivity].
      * reflexivity.
    + apply IHt. intros. apply H. now apply Union_intror.
    + apply IHt. intros. apply H. now apply Union_intror.
    + apply IHt. intros. apply H. now apply Union_intror.
  - simpl in H. f_equal.
    + apply IHt1; intuition.
    + apply close_open_eps.
      intros. apply H. apply Union_intror. apply Union_introl. now apply Union_introl.
    + apply IHt2; intuition.
    + apply close_open_eps.
      intros. apply H. apply Union_intror. apply Union_introl. now apply Union_intror.
    +  apply IHt3; intuition.
  - simpl in H. f_equal.
    + apply close_open_eps.
      intros. apply H.  now apply Union_introl.
    + apply IHt.
      intros. apply H.  now apply Union_intror.
Qed.

Lemma OPEN_VAR_INJ : open_var_inj.
Proof.
  intros x t1 t2 HF1 HF2 HEq.
  rewrite <- (CLOSE_OPEN_VAR t1 x); auto.
  rewrite <- (CLOSE_OPEN_VAR t2 x); auto.
  f_equal. assumption.
Qed.

Lemma open_close_rgn : forall r n x, lc_type_rgn r ->
                                     opening_rgn_in_rgn2 n (Rgn2_FVar true true x) (closing_rgn_in_rgn2 n x r) = r.
Proof.
  intros. induction H; unfold opening_rgn_in_rgn2, closing_rgn_in_rgn2.
  - reflexivity.
  - destruct (AsciiVars.eq_dec r x).
    + rewrite NPeano.Nat.eqb_refl. inversion e; now subst.
    + reflexivity.
Qed.
(*  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl.
  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl.
  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl. *)

Lemma opening_lc_sa : forall n x sa, lc_type_sa sa ->
                                     opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa = sa.
Proof.
  intros n x sa H. unfold opening_rgn_in_sa2.
  dependent induction sa; f_equal; inversion H; subst; inversion H1; simpl; reflexivity.
Qed.

Lemma open_close_sa : forall n x sa, lc_type_sa sa ->
                                     opening_rgn_in_sa2 n (Rgn2_FVar true true x) (closing_rgn_in_sa2 n x sa) = sa.
Proof.
  intros n x sa H.
  induction H; unfold opening_rgn_in_sa2, closing_rgn_in_sa2;
  now rewrite open_close_rgn.
Qed.

Lemma open_close_eps : forall eff n x, lc_type_eps eff ->
                                       opening_rgn_in_eps2 n (Rgn2_FVar true true x) (closing_rgn_in_eps2 n x eff) = eff.
Proof.
  intros eff n x H. unfold opening_rgn_in_eps2, closing_rgn_in_eps2.
  apply Extensionality_Ensembles.
  split.
  - intro sa. unfold In in *.
    intros [sa' [[sa'' [H2 H3]] H1]]. subst. inversion H; subst.
    destruct (H0 sa'').
    unfold opening_rgn_in_sa2, closing_rgn_in_sa2.
    destruct sa''; rewrite open_close_rgn; auto; inversion H3; now subst.
  - intro sa. intros. unfold In in *.
    inversion H; subst.
    exists (closing_rgn_in_sa2 n x sa). split.
    + exists sa. intuition.
    + destruct (H1 sa).
      rewrite open_close_sa; auto.
Qed.

Lemma OPEN_CLOSE_VAR : open_close_var.
Proof.
  intros x t H. unfold open_var, close_var. generalize 0.
  induction H; intros; simpl.
  - reflexivity.
  - f_equal; [ rewrite open_close_rgn; auto | apply IHlc_type].
  - f_equal; try (solve [rewrite  open_close_eps; auto]); [apply IHlc_type1 | apply IHlc_type2 | apply IHlc_type3].
  - f_equal. rewrite  open_close_eps; auto. apply  IHlc_type.
Qed.

Lemma open_subst_lc_sa: forall n u sa,
                          lc_type_sa sa -> opening_rgn_in_sa2 n u sa = sa.
Proof.
  intros n u sa H.
  unfold opening_rgn_in_sa2.
  inversion H; subst;
  unfold opening_rgn_in_rgn2; unfold rgn2_in_typ in r;
  dependent induction r; try (solve [reflexivity | inversion H1 | inversion H; inversion H2]).
Qed.

Lemma open_subst_lc_eps: forall n u eff, lc_type_eps eff -> opening_rgn_in_eps2 n u eff = eff.
Proof.
  intros n u eff Hlc.
  induction Hlc; intros; simpl.
  apply Extensionality_Ensembles. unfold Same_set, Included.
  intuition; unfold In in *.
  - unfold opening_rgn_in_eps2 in H0.
    destruct H0 as [x' [H1 H2]].
    erewrite open_subst_lc_sa in H2; eauto.
    + now subst.
    + destruct (H x'); auto.
  - unfold opening_rgn_in_eps2.
    exists x. intuition.
    erewrite open_subst_lc_sa; eauto.
    destruct (H x); auto.
Qed.

Lemma OPEN_LC : open_lc.
Proof.
  intros u t Hlc. unfold open.
  generalize 0. induction Hlc; intros; simpl.
  - reflexivity.
  - f_equal; [| apply IHHlc].
    unfold opening_rgn_in_rgn2.
    unfold rgn2_in_typ in r. dependent induction r.
    + reflexivity.
    + reflexivity.
    + inversion H.
  - f_equal; try (solve [apply IHHlc1 | apply IHHlc2 | apply IHHlc3]).
    + apply Extensionality_Ensembles. unfold Same_set, Included.
      split; intros. unfold In in *.
      * destruct H1 as [x' ?]. intuition.
        inversion H; subst.
        destruct (H1 x').
        eapply open_subst_lc_sa in H4; eauto.
        now rewrite H4.
      * rewrite open_subst_lc_eps; auto.
    + apply Extensionality_Ensembles. unfold Same_set, Included.
      split; intros. unfold In in *.
      * destruct H1 as [x' ?]. intuition.
        inversion H0; subst.
        destruct (H1 x').
        eapply open_subst_lc_sa in H4; eauto.
        now rewrite H4.
      * rewrite open_subst_lc_eps; auto.
  - f_equal; [ rewrite open_subst_lc_eps; auto | apply IHHlc].
Qed.

Lemma subst_open_rgn : forall x u n v r, subst_rgn x u (opening_rgn_in_rgn2 n v r) =
                                         opening_rgn_in_rgn2 n (subst_rgn x u v) (subst_rgn x u r).
Proof.
  intros x u n v r.
  unfold rgn2_in_typ in r.
  dependent induction r; try (solve [reflexivity]).
  - destruct (AsciiVars.eq_dec n0 x).
    + unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
      inversion e; subst.
      destruct (AsciiVars.eq_dec x x); [ | reflexivity].
      unfold rgn2_in_exp in u.
      dependent induction u; simpl; reflexivity.
    + unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
      unfold AsciiVars.eq in n1.
      destruct (AsciiVars.eq_dec x n0); [ | reflexivity].
      unfold AsciiVars.eq in e. symmetry in e. contradiction.
  - unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
    case (beq_nat n0 n); [ | reflexivity].
    unfold rgn2_in_typ in v.
    dependent induction v; reflexivity.
Qed.

Lemma subst_open_sa: forall n x u v e,
                        subst_sa x u (opening_rgn_in_sa2 n v e) =
                        opening_rgn_in_sa2 n (subst_rgn x u v) (subst_sa x u e).
Proof.
  intros n x u v e.
  destruct e; simpl; f_equal; rewrite subst_open_rgn; reflexivity.
Qed.

Lemma subst_open_eps: forall n x u v e,
                        (*lc_type_eps e ->*)
                        subst_eps x u (opening_rgn_in_eps2 n v e) =
                        opening_rgn_in_eps2 n (subst_rgn x u v) (subst_eps x u e).
Proof.
  intros n x u v e.
  unfold subst_eps, opening_rgn_in_eps2.
  apply Extensionality_Ensembles; unfold Same_set, Included.
  intuition; unfold In in *;
  destruct H as [x1 [[x2 [H2 H3]] H4]]; subst.
  - rewrite subst_open_sa.
    exists (subst_sa x u x2); intuition. exists x2; intuition.
  - rewrite <- subst_open_sa.
    exists (opening_rgn_in_sa2 n v x2); intuition. exists x2; intuition.
Qed.

Lemma SUBST_OPEN : subst_open.
Proof.
  intros x u t v.  unfold open.  generalize 0.
  induction t; intros; simpl.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - (*unfold open_rgn_in_type, close_rgn_in_type; simpl.*)
    f_equal; [ |  apply IHt]; auto.
    fold (subst_rgn x u (opening_rgn_in_rgn2 n v r)).
    fold (subst_rgn x u r).
    rewrite subst_open_rgn; auto.
  - (*unfold open_rgn_in_type, close_rgn_in_type; simpl.*)
    f_equal; try (solve [now apply IHt1 | now apply IHt2 | now apply IHt3]).
    + rewrite subst_open_eps; auto.
    + rewrite subst_open_eps; auto.
  - f_equal; [ |  apply IHt]; auto.
    rewrite subst_open_eps; auto.
Qed.

Lemma SUBST_OPEN_VAR : subst_open_var.
Proof.
  intros x y u t H Hlc.
  unfold open_var.
  rewrite SUBST_OPEN; auto.
  unfold open. f_equal. simpl.
  destruct (AsciiVars.eq_dec x y).
  - inversion e. contradiction.
  - reflexivity.
Qed.

Lemma singleton_eq : forall x y, x = y <-> Singleton Name x y.
Proof.
  intros x y. split.
  - intros H; subst. apply In_singleton.
  - intros H. now inversion H.
Qed.

Lemma subst_fresh_rgn : forall r x u, not_set_elem (free_region r) x ->
                                      subst_rgn x u r = r.
Proof.
  intros r x u H.
  unfold not_set_elem, free_region, Complement in H.
  unfold free_rgn_vars_in_rgn2 in H.
  unfold subst_rgn.
  unfold rgn2_in_typ in r.
  dependent induction r.
  - reflexivity.
  - unfold not, In, singleton_set in H.
    assert (x <> n) by (contradict H; now apply singleton_eq).
    destruct (AsciiVars.eq_dec x n).
    + inversion e. contradiction.
    + reflexivity.
  - reflexivity.
Qed.

Lemma subst_fresh_sa : forall sa x u, not_set_elem (free_rgn_vars_in_sa2 sa) x ->
                                      subst_sa x u sa = sa.
Proof.
  intros sa x u H.
  unfold not_set_elem, Complement, free_rgn_vars_in_sa2 in H.
  induction sa; unfold subst_sa, subst_rgn; f_equal;
  unfold free_rgn_vars_in_rgn2 in H; unfold In in *;
  unfold rgn2_in_typ in r;
  dependent induction r; try (solve [reflexivity |
                                     assert (x <> n) by (contradict H; now apply singleton_eq);
                                     destruct (AsciiVars.eq_dec x n); [inversion e; contradiction | reflexivity]]).
Qed.

Lemma subst_fresh_sa_ext :forall (e : Epsilon2) sa x u, e sa -> not_set_elem (free_rgn_vars_in_sa2 sa) x ->
                                                        (exists sa' : StaticAction2, e sa' /\ subst_sa x u sa' = sa).
Proof.
  intros e sa x u H.
  exists sa. intuition.
  now apply subst_fresh_sa.
Qed.

Lemma subst_fresh_eps : forall e x u, not_set_elem (free_rgn_vars_in_eps2 e) x ->
                                      subst_eps x u e = e.
Proof.
  intros e x u H.
  unfold free_rgn_vars_in_eps2 in H.
  unfold subst_eps.
  apply Extensionality_Ensembles; unfold Same_set, Included.
  split.
  - unfold In. intros x0.
    intros [sa' [H1 H2]]. subst.
    rewrite subst_fresh_sa; auto.
    unfold not_set_elem, Complement, In, not in *.
    intros. apply H. exists sa'. intuition.
  - unfold In.   intros x0 H0.
    exists x0. intuition.
    rewrite subst_fresh_sa; auto.
    unfold not_set_elem, Complement, In, not in *.
    intros. apply H. exists x0. intuition.
Qed.

Lemma SUBST_FRESH : subst_fresh.
Proof.
  intros x. induction t; intros u H; simpl.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - unfold not_set_elem, Complement in H.
    f_equal; [ | apply IHt].
    + apply subst_fresh_rgn.
      unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_introl.
    + unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_intror.
  - unfold not_set_elem, Complement in H.
    f_equal; [apply IHt1 | | apply IHt2 | | apply IHt3].
    + unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_introl.
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H.  apply Union_intror.  apply Union_introl. now  apply Union_introl.
    + unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H. apply Union_intror.  apply Union_intror. now apply Union_introl.
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H.  apply Union_intror.  apply Union_introl. now  apply Union_intror.
    + unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H. apply Union_intror.  apply Union_intror. now apply Union_intror.
  - f_equal; [ | apply IHt].
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement in *.
      simpl in H. unfold not in *. intros.
      apply H. now apply Union_introl.
    + simpl in H. unfold not_set_elem, free_region, Complement in *.
      unfold not in *. intros. apply H. now apply Union_intror.
Qed.

Lemma SUBST_INTRO : subst_intro.
Proof.
  intros x t u H1 H2. unfold open_var.
  replace (opening_rgn_exp 0 (Rgn2_FVar true true x) t) with (open  (Rgn2_FVar true true x) t) by (now unfold open).
  rewrite SUBST_OPEN; auto. f_equal.
  - simpl in *; destruct (AsciiVars.eq_dec x x); intros;
    [reflexivity | unfold AsciiVars.eq in n; contradict n; reflexivity ].
  - symmetry. now apply SUBST_FRESH.
Qed .


(* This file is automatically generated from the OCaml source file
<repository_root>/ml_sources/examples/crdt/oplib/examples/pncounter/pncounter_code.ml *)

From aneris.aneris_lang Require Import ast.
From aneris.aneris_lang.lib.serialization Require Import serialization_code.
From aneris.aneris_lang.lib Require Import list_code.
From aneris.examples.crdt.oplib Require Import oplib_code.

Definition pncounter_effect : val :=
  λ: "msg" "counter",
  let: "delta" := Fst (Fst "msg") in
  let: "_x" := Snd (Fst "msg") in
  let: "_y" := Snd "msg" in
  "counter" + "delta".

Definition pncounter_init_st : val := λ: <>, #0.

Definition pncounter_crdt : val :=
  λ: <>, (pncounter_init_st, pncounter_effect).

Definition pncounter_init : val :=
  λ: "addrs" "rid",
  let: "initRes" := oplib_init int_ser int_deser "addrs" "rid" pncounter_crdt in
  let: "get_state" := Fst "initRes" in
  let: "update" := Snd "initRes" in
  ("get_state", "update").


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q R S T U V : Universe, ((wd_ P T /\ (wd_ T Q /\ (wd_ R T /\ (wd_ T S /\ (wd_ Q U /\ (wd_ U R /\ (wd_ P V /\ (wd_ P Q /\ (wd_ Q S /\ (wd_ P S /\ (wd_ Q R /\ (wd_ R S /\ (wd_ U V /\ (wd_ R V /\ (wd_ P R /\ (col_ U P V /\ (col_ Q U R /\ (col_ R T S /\ (col_ P T Q /\ col_ P R V))))))))))))))))))) -> col_ P Q S)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ A I /\ (wd_ I B /\ (wd_ A B /\ (wd_ P I /\ (wd_ Q I /\ (wd_ C I /\ (col_ A I B /\ (col_ P Q I /\ col_ A C I)))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List Coq.Setoids.Setoid Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Set Implicit Arguments.

Local Coercion is_true : bool >-> Sortclass.

Instance proper_if {A B R}
         {test : bool} {then_case else_case}
         `{Proper (A -> B) R then_case, Proper (A -> B) R else_case}
: Proper R (fun x => if test then then_case x else else_case x).
Proof.
  destruct test; trivial.
Qed.
Instance proper_idmap {A R}
: Proper (R ==> R) (fun x : A => x).
Proof. repeat intro; assumption. Qed.
Instance proper_const {A B} {R1 : relation A} {R2}
         `{Reflexive B R2} v
: Proper (R1 ==> R2) (fun _ => v).
Proof.
  repeat intro; reflexivity.
Qed.
Instance pointwise_Proper {A B} R (f : A -> B) `{forall x, Proper R (f x)}
: Proper (pointwise_relation A R) f.
Proof.
  unfold Proper in *.
  repeat intro; trivial.
Qed.

Global Instance sumbool_rect_Proper {L R : Prop} {P} {R1}
: Proper (pointwise_relation L R1 ==> pointwise_relation R R1 ==> @forall_relation _ (fun _ : {L} + {R} => P) (fun _ => R1))
         (@sumbool_rect L R (fun _ => P)).
Proof.
  intros ?????? [a|a]; simpl in *; eauto.
Qed.

Global Hint Extern 0 (Proper _ (@sumbool_rect ?L ?R (fun _ => ?P))) => refine (@sumbool_rect_Proper L R P _) : typeclass_instances.

Global Instance andb_Proper
: Proper (eq ==> eq ==> eq) andb.
Proof.
  repeat ((intro; progress subst) || intros []); try reflexivity.
Qed.
Global Instance orb_Proper
: Proper (eq ==> eq ==> eq) orb.
Proof.
  repeat ((intro; progress subst) || intros []); try reflexivity.
Qed.

Global Instance map_Proper_eq {A B}
: Proper (pointwise_relation _ eq ==> eq ==> eq) (@map A B).
Proof.
  intros ?? H ? ls ?; subst.
  induction ls; trivial; simpl.
  hnf in H; rewrite H, IHls; reflexivity.
Qed.

Global Instance bool_rect_Proper {P} {R1}
: Proper (R1 ==> R1 ==> @forall_relation _ (fun _ : bool => P) (fun _ => R1))
         (@bool_rect (fun _ => P)).
Proof.
  intros ?????? [|]; simpl in *; eauto.
Qed.

Global Instance fst_eq_Proper {A B} : Proper (eq ==> eq) (@fst A B).
Proof.
  repeat intro; subst; reflexivity.
Qed.
Global Instance snd_eq_Proper {A B} : Proper (eq ==> eq) (@snd A B).
Proof.
  repeat intro; subst; reflexivity.
Qed.

Global Instance: Proper (eq ==> Basics.flip Basics.impl) is_true | 10 := _.
Global Instance: Proper (eq ==> Basics.impl) is_true | 10 := _.
Global Instance: Proper (eq ==> iff) is_true | 5 := _.
Global Instance: Proper (eq ==> eq) is_true | 0 := _.

Global Instance istrue_impl_Proper
: Proper (implb ==> Basics.impl) is_true.
Proof.
  intros [] []; compute; trivial.
Qed.

Global Instance istrue_flip_impl_Proper
: Proper (Basics.flip implb ==> Basics.flip Basics.impl) is_true.
Proof.
  intros [] []; compute; trivial.
Qed.

Global Instance implb_Reflexive : Reflexive implb.
Proof. intros []; reflexivity. Qed.
Global Instance implb_Transitive : Transitive implb.
Proof. intros [] [] []; simpl; trivial. Qed.
Global Instance implb_Antisymmetric : @Antisymmetric _ eq _ implb.
Proof. intros [] [] []; simpl; trivial. Qed.

Global Instance flip_implb_Reflexive : Reflexive (Basics.flip implb).
Proof. intros []; reflexivity. Qed.
Global Instance flip_implb_Transitive : Transitive (Basics.flip implb).
Proof. intros [] [] []; simpl; trivial. Qed.
Global Instance flip_implb_Antisymmetric : @Antisymmetric _ eq _ (Basics.flip implb).
Proof. intros [] []; compute; intros [] []; trivial. Qed.

Global Instance implb_implb_Proper0
: Proper (implb ==> Basics.flip implb ==> Basics.flip implb) implb.
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_implb_Proper1
: Proper (Basics.flip implb ==> implb ==> implb) implb.
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_flip_implb_Proper0
: Proper (Basics.flip implb ==> implb ==> Basics.flip implb) (Basics.flip implb).
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_flip_implb_Proper1
: Proper (implb ==> Basics.flip implb ==> implb) (Basics.flip implb).
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance subrelation_eq_pointwise {A B} : subrelation (@eq (A -> B)) (pointwise_relation A eq).
Proof.
  compute; intros; subst; reflexivity.
Qed.

Global Instance and_flip_impl_Proper
  : Proper (Basics.flip Basics.impl ==> Basics.flip Basics.impl ==> Basics.flip Basics.impl) and.
Proof. lazy; tauto. Qed.

Global Instance map_Proper_eq_In {A B ls}
  : Proper (forall_relation (fun a x y => List.In a ls -> x = y) ==> eq) (fun f => @List.map A B f ls).
Proof.
  induction ls as [|l ls IHls];
    unfold forall_relation.
  { repeat intro; reflexivity. }
  { intros ?? H.
    simpl; rewrite H by (left; reflexivity).
    f_equal.
    rewrite IHls; [ reflexivity | ].
    intros ??; apply H; right; assumption. }
Qed.