(** by Evelyne Contejean, LRI *)

(** * Term algebra defined as functor from a Module Signature and a Module Variable.*)

From Coq Require Import List Arith.
From hydras Require Import more_list list_permut list_set.

Set Implicit Arguments.

(** * Module Type Signature.
 There are almost no assumptions, except a decidable equality
and an arity function. *)
Module Type Signature.

  Parameter symb : Set.
  Axiom eq_symbol_dec : forall f1 f2 : symb, {f1 = f2} + {f1 <> f2}.

  (** The arity of a symbol contains also the information about built-in theories as in CiME *)
  Inductive arity_type : Set :=
  | AC : arity_type
  | C : arity_type
  | Free : nat -> arity_type.

  Parameter arity : symb -> arity_type.
End Signature.

(** * Module Type Variables.
 There are almost no assumptions, except a decidable equality. *)
Module Type Variables.

  Parameter var : Set.
  Axiom eq_variable_dec : forall v1 v2 : var, {v1 = v2} + {v1 <> v2}.

End Variables.

(** * Module Type Term built from a signature and a set of variables. *)
Module Type Term.

  Declare Module F : Signature.
  Declare Module X : Variables.

  Definition symbol := F.symb.
  Definition variable := X.var.

  Import F.
  Import X.

  (* Declare Module VSet : list_set.S with Definition DS.A := variable. *)

  Ltac destruct_arity f n Af :=
    generalize (refl_equal (arity f)); pattern f at 1; destruct (arity f) as [ |  | n]; intro Af.

  (** Definition of terms.
Arity is not taken into account, and terms may be hill-formed. *)
  Inductive term : Set :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

  Definition direct_subterm t1 t2 : Prop :=
    match t2 with
    | Var _ => False
    | Term _ l => In t1 l
    end.

  (** Definition and a few properties of the size of a term.*)
  Fixpoint size (t:term) : nat :=
    match t with
    | Var v => 1
    | Term f l => 1 + fold_left (fun size_acc e => size_acc + size e) l 0
    end.

  Axiom size_unfold :
    forall t, size t = match t with
                       | Var _ => 1
                       | Term f l => 1 + list_size size l
                       end.

  Axiom size_ge_one : forall t, 1 <= size t.

  Axiom size_direct_subterm :
    forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.

  (** ** Recursion on terms. *)
  Section Recursion.
    Variable P : term -> Type.
    Variable Pl : list term -> Type.

    Axiom term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.
    Axiom term_rec3 :
      (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t) -> P (Term f l)) -> forall t, P t.
    Axiom term_rec4 :
      (forall v, P (Var v)) -> (forall f l, Pl l -> P (Term f l)) ->
      (forall l, (forall t, In t l -> P t) -> Pl l) -> forall t, P t.
  End Recursion.

  (** ** Double recursion on terms. *)
  Section DoubleRecursion.
    Variable P2 : term -> term -> Type.
    Variable Pl2 : list term -> list term -> Type.

    Axiom term_rec7 :
      (forall v1 t2, P2 (Var v1) t2) ->
      (forall t1 v2, P2 t1 (Var v2)) ->
      (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
      (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
      forall t1 t2, P2 t1 t2.

    Axiom term_rec8 :
      (forall v1 t2, P2 (Var v1) t2) ->
      (forall t1 v2, P2 t1 (Var v2)) ->
      (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
      (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
      forall l1 l2, Pl2 l1 l2.
  End DoubleRecursion.

  (** ** Equality on terms is decidable. *)
  Axiom eq_term_dec :  forall t1 t2:term, {t1 = t2} + {t1 <> t2}.
  Declare Module Term_eq_dec : decidable_set.S with Definition A:= term
    with Definition eq_A_dec := eq_term_dec.

  (** ** Well-formedness of terms, according to the arity. *)
  Fixpoint well_formed (t:term) : Prop :=
    match t with
    | Var _ => True
    | Term f l =>
      let well_formed_list :=
          (fix well_formed_list (l:list term) : Prop :=
             match l with
             | nil => True
             | h :: tl => well_formed h /\ well_formed_list tl
             end) in
      well_formed_list l /\
      (match arity f with
       | Free n => length l = n
       | _ => length l = 2
       end)
    end.

  Axiom well_formed_unfold :
    forall t, well_formed t ->
              match t with
              | Var _ => True
              | Term f l =>
                (forall u, In u l -> well_formed u) /\
                (match arity f with
                 | Free n => length l = n
                 | _ => length l = 2
                 end)
              end.

  Axiom well_formed_fold :
    forall t,
      match t with
      | Var _ => True
      | Term f l =>
        (forall u, In u l -> well_formed u) /\
        (match arity f with
         | Free n => length l = n
         | _ => length l = 2
         end)
      end -> well_formed t.

  Fixpoint well_formed_list (l : list term) : Prop :=
    match l with
    | nil => True
    | h :: tl => well_formed h /\ well_formed_list tl
    end.

  (** ** Substitutions. *)
  Definition substitution := list (variable * term).

  Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
    match t with
    | Var v =>
      match find eq_variable_dec v sigma with
      | None => t
      | Some v_sigma => v_sigma
      end
    | Term f l => Term f (map (apply_subst sigma) l)
    end.

  Axiom empty_subst_is_id : forall t, apply_subst nil t = t.
  Axiom empty_subst_is_id_list : forall l, map (apply_subst nil) l = l.

  (** Composition of substitutions. *)
  Definition map_subst (f : variable -> term -> term) sigma :=
    map (fun x =>
           match (x : variable * term) with
           | (v, v_sigma) => (v, f v v_sigma)
           end)
        sigma.

  Definition subst_comp sigma1 sigma2 :=
    (map_subst (fun _ t => apply_subst sigma1 t) sigma2)
      ++
      (map_subst (fun v t =>
                    match find eq_variable_dec v sigma2 with
                    | None => t
                    | Some v_sigma2 => apply_subst sigma1 v_sigma2
                    end)
                 sigma1).

  Axiom subst_comp_is_subst_comp_aux1 :
    forall v sigma f,
      find eq_variable_dec v (map_subst f sigma) =
      match find eq_variable_dec v sigma with
      | None => None
      | Some t => Some (f v t)
      end.

  Axiom subst_comp_is_subst_comp :
    forall sigma1 sigma2 t,
      apply_subst (subst_comp sigma1 sigma2) t =
      apply_subst sigma1 (apply_subst sigma2 t).

  (** Well-formed substitutions. *)
  Definition well_formed_subst sigma :=
    forall v, match find eq_variable_dec v sigma with
              | None => True
              | Some t => well_formed t
              end.

  Axiom well_formed_apply_subst :
    forall sigma, well_formed_subst sigma ->
                  forall t, well_formed t -> well_formed (apply_subst sigma t).

  (** ** Positions in a term.*)
  Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
    match p with
    | nil => true
    | i :: q =>
      match t with
      | Var _ => false
      | Term _ l =>
        match nth_error l i with
        | Some ti => is_a_pos ti q
        | None => false
        end
      end
    end.

  Fixpoint subterm_at_pos (t : term) (p : list nat) {struct p}: option term :=
    match p with
    | nil => Some t
    | i :: q =>
      match t with
      | Var _ => None
      | Term _ l =>
        match nth_error l i with
        | Some ti => subterm_at_pos ti q
        | None => None
        end
      end
    end.

  Axiom size_subterm_at_pos :
    forall t i p, match subterm_at_pos t (i :: p) with
	          | Some u => size u < size t
	          | None => True
	          end.

  Axiom is_a_pos_exists_subtem :
    forall t p, is_a_pos t p = true -> exists u, subterm_at_pos t p = Some u.

  Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
    match p with
    | nil => u
    | i :: q =>
      match t with
      | Var _ => t
      | Term f l =>
        let replace_at_pos_list :=
            (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
               match l with
               | nil => nil
               | h :: tl =>
                 match j with
                 | O => (replace_at_pos h u q) :: tl
                 | S k => h :: (replace_at_pos_list k tl)
                 end
               end) in
        Term f (replace_at_pos_list i l)
      end
    end.

  Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
           {struct l}: list term :=
    match l with
    | nil => nil
    | h :: tl =>
      match i with
      | O => (replace_at_pos h u p) :: tl
      | S j => h :: (replace_at_pos_list tl  u j p)
      end
    end.

  Axiom replace_at_pos_unfold :
    forall f l u i q,
      replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).

  Axiom replace_at_pos_is_replace_at_pos1 :
    forall t u p, is_a_pos t p = true ->
                  subterm_at_pos (replace_at_pos t u p) p = Some u.

  Axiom replace_at_pos_is_replace_at_pos2 :
    forall t p u, subterm_at_pos t p = Some u -> replace_at_pos t u p = t.

  Axiom subterm_at_pos_apply_subst_apply_subst_subterm_at_pos :
    forall t p sigma,
      match subterm_at_pos t p with
      | Some u =>
        subterm_at_pos (apply_subst sigma t) p = Some (apply_subst sigma u)
      | None => True
      end.

  Axiom replace_at_pos_list_replace_at_pos_in_subterm :
    forall l1 ui l2 u i p, length l1 = i ->
                           replace_at_pos_list (l1 ++ ui :: l2) u i p =
                           l1 ++ (replace_at_pos ui u p) :: l2.

End Term.

(** * A functor building a Term Module from a Signature and a set of Variables.*)

Module Make (F1 : Signature) (X1 : Variables) <:
  Term with Module F := F1 with Module X := X1.

  Module F := F1.
  Module X := X1.

  Definition symbol := F.symb.
  Definition variable := X.var.

  Import F.
  Import X.

  Module DecVar <: decidable_set.S.
    Definition A := variable.

    Lemma eq_A_dec : forall x y : A, { x = y } + { x <> y }.
    Proof.
      apply eq_variable_dec.
    Qed.

  End DecVar.

  Module VSet <: list_set.S with Definition DS.A := variable :=
    list_set.Make (DecVar).

  (** Definition of terms.
Arity is not taken into account, and terms may be ill-formed. *)
  Inductive term : Set :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

  Definition direct_subterm t1 t2 : Prop :=
    match t2 with
    | Var _ => False
    | Term _ l => In t1 l
    end.

  (** Definition and a few properties of the size of a term.*)
  Fixpoint size (t:term) : nat :=
    match t with
    | Var v => 1
    | Term f l => 1 + fold_left (fun size_acc e => size_acc + size e) l 0
    end.

  Lemma size_unfold :
    forall t,
      size t = match t with
               | Var _ => 1
               | Term f l => 1 + list_size size l
               end.
  Proof.
    intro t; destruct t as [x | f l]; trivial.
    simpl; rewrite list_size_fold; trivial.
  Qed.

  Lemma size_ge_one : forall t, 1 <= size t.
  Proof.
    destruct t as [ x | f l ]; trivial.
    rewrite size_unfold; auto with arith.
  Qed.

  Lemma size_direct_subterm :
    forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.
  Proof.
    intros t1 t2; unfold direct_subterm; destruct t2 as [ x | f l ].
    contradiction.
    rewrite (size_unfold (Term f l)).
    induction l as [ | t l]; simpl; intuition.
    subst; auto with arith.
    apply Nat.lt_le_trans with (1 + list_size size l); trivial;
      simpl; auto with arith.
  Qed.

  (** ** Recursion on terms. *)
  Section Recursion.
    Variable P : term -> Type.
    Variable Pl : list term -> Type.

    Definition term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.
    Proof.
      intros H t; apply (H (size t) t); apply le_n.
    Qed.

    Definition term_rec3 :
      (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t) -> P (Term f l)) -> forall t, P t.
    Proof.
      intros Hvar Hterm; apply term_rec2; induction n; intros t Size_t.
      absurd (1 <= 0); auto with arith;
        apply Nat.le_trans with (size t); trivial; apply size_ge_one.
      destruct t as [ x | f l ]; trivial;
        apply Hterm; intros; apply IHn. apply Nat.lt_succ_r.
          apply Nat.lt_le_trans with (size (Term f l)); trivial;
            apply size_direct_subterm; trivial.
    Qed.

    Definition term_rec4 :
      (forall v, P (Var v)) -> (forall f l, Pl l -> P (Term f l)) ->
      (forall l, (forall t, In t l -> P t) -> Pl l) -> forall t, P t.
    Proof.
      intros Hvar Hterm Hlist; apply term_rec2;
        induction n; intros t Size_t.
      absurd (1<=0); auto with arith;
        apply Nat.le_trans with (size t); trivial; apply size_ge_one.
      destruct t as [ x | f l ]; trivial;
        apply Hterm; apply Hlist; intros t In_t; apply IHn;
          apply Nat.lt_succ_r;
          apply Nat.lt_le_trans with (size (Term f l)); trivial;
            apply size_direct_subterm; trivial.
    Qed.
  End Recursion.

  (** ** Double recursion on terms. *)
  Section DoubleRecursion.
    Variable P2 : term -> term -> Type.
    Variable Pl2 : list term -> list term -> Type.

    Definition term_rec7 :
      (forall v1 t2, P2 (Var v1) t2) ->
      (forall t1 v2, P2 t1 (Var v2)) ->
      (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
      (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
      forall t1 t2, P2 t1 t2.
    Proof.
      intros Hvt Htv Hterm Hlist.
      intro t1; pattern t1; apply term_rec2; induction n; clear t1;
        intros t1 Size_t1.
      absurd (1<=0); auto with arith;
        apply Nat.le_trans with (size t1); trivial; apply size_ge_one.
      destruct t1 as [ x1 | f1 l1 ]; trivial.
      destruct t2 as [ x2 | f2 l2 ]; trivial.
      apply Hterm; apply Hlist; intros t1 t2 In_t1 In_t2; apply IHn;
        apply Nat.lt_succ_r;
        apply Nat.lt_le_trans with (size (Term f1 l1)); trivial;
          apply size_direct_subterm; trivial.
    Qed.

    Definition term_rec8 :
      (forall v1 t2, P2 (Var v1) t2) ->
      (forall t1 v2, P2 t1 (Var v2)) ->
      (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
      (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
      forall l1 l2, Pl2 l1 l2.
    Proof.
      intros Hvt Htv Hterm Hlist l1 l2;
        apply Hlist;
        intros; apply term_rec7; trivial.
    Defined.
  End DoubleRecursion.

  (** ** Equality on terms is decidable. *)
  Theorem eq_term_dec :
    forall t1 t2:term, {t1 = t2} + {t1 <> t2}.
  Proof.
    intro t1; pattern t1; apply term_rec3.
    intro x1; destruct t2 as [ x2 | f2 l2].
    destruct (eq_variable_dec x1 x2) as  [x1_eq_x2 | x1_diff_x2].
    left; subst; trivial.
    right; intro H; apply x1_diff_x2; inversion H; trivial.
    right; discriminate.
    intros f1 l1 Hrec t2; destruct t2 as [x2 | f2 l2].
    right; discriminate.
    destruct (eq_symbol_dec f1 f2) as  [f1_eq_f2 | f1_diff_f2].

    subst; assert (Hrec_list : forall l2, {l1 = l2} + {l1 <> l2}).
    clear f2 l2; induction l1 as [ | a1 l1].
    intro l2; destruct l2 as [ | a2 l2]; [left; trivial | right; discriminate].
    intro l2; destruct l2 as [ | a2 l2].
    right; discriminate.
    assert (In_a1 : In a1 (a1 :: l1)). left; trivial.
    destruct (Hrec a1 In_a1 a2) as  [a1_eq_a2 | a1_diff_a2].
    assert (Hrec_l1 : forall t, In t l1 -> forall t2, {t = t2} + {t <> t2}).
    intros; apply Hrec; right; trivial.
    subst; destruct (IHl1 Hrec_l1 l2) as  [l1_eq_l2 | l1_diff_l2];
      [ left; subst
      | right; intro H; apply l1_diff_l2; inversion H] ; trivial.
    right; intro H; apply a1_diff_a2; inversion H; trivial.

    destruct (Hrec_list l2) as  [l1_eq_l2 | l1_diff_l2];
      [ left; subst
      | right; intro H; apply l1_diff_l2; inversion H] ; trivial.
    right; intro H; apply f1_diff_f2; inversion H; trivial.
  Qed.

  Module Term_eq_dec : decidable_set.S with Definition A:= term
    with Definition eq_A_dec := eq_term_dec.
    Definition A := term.
    Definition eq_A_dec := eq_term_dec.
  End Term_eq_dec.

  (** ** Well-formedness of terms, according to the arity. *)
  Fixpoint well_formed (t:term) : Prop :=
    match t with
    | Var _ => True
    | Term f l =>
      let well_formed_list :=
          (fix well_formed_list (l:list term) : Prop :=
             match l with
             | nil => True
             | h :: tl => well_formed h /\ well_formed_list tl
             end) in
      well_formed_list l /\
      (match arity f with
       | Free n => length l = n
       | _ => length l = 2
       end)
    end.

  Lemma well_formed_unfold :
    forall t, well_formed t ->
              match t with
              | Var _ => True
              | Term f l =>
                (forall u, In u l -> well_formed u) /\
                (match arity f with
                 | Free n => length l = n
                 | _ => length l = 2
                 end)
              end.
  Proof.
    intros t; destruct t as [ x | f l ]; trivial.
    intros [Wl A]; split; trivial.
    clear A; induction l as [ | t l].
    contradiction.
    generalize Wl; clear Wl; intros [Wa Wl] u [Eq_u_a | In_u].
    subst u; trivial.
    apply IHl; trivial.
  Qed.

  Lemma well_formed_fold :
    forall t,
      match t with
      | Var _ => True
      | Term f l =>
        (forall u, In u l -> well_formed u) /\
        (match arity f with
         | Free n => length l = n
         | _ => length l = 2
         end)
      end -> well_formed t.
  Proof.
    intros t; destruct t as [ x | f l ]; trivial.
    intros [Wl A]; split ; trivial; clear A; induction l as [ | t l]; trivial; split.
    apply Wl; left; trivial.
    apply IHl; intros; apply Wl; right; trivial.
  Qed.

  Fixpoint well_formed_list (l : list term) : Prop :=
    match l with
    | nil => True
    | h :: tl => well_formed h /\ well_formed_list tl
    end.

  (** ** Substitutions. *)
  Definition substitution := list (variable * term).

  Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
    match t with
    | Var v =>
      match find eq_variable_dec v sigma with
      | None => t
      | Some v_sigma => v_sigma
      end
    | Term f l => Term f (map (apply_subst sigma) l)
    end.

  Lemma empty_subst_is_id : forall t, apply_subst nil t = t.
  Proof.
    intro t; pattern t; apply term_rec3; clear t; trivial.
    intros f l IH; simpl; apply (f_equal (fun l => Term f l));
      induction l as [ | t l]; trivial; simpl; rewrite (IH t).
    rewrite IHl; trivial.
    intros; apply IH; right; trivial.
    left; trivial.
  Qed.

  Lemma empty_subst_is_id_list : forall l, map (apply_subst nil) l = l.
  Proof.
    intro l; induction l as [ | t l]; simpl;
      [idtac | rewrite empty_subst_is_id; rewrite IHl];
      trivial.
  Qed.

  (** Composition of substitutions. *)
  Definition map_subst (f : variable -> term -> term) sigma :=
    map (fun x =>
           match (x : variable * term) with
           | (v, v_sigma) => (v, f v v_sigma)
           end)
        sigma.

  Definition subst_comp sigma1 sigma2 :=
    (map_subst (fun _ t => apply_subst sigma1 t) sigma2)
      ++
      (map_subst (fun v t =>
                    match find eq_variable_dec v sigma2 with
                    | None => t
                    | Some v_sigma2 => apply_subst sigma1 v_sigma2
                    end)
                 sigma1).

  Lemma subst_comp_is_subst_comp_aux1 :
    forall v sigma f,
      find eq_variable_dec v (map_subst f sigma) =
      match find eq_variable_dec v sigma with
      | None => None
      | Some t => Some (f v t)
      end.
  Proof.
    intros v sigma f; induction sigma as [ | [v1 a1] sigma ].
    simpl; trivial.
    simpl; elim (eq_variable_dec v v1); intro v_eq_v1; trivial;
      subst v; trivial.
  Qed.

  Lemma subst_comp_is_subst_comp_aux2 :
    forall v sigma1 sigma2,
      find (B:= term) eq_variable_dec v (sigma1 ++ sigma2)  =
      match find eq_variable_dec v sigma1 with
      | Some _ => find eq_variable_dec v sigma1
      | None => find eq_variable_dec v sigma2
      end.
  Proof.
    intros v sigma1 sigma2;
      induction sigma1 as [ | [v1 a1] sigma1] ; trivial.
    simpl; elim (eq_variable_dec v v1); intro v_eq_v1; trivial.
  Qed.

  Theorem subst_comp_is_subst_comp :
    forall sigma1 sigma2 t,
      apply_subst (subst_comp sigma1 sigma2) t =
      apply_subst sigma1 (apply_subst sigma2 t).
  Proof.
    intros sigma1 sigma2 t; pattern t; apply term_rec3; clear t.
    intro v; unfold subst_comp;
      simpl; rewrite subst_comp_is_subst_comp_aux2;
        do 2 rewrite subst_comp_is_subst_comp_aux1;
        destruct (find eq_variable_dec v sigma2); trivial; simpl;
          destruct (find eq_variable_dec v sigma1); trivial.
    intros f l IH; simpl; apply (f_equal (fun l => Term f l));
      induction l as [ | a l]; trivial.
    simpl; rewrite (IH a).
    rewrite IHl; trivial.
    intros; apply IH; right; trivial.
    left; trivial.
  Qed.

  (** Well-formed substitutions. *)
  Definition well_formed_subst sigma :=
    forall v, match find eq_variable_dec v sigma with
              | None => True
              | Some t => well_formed t
              end.

  Theorem well_formed_apply_subst :
    forall sigma, well_formed_subst sigma ->
                  forall t, well_formed t -> well_formed (apply_subst sigma t).
  Proof.
    intros sigma W_sigma t; pattern t;
      apply term_rec3.
    intros v _; simpl; generalize (W_sigma v);
      destruct (find eq_variable_dec v sigma); trivial.
    intros f l Hrec [Wl A]; split.
    clear A; induction l as [ | a l]; simpl; trivial;
      inversion_clear Wl as [Wa Wl']; split.
    apply Hrec; trivial; left; trivial.
    apply IHl; trivial; intros; apply Hrec; trivial; right; trivial.
    rewrite length_map; trivial.
  Qed.

  (** ** Positions in a term.*)
  Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
    match p with
    | nil => true
    | i :: q =>
      match t with
      | Var _ => false
      | Term _ l =>
        match nth_error l i with
        | Some ti => is_a_pos ti q
        | None => false
        end
      end
    end.

  Fixpoint subterm_at_pos (t : term) (p : list nat) {struct p}: option term :=
    match p with
    | nil => Some t
    | i :: q =>
      match t with
      | Var _ => None
      | Term _ l =>
        match nth_error l i with
        | Some ti => subterm_at_pos ti q
        | None => None
        end
      end
    end.

  Lemma size_subterm_at_pos :
    forall t i p, match subterm_at_pos t (i :: p) with
	          | Some u => size u < size t
	          | None => True
	          end.
  Proof.
    intros t i p; generalize t i; clear t i; induction p as [ | j p].
    intros [ v | f l ] j; simpl subterm_at_pos; cbv iota beta; trivial.
    generalize (nth_error_ok_in j l); destruct (nth_error l j) as [tj | ]; [idtac | trivial].
    intro H; apply size_direct_subterm; simpl; apply H; trivial.
    intros [ v | f l ] i; simpl subterm_at_pos; cbv iota beta; trivial.
    generalize (nth_error_ok_in i l); destruct (nth_error l i) as [ti | ]; [idtac | trivial].
    intro ti_in_l; generalize (IHp ti j); simpl subterm_at_pos;
      destruct ti as [vi | fi li]; trivial.
    generalize (nth_error_ok_in j li); destruct (nth_error li j) as [tij | ]; [idtac | trivial].
    intro tij_in_li; destruct (subterm_at_pos tij p) as [ u | ]; trivial.
    intro H; apply Nat.lt_trans with (size (Term fi li)); trivial.
    apply size_direct_subterm; simpl; apply ti_in_l; trivial.
  Qed.

  Lemma is_a_pos_exists_subtem :
    forall t p, is_a_pos t p = true -> exists u, subterm_at_pos t p = Some u.
  Proof.
    intros t p; generalize t; clear t; induction p as [ | i q ].
    intros t _; exists t; trivial.
    intros t; destruct t as [ x | f l ]; simpl.
    intros; discriminate.
    destruct (nth_error l i) as [ ti | ].
    intro; apply IHq; trivial.
    intros; discriminate.
  Qed.

  Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
    match p with
    | nil => u
    | i :: q =>
      match t with
      | Var _ => t
      | Term f l =>
        let replace_at_pos_list :=
            (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
               match l with
               | nil => nil
               | h :: tl =>
                 match j with
                 | O => (replace_at_pos h u q) :: tl
                 | S k => h :: (replace_at_pos_list k tl)
                 end
               end) in
        Term f (replace_at_pos_list i l)
      end
    end.

  Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
           {struct l}: list term :=
    match l with
    | nil => nil
    | h :: tl =>
      match i with
      | O => (replace_at_pos h u p) :: tl
      | S j => h :: (replace_at_pos_list tl  u j p)
      end
    end.

  Lemma replace_at_pos_unfold :
    forall f l u i q,
      replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).
  Proof.
    intros f l u i q; simpl; apply (f_equal (fun l => Term f l));
      generalize u i q; clear u i q;
        induction l as [| t l]; intros u i q; trivial.
    simpl; destruct i as [ | i ]; trivial.
    rewrite <- IHl; trivial.
  Qed.

  Lemma replace_at_pos_is_replace_at_pos1 :
    forall t u p, is_a_pos t p = true ->
                  subterm_at_pos (replace_at_pos t u p) p = Some u.
  Proof.
    intro t; pattern t; apply term_rec3; clear t.
    intros x u p; destruct p as [ | i q ]; trivial;
      intros; discriminate.
    intros f l IHl u p; destruct p as [ | i q ]; trivial.
    rewrite replace_at_pos_unfold; simpl; generalize i q; clear i q;
      induction l as [ | t l ]; intros i q.
    destruct i as [ | i ]; simpl; intros; discriminate.
    destruct i as [ | i ]; simpl.
    intros; apply (IHl t); trivial; left; trivial.
    intros; apply IHl0; intros; trivial; apply IHl; trivial; right; trivial.
  Qed.

  Lemma replace_at_pos_is_replace_at_pos2 :
    forall t p u, subterm_at_pos t p = Some u -> replace_at_pos t u p = t.
  Proof.
    intro t; pattern t; apply term_rec3; clear t.
    intros v p u; destruct p as [ | i q ]; intro H; inversion_clear H; trivial.
    intros f l IHl p; destruct p as [ | i q ].
    intros u H; inversion_clear H; trivial.
    intros u H; rewrite replace_at_pos_unfold;
      apply (f_equal (fun l => Term f l)); generalize i q u H; clear i q u H;
        induction l as [ | t l ]; intros i q u H.
    destruct i as [ | i ]; simpl; intros; discriminate.
    destruct i as [ | i ]; simpl.
    rewrite IHl; trivial; left; trivial.
    rewrite IHl0; trivial; intros; apply IHl; trivial; right; trivial.
  Qed.

  Lemma subterm_at_pos_apply_subst_apply_subst_subterm_at_pos :
    forall t p sigma,
      match subterm_at_pos t p with
      | Some u =>
        subterm_at_pos (apply_subst sigma t) p = Some (apply_subst sigma u)
      | None => True
      end.
  Proof.
    intro t; pattern t; apply term_rec3; clear t.
    intros v p; destruct p as [ | i q ]; simpl; trivial.
    intros f l IHl p; destruct p as [ | i q ]; simpl; trivial.
    assert (H : forall (l : list term) i,
               match nth_error l i with
               | Some li => In li l
               | None => True end).
    clear IHl l i; intro l;
      induction l as [ | t l ]; intro i; destruct i as [ | i ]; simpl; trivial.
    left; trivial.
    generalize (IHl i); destruct (nth_error l i); trivial; intros; right; trivial.
    generalize i; clear i; induction l as [ | l ll ];
      intros i; destruct i as [ | i ]; simpl; trivial.
    intros; apply IHl; left; trivial.
    intro sigma; apply IHll; intros; apply IHl; right; trivial.
  Qed.

  Lemma replace_at_pos_list_replace_at_pos_in_subterm :
    forall l1 ui l2 u i p, length l1 = i ->
                           replace_at_pos_list (l1 ++ ui :: l2) u i p =
                           l1 ++ (replace_at_pos ui u p) :: l2.
  Proof.
    intros l1; induction l1 as [ | u1 l1 ]; intros ui l2 u i p L; simpl in L.
    subst i; trivial.
    destruct i as [ | i ].
    discriminate.
    simpl; rewrite IHl1; trivial.
    inversion L; trivial.
  Qed.

End Make.


Require Import Extensionality.

Set Implicit Arguments.
Unset Elimination Schemes.

Inductive Rlist (R : Type) (A : Type) := rnode : (R -> Rnode R A) -> Rlist R A
with Rnode (R : Type) (A : Type) :=
| rnil : Rnode R A
| rcons : A -> Rlist R A -> Rnode R A.

Definition t R A := Rlist R A.

Arguments rnode [_ _] f.
Arguments rnil [_ _].
Arguments rcons [_ _] x l.

Definition nil {R A} : Rlist R A := rnode (fun _ => rnil).
Definition cons {R A} (x : R -> A) (l : Rlist R A) : Rlist R A :=
  rnode (fun r => rcons (x r) l).

Definition lift {R A} (x : A) := @rnode R A (fun _ => rcons x (rnode (fun _ => rnil))).

Fixpoint map {R A B} (f : A -> B) (l : Rlist R A) : Rlist R B :=
match l with
| rnode n => rnode (fun r => map_node f (n r))
end

with map_node {R A B} (f : A -> B) (n : Rnode R A) :=
match n with
| rnil => rnil
| rcons x l => rcons (f x) (map f l)
end.

Fixpoint set {R S A} (g : S -> R) (l : Rlist R A) : Rlist S A :=
match l with
| rnode n => rnode (fun r => set_node g (n (g r)))
end

with set_node {R S A} (g : S -> R) (n : Rnode R A) :=
match n with
| rnil => rnil
| rcons x l => rcons x (set g l)
end.

Fixpoint run {R A} (l : Rlist R A) (r : R) : list A :=
match l with
| rnode n => run_node (n r) r
end

with run_node {R A} (n : Rnode R A) (r : R) : list A :=
match n with
| rnil => Datatypes.nil
| rcons x l => Datatypes.cons x (run l r)
end.

Fixpoint app {R A} (l1 : Rlist R A) (l2 : Rlist R A) : Rlist R A :=
match l1 with
| rnode n => rnode (fun r => app_node (n r) l2 r)
end

with app_node {R A} (n : Rnode R A) (l2 : Rlist R A) : R -> Rnode R A :=
match n with
| rnil => fun r => match l2 with rnode n => n r end
| rcons x l1 => fun r => rcons x (app l1 l2)
end.

Lemma app_id_r : forall R A l,
  @app R A l nil ≅ l
with app_id_r_node : forall R A n r,
  @app_node R A n nil r ≅ n.
Proof.
+ intros R A [n] Hext; simpl.
  f_equal; apply Hext; intros r.
  apply app_id_r_node; assumption.
+ intros R A [|x l] r Hext; simpl.
  - reflexivity.
  - f_equal; apply app_id_r; assumption.
Qed.

Lemma app_id_l : forall R A (l : Rlist R A),
  @app R A nil l ≅ l.
Proof.
intros R A [n] Hext; simpl; f_equal.
Qed.

Lemma map_app : forall R A B (f : A -> B) l1 l2,
  @map R A B f (app l1 l2) ≅ app (map f l1) (map f l2)
with map_app_node : forall R A B (f : A -> B) n1 l2 r,
  @map_node R A B f (app_node n1 l2 r) ≅ app_node (map_node f n1) (map f l2) r.
Proof.
+ intros R A B f [n1] l2 Hext; simpl.
  f_equal; apply Hext; intros r; apply map_app_node; assumption.
+ intros R A B f n1 l2 r Hext.
  destruct n1 as [|x l1]; [destruct l2 as [n2]; reflexivity|].
  simpl; f_equal; apply map_app; assumption.
Qed.

Lemma set_app : forall R S A (g : S -> R) l1 l2,
  @set R S A g (app l1 l2) ≅ app (set g l1) (set g l2)
with set_app_node : forall R S A (g : S -> R) n1 l2 r,
  @set_node R S A g (app_node n1 l2 (g r)) ≅ app_node (set_node g n1) (set g l2) r.
Proof.
+ intros R S A f [n1] l2 Hext; simpl.
  f_equal; apply Hext; intros r; apply set_app_node; assumption.
+ intros R S A f n1 l2 r Hext.
  destruct n1 as [|x l1]; [destruct l2 as [n2]; reflexivity|].
  simpl; f_equal; apply set_app; assumption.
Qed.

Fixpoint concat {R A} (l : Rlist R (Rlist R A)) : Rlist R A :=
match l with
| rnode n => rnode (fun r => concat_node (n r) r)
end

with concat_node {R A} (n : Rnode R (Rlist R A)) : R -> Rnode R A :=
match n with
| rnil => fun _ => rnil
| rcons x l => fun r => match app x (concat l) with rnode n => n r end
end.

Lemma app_assoc : forall R A (l1 l2 l3 : Rlist R A),
  app l1 (app l2 l3) ≅ app (app l1 l2) l3
with app_assoc_node : forall R A (n1 : Rnode R A) (l2 l3 : Rlist R A) r,
  app_node n1 (app l2 l3) r ≅ app_node (app_node n1 l2 r) l3 r.
Proof.
+ intros R A [n1] l2 l3 Hext; simpl.
  f_equal; apply Hext; intros r; apply app_assoc_node; assumption.
+ intros R A [|x l1] l2 l3 r Hext; simpl.
  - destruct l2 as [n2]; reflexivity.
  - rewrite app_assoc; [reflexivity|assumption].
Qed.

Lemma concat_app : forall R A l1 l2,
  @concat R A (app l1 l2) ≅ app (concat l1) (concat l2)
with concat_app_node : forall R A n1 l2 r,
  @concat_node R A (app_node n1 l2 r) r ≅ app_node (concat_node n1 r) (concat l2) r.
Proof.
+ intros R A [n1] l2 Hext; simpl.
  f_equal; apply Hext; intros r; apply concat_app_node; assumption.
+ intros R A [|x l1] l2 r Hext; simpl.
  - destruct l2 as [n2]; reflexivity.
  - rewrite (concat_app _ _ l1); [|assumption].
    destruct x as [n]; simpl.
    apply app_assoc_node; assumption.
Qed.

Lemma concat_map : forall R A (l : Rlist R (Rlist R (Rlist R A))),
  concat (concat l) ≅ concat (map concat l)
with concat_map_node : forall R A (n : Rnode R (Rlist R (Rlist R A))) r,
  concat_node (concat_node n r) r ≅ concat_node (map_node concat n) r.
Proof.
+ intros R A l Hext; destruct l as [n]; simpl.
  f_equal; apply Hext; intros r.
  apply concat_map_node; assumption.
+ intros R A [|x l] r Hext.
  - reflexivity.
  - simpl; rewrite <- concat_map; [|assumption].
    destruct x as [n]; simpl.
    apply concat_app_node; assumption.
Qed.

Lemma map_concat : forall R A B (f : A -> B) (l : Rlist R (Rlist R A)),
  map f (concat l) ≅ concat (map (map f) l)
with map_concat_node : forall R A B (f : A -> B) (n : Rnode R (Rlist R A)) r,
  map_node f (concat_node n r) ≅ concat_node (map_node (map f) n) r.
Proof.
+ intros R A B f [n] Hext; simpl.
  f_equal; apply Hext; intros r.
  apply map_concat_node; assumption.
+ intros R A B f [|[n] l] r Hext; simpl.
  - reflexivity.
  - rewrite map_app_node; [|assumption].
    f_equal; apply map_concat; assumption.
Qed.

Lemma set_concat : forall R S A (g : S -> R) (l : Rlist R (Rlist R A)),
  set g (concat l) ≅ concat (set g (map (set g) l))
with set_concat_node : forall R S A (g : S -> R) (n : Rnode R (Rlist R A)) r,
  set_node g (concat_node n (g r)) ≅ concat_node (set_node g (map_node (set g) n)) r.
Proof.
+ intros R S A g [n] Hext; simpl.
  f_equal; apply Hext; intros r.
  apply set_concat_node; assumption.
+ intros R S A g [|[n] l] r Hext; simpl.
  - reflexivity.
  - rewrite set_app_node; [|assumption].
    f_equal; apply set_concat; assumption.
Qed.

Fixpoint fold_right {R A B} (f : A -> (R -> B) -> (R -> B)) (accu : R -> B) (l : Rlist R A) (r : R) {struct l} : B :=
match l with
| rnode n => fold_right_node f accu (n r) r
end

with fold_right_node {R A B} (f : A -> (R -> B) -> (R -> B)) (accu : R -> B) (n : Rnode R A) (r : R) {struct n} : B :=
match n with
| rnil => accu r
| rcons x l => f x (fold_right f accu l) r
end.

Lemma map_set : forall R S A B f g l,
  @map S A B f (@set R S A g l) ≅ set g (map f l)
with map_set_node : forall R S A B f g n,
  @map_node S A B f (@set_node R S A g n) ≅ set_node g (map_node f n).
Proof.
+ intros R S A B f g [n] Hext; simpl.
  f_equal; apply Hext; intros s.
  apply map_set_node; assumption.
+ intros R S A B f g [|x l] Hext; simpl.
  - reflexivity.
  - f_equal; apply map_set; assumption.
Qed.

Lemma set_set : forall R S T A f g l,
  @set S T A g (@set R S A f l) ≅ set (fun r => f (g r)) l
with set_set_node : forall R S T A f g n,
  @set_node S T A g (@set_node R S A f n) ≅ set_node (fun r => f (g r)) n.
Proof.
+ intros R S T A f g [n] Hext.
  simpl; f_equal; apply Hext; intros r.
  apply set_set_node; assumption.
+ intros R S T A f g [|x l] Hext; simpl.
  - reflexivity.
  - f_equal; apply set_set; assumption.
Qed.

Lemma map_map : forall R A B C f g l,
  @map R B C g (@map R A B f l) ≅ map (fun x => g (f x)) l
with map_map_node : forall R A B C f g n,
  @map_node R B C g (@map_node R A B f n) ≅ map_node (fun x => g (f x)) n.
Proof.
+ intros R A B C f g [n] Hext.
  simpl; f_equal; apply Hext; intros r.
  apply map_map_node; assumption.
+ intros R A B C f g [|x l] Hext; simpl.
  - reflexivity.
  - f_equal; apply map_map; assumption.
Qed.

Lemma map_id : forall R A l, @map R A A (@id _) l ≅ l
with map_id_node : forall R A n, @map_node R A A (@id _) n ≅ n.
Proof.
+ intros R A [n] Hext; simpl; f_equal; apply Hext; intros u; apply map_id_node; assumption.
+ intros R A [|x l] Hext; simpl.
  - reflexivity.
  - f_equal; apply map_id; assumption.
Qed.

Lemma set_id : forall R A l, @set R R A (@id _) l ≅ l
with set_id_node : forall R A n, @set_node R R A (@id _) n ≅ n.
Proof.
+ intros R A [n] Hext; simpl; f_equal; apply Hext; intros u; apply set_id_node; assumption.
+ intros R A [|x l] Hext; simpl.
  - reflexivity.
  - f_equal; apply set_id; assumption.
Qed.

Definition collapse {R A} (f : R -> Rlist R A) : Rlist R A :=
  rnode (fun r => match f r with rnode n => n r end).

Lemma collapse_app : forall R A f g,
  @collapse R A (fun r => app (f r) (collapse g)) ≅ app (collapse f) (collapse g).
Proof.
intros R A f g Hext; unfold collapse; simpl; f_equal.
apply Hext; intros r; destruct (f r) as [n]; simpl; reflexivity.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export lsubst_hyps.
Require Export per_can.
Require Export per_props_atom.
Require Export per_props_nat.
Require Export cequiv_util.

(*
   H |- a = b in Base

     By EqualInBase

     H |- a ~ b
     forall v in (free_vars a), H |- v in Base

 *)

Definition rule_equal_in_base_concl {o} (a b : @NTerm o) H :=
  mk_baresequent H (mk_conclax (mk_equality a b mk_base)).

Definition rule_equal_in_base_hyp1 {o} (a b : @NTerm o) H :=
  mk_baresequent H (mk_conclax (mk_cequiv a b)).

Definition rule_equal_in_base_hyp2 {o} (v : NVar) (H : @bhyps o) :=
  mk_baresequent H (mk_conclax (mk_member (mk_var v) mk_base)).

Definition rule_equal_in_base_rest {o} (a : @NTerm o) (H : @bhyps o) :=
  map (fun v => rule_equal_in_base_hyp2 v H)
      (free_vars a).

Definition rule_equal_in_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (rule_equal_in_base_concl a b H)
      (rule_equal_in_base_hyp1 a b H :: rule_equal_in_base_rest a H)
      [].

Lemma rule_equal_in_base_true3 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true3 lib (rule_equal_in_base H a b).
Proof.
  unfold rule_equal_in_base, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (rule_equal_in_base_concl a b H)) as wfc by prove_seq.
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  allrw <- @member_cequiv_iff.
  apply tequality_mkc_cequiv in hyp0.
  applydup hyp0 in hyp1; clear hyp0; spcast.
  spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;[|eauto].

  clear dependent b.

  pose proof (lsubstc_csub_filter_free_vars a w1 s1 ca1) as e1; exrepnd; rw e0; clear e0.
  pose proof (lsubstc_csub_filter_free_vars a w1 s2 c1) as e2; exrepnd; rw e0; clear e0.

  apply cequivc_lsubstc; try (apply isprogram_csubst; eauto 3 with slow).
  apply implies_cequiv_csub_if_eq_doms; auto.

  { rw @dom_csub_csub_keep.
    apply implies_no_repeats_lkeep.
    apply similarity_dom in sim; repnd.
    rw sim0.
    eapply vswf_hypotheses_implies_no_repeats; eauto. }

  { allrw @dom_csub_csub_keep.
    apply similarity_dom in sim; repnd.
    rw sim0; rw sim; auto. }

  { introv e1 e2.
    rw @csub_find_csub_keep in e1.
    rw @csub_find_csub_keep in e2.
    boolvar; ginv.
    pose proof (hyps (mk_baresequent H (mk_conclax (mk_member (mk_var v) mk_base)))) as hyp.
    autodimp hyp h.

    { rw in_map_iff; eexists; dands; eauto. }

    destruct hyp as [ws hyp].
    destseq; allsimpl; proof_irr; GC.
    vr_seq_true in hyp.
    pose proof (hyp s1 s2 hf sim) as hyp0; clear hyp; exrepnd.
    lsubst_tac.
    clear hyp0.
    apply tequality_mkc_member_base in hyp1; spcast.
    apply cequiv_stable in hyp1.
    repeat (erewrite lsubstc_mk_var_if_csub_find in hyp1;[|eauto]).
    auto. }
Qed.

Lemma rule_equal_in_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_equal_in_base H a b).
Proof.
  introv.
  apply rule_true3_implies_rule_true; auto.
  apply rule_equal_in_base_true3; auto.
Qed.

Lemma rule_equal_in_base_true2 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true2 lib (rule_equal_in_base H a b).
Proof.
  introv.
  apply rule_true_iff_rule_true2; auto.
  apply rule_equal_in_base_true; auto.
Qed.

Lemma rule_equal_in_base_wf2 {o} :
  forall (H : barehypotheses) (a b : @NTerm o),
    wf_rule2 (rule_equal_in_base H a b).
Proof.
  introv wf i.

  allsimpl; repdors; sp; subst; allunfold @wf_bseq; wfseq; auto;
  unfold rule_equal_in_base_rest in i; rw in_map_iff in i; exrepnd; subst; allsimpl; auto.
  unfold covered; simpl.
  allunfold @covered.
  allrw subvars_eq.
  repeat (rw subset_cons_l); dands; auto.
Qed.

(* same as above but we don't force the subgoals to have given extracts *)

Definition rule_equal_in_base2_hyp1 {o} (a b : @NTerm o) e H :=
  mk_baresequent H (mk_concl (mk_cequiv a b) e).

Definition rule_equal_in_base2_hyp2 {o} (v : NVar) e (H : @bhyps o) :=
  mk_baresequent H (mk_concl (mk_member (mk_var v) mk_base) e).

Definition rule_equal_in_base2_rest {o}
           (a : @NTerm o)
           (F : forall v (i : LIn v (free_vars a)), @NTerm o)
           (H : @bhyps o) :=
  mapin
    (free_vars a)
    (fun v i => rule_equal_in_base2_hyp2 v (F v i) H).

Definition rule_equal_in_base2 {o}
           (H : barehypotheses)
           (a b : @NTerm o)
           (e : NTerm)
           (F : forall v (i : LIn v (free_vars a)), @NTerm o)
  :=
    mk_rule
      (rule_equal_in_base_concl a b H)
      (rule_equal_in_base2_hyp1 a b e H :: rule_equal_in_base2_rest a F H)
      [].

Lemma rule_equal_in_base2_true3 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true3 lib (rule_equal_in_base2 H a b e F).
Proof.
  unfold rule_equal_in_base2, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (rule_equal_in_base_concl a b H)) as wfc by prove_seq.
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  allrw @equality_in_mkc_cequiv; repnd.
  apply tequality_mkc_cequiv in hyp0.
  applydup hyp0 in hyp1; clear hyp0; spcast.
  spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;[|eauto].

  clear dependent b.

  pose proof (lsubstc_csub_filter_free_vars a w1 s1 ca1) as e1; exrepnd; rw e0; clear e0.
  pose proof (lsubstc_csub_filter_free_vars a w1 s2 c1) as e2; exrepnd; rw e0; clear e0.

  apply cequivc_lsubstc; try (apply isprogram_csubst; eauto 3 with slow).
  apply implies_cequiv_csub_if_eq_doms; auto.

  { rw @dom_csub_csub_keep.
    apply implies_no_repeats_lkeep.
    apply similarity_dom in sim; repnd.
    rw sim0.
    eapply vswf_hypotheses_implies_no_repeats; eauto. }

  { allrw @dom_csub_csub_keep.
    apply similarity_dom in sim; repnd.
    rw sim0; rw sim; auto. }

  { introv e1 e2.
    rw @csub_find_csub_keep in e1.
    rw @csub_find_csub_keep in e2.
    boolvar; ginv.
    pose proof (hyps (mk_baresequent H (mk_concl (mk_member (mk_var v) mk_base) (F v Heqb)))) as hyp.
    autodimp hyp h.

    { unfold rule_equal_in_base2_rest.
      apply in_mapin.
      eexists; eexists.
      unfold rule_equal_in_base2_hyp2; eauto. }

    destruct hyp as [ws hyp].
    destseq; allsimpl; proof_irr; GC.
    vr_seq_true in hyp.
    pose proof (hyp s1 s2 hf sim) as hyp0; clear hyp; exrepnd.
    lsubst_tac.
    clear hyp0.
    apply tequality_mkc_member_base in hyp1; spcast.
    apply cequiv_stable in hyp1.
    repeat (erewrite lsubstc_mk_var_if_csub_find in hyp1;[|eauto]).
    auto. }
Qed.

Lemma rule_equal_in_base2_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true lib (rule_equal_in_base2 H a b e F).
Proof.
  introv.
  apply rule_true3_implies_rule_true; auto.
  apply rule_equal_in_base2_true3; auto.
Qed.

Lemma rule_equal_in_base2_true2 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true2 lib (rule_equal_in_base2 H a b e F).
Proof.
  introv.
  apply rule_true_iff_rule_true2; auto.
  apply rule_equal_in_base2_true; auto.
Qed.

Lemma rule_equal_in_base2_wf2 {o} :
  forall (H : barehypotheses) (a b : @NTerm o) e F,
    wf_rule2 (rule_equal_in_base2 H a b e F).
Proof.
  introv wf i.

  allsimpl; repdors; sp; subst; allunfold @wf_bseq; wfseq; auto;
  unfold rule_equal_in_base_rest in i; apply in_mapin in i; exrepnd; subst; allsimpl; auto.
  unfold covered; simpl.
  allunfold @covered.
  allrw subvars_eq.
  repeat (rw subset_cons_l); dands; auto.
Qed.

(*
   H |- a = b in Base

     By AtomSubtypeBase

     H |- a = b in Atom

 *)
Definition rule_atom_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_atom))]
      [].

Lemma rule_atom_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_atom_subtype_base H a b).
Proof.
  unfold rule_atom_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_atom_iff in hyp0; exrepnd; spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;
    [apply computes_to_valc_implies_cequivc;eauto|].
  eapply cequivc_trans;
    [|apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto].
  apply cequivc_refl.
Qed.

(*
   H |- a = b in Base

     By UAtomSubtypeBase

     H |- a = b in UAtom

 *)
Definition rule_uatom_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_uatom))]
      [].

Lemma rule_uatom_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_uatom_subtype_base H a b).
Proof.
  unfold rule_uatom_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_uatom_iff in hyp0; exrepnd; spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;
    [apply computes_to_valc_implies_cequivc;eauto|].
  eapply cequivc_trans;
    [|apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto].
  apply cequivc_refl.
Qed.

(*
   H |- a = b in Base

     By IntSubtypeBase

     H |- a = b in Int

 *)
Definition rule_int_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_int))]
      [].

Lemma rule_int_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_int_subtype_base H a b).
Proof.
  unfold rule_int_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_int_implies_cequiv in hyp0.
  apply equality_in_base_iff; spcast; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../per/" "../close/")
*** End:
*)


(* ==================================== *)
(* ===== CH07_inv_hmap_inv_poly.v ===== *)
(* ==================================== *)

Require Export CH06_induction.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma map_left_dart_less :
  forall (m:fmap)(mr:fmap)(p:point)(da:dart),
  inv_hmap mr -> inv_poly mr -> well_emb mr ->
  inv_noalign_point mr p -> convex mr ->
  inv_hmap m -> ~ exd m da -> left_dart mr p da ->
  forall (d:dart), exd m d -> ~ left_dart mr p d.
Proof.
intros m mr p da H_1 H_2 H_3 H_4 H_5 Hmap Hexd Hleft db Hdb.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; tauto.
 (* Cas 2 : m = I *)
 simpl in *.
 destruct Hmap as [Hmap [Hmap1 Hmap2]].
 rewritenotorandnot Hexd Hexd1 Hexd2.
 elim Hdb; clear Hdb; intro Hdb; [subst db | idtac].
  elim (left_dart_dec mr p d); [intro H1 | trivial].
   generalize (one_left mr p da d H_1 H_2 H_3 H_4 H_5 Hleft H1).
   intro H3; apply neq_sym in Hexd1; contradiction.
  apply (IHm Hmap Hexd2 Hdb).
 (* Cas 3 : m = L *)
 simpl in *; apply IHm; intuition.
Qed.

Lemma map_right_dart_less :
  forall (m:fmap)(mr:fmap)(p:point)(da:dart),
  inv_hmap mr -> inv_poly mr -> well_emb mr ->
  inv_noalign_point mr p -> convex mr ->
  inv_hmap m -> ~ exd m da -> right_dart mr p da ->
  forall (d:dart), exd m d -> ~ right_dart mr p d.
Proof.
intros m mr p da H_1 H_2 H_3 H_4 H_5 Hmap Hexd Hright db Hdb.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; tauto.
 (* Cas 2 : m = I *)
 simpl in *.
 destruct Hmap as [Hmap [Hmap1 Hmap2]].
 rewritenotorandnot Hexd Hexd1 Hexd2.
 elim Hdb; clear Hdb; intro Hdb; [subst db | idtac].
  elim (right_dart_dec mr p d); [intro H1 | trivial].
   generalize (one_right mr p da d H_1 H_2 H_3 H_4 H_5 Hright H1).
   intro H3; apply neq_sym in Hexd1; contradiction.
  apply (IHm Hmap Hexd2 Hdb).
 (* Cas 3 : m = L *)
 simpl in *; apply IHm; tauto.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Theorem inv_hmap_CHID :
  forall (m:fmap)(mr:fmap)(x:dart)(tx:tag)(px:point)(max:dart),
  submap m mr -> inv_hmap m ->
  inv_hmap mr -> inv_poly mr -> well_emb mr -> inv_noalign_point mr px -> convex mr ->
  x <> nil -> max <> nil -> x <> max -> ~ exd mr x ->  ~ exd mr max ->
  inv_hmap (CHID m mr x tx px max).
Proof.
intros m mr x tx px max Hsub Hinv1 Hmr1 Hmr2 Hmr3 Hmr4 Hmr5 Hneq1 Hneq2 Hneq0 Hexd1 Hexd2.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; unfold prec_I; simpl; tauto.
 (* Cas 2 : m = I *)
simpl in Hsub, Hinv1.
unfold prec_I in Hinv1.
destruct Hsub as [Hsub [Hsub1 [Hsub2 Hsub3]]].
destruct Hinv1 as [Hinv1 [Hneq3 Hexd3]].
generalize (IHm Hsub Hinv1); clear IHm; intro IHm.
 simpl in *.
 elim blue_dart_dec.
  elim invisible_dec.
   intros H_ccw H_blue.
(* == 1 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
   elim left_dart_dec.
    intros H_left H_ccw H_blue.
(* == 2 == *)
simpl; unfold prec_I, prec_L.
simpl; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
apply and_not_not_or; split.
 apply (exd_not_exd_neq mr d max); assumption.
 apply (max_CHID_3 m mr x tx px max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply (map_left_dart_less m mr px d); try assumption.
left; trivial.
right; right; apply (x_CHID_1 m mr x tx px max); try assumption.
unfold succ; simpl; apply (max_CHID_4 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
unfold pred; simpl; apply (x_CHID_5 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
elimeqdartdec; apply neq_sym; assumption.
right; left; trivial.
left; trivial.
unfold succ; simpl; apply eq_not_neq; apply not_exd_A_nil; try assumption.
 apply (not_exd_CHID m mr x tx px max d); try assumption.
  apply (exd_not_exd_neq mr d x); assumption.
  apply (exd_not_exd_neq mr d max); assumption.
unfold pred; simpl; apply (max_CHID_5 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
elim (eq_dart_dec max d).
 intro Heq; subst d; contradiction.
 elimeqdartdec; intuition.
(* ======= *)
    intros H_left H_ccw H_blue.
(* == 3 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
  elim red_dart_dec.
   elim invisible_dec.
    intros H_ccw H_red H_blue.
(* == 4 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
    elim right_dart_dec.
    intros H_right H_ccw H_red H_blue.
(* == 5 == *)
simpl; unfold prec_I, prec_L.
simpl; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
right; apply (x_CHID_1 m mr x tx px max); try assumption.
left; trivial.
unfold succ; simpl; apply (x_CHID_4 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply (map_right_dart_less m mr px d); try assumption.
unfold pred; simpl; apply eq_not_neq; apply not_exd_A_1_nil; try assumption.
 apply (not_exd_CHID m mr x tx px max d); try assumption.
  apply (exd_not_exd_neq mr d x); assumption.
  apply (exd_not_exd_neq mr d max); assumption.
elim (eq_dart_dec d x); intro Heq.
 subst d; contradiction.
 assert (H0 : cA (CHID m mr x tx px max) zero x = x).
  apply fixpoint_cA; try assumption.
  apply (x_CHID_1 m mr x tx px max); try assumption.
  apply (x_CHID_4 m mr x tx px max); try assumption.
   apply (submap_not_exd m mr x); try assumption.
   apply (map_right_dart_less m mr px d); try assumption.
  apply (x_CHID_3 m mr x tx px max); try assumption.
   apply (submap_not_exd m mr x); try assumption.
 rewrite H0; apply neq_sym; assumption.
(* ======= *)
     intros H_right H_ccw H_red H_blue.
(* == 6 == *)
assumption.
(* ======= *)
   intros Hred Hblue.
(* == 7 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
 (* Cas 3 : m = L *)
simpl in Hsub, Hinv1.
unfold prec_L in Hinv1.
destruct Hsub as [Hsub [Hsub1 Hsub2]].
destruct Hinv1 as [Hinv1 [H1 [H2 [H3 [H4 H5]]]]].
generalize (IHm Hsub Hinv1); clear IHm; intro IHm.
induction d; simpl in *.
  elim ccw_dec.
   intros H_ccw.
(* == 8 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (blue_dart_CHID_1 m mr x tx px max d0); try assumption.
 apply succ_zero_blue_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (red_dart_CHID_3 m mr x tx px max d1); try assumption.
 apply pred_zero_red_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
 unfold invisible; elim blue_dart_dec; intro Hblue.
  cut (~ blue_dart mr d1); [contradiction|idtac].
  apply red_not_blue; try assumption.
  apply pred_zero_red_dart; try assumption.
  unfold pred; rewrite Hsub2; try assumption.
  apply (exd_not_nil m d0); try assumption.
  left; rewrite Hsub2; assumption.
apply (blue_dart_CHID_5 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply succ_zero_blue_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 rewrite Hsub1; assumption.
apply (red_dart_CHID_8 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply pred_zero_red_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
 rewrite Hsub2; assumption.
assert (H0 : cA (CHID m mr x tx px max) zero d0 = d0).
 apply fixpoint_cA; try assumption.
 apply (blue_dart_CHID_1 m mr x tx px max d0); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (blue_dart_CHID_5 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
  rewrite Hsub1; assumption.
 apply (blue_dart_CHID_3 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply succ_zero_blue_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply pred_zero_red_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======= *)
   intros H_ccw.
(* == 9 == *)
assumption.
(* ======= *)
  elim invisible_dec.
   intros H_ccw.
(* == 10 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (red_dart_CHID_3 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (blue_dart_CHID_1 m mr x tx px max d1); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
apply (red_dart_CHID_5 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (blue_dart_CHID_20 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
assert (H0 : cA (CHID m mr x tx px max) one d0 = d0).
 apply fixpoint_cA; try assumption.
 apply (red_dart_CHID_3 m mr x tx px max d0); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (red_dart_CHID_5 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (red_dart_CHID_2 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply pred_one_blue_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply succ_one_red_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======== *)
   elim invisible_dec.
    intros H_ccw1 H_ccw2.
(* == 11 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (red_dart_CHID_11 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (blue_dart_CHID_1 m mr x tx px max d1); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
apply (red_dart_CHID_13 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (blue_dart_CHID_20 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
assert (H0 : cA (CHID m mr x tx px max) one d0 = d0).
 apply fixpoint_cA; try assumption.
apply (red_dart_CHID_11 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (red_dart_CHID_13 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
 apply (red_dart_CHID_2 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply pred_one_blue_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply succ_one_red_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======== *)
    intros H_ccw1 H_ccw2.
(* == 12 == *)
assumption.
(* ======== *)
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Theorem inv_poly_CHID :
  forall (m:fmap)(x:dart)(tx:tag)(px:point)(max:dart),
  inv_hmap m -> inv_poly m -> well_emb m -> inv_noalign_point m px -> convex m ->
  x <> nil -> max <> nil -> x <> max -> ~ exd m x ->  ~ exd m max ->
  inv_poly (CHID m m x tx px max).
Proof.
intros m x tx px max H1 H2 H3 H4 H5 Hneq1 Hneq2 Hneq0 Hexd1 Hexd2.
unfold inv_poly; intros d Hexd0.
assert (Hsub : submap m m).
 apply submap_2_submap; try assumption.
 apply submap_2_refl.
generalize (exd_CHID_exd_m_or_x_or_max m m x tx px max d Hexd0); intro H.
elim H; clear H; intro H.
 generalize (H2 d H); clear H2; intro H2.
 elim H2; clear H2; intro H2.
  left; apply black_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
 elim H2; clear H2; intro H2.
  cut (black_dart (CHID m m x tx px max) d \/ blue_dart (CHID m m x tx px max) d).
  intro H0; elim H0; clear H0; intro H0.
  left; assumption.
  right; left; assumption.
  apply blue_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
  cut (~ exd (CHID m m x tx px max) d \/ red_dart (CHID m m x tx px max) d).
  intro H0; elim H0; clear H0; intro H0.
  contradiction.
  right; right; assumption.
  apply red_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
elim H; clear H; intro H; subst d.
 elim (pred_dec (CHID m m x tx px max) one x); intro Hpred.
  apply (pred_one_x_exd_left_dart) in Hpred; try assumption.
  generalize (exd_left_dart_exd_right_dart m px H1 H2 Hpred); intro Hsucc.
  cut (blue_dart (CHID m m x tx px max) x).
  right; left; assumption.
  apply x_CHID_11; try assumption.
  cut (forall (d:dart), exd m d -> ~ left_dart m px d). intro Hleft.
  cut (forall (d:dart), exd m d -> ~ right_dart m px d). intro Hright.
  cut (black_dart (CHID m m x tx px max) x).
  left; assumption.
  apply x_CHID_6; try assumption.
  intros d Hexd; split.
  apply Hleft; try assumption.
  apply Hright; try assumption.
  apply not_exd_left_dart_not_exd_right_dart; try assumption.
  intros d Hexd.
  apply (not_pred_one_x_not_exd_left_dart m m x tx px max); try assumption.
  cut (~ exd (CHID m m x tx px max) max \/ red_dart (CHID m m x tx px max) max).
  intro H0; elim H0; clear H0; intro H0.
  contradiction.
  right; right; assumption.
  apply max_CHID; try assumption.
  left; apply exd_max_exd_left_dart with x tx max; try assumption.
Qed.


(**
HSS Signature to Signature functor

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Notations.
(* Require Import UniMath.SubstitutionSystems.FromBindingSigsToMonads_Summary. *)
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.Signatures.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.
(* Require Import UniMath.CategoryTheory.Chains.All. *)
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.SubstitutionSystems.ModulesFromSignatures.
Require Import UniMath.SubstitutionSystems.SignatureCategory.
Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.LModulesComplements.
Require Import Modules.Signatures.Signature.
Open Scope cat.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.PointedFunctors.
Set Automatic Introduction.

Section LiftLModuleMor.

Context {C D : category} (H : Signature C D C)
          (T : Monad C).

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ).
Local Notation "'p' T" := (ptd_from_mon  T) (at level 3).

(* Has this been already defined somewhere ?? *)
Definition ptd_mor_from_Monad_mor {M N : Monad C} (f : Monad_Mor M N)
  : ptd_mor _ (p M) (p N).
Proof.
  use tpair.
  - apply f.
  - intro c.
    apply (Monad_Mor_η f).
Defined.

Local Notation liftlmodule := (ModulesFromSignatures.lift_lmodule H T).
(* We should move this part (that turns a signature into a functor)
 into UniMath/ModulesFromSignatures *)
(**
The following diagram must be proved commutative:
<<<

                H f (T X)                θ
  (H M) (T X) ---------> (H N) (T X) --------> H (N T) X
       |                                           |
       |                                           |
       |                                           |
 θ     |                                           |  H (σ_N) X
       |                                           |
       |                                           |
       V                                           V
   H (M T) X ------------> (H M) X ----------->  (H N) X
                H (σ_M) X            (H f) X

>>>

By naturality of θ, the top arrow rewrites
<<<
                θ                      H (f T) X
  (H M) (T X) ---------> (H (M T)) X ----------> H (N T) X
>>>
And the remaining diagram comes from the fact that f is a module morphism

*)

Lemma lift_lmodule_mor_law {M N : LModule T C} (f : LModule_Mor T M N) :
  LModule_Mor_laws T (T := liftlmodule M) (T' := liftlmodule N) (# H (f : _ ⟹ _)).
Proof.
  intro X.
  etrans; [apply assoc|].
  etrans.
  {
    apply cancel_postcomposition.
    apply (θ_nat_1_pw _ _ (f : nat_trans _ _) (p T) X).
  }
  etrans;[|apply assoc].
  etrans;[eapply pathsinv0; apply assoc |].
  apply cancel_precomposition.
  etrans; [apply functor_comp_pw|].
  etrans; [| eapply pathsinv0; apply functor_comp_pw].
  apply functor_cancel_pw.
  apply (nat_trans_eq (homset_property _)).
  intro x.
  cbn. unfold HorizontalComposition.horcomp_data; cbn.
  rewrite functor_id, id_right.
  apply LModule_Mor_σ.
Qed.

Definition lift_lmodule_mor {M N : LModule T C} (f : LModule_Mor T M N) :
  LModule_Mor T (liftlmodule M) (liftlmodule N)
  := # H (f : M ⟹ N),, lift_lmodule_mor_law f.

End LiftLModuleMor.

Section SigWithStrengthToSignature.

Context {C : category}.

Local Notation MONAD := (Monad C).
Local Notation PRE_MONAD := (category_Monad C).

Local Notation hsC := (homset_property C).

Context (H : Signature C C C).
Local Notation liftlmodule := (ModulesFromSignatures.lift_lmodule H ).

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ).
(** commutation pullback module/liftlmodule *)
(**
It is almost the same diagram than for liftlmodule_mor, but now we exploit
the naturality in the second component
<<<

                H S (T X)                θ
  (H S) (R X) ---------> (H S) (S X) --------> H (S S) X
       |                                           |
       |                                           |
       |                                           |
 θ     |                                           |  H (μ_S) X
       |                                           |
       |                                           |
       V                                           V
   H (S R) X ------------> (H M) X ----------->  (H S) X
                H (σ_M) X            (H f) X

>>>

By naturality of θ, the top arrow rewrites
<<<
                θ                      H (f T) X
  (H M) (T X) ---------> (H (M T)) X ----------> H (N T) X
>>>
*)
Lemma lift_pb_LModule_eq_mult {R S : Monad C} ( f : Monad_Mor R S) c :
  (ModulesFromSignatures.lift_lm_mult H R (pb_LModule f (tautological_LModule S)) : nat_trans _ _) c =
  (pb_LModule_σ f (liftlmodule S (tautological_LModule S))) c.
Proof.
  apply pathsinv0.
    etrans;[ apply assoc|].
  etrans.
  {
    apply cancel_postcomposition.
    apply (θ_nat_2_pw (S : functor _ _) _ _ (ptd_mor_from_Monad_mor f)).
  }
  apply pathsinv0.
  cbn.
  etrans;[|apply assoc].
  apply cancel_precomposition.
  apply pathsinv0.
  etrans;[apply functor_comp_pw|].
  apply functor_cancel_pw.
  apply nat_trans_eq.
  - apply homset_property.
  - intro x.
    cbn. unfold HorizontalComposition.horcomp_data; cbn.
    rewrite id_left.
    apply idpath.
Qed.

Lemma lift_pb_LModule_iso
  {R S : Monad C}
  (f : Monad_Mor R S) :
    iso (C := precategory_LModule _ _)
    (liftlmodule R (pb_LModule f (tautological_LModule S)))
    (pb_LModule f (liftlmodule S (tautological_LModule S))).
Proof.
  apply LModule_same_func_iso.
  apply lift_pb_LModule_eq_mult.
Defined.

Definition lift_pb_LModule
  {R S : Monad C}
  (f : Monad_Mor R S) :
  LModule_Mor R (liftlmodule R (pb_LModule f (tautological_LModule S)))
              (pb_LModule f (liftlmodule S (tautological_LModule S))) :=
  morphism_from_iso (lift_pb_LModule_iso f).

Definition sigWithStrength_to_sig_data : @signature_data C.
Proof.
  use tpair.
  + intro R.
    apply (ModulesFromSignatures.lift_lmodule H _ (tautological_LModule _ )).
  + cbn.
    intros R S f.
    cbn.
    (* We need a morphism H R ---> H (f* S)
        defined as H R ---> H (f* S) ---> f* (H S)
     *)
    eapply (compose (C := category_LModule R C)).
           (* LModule_composition. *)
    * use lift_lmodule_mor.
      -- apply (pb_LModule f).
         apply (tautological_LModule S).
      -- apply monad_mor_to_lmodule.
    * apply lift_pb_LModule.
Defined.

Lemma sigWithStrength_to_sig_is_signature : is_signature sigWithStrength_to_sig_data.
Proof.
  split.
  - intros R X.
    cbn.
    rewrite id_right.
    assert (h := functor_id H (R : functor _ _)).
    eapply nat_trans_eq_pointwise in h.
    etrans; [|apply h].
    apply functor_cancel_pw.
    apply (nat_trans_eq (homset_property _)).
    intro; apply idpath.
  - intros R S T f g.
    apply LModule_Mor_equiv;[apply homset_property|].
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite !id_right.
    apply pathsinv0.
    apply functor_comp_pw.
Qed.

Definition sigWithStrength_to_sig : signature C := sigWithStrength_to_sig_data ,, sigWithStrength_to_sig_is_signature.

End SigWithStrengthToSignature.

Section SigWithStrengthToSignatureMor.
  Context {C  : category}.

  Let Sig := Signature_category C C C.
  Local Notation F := sigWithStrength_to_sig.

  Context {A B : Sig}.
  Variable (f : Sig ⟦ A, B⟧).

  (* Let θ_nat_2_pw (H : Signature C (homset_property C) C (homset_property C)) := *)
  (*   (θ_nat_2_pointwise _ _ _ _ H (theta H)). *)
  (* Let θ_nat_1_pw (H : Signature C (homset_property C) C (homset_property C)) := *)
  (*   (θ_nat_1_pointwise _ _ _ _ H (theta H)). *)
  Local Notation "'p' T" := (ptd_from_mon T) (at level 3).

  Lemma sigWithStrength_to_sig_mod_mor_laws (R : Monad C) :
  @LModule_Mor_laws C R C (F A R) (F B R)
    ( (# (SignatureForgetfulFunctor C C C) f : nat_trans _ _) ( R : functor _ _ )).
  Proof.
    (*
<<<
              f_R R
    A(R) R -----------> B(R) R
       |                   |
       |                   |
 θ A   |                   | θ B
       |                   |
       |                   |
       V                   V
    A(R R)              B (R R)
       |                   |
       |                   |
 A(μ)  |                   | B(μ)
       |                   |
       |                   |
       V                   V
      A(R) ----------->  B(R)
             f_R
>>>
And as f is a signature morphism, we have

<<<
              f_X R
    A(X) R ---------->  B(X) R
       |                   |
       |                   |
 θ A   |                   | θ B
       |                   |
       |                   |
       V                   V
    A(X R) ----------->  B(X R)
             f_XR
>>>
*)
    intro c.
    assert (hf := nat_trans_eq_pointwise (pr2 f (R : functor _ _) (p R)) c).
    cbn in hf. unfold HorizontalComposition.horcomp_data in hf; cbn in hf.
    rewrite functor_id,id_right in hf.
    cbn.
    etrans.
    {
      etrans;[apply assoc|].
      apply cancel_postcomposition.
      exact ( !hf).
    }
    do 2 rewrite <- assoc.
    apply cancel_precomposition.
    apply pathsinv0.
    assert (hf' := (nat_trans_ax (pr1 f) _ _ (μ R) )).
    eapply nat_trans_eq_pointwise in hf'.
    apply hf'.
  Qed.

  Definition sigWithStrength_to_sig_mod_mor (R : Monad C) :
    LModule_Mor  R  (F A R) (F B R) :=
    _ ,, sigWithStrength_to_sig_mod_mor_laws R.

  Lemma sigWithStrength_to_sig_is_signature_Mor : is_signature_Mor (F A) (F B) sigWithStrength_to_sig_mod_mor.
  Proof.
    intros R S g.
    change ((#(A : Signature _ _ _ ) (g : nat_trans _ _))· identity _ · (pr11 f (S : functor _ _)) =
            (pr11 f (R : functor _ _)) · (# (B : Signature _ _ _ ) (g : nat_trans _ _) · identity _)).
    do 2 rewrite id_right.
    apply nat_trans_ax.
  Qed.
  Definition sigWithStrength_to_sig_mor   : signature_Mor (F A) (F B) :=
    _ ,, sigWithStrength_to_sig_is_signature_Mor.
End SigWithStrengthToSignatureMor.

Section SigWithStrengthToSignatureFunctor.
  Context {C  : category}.

  Let Sig := Signature_category C C C.
  Local Notation F := sigWithStrength_to_sig.

  Definition sigWithStrength_to_sig_functor_data : functor_data Sig (signature_category (C := C)) :=
    make_functor_data (C' := signature_category) _ (@sigWithStrength_to_sig_mor C).

  Lemma sigWithStrength_to_sig_is_functor : is_functor sigWithStrength_to_sig_functor_data.
  Proof.
    split.
    - intro S.
      apply signature_Mor_eq.
      intro X.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply idpath.
    - intros R S T f g.
      apply signature_Mor_eq.
      intro X.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply idpath.
  Defined.

  Definition sigWithStrength_to_sig_functor : functor Sig (signature_category (C := C)) :=
    make_functor _ sigWithStrength_to_sig_is_functor.
End SigWithStrengthToSignatureFunctor.


Require Import QArith_base Qcanon.
Require Import RAux.
Require Import PolSBase.
Require Import PolAuxList.
Require Import PolAux.

Definition Qc2R_can a :=
  if (Pos.eqb (Qden a) 1) then IZR (Qnum a)
  else if (Z.eqb (Qnum a) 1) then Rinv (IZR (Z.pos (Qden a)))
  else (IZR (Qnum a) / IZR (Z.pos (Qden a)))%R.

Definition Rconvert_back (e : PExpr Qc) (l : list R) : R :=
  convert_back Qc R R0 Rplus Rminus Rmult Ropp Qc2R_can l e.

Definition is_Qc1 := Qc_eq_bool 1.
Definition is_Qc0 := Qc_eq_bool 0.
Definition is_Qcpos x := Qle_bool 0 (this x).
Definition is_Qcdiv (x y : Qc) := true.

Definition Rsimpl_minus (e : PExpr Qc) :=
  simpl_minus
    Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv e.

Definition Rsimpl (e : PExpr Qc) :=
  simpl
    Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv e.

Ltac rs term1 term2 :=
  let term := constr:(Rminus term1 term2) in
  let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
  let fv := Trev rfv in
  let expr1 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term1 fv in
  let expr2 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term2 fv in
  let re := (eval vm_compute in (Rsimpl_minus (PEsub expr1 expr2))) in
  let expr3 := match re with (PEsub ?X1 _) => X1 end in
  let expr4 := match re with (PEsub _ ?X1) => X1 end in
  let re1 := constr:(PEsub expr1 expr3) in
  let re1' :=
      (eval
         unfold
         Rconvert_back, convert_back, pos_nth, jump,
       hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
        inject_Z, Z.eqb, Qden, Qnum, Z2R, P2R,
       Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
       Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
 in (Rconvert_back (PEadd re1 expr3) fv))
  in
  let re1'' := (eval lazy beta in re1') in
  let
    re2' :=
    (eval
       unfold
       Rconvert_back, convert_back, pos_nth, jump,
     hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
     inject_Z, Z.eqb, Qden, Qnum, Z2R, P2R,
     Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
     Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
     in (Rconvert_back (PEadd re1 expr4) fv))
  in
  let re2'' := (eval lazy beta in re2') in
  replace2_tac term1 term2 re1'' re2''; [idtac| try field | try field].

Ltac rpols :=
  match goal with
  | |- (?X1 = ?X2)%R => rs X1 X2; try apply Rplus_eq_compat_l
  | |- (?X1 <> ?X2)%R => rs X1 X2; apply Rplus_neg_compat_l
  | |- Rlt ?X1 ?X2 => rs X1 X2; apply Rplus_lt_compat_l
  | |- Rgt ?X1 ?X2 => rs X1 X2; apply Rplus_gt_compat_l
  | |- Rle ?X1 ?X2 => rs X1 X2; apply Rplus_le_compat_l
  | |- Rge ?X1 ?X2 => rs X1 X2; apply Rplus_ge_compat_l
  | _ => fail
  end.

Ltac hyp_rpols H :=
  generalize H;
  let tmp := fresh "tmp" in
  match (type of H) with
  | (?X1 = ?X2)%R =>
    rs X1 X2; intros tmp; generalize (Rplus_eq_reg_l _ _ _ tmp); clear H tmp; intro H
  | (?X1 <> ?X2)%nat =>
    rs X1 X2; intros tmp; generalize (Rplus_neg_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rlt ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_lt_reg_r _ _ _ tmp); clear H tmp; intro H
  | Rgt ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_gt_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rle ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_le_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rge ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_ge_reg_l _ _ _ tmp); clear H tmp; intro H
  | _ => fail
  end.