(*****************************************************************

 Enrichments of functors

 In this file, we define functos with enrichments. The approach
 we take, is the same as for enrichments for categories.

 Contents
 1. Functors with enrichments
 2. Fully faithful functors
 3. The enriched identity functor
 4. The composition of enriched functors
 5. The constant functor

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.limits.terminal.

Import MonoidalNotations.

Local Open Scope cat.
Local Open Scope moncat.

(**
 1. Functors with enrichments
 *)
Definition functor_enrichment_data
           {V : monoidal_cat}
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           (E₁ : enrichment C₁ V)
           (E₂ : enrichment C₂ V)
  : UU
  := ∏ (x y : C₁), E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , F y ⦄.

Definition is_functor_enrichment
           {V : monoidal_cat}
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (FE : functor_enrichment_data F E₁ E₂)
  : UU
  := (∏ (x : C₁),
      enriched_id E₁ x · FE x x
      =
      enriched_id E₂ (F x))
     ×
     (∏ (x y z : C₁),
      enriched_comp E₁ x y z
      · FE x z
      =
      FE y z #⊗ FE x y
      · enriched_comp E₂ (F x) (F y) (F z))
     ×
     (∏ (x y : C₁) (f : x --> y),
      enriched_from_arr E₂ (#F f)
      =
      enriched_from_arr E₁ f · FE x y).

Definition isaprop_is_functor_enrichment
           {V : monoidal_cat}
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (FE : functor_enrichment_data F E₁ E₂)
  : isaprop (is_functor_enrichment FE).
Proof.
  repeat (use isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property.
Qed.

Definition functor_enrichment
           {V : monoidal_cat}
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           (E₁ : enrichment C₁ V)
           (E₂ : enrichment C₂ V)
  : UU
  := ∑ (FE : functor_enrichment_data F E₁ E₂), is_functor_enrichment FE.

Definition isaset_functor_enrichment
           {V : monoidal_cat}
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           (E₁ : enrichment C₁ V)
           (E₂ : enrichment C₂ V)
  : isaset (functor_enrichment F E₁ E₂).
Proof.
  use isaset_total2.
  - do 2 (use impred_isaset ; intro).
    apply homset_property.
  - intro.
    apply isasetaprop.
    apply isaprop_is_functor_enrichment.
Qed.

Definition functor_enrichment_to_data
           {V : monoidal_cat}
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (FE : functor_enrichment F E₁ E₂)
           (x y : C₁)
  : E₁ ⦃ x, y ⦄ --> E₂ ⦃ F x, F y ⦄
  := pr1 FE x y.

Coercion functor_enrichment_to_data : functor_enrichment >-> Funclass.

Section FunctorLaws.
  Context {V : monoidal_cat}
          {C₁ C₂ : category}
          {F : C₁ ⟶ C₂}
          {E₁ : enrichment C₁ V}
          {E₂ : enrichment C₂ V}
          (FE : functor_enrichment F E₁ E₂).

  Definition functor_enrichment_id
             (x : C₁)
    : enriched_id E₁ x · FE x x
      =
      enriched_id E₂ (F x).
  Proof.
    exact (pr12 FE x).
  Qed.

  Definition functor_enrichment_comp
             (x y z : C₁)
    : enriched_comp E₁ x y z
      · FE x z
      =
      FE y z #⊗ FE x y
      · enriched_comp E₂ (F x) (F y) (F z).
  Proof.
    exact (pr122 FE x y z).
  Qed.

  Definition functor_enrichment_from_arr
             {x y : C₁}
             (f : x --> y)
    : enriched_from_arr E₂ (#F f)
      =
      enriched_from_arr E₁ f · FE x y.
  Proof.
    exact (pr222 FE x y f).
  Qed.
End FunctorLaws.

Definition functor_with_enrichment
           {V : monoidal_cat}
           (E₁ : cat_with_enrichment V)
           (E₂ : cat_with_enrichment V)
  : UU
  := ∑ (F : E₁ ⟶ E₂), functor_enrichment F E₁ E₂.

Coercion functor_with_enrichment_to_functor
         {V : monoidal_cat}
         {E₁ : cat_with_enrichment V}
         {E₂ : cat_with_enrichment V}
         (F : functor_with_enrichment E₁ E₂)
  : E₁ ⟶ E₂
  := pr1 F.

(**
 2. Fully faithful functors
 *)
Definition fully_faithful_enriched_functor
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {V : monoidal_cat}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (EF : functor_enrichment F E₁ E₂)
  : UU
  := ∏ (x y : C₁), is_z_isomorphism (EF x y).

Definition isaprop_fully_faithful_enriched_functor
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {V : monoidal_cat}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (EF : functor_enrichment F E₁ E₂)
  : isaprop (fully_faithful_enriched_functor EF).
Proof.
  repeat (use impred ; intro).
  apply isaprop_is_z_isomorphism.
Qed.

Definition fully_faithful_enriched_functor_to_faithful
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           {V : monoidal_cat}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           (EF : functor_enrichment F E₁ E₂)
           (HEF : fully_faithful_enriched_functor EF)
  : faithful F.
Proof.
  intros x y f.
  use invproofirrelevance.
  intros φ₁ φ₂.
  use subtypePath.
  {
    intro.
    apply homset_property.
  }
  refine (!(enriched_to_from_arr E₁ (pr1 φ₁)) @ _).
  refine (_ @ enriched_to_from_arr E₁ (pr1 φ₂)).
  apply maponpaths.
  use (cancel_z_iso _ _ (_ ,, HEF x y)) ; cbn.
  pose (maponpaths (enriched_from_arr E₂) (pr2 φ₁ @ !(pr2 φ₂))) as p.
  rewrite !(functor_enrichment_from_arr EF) in p.
  exact p.
Qed.

(**
 3. The enriched identity functor
 *)
Definition functor_id_enrichment
           {V : monoidal_cat}
           {C : category}
           (E : enrichment C V)
  : functor_enrichment (functor_identity C) E E.
Proof.
  refine ((λ x y, identity _) ,, _).
  repeat split.
  - abstract
      (intro x ; cbn ;
       apply id_right).
  - abstract
      (intros x y z ; cbn ;
       rewrite id_right ;
       rewrite tensor_id_id ;
       rewrite id_left ;
       apply idpath).
  - abstract
      (intros x y f ; cbn ;
       rewrite id_right ;
       apply idpath).
Defined.

Definition functor_id_enrichment_fully_faithful
           {V : monoidal_cat}
           {C : category}
           (E : enrichment C V)
  : fully_faithful_enriched_functor (functor_id_enrichment E).
Proof.
  intros x y.
  apply is_z_isomorphism_identity.
Defined.

(**
 4. The composition of enriched functors
 *)
Definition functor_comp_enrichment
           {V : monoidal_cat}
           {C₁ C₂ C₃ : category}
           {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           {E₃ : enrichment C₃ V}
           (FE₁ : functor_enrichment F₁ E₁ E₂)
           (FE₂ : functor_enrichment F₂ E₂ E₃)
  : functor_enrichment (F₁ ∙ F₂) E₁ E₃.
Proof.
  refine ((λ x y, FE₁ x y · FE₂ (F₁ x) (F₁ y)) ,, _).
  repeat split ; cbn.
  - abstract
      (intros x ;
       rewrite !assoc ;
       etrans ;
       [ apply maponpaths_2 ;
         apply functor_enrichment_id
       | ] ;
       apply functor_enrichment_id).
  - abstract
      (intros x y z ;
       rewrite !assoc ;
       etrans ;
       [ apply maponpaths_2 ;
         apply functor_enrichment_comp
       | ] ;
       rewrite !assoc' ;
       etrans ;
       [ apply maponpaths ;
         apply functor_enrichment_comp
       | ] ;
       rewrite !assoc ;
       apply maponpaths_2 ;
       rewrite tensor_comp_mor ;
       apply idpath).
  - abstract
      (intros x y f ;
       etrans ;
       [ apply (functor_enrichment_from_arr FE₂)
       | ] ;
       etrans ;
       [ apply maponpaths_2 ;
         apply (functor_enrichment_from_arr FE₁)
       | ] ;
       rewrite !assoc ;
       apply idpath).
Defined.

Definition functor_comp_enrichment_fully_faithful
           {V : monoidal_cat}
           {C₁ C₂ C₃ : category}
           {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃}
           {E₁ : enrichment C₁ V}
           {E₂ : enrichment C₂ V}
           {E₃ : enrichment C₃ V}
           {FE₁ : functor_enrichment F₁ E₁ E₂}
           {FE₂ : functor_enrichment F₂ E₂ E₃}
           (HF₁ : fully_faithful_enriched_functor FE₁)
           (HF₂ : fully_faithful_enriched_functor FE₂)
  : fully_faithful_enriched_functor (functor_comp_enrichment FE₁ FE₂).
Proof.
  intros x y ; cbn.
  use is_z_iso_comp_of_is_z_isos.
  - apply HF₁.
  - apply HF₂.
Defined.

(**
 5. The constant functor
 *)
Definition functor_constant_enrichment
           {V : monoidal_cat}
           (HV : isTerminal V (I_{V}))
           {C₁ C₂ : category}
           (a : C₂)
           (E₁ : enrichment C₁ V)
           (E₂ : enrichment C₂ V)
  : functor_enrichment (constant_functor _ _ a) E₁ E₂.
Proof.
  simple refine (_ ,, _ ,, _ ,, _).
  - exact (λ x y, TerminalArrow (_ ,, HV) _ · enriched_id E₂ a).
  - abstract
      (intros x ; cbn ;
       rewrite !assoc ;
       refine (_ @ id_left _) ;
       apply maponpaths_2 ;
       apply (@TerminalArrowEq _ (_ ,, HV))).
  - abstract
      (intros x y z ; cbn ;
       refine (!_) ;
       etrans ;
       [ apply maponpaths_2 ;
         apply tensor_comp_mor
       | ] ;
       rewrite !assoc' ;
       etrans ;
       [ apply maponpaths ;
         rewrite tensor_split ;
         rewrite !assoc' ;
         rewrite <- enrichment_id_left ;
         rewrite tensor_lunitor ;
         apply idpath
       | ] ;
       rewrite !assoc ;
       apply maponpaths_2 ;
       apply (@TerminalArrowEq _ (_ ,, HV))).
  - abstract
      (intros x y f ; cbn ;
       rewrite enriched_from_arr_id ;
       refine (!(id_left _) @ _) ;
       rewrite !assoc ;
       apply maponpaths_2 ;
       apply (@TerminalArrowEq _ (_ ,, HV))).
Defined.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas for LN infrastructure *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Type_Substitution Cyclone_LN_FV Cyclone_LN_LC_Body Cyclone_LN_Open_Close Cyclone_LN_Tactics.

(* TODO:
     TOC
     more reasonable lemma naming.
     notation
     applys- why did this get dropped? what does it do?
     all: tactic.
     ltac:(some_tactic) - gallina expression evaluates to the terms from the tactic.
     Think about variable only substitution for some of the lemmas.
*)

(* Opening type variables in types. *)
Lemma open_rec_t_core:
  forall t i j u v,
    i <> j ->
      (open_rec_t_t j v t) = (open_rec_t_t i u (open_rec_t_t j v t)) ->
      t = (open_rec_t_t i u t).
Proof.
  induction t; introv Neq Equ; inversion* Equ; simpls; fequals*.
  case_nat*.
  case_nat*.
Qed.

(* Opening type variables in terms. *)

Lemma open_rec_t_tm_v_core:
  forall t i j  u v,
    i <> j ->
      (open_rec_t_tm_v j v t) = (open_rec_t_tm_v i u (open_rec_t_tm_v j v t)) ->
      t = (open_rec_t_tm_v i u t).
Proof.
  induction t; introv Neq Equ; inversion* Equ; simpls*.
Qed.

Ltac inversion_on_matching_terms :=
  match goal with
    | H: (?C _) = (?C _) |- _ => inversion H
    | H: (?C _ _) = (?C _ _) |- _ => inversion H
    | H: (?C _ _ _) = (?C _ _ _) |- _ => inversion H
  end.

Ltac open_rec_t_tm_x_core j' v0' v' :=
  intros;
  simpl in *;
  fequals*;
  simpl in *;
  try inversion_on_matching_terms;
  try solve[fequals*];
  try apply open_rec_t_tm_v_core with (j:= j') (v:= v0'); try assumption;
  apply open_rec_t_core with (j:= j') (v:= v'); try assumption.

(* BUG why can't I put this into the induction without j being bound? *)

(*
Definition Q :=
             (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_st j v t) =
                (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
                t = (open_rec_t_tm_st i u t)).

Lemma open_rec_t_tm_st_core':
  forall t i j u v,
    i <> j ->
    (open_rec_t_tm_st j v t) = (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
    t = (open_rec_t_tm_st i u t).
Proof.
  apply (St_ind_mutual
             (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_st j v t) =
                (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
                t = (open_rec_t_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_e j v t) =
                (open_rec_t_tm_e i u (open_rec_t_tm_e j v t)) ->
                t = (open_rec_t_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_f j v t) =
                (open_rec_t_tm_f i u (open_rec_t_tm_f j v t)) ->
                t = (open_rec_t_tm_f i u t)));
  open_rec_t_tm_x_core j v0 v.
Qed.

*)

Lemma open_rec_t_tm_st_core:
  forall t i j u v,
    i <> j ->
    (open_rec_t_tm_st j v t) = (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
    t = (open_rec_t_tm_st i u t).
Proof.
  apply (St_ind_mutual
             (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_st j v t) =
                (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
                t = (open_rec_t_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_e j v t) =
                (open_rec_t_tm_e i u (open_rec_t_tm_e j v t)) ->
                t = (open_rec_t_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_f j v t) =
                (open_rec_t_tm_f i u (open_rec_t_tm_f j v t)) ->
                t = (open_rec_t_tm_f i u t)));
  open_rec_t_tm_x_core j v0 v.
Qed.

Lemma open_rec_t_tm_e_core:
  forall t i j u v,
    i <> j ->
    (open_rec_t_tm_e j v t) = (open_rec_t_tm_e i u (open_rec_t_tm_e j v t)) ->
    t = (open_rec_t_tm_e i u t).
Proof.
  apply (E_ind_mutual
           (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_st j v t) = (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
                t = (open_rec_t_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_e j v t) = (open_rec_t_tm_e i u (open_rec_t_tm_e j v t)) ->
                t = (open_rec_t_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_f j v t) = (open_rec_t_tm_f i u (open_rec_t_tm_f j v t)) ->
                t = (open_rec_t_tm_f i u t)));
  open_rec_t_tm_x_core j v0 v.
Qed.

Lemma open_rec_t_tm_f_core:
  forall t i j u v,
    i <> j ->
    (open_rec_t_tm_f j v t) = (open_rec_t_tm_f i u (open_rec_t_tm_f j v t)) ->
    t = (open_rec_t_tm_f i u t).
Proof.
  apply (F_ind_mutual
           (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_st j v t) = (open_rec_t_tm_st i u (open_rec_t_tm_st j v t)) ->
                t = (open_rec_t_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_e j v t) = (open_rec_t_tm_e i u (open_rec_t_tm_e j v t)) ->
                t = (open_rec_t_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_t_tm_f j v t) = (open_rec_t_tm_f i u (open_rec_t_tm_f j v t)) ->
                t = (open_rec_t_tm_f i u t)));
  open_rec_t_tm_x_core j v0 v.
Qed.

Lemma open_rec_v_tm_core:
  forall t i j u v,
    i <> j ->
    (open_rec_t_tm j v t) = (open_rec_t_tm i u (open_rec_t_tm j v t)) ->
    t = (open_rec_t_tm i u t).
Proof.
  induction t; introv neq equ;
  simpl;
  fequals*;
  inversion equ.
  apply open_rec_t_tm_st_core with (j:= j) (v:= v); assumption.
  apply open_rec_t_tm_e_core with (j:= j) (v:= v); assumption.
  apply open_rec_t_tm_f_core with (j:= j) (v:= v); assumption.
Qed.

Lemma open_rec_v_tm_v_core:
  forall t i j  u v,
    i <> j ->
      (open_rec_v_tm_v j v t) = (open_rec_v_tm_v i u (open_rec_v_tm_v j v t)) ->
      t = (open_rec_v_tm_v i u t).
Proof.
  induction t; introv Neq Equ; inversion* Equ; simpls*.
  case_nat*.
  case_nat*.
Qed.

Lemma open_rec_v_tm_p_core:
  forall t i j  u v,
    i <> j ->
      (open_rec_v_tm_p j v t) = (open_rec_v_tm_p i u (open_rec_v_tm_p j v t)) ->
      t = (open_rec_v_tm_p i u t).
Proof.
  induction t; introv Neq Equ; inversion* Equ; simpls*.
  case_nat*.
  case_nat*.
Qed.

Ltac open_rec_v_tm_x_core j v0:=
  try solve[intros;
            simpl in *;
            inversion_on_matching_terms;
            fequals*;
            try apply open_rec_v_tm_v_core with (j:= j) (v:= v0); auto;
            try apply open_rec_v_tm_p_core with (j:= j) (v:= v0); auto].

Lemma open_rec_v_tm_st_core:
  forall t i j u v,
    i <> j ->
    (open_rec_v_tm_st j v t) = (open_rec_v_tm_st i u (open_rec_v_tm_st j v t)) ->
    t = (open_rec_v_tm_st i u t).
Proof.
  apply (St_ind_mutual
           (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_st j v t) = (open_rec_v_tm_st i u (open_rec_v_tm_st j v t)) ->
                t = (open_rec_v_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_e j v t) = (open_rec_v_tm_e i u (open_rec_v_tm_e j v t)) ->
                t = (open_rec_v_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_f j v t) = (open_rec_v_tm_f i u (open_rec_v_tm_f j v t)) ->
                t = (open_rec_v_tm_f i u t)));
  open_rec_v_tm_x_core j v0.
Qed.

Lemma open_rec_v_tm_e_core:
  forall t i j u v,
    i <> j ->
    (open_rec_v_tm_e j v t) = (open_rec_v_tm_e i u (open_rec_v_tm_e j v t)) ->
    t = (open_rec_v_tm_e i u t).
Proof.
  apply (E_ind_mutual
           (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_st j v t) = (open_rec_v_tm_st i u (open_rec_v_tm_st j v t)) ->
                t = (open_rec_v_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_e j v t) = (open_rec_v_tm_e i u (open_rec_v_tm_e j v t)) ->
                t = (open_rec_v_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_f j v t) = (open_rec_v_tm_f i u (open_rec_v_tm_f j v t)) ->
                t = (open_rec_v_tm_f i u t)));
  open_rec_v_tm_x_core j v0.
Qed.

Lemma open_rec_v_tm_f_core:
  forall t i j u v,
    i <> j ->
    (open_rec_v_tm_f j v t) = (open_rec_v_tm_f i u (open_rec_v_tm_f j v t)) ->
    t = (open_rec_v_tm_f i u t).
Proof.
  apply (F_ind_mutual
           (fun t : St =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_st j v t) = (open_rec_v_tm_st i u (open_rec_v_tm_st j v t)) ->
                t = (open_rec_v_tm_st i u t))
           (fun t : E  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_e j v t) = (open_rec_v_tm_e i u (open_rec_v_tm_e j v t)) ->
                t = (open_rec_v_tm_e i u t))
           (fun t : F  =>
              forall i j u v,
                i <> j ->
                (open_rec_v_tm_f j v t) = (open_rec_v_tm_f i u (open_rec_v_tm_f j v t)) ->
                t = (open_rec_v_tm_f i u t)));
  open_rec_v_tm_x_core j v0.
Qed.

(* Bug bindings of names of LibVar vs LibVarPath. *)
Lemma lc__open_rec_t_identity:
  forall t,
    lc_t t -> forall k u, t = (open_rec_t_tk u t).
Proof.
  introv lct.
  induction lct; try intros k u; simpl; auto; try solve[congruence];

  introv;
  fequals*;
  pick_fresh alpha;
  (* lets: (open_rec_t_core t0). Lets is failing here. Bummer. *)
  lets L: open_rec_t_core;
  specialize (L t0 (S k0) 0 u (ftvar alpha));
  auto.
Qed.

Ltac inversion_on_lc :=
  match goal with
    | H : lc_t_tm_st _ |- _ => inversions H
    | H : lc_t_tm_e  _ |- _ => inversions H
    | H : lc_t_tm_f  _ |- _ => inversions H
  end.

Ltac lc_t_tm_x__open_rec_t_x_identity:=
  try solve[intros;
  inversion_on_lc;
  simpl;
  fequals*;
  try solve[apply* lc__open_rec_t_identity]].

Lemma lc_t_tm_st__open_rec_t_st_identity:
  forall t,
    lc_t_tm_st t -> forall k u, t = (open_rec_t_tm_st k u t).
Proof.
  apply (St_ind_mutual
          (fun t : St =>
              lc_t_tm_st t -> forall k u, t = (open_rec_t_tm_st k u t))
           (fun t : E  =>
              lc_t_tm_e t -> forall k u, t = (open_rec_t_tm_e k u t))
           (fun t : F  =>
              lc_t_tm_f t -> forall k u, t = (open_rec_t_tm_f k u t)));
  lc_t_tm_x__open_rec_t_x_identity.
Qed.

Lemma lc_t_tm_e__open_rec_t_st_identity:
  forall t,
    lc_t_tm_e t -> forall k u, t = (open_rec_t_tm_e k u t).
  apply (E_ind_mutual
           (fun t : St =>
              lc_t_tm_st t -> forall k u, t = (open_rec_t_tm_st k u t))
           (fun t : E  =>
              lc_t_tm_e t -> forall k u, t = (open_rec_t_tm_e k u t))
           (fun t : F  =>
              lc_t_tm_f t -> forall k u, t = (open_rec_t_tm_f k u t)));
  lc_t_tm_x__open_rec_t_x_identity.
Qed.

Lemma lc_t_tm_f__open_rec_t_st_identity:
  forall t,
    lc_t_tm_f t -> forall k u, t = (open_rec_t_tm_f k u t).
Proof.
  apply (F_ind_mutual
           (fun t : St =>
              lc_t_tm_st t -> forall k u, t = (open_rec_t_tm_st k u t))
           (fun t : E  =>
              lc_t_tm_e t -> forall k u, t = (open_rec_t_tm_e k u t))
           (fun t : F  =>
              lc_t_tm_f t -> forall k u, t = (open_rec_t_tm_f k u t)));
  lc_t_tm_x__open_rec_t_x_identity.
Qed.

Lemma lc_t_tm__open_rec_t_identity:
  forall t,
    lc_t_tm t -> forall k u, t = (open_rec_t_tm k u t).
Proof.
  destruct t; intros; simpl; fequals*; inversion H.
  apply* lc_t_tm_st__open_rec_t_st_identity.
  apply* lc_t_tm_e__open_rec_t_st_identity.
  apply* lc_t_tm_f__open_rec_t_st_identity.
Qed.

(* Substitution identity given fresh variables. *)

Lemma subst_t_tv_t_fresh : forall x t u,
  x \notin ftv_t t ->  t = (subst_t_tv_t u x t).
Proof.
  intros.
  induction t; simpls*;
  fequals*;
  case_var*.
Qed.

Lemma subst_t_tv_t_v_fresh : forall x t u,
  x \notin ftv_tm_v t ->  t = (subst_t_tv_t_v u x t).
Proof.
  induction t; simpls*.
Qed.

Ltac subst_t_tv_t_x_fresh :=
  lets: subst_t_tv_t_v_fresh;
  lets: subst_t_tv_t_fresh;
  intros;
  simpls*;
  fequals*.

Lemma subst_t_tv_t_st_fresh : forall x u t,
  x \notin ftv_tm_st t ->  t = (subst_t_tv_t_st u x t).
Proof.
  intros x u.
  apply (St_ind_mutual
           (fun t : St =>
              x \notin ftv_tm_st t ->  t = (subst_t_tv_t_st u x t))
           (fun t : E  =>
              x \notin ftv_tm_e t ->  t = (subst_t_tv_t_e u x t))
           (fun t : F  =>
              x \notin ftv_tm_f t ->  t = (subst_t_tv_t_f u x t)));
    subst_t_tv_t_x_fresh.
Qed.

Lemma subst_t_tv_t_e_fresh : forall x u t,
  x \notin ftv_tm_e t ->  t = (subst_t_tv_t_e u x t).
Proof.
  intros x u.
  apply (E_ind_mutual
           (fun t : St =>
              x \notin ftv_tm_st t ->  t = (subst_t_tv_t_st u x t))
           (fun t : E  =>
              x \notin ftv_tm_e t ->  t = (subst_t_tv_t_e u x t))
           (fun t : F  =>
              x \notin ftv_tm_f t ->  t = (subst_t_tv_t_f u x t)));
    subst_t_tv_t_x_fresh.
Qed.

Lemma subst_t_tv_t_f_fresh : forall x u t,
  x \notin ftv_tm_f t ->  t = (subst_t_tv_t_f u x t).
Proof.
  intros x u.
  apply (F_ind_mutual
           (fun t : St =>
              x \notin ftv_tm_st t ->  t = (subst_t_tv_t_st u x t))
           (fun t : E  =>
              x \notin ftv_tm_e t ->  t = (subst_t_tv_t_e u x t))
           (fun t : F  =>
              x \notin ftv_tm_f t ->  t = (subst_t_tv_t_f u x t)));
    subst_t_tv_t_x_fresh.
Qed.

Lemma subst_t_tv_t_tm_fresh : forall x u t,
  x \notin ftv_tm t ->  t = (subst_t_tv_t_tm u x t).
Proof.
  destruct t; intros; simpl; fequals*.
  apply* subst_t_tv_t_st_fresh.
  apply* subst_t_tv_t_e_fresh.
  apply* subst_t_tv_t_f_fresh.
Qed.

(* Substitutions for term variables in terms is identity with a fresh variable. *)

Lemma subst_v_v_tm_v_fresh : forall x t u,
  x \notin fv_tm_v t ->  t = (subst_v_v_tm_v u x t).
Proof.
  intros.
  induction t.
  all: simpls*.
  case_var*.
Qed.

Ltac subst_v_v_tm_x_fresh :=
  lets: subst_v_v_tm_v_fresh;
  lets: subst_t_tv_t_fresh;
  intros;
  simpls*;
  fequals*.

Lemma subst_v_v_tm_st_fresh : forall x u t,
  x \notin fv_tm_st t ->  t = (subst_v_v_tm_st u x t).
Proof.
  intros x u.
  apply (St_ind_mutual
           (fun t : St =>
              x \notin fv_tm_st t ->  t = (subst_v_v_tm_st u x t))
           (fun t : E  =>
              x \notin fv_tm_e t ->  t = (subst_v_v_tm_e u x t))
           (fun t : F  =>
              x \notin fv_tm_f t ->  t = (subst_v_v_tm_f u x t)));
    subst_v_v_tm_x_fresh.
Qed.

Lemma subst_v_v_tm_e_fresh : forall x u t,
  x \notin fv_tm_e t ->  t = (subst_v_v_tm_e u x t).
Proof.
  intros x u.
  apply (E_ind_mutual
           (fun t : St =>
              x \notin fv_tm_st t ->  t = (subst_v_v_tm_st u x t))
           (fun t : E  =>
              x \notin fv_tm_e t ->  t = (subst_v_v_tm_e u x t))
           (fun t : F  =>
              x \notin fv_tm_f t ->  t = (subst_v_v_tm_f u x t)));
    subst_v_v_tm_x_fresh.
Qed.

Lemma subst_v_v_tm_f_fresh : forall x u t,
  x \notin fv_tm_f t ->  t = (subst_v_v_tm_f u x t).
Proof.
  intros x u.
  apply (F_ind_mutual
           (fun t : St =>
              x \notin fv_tm_st t ->  t = (subst_v_v_tm_st u x t))
           (fun t : E  =>
              x \notin fv_tm_e t ->  t = (subst_v_v_tm_e u x t))
           (fun t : F  =>
              x \notin fv_tm_f t ->  t = (subst_v_v_tm_f u x t)));
    subst_v_v_tm_x_fresh.
Qed.

Lemma subst_v_v_tm_fresh : forall x u t,
  x \notin fv_tm t ->  t = (subst_v_v_tm u x t).
Proof.
  destruct t; intros; simpl; fequals*.
  apply* subst_v_v_tm_st_fresh.
  apply* subst_v_v_tm_e_fresh.
  apply* subst_v_v_tm_f_fresh.
Qed.

(* Substitution distributes on the open operation. *)

(* For types for type variable substitution. *)

Lemma subst_open_t :
  forall x u t1 t2,
    lc_t u ->
    (subst_t_tv_t u x (open_t t2 t1)) =
    (open_t (subst_t_tv_t u x t2) (subst_t_tv_t u x t1)).
Proof.
  intros.
  unfold open_t.
  generalize 0.
  induction t1; try solve[intros; simpl; fequals*].
  intros; simpl; case_nat*.
  intros.
  simpl.
  case_var*.
  apply* lc__open_rec_t_identity.
Qed.

(* For types for type variables in terms. *)
(* This does not make sense because we can not substitute terms into term binders
generally in Cyclone.

 This is due to the inability to generally substitute a term for a variable
 in p_e x p expressions.

 Will it make problems in the proofs? Perhaps.

Lemma subst_open_t_tm_st:
  forall u alpha s1 s2,
    lc_t u ->
    (subst_t_tv_t_st u alpha (open_rec_t_tm_st 0 s2 s1)) =
    (open_rec_t_tm_st 0 (subst_t_tv_t_st u alpha s2) (subst_t_tv_t_st u alpha s1)).

 And neither does this make sense:

Lemma subst_open_t_tm_st:
  forall x y s1 s2,
    lc_t_tm_st (e_s (v_e y)) ->
    (subst_v_v_tm_st x y (open_rec_v_tm_st 0 s2 s1)) =
    (open_rec_v_tm_st 0 (subst_v_v_tm_st x y s2) (subst_v_v_tm_st x y s1)).

 But both of these might work on variable for varible substition?

*)

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_tvar:
  forall (alpha beta : var) t e,
    alpha <> beta ->
    lc_t t ->
    forall n,
    (open_rec_t_tn (ftvar beta)  (subst_t_tv_t t  alpha e)) =
    (subst_t_tv_t t    alpha         (open_rec_t_t n (ftvar beta) e)).
Proof.
  introv Neq lctaut.
  induction e; intros;
  lets L: (lc__open_rec_t_identity lctaut);
  simpls*; fequals*; simpls*.
  case_nat*.
  simpl.
  case_var*.
  case_var*.
Qed.

Lemma subst_open_tvar_term:
  forall (alpha beta : var) t e,
    alpha <> beta ->
    lc_t t ->
    forall n,
    (open_rec_t_tm n (ftvar beta)  (subst_t_tv_t_tm t  alpha e)) =
    (subst_t_tv_t_tm    t    alpha      (open_rec_t_tm n (ftvar beta) e)).
Proof.
  introv Neq lctaut.
  induction e; intros.
  lets L: (lc_t_tm__open_rec_t_identity lctaut).
  simpls*; fequals*; simpls*.
  case_nat*.
  simpl.
  case_var*.
  case_var*.
Qed.

Lemma subst_open_evar:
  forall (x y : var) t e,
    x <> y ->
    lc_term t ->
    forall n,
    (open_rec_t_t n (fvar y)  (subst_t_tv_t t  x e)) =
    (subst_t_tv_t t          x   (open_rec_t_t n (fevar y) e)).
Proof.
  introv Neq lctaut.
  induction e; intros;
  lets L: (lc__open_rec_t_identity lctaut);
  simpls*; fequals*; simpls*.
  case_nat*.
  simpl.
  case_var*.
  case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro_tau :
  forall alpha t u,
    alpha \notin (ftv_t t) ->
    lc_t u ->
    (open_rec_t_t 0 t u) = (subst_t_tv_t u alpha (open_rec_t_t 0 t (ftvar alpha))).
Proof.
  introv Fr lctauu.
  induction t; intros; simpls*; case_var*; fequals*; simpls*;
  lets L : (lc__open_rec_t_identity lctauu 0);
  symmetry;
  auto.
Qed.

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(** Tactic to permute subst and open var *)

Ltac cross :=
  rewrite subst_open_var; try cross.

Tactic Notation "cross" "*" :=
  cross; auto_star.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs as y. rewrite* subst_open_var.
Qed.

Lemma subst_body : forall z u t,
  body t -> term u -> body ([z ~> u]t).
  unfold body. introv [L H]. exists (L \u \{z}).
  intros. rewrite~ subst_open_var. apply* subst_term.
Qed.

Hint Resolve subst_term subst_body.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof.
  intros. unfold body. inversion* H.
Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof.
  intros. inversion* H.
Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_tm : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_tm.

(* ********************************************************************** *)
(** ** Additional results on primitive operations *)

(** Open_var with fresh names is an injective operation *)

Lemma open_var_inj : forall x t1 t2,
  x \notin (fv t1) -> x \notin (fv t2) ->
  (t1 ^ x = t2 ^ x) -> (t1 = t2).
Proof.
  intros x t1. unfold open. generalize 0.
  induction t1; intro k; destruct t2; simpl; intros; inversion H1;
  try solve [ f_equal*
  | |-  do 2 try case_nat; inversions* H1; try notin_false ].
Qed.

(** Close var commutes with open with some freshness conditions,
  this is used in the proofs of [close_var_body] and [close_var_open] *)

Lemma close_var_rec_open : forall x y z t1 i j,
  i <> j -> y <> x -> y \notin (fv t1) ->
    {i ~> trm_fvar y} ({j ~> trm_fvar z} (close_var_rec j x t1) )
  = {j ~> trm_fvar z} (close_var_rec j x ({i ~> trm_fvar y}t1) ).
Proof.
  induction t1; simpl; intros; try solve [ f_equal* ].
  do 2 (case_nat; simpl); try solve [ case_var* | case_nat* ].
  case_var*. simpl. case_nat*.
Qed.

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_fresh : forall x t,
  x \notin fv (close_var x t).
Proof.
  introv. unfold close_var. generalize 0.
  induction t; intros k; simpls; notin_simpl; auto.
  case_var; simpls*.
Qed.

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_body : forall x t,
  term t -> body (close_var x t).
Proof.
  introv W. exists \{x}. intros y Fr.
  unfold open, close_var. generalize 0. gen y.
  induction W; intros y Fr k; simpls.
  case_var; simpls*. case_nat*.
  auto_star.
  apply_fresh* term_abs as z.
   unfolds open. rewrite* close_var_rec_open.
Qed.

(** Close var is the right inverse of open_var *)

Lemma close_var_open : forall x t,
  term t -> t = (close_var x t) ^ x.
Proof.
  introv W. unfold close_var, open. generalize 0.
  induction W; intros k; simpls; f_equal*.
  case_var*. simpl. case_nat*.
  let L := gather_vars in match goal with = ?t =>
    destruct (var_fresh (L \u fv t)) as [y Fr] end.
  apply* (@open_var_inj y).
  unfolds open. rewrite* close_var_rec_open.
Qed.

(** An abstract specification of close_var, which packages the
  result of the operation and all the properties about it. *)

Lemma close_var_spec : forall t x, term t ->
  exists u, t = u ^ x /\ body u /\ x \notin (fv u).
Proof.
  intros. exists (close_var x t). splits 3.
  apply* close_var_open.
  apply* close_var_body.
  apply* close_var_fresh.
Qed.


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 O : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ O A /\ (wd_ O B /\ (wd_ C O /\ (col_ A B C /\ col_ O A B))))))) -> col_ B O C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files extends the implementation of finite over [positive] to finite
maps whose keys range over Coq's data type of binary naturals [Z]. *)
From stdpp Require Import pmap mapset.
From stdpp Require Export prelude fin_maps.
Set Default Proof Using "Type".
Local Open Scope Z_scope.

Record Zmap (A : Type) : Type :=
  ZMap { Zmap_0 : option A; Zmap_pos : Pmap A; Zmap_neg : Pmap A }.
Arguments Zmap_0 {_} _ : assert.
Arguments Zmap_pos {_} _ : assert.
Arguments Zmap_neg {_} _ : assert.
Arguments ZMap {_} _ _ _ : assert.

Instance Zmap_eq_dec `{EqDecision A} : EqDecision (Zmap A).
Proof.
 refine (λ t1 t2,
  match t1, t2 with
  | ZMap x t1 t1', ZMap y t2 t2' =>
     cast_if_and3 (decide (x = y)) (decide (t1 = t2)) (decide (t1' = t2'))
  end); abstract congruence.
Defined.
Instance Zempty {A} : Empty (Zmap A) := ZMap None ∅ ∅.
Instance Zlookup {A} : Lookup Z A (Zmap A) := λ i t,
  match i with
  | Z0 => Zmap_0 t | Zpos p => Zmap_pos t !! p | Zneg p => Zmap_neg t !! p
  end.
Instance Zpartial_alter {A} : PartialAlter Z A (Zmap A) := λ f i t,
  match i, t with
  | Z0, ZMap o t t' => ZMap (f o) t t'
  | Zpos p, ZMap o t t' => ZMap o (partial_alter f p t) t'
  | Zneg p, ZMap o t t' => ZMap o t (partial_alter f p t')
  end.
Instance Zto_list {A} : FinMapToList Z A (Zmap A) := λ t,
  match t with
  | ZMap o t t' => default [] o (λ x, [(0,x)]) ++
     (prod_map Zpos id <$> map_to_list t) ++
     (prod_map Zneg id <$> map_to_list t')
  end.
Instance Zomap: OMap Zmap := λ A B f t,
  match t with ZMap o t t' => ZMap (o ≫= f) (omap f t) (omap f t') end.
Instance Zmerge: Merge Zmap := λ A B C f t1 t2,
  match t1, t2 with
  | ZMap o1 t1 t1', ZMap o2 t2 t2' =>
     ZMap (f o1 o2) (merge f t1 t2) (merge f t1' t2')
  end.
Instance Nfmap: FMap Zmap := λ A B f t,
  match t with ZMap o t t' => ZMap (f <$> o) (f <$> t) (f <$> t') end.

Instance: FinMap Z Zmap.
Proof.
  split.
  - intros ? [??] [??] H. f_equal.
    + apply (H 0).
    + apply map_eq. intros i. apply (H (Zpos i)).
    + apply map_eq. intros i. apply (H (Zneg i)).
  - by intros ? [].
  - intros ? f [] [|?|?]; simpl; [done| |]; apply lookup_partial_alter.
  - intros ? f [] [|?|?] [|?|?]; simpl; intuition congruence ||
      intros; apply lookup_partial_alter_ne; congruence.
  - intros ??? [??] []; simpl; [done| |]; apply lookup_fmap.
  - intros ? [o t t']; unfold map_to_list; simpl.
    assert (NoDup ((prod_map Z.pos id <$> map_to_list t) ++
      (prod_map Z.neg id <$> map_to_list t'))).
    { apply NoDup_app; split_and?.
      - apply (NoDup_fmap_2 _), NoDup_map_to_list.
      - intro. rewrite !elem_of_list_fmap. naive_solver.
      - apply (NoDup_fmap_2 _), NoDup_map_to_list. }
    destruct o; simpl; auto. constructor; auto.
    rewrite elem_of_app, !elem_of_list_fmap. naive_solver.
  - intros ? t i x. unfold map_to_list. split.
    + destruct t as [[y|] t t']; simpl.
      * rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
        intros [?|[[[??][??]]|[[??][??]]]]; simplify_eq/=; [done| |];
          by apply elem_of_map_to_list.
      * rewrite elem_of_app, !elem_of_list_fmap. intros [[[??][??]]|[[??][??]]];
          simplify_eq/=; by apply elem_of_map_to_list.
    + destruct t as [[y|] t t']; simpl.
      * rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
        destruct i as [|i|i]; simpl; [intuition congruence| |].
        { right; left. exists (i, x). by rewrite elem_of_map_to_list. }
        right; right. exists (i, x). by rewrite elem_of_map_to_list.
      * rewrite elem_of_app, !elem_of_list_fmap.
        destruct i as [|i|i]; simpl; [done| |].
        { left; exists (i, x). by rewrite elem_of_map_to_list. }
        right; exists (i, x). by rewrite elem_of_map_to_list.
  - intros ?? f [??] [|?|?]; simpl; [done| |]; apply (lookup_omap f).
  - intros ??? f ? [??] [??] [|?|?]; simpl; [done| |]; apply (lookup_merge f).
Qed.

(** * Finite sets *)
(** We construct sets of [Z]s satisfying extensional equality. *)
Notation Zset := (mapset Zmap).
Instance Zmap_dom {A} : Dom (Zmap A) Zset := mapset_dom.
Instance: FinMapDom Z Zmap Zset := mapset_dom_spec.


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

- Frederic Blanqui, 2005-02-17

properties of systems with unary symbols only
*)

Set Implicit Arguments.

From CoLoR Require Import ATrs VecUtil LogicUtil ListUtil NatUtil VecMax EqUtil
     RelUtil SN ListMax.

(***********************************************************************)
(** tactics *)

Ltac arity1 hyp :=
  match goal with
    | e : ?i + S ?j = arity ?f |- _ =>
      ded (hyp f); assert (i=0); [lia | subst i; assert (j=0);
        [lia | subst j; VOtac]]
  end.

(***********************************************************************)
(** we assume a signature with unary symbols only *)

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation terms := (vector term).
Notation context := (context Sig).
Notation substitution := (substitution Sig).
Notation rule := (rule Sig). Notation rules := (list rule).

Definition is_unary := forall f : Sig, 1 = arity f.

Variable is_unary_sig : is_unary.

Ltac arity := arity1 is_unary_sig.

(***********************************************************************)
(** boolean function checking is_unary *)

Definition bis_unary Fs := forallb (fun f : Sig => beq_nat 1 (arity f)) Fs.

Lemma bis_unary_ok : forall (Fs : list Sig) (Fs_ok : forall f, In f Fs),
  bis_unary Fs = true <-> is_unary.

Proof.
intros. apply forallb_ok_fintype. intro. rewrite beq_nat_ok. refl. hyp.
Qed.

(***********************************************************************)
(** unary function application *)

Definition Fun1 f (t : term) :=
  @Fun Sig f (Vcast (Vcons t Vnil) (is_unary_sig f)).

Lemma sub_fun1 : forall s f u, sub s (Fun1 f u) = Fun1 f (sub s u).

Proof.
intros. unfold Fun1. rewrite sub_fun, Vmap_cast. simpl Vmap. refl.
Qed.

Lemma vars_fun1 : forall f u, vars (Fun1 f u) = vars u.

Proof.
intros. unfold Fun1. rewrite vars_fun, vars_vec_cast. simpl.
rewrite <- app_nil_end. refl.
Qed.

Lemma maxvar_fun1 : forall f t, maxvar (Fun1 f t) = maxvar t.

Proof.
intros. unfold Fun1. rewrite maxvar_fun, maxvars_cast.
unfold maxvars. simpl Vmap. simpl VecMax.Vmax. rewrite max_0_r. refl.
Qed.

(***********************************************************************)
(** specific induction principle *)

Section term_ind.

Variables (P : term -> Prop)
  (Hvar : forall x, P (Var x))
  (Hfun : forall f t, P t -> P (Fun1 f t)).

Lemma term_ind_forall : forall t, P t.

Proof.
apply term_ind_forall_cast. hyp. intro f. ded (is_unary_sig f). destruct ts.
intro. lia. destruct ts.
simpl Vforall. split_all. assert (h0 = is_unary_sig f). apply eq_unique.
subst h0. apply Hfun. hyp.
intro. lia.
Qed.

End term_ind.

(***********************************************************************)
(** unique variable of a term *)

Fixpoint var (t : term) : variable :=
  match t with
    | Var x => x
    | Fun _ ts => Vmap_first 0 var ts
  end.

Lemma var_fun1 : forall f u, var (Fun1 f u) = var u.

Proof.
intros. unfold Fun1, var; fold var. rewrite Vmap_first_cast. refl.
Qed.

Lemma var_fill : forall c t, var (fill c t) = var t.

Proof.
induction c; simpl; intros. refl. rewrite Vmap_first_cast. arity. simpl.
apply IHc.
Qed.

Lemma var_sub : forall s t, var (sub s t) = var (s (var t)).

Proof.
intro s. apply term_ind_forall. refl. intros. rewrite sub_fun1, !var_fun1. hyp.
Qed.

Lemma vars_var : forall t, vars t = var t :: nil.

Proof.
apply term_ind_forall. refl. intros. rewrite vars_fun1, var_fun1. hyp.
Qed.

Lemma maxvar_var : forall t, maxvar t = var t.

Proof.
intro t; pattern t; apply term_ind_forall; clear t; intros. refl.
rewrite maxvar_fun1, var_fun1. hyp.
Qed.

(***********************************************************************)
(** unary context application *)

Lemma cont_aux : forall f : Sig, 0 + S 0 = arity f.

Proof. intro. rewrite <- is_unary_sig. refl. Qed.

Lemma cont_aux_eq : forall f, cont_aux f = is_unary_sig f.

Proof. intro. apply eq_unique. Qed.

Definition Cont1 f c := Cont f (cont_aux f) Vnil c Vnil.

Lemma fill_cont1 : forall f c t, fill (Cont1 f c) t = Fun1 f (fill c t).

Proof.
intros. unfold Cont1. unfold fill. fold (fill c t). simpl Vapp. unfold Fun1.
apply args_eq. apply Vcast_pi.
Qed.

(***********************************************************************)
(** biggest context of a term *)

Fixpoint cont (t : term) : context :=
  match t with
    | Var _ => Hole
    | Fun f ts => Cont1 f (Vmap_first Hole cont ts)
  end.

Lemma cont_fun1 : forall f t, cont (Fun1 f t) = Cont1 f (cont t).

Proof.
intros. unfold Fun1, cont. fold cont. rewrite Vmap_first_cast. refl.
Qed.

Lemma subc_cont : forall s (c : context), subc s c = c.

Proof. induction c; simpl; intros. refl. arity. simpl. rewrite IHc. refl. Qed.

Lemma term_cont_var : forall t, t = fill (cont t) (Var (var t)).

Proof.
apply term_ind_forall. refl.
intros. rewrite cont_fun1, fill_cont1, var_fun1, <- H. refl.
Qed.

Lemma sub_cont : forall s t, sub s t = fill (cont t) (s (var t)).

Proof.
intro. apply term_ind_forall. refl. intros.
rewrite sub_fun1, cont_fun1, var_fun1, fill_cont1, <- H. refl.
Qed.

Lemma term_sub_cont : forall x t,
  t = sub (single x (Var (var t))) (fill (cont t) (Var x)).

Proof.
intros. rewrite sub_fill, subc_cont. unfold single. simpl.
rewrite (beq_refl beq_nat_ok). apply term_cont_var.
Qed.

Lemma fill_var_elim : forall x c d (u : term), fill c (Var x) = fill d u ->
  exists e, c = comp d e.

Proof.
induction c. simpl. intros. destruct (var_eq_fill H). subst. exists Hole. refl.
simpl. intros. destruct (fun_eq_fill H). subst. exists (Cont f e t c t0). refl.
decomp H0. subst. simpl in *. Funeqtac. arity. arity. simpl Vapp in *.
assert (x2=e). apply eq_unique. subst x2. rewrite Vcast_eq in H0.
inversion H0. destruct (IHc _ _ H3). subst. exists x0. refl.
Qed.

Arguments fill_var_elim [x c d u] _.

Lemma fill_eq_cont : forall (t : term) c d, fill c t = fill d t <-> c = d.

Proof.
split. 2:{ intro. subst. refl. }
revert d. revert c. induction c.
(* c=Hole *)
simpl. intro. sym. apply (wf_term H).
(* c=Cont *)
destruct d; simpl.
(* d=Hole *)
intro. change (fill (Cont f e t0 c t1) t = t) in H. symmetry in H.
ded (wf_term H). hyp.
(* d=Cont *)
intro. Funeqtac. arity. arity. assert (e0=e). apply eq_unique. subst.
rewrite Vcast_eq, Vapp_eq in H0. destruct H0. inversion H2.
rewrite (IHc _ H4). refl.
Qed.

Lemma maxvar_fill : forall (t : term) c, maxvar (fill c t) = maxvar t.

Proof.
induction c. refl. simpl fill. rewrite maxvar_fun. unfold maxvars.
rewrite Vmap_cast, Vmax_cast. arity. simpl. rewrite IHc. apply max_0_r.
Qed.

(***********************************************************************)
(** equivalent definition of rewriting (when rules preserve variables) *)

Section red.

Variables (R : rules) (hR : rules_preserve_vars R).

Lemma rules_preserve_vars_var : forall l r, In (mkRule l r) R -> var r = var l.

Proof.
intros. ded (hR _ _ H). rewrite !vars_var in H0. unfold incl in H0.
ded (H0 (var r)). simpl in H1. fo.
Qed.

Arguments rules_preserve_vars_var [l r] _.

Definition red1 t u := exists l, exists r, exists c, exists d,
  In (mkRule l r) R /\ t = fill (comp c (comp (cont l) d)) (Var (var t))
  /\ u = fill (comp c (comp (cont r) d)) (Var (var t)).

Lemma red1_ok : forall t u, red R t u <-> red1 t u.

Proof.
intros t u; split; intro H.
(* red -> red1 *)
redtac. ex l r c (cont (s (var l))).
subst. rewrite !sub_cont, !fill_fill, !var_fill. split_all.
rewrite (term_cont_var (s (var l))) at 1. rewrite fill_fill, comp_comp. refl.
rewrite (term_cont_var (s (var r))) at 1.
rewrite fill_fill, comp_comp, (rules_preserve_vars_var lr). refl.
(* red1 -> red *)
destruct H as [l]. destruct H as [r]. destruct H as [c]. destruct H as [d].
decomp H.
set (s := fun x => if beq_nat x (var l) then fill d (Var (var t)) else Var x).
ex l r c s. rewrite H2, H3, !sub_cont. unfold s.
rewrite (rules_preserve_vars_var H0), (beq_refl beq_nat_ok),
  !fill_fill, !comp_comp. tauto.
Qed.

Lemma red1_eq : red R == red1.

Proof. rewrite rel_eq. apply red1_ok. Qed.

End red.

Arguments rules_preserve_vars_var [R] _ [l r] _.

(***********************************************************************)
(** equivalent definition of rewriting modulo (when rules preserve variables) *)

Section red_mod.

Variables (E R : rules)
  (hE : rules_preserve_vars E) (hR : rules_preserve_vars R).

Definition red_mod1 := red1 E # @ red1 R.

Lemma red_mod1_eq : red_mod E R == red_mod1.

Proof. unfold red_mod, red_mod1. rewrite !red1_eq; auto. refl. Qed.

End red_mod.

(***********************************************************************)
(** some properties of renamings *)

Definition is_renaming (s : substitution) := forall x, exists y, s x = Var y.

Lemma is_ren_single_var : forall x y, is_renaming (single x (Var y)).

Proof.
unfold is_renaming, single. intros. case_beq_nat x x0. exists y. refl.
exists x0. refl.
Qed.

Section renaming.

Variables (s : substitution) (hs : is_renaming s).

Lemma size_sub : forall t, size (sub s t) = size t.

Proof.
intro t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  size_terms (Vmap (sub s) ts) = size_terms ts); clear t.
(* Var *)
simpl. intro. destruct (hs x). rewrite H. refl.
(* Fun *)
intros. rewrite sub_fun, !size_fun, H. refl.
(* Vnil *)
refl.
(* Vcons *)
intros. simpl. rewrite H, H0. refl.
Qed.

Section red.

Variables (R : rules) (hR : rules_preserve_vars R).

(*REMARK: instance of a more general lemma on left-linear TRSs *)
Lemma red_ren : forall t u,
  red R (sub s t) u -> exists v, red R t v /\ sub s v = u.

Proof.
intros t u. rewrite red1_ok. 2: hyp. intro h. destruct h as [l].
destruct H as[r]. destruct H as [c]. destruct H as [d]. decomp H.
exists (fill (comp c (comp (cont r) d)) (Var (var t))). rewrite red1_ok.
2: hyp. split.
(* left *)
ex l r c d. split_all.
revert H2. rewrite (term_cont_var t), sub_fill, !var_fill.
simpl. rewrite subc_cont. destruct (hs (var t)). rewrite H. simpl. intro.
destruct (fill_var_elim H2) as [e]. revert H2. rewrite H1, !comp_comp.
intro. rewrite fill_eq_cont, !comp_eq in H2. rewrite H2. refl.
(* right *)
rewrite sub_fill, subc_cont, H3, fill_eq.
simpl. rewrite var_sub. destruct (hs (var t)). rewrite H. refl.
Qed.

Arguments red_ren [t u] _.

Lemma rtc_red_ren : forall t u,
  red R # (sub s t) u -> exists v, red R # t v /\ sub s v = u.

Proof.
cut (forall t' u, red R # t' u -> forall t, t' = sub s t -> exists v,
  red R # t v /\ sub s v = u). intros. apply H with (t':=sub s t). hyp. refl.
induction 1; intros; subst.
destruct (red_ren H). exists x. intuition.
exists t. intuition.
destruct (IHclos_refl_trans1 t (eq_refl (sub s t))). destruct H1.
symmetry in H2. destruct (IHclos_refl_trans2 x H2). exists x0. split_all.
apply rtc_trans with x; hyp.
Qed.

Lemma SN_red_ren : forall t : term, SN (red R) t -> SN (red R) (sub s t).

Proof.
induction 1. apply SN_intro. intros. destruct (red_ren H1). destruct H2.
subst. apply H0. hyp.
Qed.

End red.

Arguments red_ren [R] _ [t u] _.
Arguments rtc_red_ren [R] _ [t u] _.

Section red_mod.

Variables (E R : rules)
  (hE : rules_preserve_vars E) (hR : rules_preserve_vars R).

Lemma red_mod_ren : forall t u, red_mod E R (sub s t) u ->
  exists v, red_mod E R t v /\ sub s v = u.

Proof.
intros. do 2 destruct H. destruct (rtc_red_ren hE H). destruct H1. subst.
destruct (red_ren hR H0). exists x. split_all. exists x0. intuition.
Qed.

Arguments red_mod_ren [t u] _.

Lemma SN_red_mod_ren : forall t : term,
  SN (red_mod E R) t -> SN (red_mod E R) (sub s t).

Proof.
induction 1. apply SN_intro. intros. destruct (red_mod_ren H1). destruct H2.
subst. apply H0. hyp.
Qed.

End red_mod.

End renaming.

Arguments red_ren [s] _ [R] _ [t u] _.
Arguments red_mod_ren [s] _ [E R] _ _ [t u] _.

(***********************************************************************)
(** equivalence with rewriting on terms with at most 0 as variable *)

Definition red0 (R : rules) t u := red R t u /\ maxvar t = 0.

Lemma red0_incl_red : forall R, red0 R << red R.

Proof. intros R t u. unfold red0. tauto. Qed.

Section red0.

Variables (R : rules) (hR : rules_preserve_vars R).

Lemma red0_maxvar : forall t u, red0 R t u -> maxvar u = 0.

Proof.
unfold red0. split_all. cut (maxvar u <= maxvar t). lia.
apply (red_maxvar hR H).
Qed.

Lemma WF_red0 : WF (red R) <-> WF (red0 R).

Proof.
split; intro.
(* -> *)
apply (WF_incl (red R)). intros t u. unfold red0. intuition. hyp.
(* <- *)
cut (forall t, SN (red0 R) t -> maxvar t = 0 -> forall x,
  SN (red R) (sub (single 0 (@Var Sig x)) t)).
(* cut correctness *)
intro. intro u. rewrite (term_sub_cont 0 u). apply H0. apply H.
rewrite maxvar_fill. refl.
(* proof with cut *)
induction 1. intros h v. apply SN_intro; intros.
destruct (red_ren (is_ren_single_var 0 v) hR H2). destruct H3.
subst. assert (red0 R x x0). unfold red0. intuition.
apply H1. hyp. eapply red0_maxvar. apply H4.
Qed.

End red0.

Definition red_mod0 (E R : rules) t u := red_mod E R t u /\ maxvar t = 0.

Lemma red_mod0_incl_red_mod : forall E R, red_mod0 E R << red_mod E R.

Proof. intros E R t u. unfold red_mod0. tauto. Qed.

Section red_mod0.

Variables (E R : rules)
  (hE : rules_preserve_vars E) (hR : rules_preserve_vars R).

Lemma red_mod0_maxvar : forall t u, red_mod0 E R t u -> maxvar u = 0.

Proof.
intros. destruct H. cut (maxvar u <= maxvar t). lia.
apply (red_mod_maxvar hE hR H).
Qed.

Lemma WF_red_mod0 : WF (red_mod E R) <-> WF (red_mod0 E R).

Proof.
split; intro.
(* -> *)
apply (WF_incl (red_mod E R)). intros t u. unfold red_mod0. intuition.
hyp.
(* <- *)
cut (forall t, SN (red_mod0 E R) t -> maxvar t = 0 -> forall x,
  SN (red_mod E R) (sub (single 0 (@Var Sig x)) t)).
(* cut correctness *)
intro. intro u. rewrite (term_sub_cont 0 u). apply H0. apply H.
rewrite maxvar_fill. refl.
(* proof with cut *)
induction 1. intros h v. apply SN_intro; intros.
destruct (red_mod_ren (is_ren_single_var 0 v) hE hR H2). destruct H3.
subst. assert (red_mod0 E R x x0). unfold red_mod0. split_all.
apply H1. hyp. eapply red_mod0_maxvar. apply H4.
Qed.

End red_mod0.

(***********************************************************************)
(** equivalence with rewriting on rules with at most 0 as variable *)

Section reset.

Definition reset t := sub (swap (var t) 0) t.

Definition reset_rule (a : rule) := mkRule (reset (lhs a)) (reset (rhs a)).

Definition reset_rules := map reset_rule.

Lemma reset_fun1 : forall f t, reset (Fun1 f t) = Fun1 f (reset t).

Proof. intros. unfold reset. rewrite var_fun1, sub_fun1. refl. Qed.

Lemma var_reset : forall t, var (reset t) = 0.

Proof.
intro t; pattern t; apply term_ind_forall; clear t; intros.
unfold reset, swap, single. simpl. rewrite (beq_refl beq_nat_ok). refl.
unfold reset. rewrite sub_fun1, !var_fun1. fold (reset t). hyp.
Qed.

Lemma maxvar_reset : forall t, maxvar (reset t) = 0.

Proof. intro. rewrite maxvar_var, var_reset. refl. Qed.

Lemma maxvar_reset_rules : forall R a, In a (reset_rules R) ->
  maxvar (lhs a) = 0 /\ maxvar (rhs a) = 0.

Proof.
intros. unfold reset_rules in H. destruct (in_map_elim H). destruct H0. subst.
destruct x as [l r]. unfold reset_rule. simpl. rewrite !maxvar_reset. auto.
Qed.

Section red.

Variable R : rules.
Variable hR : rules_preserve_vars R.

Lemma rules_preserve_vars_reset : rules_preserve_vars (reset_rules R).

Proof.
intros l0 r0 h. destruct (in_map_elim h). destruct H. destruct x as [l r].
unfold reset_rule in H0. simpl in H0. inversion H0.
rewrite !vars_var, !var_reset. refl.
Qed.

Lemma red_reset : forall t u, red R t u <-> red (reset_rules R) t u.

Proof.
split; intro.
(* -> *)
redtac. subst. ded (rules_preserve_vars_var hR lr).
case (In_dec eq_nat_dec 0 (vars l)); intro.
(* In 0 (vars l) *)
rewrite vars_var in i. simpl in i. split_all.
apply red_rule. assert (mkRule l r = reset_rule (mkRule l r)).
unfold reset_rule. simpl. unfold reset. rewrite H, !H0, !swap_id. refl.
rewrite H1. apply in_map. hyp.
(* ~In 0 (vars l) *)
rewrite swap_intro with (x:=var l)(y:=0). 2: hyp.
rewrite swap_intro with (t:=r)(x:=var r)(y:=0).
2:{ rewrite vars_var. rewrite vars_var in n. rewrite H. hyp. }
(*VERY SLOW*)rewrite H at -2. apply red_rule.
change (In (reset_rule (mkRule l r)) (reset_rules R)). apply in_map. hyp.
(* <- *)
redtac. rename l into l0. rename r into r0. subst. destruct (in_map_elim lr).
destruct H. destruct x as [l r]. unfold reset_rule in H0. simpl in H0.
inversion H0. unfold reset. rewrite !sub_sub.
ded (rules_preserve_vars_var hR H). rewrite H1. apply red_rule. hyp.
Qed.

Lemma red_reset_eq : red R == red (reset_rules R).

Proof. split; intros t u; rewrite <- red_reset; auto. Qed.

Lemma hd_red_reset : forall t u, hd_red R t u <-> hd_red (reset_rules R) t u.

Proof.
split; intro.
(* -> *)
redtac. subst. ded (rules_preserve_vars_var hR lr).
case (In_dec eq_nat_dec 0 (vars l)); intro.
(* In 0 (vars l) *)
rewrite vars_var in i. simpl in i. split_all.
apply hd_red_rule. assert (mkRule l r = reset_rule (mkRule l r)).
unfold reset_rule. simpl. unfold reset. rewrite H, !H0, !swap_id. refl.
rewrite H1. apply in_map. hyp.
(* ~In 0 (vars l) *)
rewrite swap_intro with (x:=var l)(y:=0). 2: hyp.
rewrite swap_intro with (t:=r)(x:=var r)(y:=0).
2:{ rewrite vars_var. rewrite vars_var in n. rewrite H. hyp. }
(*VERY SLOW*)rewrite H at -2. apply hd_red_rule.
change (In (reset_rule (mkRule l r)) (reset_rules R)). apply in_map. hyp.
(* <- *)
redtac. rename l into l0. rename r into r0. subst. destruct (in_map_elim lr).
destruct H. destruct x as [l r]. unfold reset_rule in H0. simpl in H0.
inversion H0. unfold reset. rewrite !sub_sub.
ded (rules_preserve_vars_var hR H). rewrite H1. apply hd_red_rule. hyp.
Qed.

Lemma hd_red_reset_eq : hd_red R == hd_red (reset_rules R).

Proof. split; intros t u; rewrite <- hd_red_reset; auto. Qed.

End red.

Variable E R : rules.
Variable hE : rules_preserve_vars E.
Variable hR : rules_preserve_vars R.

Lemma red_mod_reset_eq : red_mod E R == red_mod (reset_rules E) (reset_rules R).

Proof. unfold red_mod. rewrite <- !red_reset_eq; try hyp. refl. Qed.

Lemma hd_red_mod_reset_eq :
  hd_red_mod E R == hd_red_mod (reset_rules E) (reset_rules R).

Proof.
unfold hd_red_mod. rewrite <- hd_red_reset_eq; try hyp.
rewrite <- red_reset_eq; try hyp. refl.
Qed.

Lemma red_mod_reset : forall t u,
  red_mod E R t u <-> red_mod (reset_rules E) (reset_rules R) t u.

Proof. rewrite <- rel_eq. apply red_mod_reset_eq. Qed.

Lemma hd_red_mod_reset : forall t u,
  hd_red_mod E R t u <-> hd_red_mod (reset_rules E) (reset_rules R) t u.

Proof. rewrite <- rel_eq. apply hd_red_mod_reset_eq. Qed.

End reset.

End S.

Arguments rules_preserve_vars_var [Sig] _ [R] _ [l r] _.
Arguments bis_unary_ok [Sig Fs] _.

(***********************************************************************)
(** tactics for Rainbow *)

Ltac is_unary Fs_ok := rewrite <- (bis_unary_ok Fs_ok); check_eq.


(* BEGIN FIX *)
From Coq Require Import Strings.String.
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.

(*
BNF szintaxis:

a,a1,a2,... ::= n | x | a1 + a2 | a1 - a2 | a1 * a2
b,b1,b2,... ::= true | false | b1 && b2 | ~b | a1 = a2 | a1 <= a2
c,c1,c2 ::= SKIP | IF b THEN c1 ELSE c2 | WHILE b DO c END | x ::= a | c1 ;; c2
*)

(* Coq szintaxis: *)

Inductive aexp : Type :=
  | alit (n : nat)
  | avar (x : string)
  | aplus (a1 a2 : aexp)
  | aminus (a1 a2 : aexp)
  | amult (a1 a2 : aexp).
Inductive bexp : Type :=
| btrue
| bfalse
| band (b1 b2 : bexp)
| bnot (b : bexp)
| beq (a1 a2 : aexp)
| bleq (a1 a2 : aexp).
Inductive cmd : Type :=
| cskip
| cif (b : bexp) (c1 c2 : cmd)
| cwhile (b : bexp) (c : cmd)
| cassign (x : string) (a : aexp)
| cseq (c1 c2 : cmd).

Declare Scope myscope.

Coercion avar : string >-> aexp.
Coercion alit : nat >-> aexp.
Notation "x + y"     := (aplus x y) (at level 50, left associativity) : myscope.
Notation "x - y"     := (aminus x y) (at level 50, left associativity) : myscope.
Notation "x * y"     := (amult x y) (at level 40, left associativity) : myscope.
Definition bool2bexp (b : bool) : bexp := if b then btrue else bfalse.
Coercion bool2bexp : bool >-> bexp.
Notation "x & y" := (band x y) (at level 81, left associativity) : myscope.
Notation "'~' b" := (bnot b) (at level 75, right associativity) : myscope.
Notation "x == y" := (beq x y) (at level 70, no associativity) : myscope.
Notation "x <= y" := (bleq x y) (at level 70, no associativity) : myscope.
Notation "'SKIP'"    := cskip : myscope.
Notation "'IF' b 'THEN' c1 'ELSE' c2 'FI'" := (cif b c1 c2) (at level 80, right associativity) : myscope.
Notation "'WHILE' b 'DO' c 'END'" := (cwhile b c) (at level 80, right associativity) : myscope.
Notation "x '::=' a" := (cassign x a) (at level 60) : myscope.
Notation "c1 ;; c2"  := (cseq c1 c2) (at level 80, right associativity) : myscope.

Definition X : string := "X"%string.
Definition Y : string := "Y"%string.
Definition Z : string := "Z"%string.

Open Scope myscope.

Definition fac : cmd :=
  X ::= 1 ;;
  Y ::= 1 ;;
  WHILE Y <= Z DO
    X ::= X * Y ;;
    Y ::= Y + 1
  END.

Close Scope myscope.

(* Ird at fac'-t ugy, hogy fac-al megegyezzen, de a csunya jelolessel! *)
Definition fac' : cmd :=
(* END FIX *)
(cseq
  (cassign X (alit 1))
  (cseq
    (cassign Y (alit 1))
       (cwhile (bleq (avar Y) (avar Z))
               (cseq
                 (cassign X (amult (avar X) (avar Y)))
                 (cassign Y (aplus (avar Y)  (alit 1))
))))).
(* BEGIN FIX *)
Example facVsFac' : fac = fac'. reflexivity. Qed.

(* denotacios szemantika *)

Definition state : Type := string -> nat.
Definition empty : state := fun x => 0.
Definition update (x:string)(n:nat)(s:state) : state :=
  fun x' => match string_dec x x' with
  | left  e => n
  | right e => s x'
  end.
Fixpoint aeval (a : aexp)(s : state) : nat :=
match a with
| alit n => n
| avar x => s x
| aplus a1 a2 => (aeval a1 s) + (aeval a2 s)
| aminus a1 a2 => (aeval a1 s) - (aeval a2 s)
| amult a1 a2 => (aeval a1 s) * (aeval a2 s)
end.
Fixpoint beval (b : bexp)(s : state) : bool :=
match b with
 | btrue => true
 | bfalse => false
 | band b1 b2 => (beval b1 s) && (beval b2 s)
 | bnot b => negb (beval b s)
 | beq a1 a2 => aeval a1 s =? aeval a2 s
 | bleq a1 a2 => aeval a1 s <=? aeval a2 s
end.
Fixpoint ceval (c : cmd)(s : state)(n : nat) : state :=
match n with
| O => s
| S n' =>
  match c with
   | cskip => s
   | cif b c1 c2 => if beval b s
                    then (ceval c1 s n')
                    else (ceval c2 s n')
   | cassign x a => update x (aeval a s) s
   | cseq c1 c2 => ceval c2 (ceval c1 s n') n'
   | cwhile b c => if beval b s
                    then ceval (cwhile b c) (ceval c s n') n'
                    else s
  end
end.

Open Scope myscope.

Example prog1 : exists (c : cmd), forall (n : nat),
  ceval c (update X n empty) 10 X = (n + 1)%nat.
exists (X ::= X + 1). intros. simpl. reflexivity. Qed.

(* Irj programot, mely Y-ba beteszi X ketszereset! *)
Example prog2 : exists (c : cmd), forall (n : nat),
  ceval c (update X n empty) 10 Y = (2 * n)%nat.
(* END FIX *)
Proof.
  exists (Y ::= 2 * X).
  intros.
  simpl.
  reflexivity.
Qed.

(* BEGIN FIX *)
Definition prog3 : cmd :=
(* END FIX *)
WHILE Z == 1 DO Y ::= 1 END;;
WHILE Z == 2 DO Y ::= 3 END;;
WHILE Z == 3 DO Y ::= 6 END;;
WHILE Z == 4 DO Y ::= 10 END;;
WHILE Z == 5 DO Y ::= 15 END;;
WHILE Z == 6 DO Y ::= 21 END.

Compute ceval prog3 (update Z 4 empty) 10 Y.
Compute ceval prog3 (update Z 4 empty) 10 X.

(* BEGIN FIX *)
Lemma prog3Test1 : ceval prog3 (update Z 1 empty) 10 Y =  1. reflexivity. Qed.
Lemma prog3Test2 : ceval prog3 (update Z 2 empty) 10 Y =  3. reflexivity. Qed.
Lemma prog3Test3 : ceval prog3 (update Z 3 empty) 10 Y =  6. reflexivity. Qed.
Lemma prog3Test4 : ceval prog3 (update Z 4 empty) 10 Y = 10. reflexivity. Qed.
Lemma prog3Test5 : ceval prog3 (update Z 5 empty) 10 Y = 15. reflexivity. Qed.
Lemma prog3Test6 : ceval prog3 (update Z 6 empty) 10 Y = 21. reflexivity. Qed.

Definition prog4 (a b : nat) : cmd := Y ::= 1 ;; WHILE X + 1 <= b DO Y ::= Y * a ;; X ::= X + 1 END.

Definition f (a b : nat) : nat :=
(* END FIX *)
a^b.

(* BEGIN FIX *)
Lemma prog4Test1 : ceval (prog4 2 0) empty 10 Y = f 2 0. reflexivity. Qed.
Lemma prog4Test2 : ceval (prog4 2 1) (update Z 1 empty) 10 Y = f 2 1. reflexivity. Qed.
Lemma prog4Test3 : ceval (prog4 2 2) (update Z 1 empty) 10 Y = f 2 2. reflexivity. Qed.
Lemma prog4Test4 : ceval (prog4 2 3) (update Z 1 empty) 10 Y = f 2 3. reflexivity. Qed.
Lemma prog4Test5 : ceval (prog4 2 4) (update Z 1 empty) 10 Y = f 2 4. reflexivity. Qed.
Lemma prog4Test6 : ceval (prog4 3 1) (update Z 1 empty) 10 Y = f 3 1. reflexivity. Qed.
Lemma prog4Test7 : ceval (prog4 3 2) (update Z 1 empty) 10 Y = f 3 2. reflexivity. Qed.
Lemma prog4Test8 : ceval (prog4 3 3) (update Z 1 empty) 10 Y = f 3 3. reflexivity. Qed.
Lemma prog4Test9 : ceval (prog4 3 4) (update Z 1 empty) 10 Y = f 3 4. reflexivity. Qed.
(* END FIX *)


Require Import GeoCoq.Tarski_dev.Ch06_out_lines.

Section Coplanar_perm.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma coplanar_perm_1 : forall A B C D,
  Coplanar A B C D -> Coplanar A B D C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_2 : forall A B C D,
  Coplanar A B C D -> Coplanar A C B D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_3 : forall A B C D,
  Coplanar A B C D -> Coplanar A C D B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_4 : forall A B C D,
  Coplanar A B C D -> Coplanar A D B C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_5 : forall A B C D,
  Coplanar A B C D -> Coplanar A D C B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_6 : forall A B C D,
  Coplanar A B C D -> Coplanar B A C D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_7 : forall A B C D,
  Coplanar A B C D -> Coplanar B A D C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_8 : forall A B C D,
  Coplanar A B C D -> Coplanar B C A D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_9 : forall A B C D,
  Coplanar A B C D -> Coplanar B C D A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_10 : forall A B C D,
  Coplanar A B C D -> Coplanar B D A C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_11 : forall A B C D,
  Coplanar A B C D -> Coplanar B D C A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_12 : forall A B C D,
  Coplanar A B C D -> Coplanar C A B D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_13 : forall A B C D,
  Coplanar A B C D -> Coplanar C A D B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_14 : forall A B C D,
  Coplanar A B C D -> Coplanar C B A D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_15 : forall A B C D,
  Coplanar A B C D -> Coplanar C B D A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_16 : forall A B C D,
  Coplanar A B C D -> Coplanar C D A B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_17 : forall A B C D,
  Coplanar A B C D -> Coplanar C D B A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_18 : forall A B C D,
  Coplanar A B C D -> Coplanar D A B C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_19 : forall A B C D,
  Coplanar A B C D -> Coplanar D A C B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_20 : forall A B C D,
  Coplanar A B C D -> Coplanar D B A C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_21 : forall A B C D,
  Coplanar A B C D -> Coplanar D B C A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_22 : forall A B C D,
  Coplanar A B C D -> Coplanar D C A B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_23 : forall A B C D,
  Coplanar A B C D -> Coplanar D C B A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma ncoplanar_perm_1 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A B D C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_1, HCop.
Qed.

Lemma ncoplanar_perm_2 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A C B D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_2, HCop.
Qed.

Lemma ncoplanar_perm_3 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A C D B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_4, HCop.
Qed.

Lemma ncoplanar_perm_4 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A D B C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_3, HCop.
Qed.

Lemma ncoplanar_perm_5 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A D C B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_5, HCop.
Qed.

Lemma ncoplanar_perm_6 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B A C D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_6, HCop.
Qed.

Lemma ncoplanar_perm_7 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B A D C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_7, HCop.
Qed.

Lemma ncoplanar_perm_8 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B C A D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_12, HCop.
Qed.

Lemma ncoplanar_perm_9 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B C D A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_18, HCop.
Qed.

Lemma ncoplanar_perm_10 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B D A C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_13, HCop.
Qed.

Lemma ncoplanar_perm_11 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B D C A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_19, HCop.
Qed.

Lemma ncoplanar_perm_12 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C A B D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_8, HCop.
Qed.

Lemma ncoplanar_perm_13 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C A D B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_10, HCop.
Qed.

Lemma ncoplanar_perm_14 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C B A D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_14, HCop.
Qed.

Lemma ncoplanar_perm_15 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C B D A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_20, HCop.
Qed.

Lemma ncoplanar_perm_16 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C D A B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_16, HCop.
Qed.

Lemma ncoplanar_perm_17 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C D B A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_22, HCop.
Qed.

Lemma ncoplanar_perm_18 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D A B C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_9, HCop.
Qed.

Lemma ncoplanar_perm_19 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D A C B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_11, HCop.
Qed.

Lemma ncoplanar_perm_20 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D B A C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_15, HCop.
Qed.

Lemma ncoplanar_perm_21 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D B C A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_21, HCop.
Qed.

Lemma ncoplanar_perm_22 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D C A B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_17, HCop.
Qed.

Lemma ncoplanar_perm_23 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D C B A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_23, HCop.
Qed.

Lemma coplanar_trivial : forall A B C, Coplanar A A B C.
Proof.
intros.
exists B; Col5.
Qed.

Lemma col__coplanar : forall A B C D,
  Col A B C -> Coplanar A B C D.
Proof.
intros.
exists C; Col5.
Qed.

Lemma ncop__ncol : forall A B C D,
  ~ Coplanar A B C D -> ~ Col A B C.
Proof.
intros.
intro.
apply H, col__coplanar, H0.
Qed.

Lemma ncop__ncols : forall A B C D,
  ~ Coplanar A B C D -> ~ Col A B C /\ ~ Col A B D /\ ~ Col A C D /\ ~ Col B C D.
Proof.
intros; repeat split.
apply ncop__ncol with D, H.
apply ncop__ncol with C, ncoplanar_perm_1, H.
apply ncop__ncol with B, ncoplanar_perm_3, H.
apply ncop__ncol with A, ncoplanar_perm_9, H.
Qed.

Lemma bet__coplanar : forall A B C D,
  Bet A B C -> Coplanar A B C D.
Proof.
intros.
apply col__coplanar; Col.
Qed.

Lemma out__coplanar : forall A B C D,
  Out A B C -> Coplanar A B C D.
Proof.
intros.
apply col__coplanar; Col.
Qed.

Lemma midpoint__coplanar : forall A B C D,
  Midpoint A B C -> Coplanar A B C D.
Proof.
intros A B C D [].
apply col__coplanar; Col.
Qed.

Lemma perp__coplanar : forall A B C D,
  Perp A B C D -> Coplanar A B C D.
Proof.
intros A B C D [P HP].
unfold Perp_at in HP; spliter.
exists P; left; Col.
Qed.

Lemma ts__coplanar : forall A B C D,
  TS A B C D -> Coplanar A B C D.
Proof.
intros A B C D [_ [_ [X []]]].
exists X; left; split; Col.
Qed.

Lemma reflectl__coplanar : forall A B C D,
  ReflectL A B C D -> Coplanar A B C D.
Proof.
intros A B C D [[X [[] HCol]] _].
exists X.
left; split; Col.
Qed.

Lemma reflect__coplanar : forall A B C D,
  Reflect A B C D -> Coplanar A B C D.
Proof.
intros A B C D [[_ HR]|[Heq]].
  apply reflectl__coplanar, HR.
subst; apply coplanar_perm_16, coplanar_trivial.
Qed.

Lemma inangle__coplanar : forall A B C D,
  InAngle A B C D -> Coplanar A B C D.
Proof.
intros A B C D H.
unfold InAngle in H; spliter.
destruct H2 as [X [HBet Dij]].
exists X; right; left.
split; Col.
induction Dij; [subst|]; Col.
Qed.

Lemma pars__coplanar : forall A B C D,
  Par_strict A B C D -> Coplanar A B C D.
Proof.
  unfold Par_strict; intros; spliter; assumption.
Qed.

Lemma par__coplanar : forall A B C D,
  Par A B C D -> Coplanar A B C D.
Proof.
  intros A B C D H.
  destruct H.
    apply pars__coplanar; assumption.
  spliter; exists A; left; Col.
Qed.

Lemma plg__coplanar : forall A B C D,
  Plg A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [H [M [[H1 _] [H2 _]]]].
  exists M; right; left; split; Col.
Qed.

Lemma plgs__coplanar : forall A B C D,
  Parallelogram_strict A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [_ [HPar _]].
  apply par__coplanar, HPar.
Qed.

Lemma plgf__coplanar : forall A B C D,
  Parallelogram_flat A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [HCol _].
  apply col__coplanar, HCol.
Qed.

Lemma parallelogram__coplanar : forall A B C D,
  Parallelogram A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [Hs|Hf].
    apply plgs__coplanar, Hs.
    apply plgf__coplanar, Hf.
Qed.

Lemma rhombus__coplanar : forall A B C D,
  Rhombus A B C D -> Coplanar A B C D.
Proof.
  unfold Rhombus.
  intros; spliter; apply plg__coplanar; assumption.
Qed.

Lemma rectangle__coplanar : forall A B C D,
  Rectangle A B C D -> Coplanar A B C D.
Proof.
  unfold Rectangle.
  intros; spliter; apply plg__coplanar; assumption.
Qed.

Lemma square__coplanar : forall A B C D,
  Square A B C D -> Coplanar A B C D.
Proof.
  unfold Square.
  intros; spliter; apply rectangle__coplanar; assumption.
Qed.

Lemma lambert__coplanar : forall A B C D,
  Lambert A B C D -> Coplanar A B C D.
Proof.
  unfold Lambert.
  intros; spliter; assumption.
Qed.

End Coplanar_perm.

Hint Resolve coplanar_perm_1 coplanar_perm_2 coplanar_perm_3 coplanar_perm_4 coplanar_perm_5
coplanar_perm_6 coplanar_perm_7 coplanar_perm_8 coplanar_perm_9 coplanar_perm_10 coplanar_perm_11
coplanar_perm_12 coplanar_perm_13 coplanar_perm_14 coplanar_perm_15 coplanar_perm_16 coplanar_perm_17
coplanar_perm_18 coplanar_perm_19 coplanar_perm_20 coplanar_perm_21 coplanar_perm_22 coplanar_perm_23
ncoplanar_perm_1 ncoplanar_perm_2 ncoplanar_perm_3 ncoplanar_perm_4 ncoplanar_perm_5 ncoplanar_perm_6
ncoplanar_perm_7 ncoplanar_perm_8 ncoplanar_perm_9 ncoplanar_perm_10 ncoplanar_perm_11
ncoplanar_perm_12 ncoplanar_perm_13 ncoplanar_perm_14 ncoplanar_perm_15 ncoplanar_perm_16
ncoplanar_perm_17 ncoplanar_perm_18 ncoplanar_perm_19 ncoplanar_perm_20 ncoplanar_perm_21
ncoplanar_perm_22 ncoplanar_perm_23 coplanar_trivial col__coplanar bet__coplanar out__coplanar
midpoint__coplanar perp__coplanar ts__coplanar reflectl__coplanar reflect__coplanar inangle__coplanar
pars__coplanar par__coplanar plg__coplanar plgs__coplanar plgf__coplanar parallelogram__coplanar
rhombus__coplanar rectangle__coplanar square__coplanar lambert__coplanar : cop.

Ltac Cop := auto 3 with cop.


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

- Frederic Blanqui, 2005-02-17
- Solange Coupet-Grimal and William Delobel, 2006-01-09

useful results on accessibility
*)

Set Implicit Arguments.

Require Import Morphisms Basics.
Require Export Wellfounded.
Require Import LogicUtil RelUtil.

Arguments wf_incl [A R1 R2] _ _ _.

(***********************************************************************)
(** Compatibility of accessibility wrt relation inclusion/equivalence. *)

#[export] Instance Acc_incl A : Proper (incl --> eq ==> impl) (@Acc A).

Proof.
  intros R R' R'R x x' xx'. subst x'. induction 1. apply Acc_intro. fo.
Qed.

#[export] Instance Acc_same A : Proper (same ==> eq ==> iff) (@Acc A).

Proof.
  intros R R' [RR' R'R] x x' xx'. subst x'. split; intro h.
  rewrite R'R. hyp. rewrite RR'. hyp.
Qed.

(*TODO: try to remove*)
Lemma Acc_eq_rel : forall A (R S : relation A) x,
  (forall a b, R a b <-> S a b) -> Acc R x -> Acc S x.

Proof.
  induction 2. constructor. intros z Szx; apply H1. exact (proj2 (H z x) Szx).
Qed.

#[export] Instance well_founded_incl A :
  Proper (incl --> impl) (@well_founded A).

Proof. intros R R' R'R h. intro x. rewrite <- R'R. fo. Qed.

#[export] Instance well_founded_same A : Proper (same ==> iff) (@well_founded A).

Proof.
  intros R R' [RR' R'R]. split; intro h. rewrite R'R. hyp. rewrite RR'. hyp.
Qed.

(***********************************************************************)
(** Transitive closure. *)

Section rtc.

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

  Lemma Acc_rtc : forall x y, clos_refl_trans R x y -> Acc R y -> Acc R x.

  Proof.
    induction 1.
    intro. eapply Acc_inv. apply H0. hyp.
    auto.
    intro. apply IHclos_refl_trans1. apply IHclos_refl_trans2. hyp.
  Qed.

  Lemma Acc_tc_ind : forall P : A->Prop,
    (forall x, (forall y, clos_trans R y x -> P y) -> P x)
    -> forall x, Acc R x -> P x.

  Proof.
    intros. eapply Acc_ind with (R := clos_trans R). clear x H0. intros.
    apply H. intros. apply H1. hyp.
    apply Acc_clos_trans. hyp.
  Qed.

End rtc.

(***********************************************************************)
(** Symmetric product. *)

Section symprod.

  Variables (A B : Type) (leA : relation A) (leB : relation B).

  Notation Symprod := (symprod leA leB).

  Lemma Acc_symprod_fst x : Acc Symprod x -> Acc leA (fst x).

  Proof.
    induction 1. destruct x. simpl. apply Acc_intro. intros. ded (H0 (y,b)).
    apply H2. apply left_sym. hyp.
  Qed.

  Lemma Acc_symprod_snd x : Acc Symprod x -> Acc leB (snd x).

  Proof.
    induction 1. destruct x. simpl. apply Acc_intro. intros. ded (H0 (a,y)).
    apply H2. apply right_sym. hyp.
  Qed.

  Lemma Acc_symprod_invl x y : Acc Symprod (x,y) -> Acc leA x.

  Proof. intros. ded (Acc_symprod_fst H). hyp. Qed.

  Lemma Acc_symprod_invr x y : Acc Symprod (x,y) -> Acc leB y.

  Proof. intros. ded (Acc_symprod_snd H). hyp. Qed.

  Lemma Acc_symprod_inv x y : Acc Symprod (x,y) -> Acc leA x /\ Acc leB y.

  Proof.
    intros. split. eapply Acc_symprod_invl. apply H. eapply Acc_symprod_invr.
    apply H.
  Qed.

End symprod.

(***********************************************************************)
(** Restricted accessibility. *)

Section RestrictedAcc.

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

  Inductive Restricted_acc (R : relation A) : A -> Prop :=
  | Restricted_acc_cons : forall a,
    (forall a', P a' -> R a' a -> Restricted_acc R a') -> Restricted_acc R a.

  Lemma Restricted_acc_eq_acc : forall R a,
    Acc (fun a a' => P a /\ R a a') a <-> Restricted_acc R a.

  Proof.
    intros R a.
    split.
    (* => *)
    intro acc_a; induction acc_a as [a acc_a IHa].
    constructor; trivial.
    intros a' Pa' Ha'.
    apply IHa; split; trivial.
    (* <= *)
    intro Raa; induction Raa as [a Raa IHa].
    constructor.
    intros a' Ha'; elim Ha'; clear Ha'; intros Pa' Ra'a.
    apply (IHa a' Pa' Ra'a).
  Qed.

End RestrictedAcc.

(***********************************************************************)
(** List of accessible arguments. *)

From Coq Require Import List.

Definition Accs (A : Type) R l := forall a : A, In a l -> Acc R a.

(***********************************************************************)
(** Simulation and morphisms. *)

Section Accessibility.

  Variables (A B : Type) (R : relation A).

  Definition mimic (P : relation A) := forall x x', P x x' ->
    forall y', R y' x' -> exists2 y, R y x & P y y'.

  Lemma Acc_mimic : forall x (P: relation A),
    Acc R x -> mimic P -> forall x', P x x' -> Acc R x'.

  Proof.
    induction 1.
    intros mim x' Pxx'.
    constructor.
    intros y' Ry'x'.
    unfold mimic in mim.
    destruct (mim x x' Pxx' y' Ry'x') as [y Ryx Pyy'].
    apply H0 with y; trivial.
  Qed.

  Variables x y : A.

  Section AccHomo.

    Variable T : relation B.
    Variable z : B.
    Variable morphism : A -> B -> Prop.
    Variable comp : forall x y x',
      morphism x' x -> T y x -> exists2 y': A, R y' x' & morphism y' y.

    Lemma Acc_homo :
      forall x, Acc R x -> forall x', morphism x x' -> Acc T x'.

    Proof.
      induction 1.
      intros x' x0x'.
      constructor.
      intros w Twx'.
      destruct (comp x0x' Twx') as [x1 Rx x1w].
      eapply H0; eauto.
    Qed.

  End AccHomo.

  Section AccIso.

    Variable T : relation B.
    Variable z : B.
    Variable iso : A -> B -> Prop.
    Variable iso_comp : forall x y' x',
      iso x x' -> T y' x' -> {y: A | R y x & iso y y'}.

    Lemma Acc_iso : iso x z -> Acc R x -> Acc T z.

    Proof.
      intros iso_x_z Acc_x; generalize z iso_x_z; clear iso_x_z z.
      induction Acc_x as [x Acc_x Hind].
      intros z iso_x_z.
      constructor.
      intros z' T_z'_z.
      elim (iso_comp iso_x_z T_z'_z).
      intros x' Rx' iso_x'_z'.
      apply Hind with x'; hyp.
    Qed.

  End AccIso.

End Accessibility.

(***********************************************************************)
(** Wellfounded fixpoints: we extend [Fix_F_inv] to any relation [eq]. *)

Arguments Fix [A R] _ [P] _ _.
Arguments Fix_eq [A R] _ [P F] _ _.
Arguments Fix_F [A R P] _ [x] _.
Arguments Fix_F_eq [A R P] _ [x] _.
Arguments Fix_F_inv [A R] _ [P] _ _ [x] _ _.

Section Fix.

  Variables (A : Type) (R : relation A) (Rwf : well_founded R)
    (P : A -> Type) (F : forall x : A, (forall y : A, R y x -> P y) -> P x)
    (eq : forall x, relation (P x))
    (F_ext : forall x (f g : forall y, R y x -> P y),
      (forall y (p : R y x), eq (f y p) (g y p)) -> eq (F f) (F g)).

  Notation Fix_F := (Fix_F F).
  Notation Fix_F_eq := (Fix_F_eq F).
  Notation Fix := (Fix Rwf F).
  Infix "==" := eq (at level 70).

  Lemma Fix_F_inv : forall x (r s : Acc R x), Fix_F r == Fix_F s.

  Proof.
    intro x; induction (Rwf x); intros.
    rewrite <- (Fix_F_eq r), <- (Fix_F_eq s); intros.
    apply F_ext; auto.
  Qed.

  Lemma Fix_eq : forall x, Fix x == F (fun y (p : R y x) => Fix y).

  Proof.
    intro x; unfold Wf.Fix.
    rewrite <- Fix_F_eq.
    apply F_ext; intros.
    apply Fix_F_inv.
  Qed.

End Fix.

Arguments Fix_F_inv [A R] _ [P] _ _ _ [x] _ _.
Arguments Fix_eq [A R] _ [P F eq] _ _.

(***********************************************************************)
(** A well-founded relation is irreflexive. *)

Lemma wf_irrefl : forall A (R : relation A), well_founded R -> Irreflexive R.

Proof. intros A R wf x. induction (wf x). intro n. eapply H0. apply n. hyp. Qed.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat.
Require Import div seq fintype tuple finfun finset.
Require Import groups action gseries maximal.

(* n-transitive and primitive actions *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Section PrimitiveDef.

Variables (aT : finGroupType) (sT : finType).
Variables (A : {set aT}) (to : {action aT &-> sT}) (S : {set sT}).

Definition imprimitivity_system Q :=
  [&& partition Q S, [acts A, on Q | to^*] & 1 < #|Q| < #|S|].

Definition primitive :=
  [transitive A, on S | to] && ~~ existsb Q, imprimitivity_system Q.

End PrimitiveDef.

Notation "[ 'primitive' A , 'on' S | to ]" := (primitive A to S)
  (at level 0, format "[ 'primitive'  A ,  'on'  S  |  to ]") : form_scope.

Prenex Implicits imprimitivity_system.

Section Primitive.

Variables (aT : finGroupType) (sT : finType).
Variables (G : {group aT}) (to : {action aT &-> sT}) (S : {set sT}).

Lemma trans_prim_astab : forall x,
  x \in S -> [transitive G, on S | to] ->
    [primitive G, on S | to] = maximal_eq 'C_G[x | to] G.
Proof.
move=> x Sx trG; rewrite /primitive trG negb_exists.
apply/forallP/maximal_eqP=> /= [primG | [_ maxCx] Q].
  split=> [|H sCH sHG]; first exact: subsetIl.
  pose X := orbit to H x; pose Q := orbit (to^*)%act G X.
  have Xx: x \in X by exact: orbit_refl.
  have defH: 'N_(G)(X | to) = H.
    have trH: [transitive H, on X | to] by apply/imsetP; exists x.
    have sHN: H \subset 'N_G(X | to) by rewrite subsetI sHG atrans_acts.
    move/(subgroup_transitiveP Xx sHN): (trH) => /= <-.
      by rewrite mulSGid //= setIAC subIset ?sCH.
    apply/imsetP; exists x => //; apply/eqP.
    by rewrite eqEsubset imsetS // acts_sub_orbit ?subsetIr.
  move: (sCH); rewrite subEproper; case/predU1P; first by left.
  move/proper_card=> oCH; right; apply/eqP; rewrite eqEcard sHG leqNgt.
  apply: contra {primG}(primG Q) => oHG; apply/and3P; split; last first.
  - rewrite card_orbit astab1_set defH -(@ltn_pmul2l #|H|) ?LaGrange // muln1.
    rewrite oHG -(@ltn_pmul2l #|H|) ?LaGrange // -(card_orbit_stab to G x).
    by rewrite -(atransP trG x Sx) mulnC card_orbit ltn_pmul2r.
  - by apply/actsP=> a Ga Y; apply: orbit_transr; exact: mem_orbit.
  apply/and3P; split; last 1 first.
  - rewrite orbit_sym; apply/imsetP=> [[a _]] /= defX.
    by rewrite defX /setact imset0 inE in Xx.
  - apply/eqP; apply/setP=> y; apply/bigcupP/idP=> [[Xa] | Sy].
      case/imsetP=> a Ga ->{Xa}; case/imsetP=> z; case/imsetP=> b Hb -> ->.
      by rewrite !(actsP (atrans_acts trG)) //; exact: subsetP Hb.
    case: (atransP2 trG Sx Sy) => a Ga ->.
    by exists ((to^*)%act X a); apply: mem_imset; rewrite // orbit_refl.
  apply/trivIsetP=> Y Z; case/imsetP=> a Ga ->; case/imsetP=> b Gb ->{Y Z}.
  case dab: [disjoint _ & _]; [by right | left].
  apply: (canRL (actKV _ _)); rewrite -actM; apply/astab1P.
  rewrite astab1_set (subsetP (subsetIr G _)) //= defH.
  case/existsP: dab => y; case/andP.
  case/imsetP=> z; case/imsetP=> a1 Ha1 -> ->{y z}.
  case/imsetP=> t; case/imsetP=> b1 Hb1 ->{t}.
  do 2!move/(canLR (actK _ _)); rewrite -!actM; move/astab1P => Cab.
  rewrite -(groupMr _ (groupVr Hb1)) -mulgA -(groupMl _ Ha1).
  by rewrite (subsetP sCH) // inE Cab !groupM ?groupV // (subsetP sHG).
apply/and3P=> [[]]; case/and3P; set sto := (to^*)%act.
move/eqP=> defS tIQ ntQ actQ; rewrite !ltnNge -negb_or; case/orP.
pose X := cover_at x Q; have Xx: x \in X by rewrite mem_cover_at defS.
have QX: X \in Q by rewrite cover_at_mem ?defS.
have toX: forall Y a, Y \in Q -> a \in G -> to x a \in Y -> sto X a = Y.
  move=> Y a QY Ga Yxa; case: (trivIsetP tIQ Y (sto X a)) => //.
    by rewrite (actsP actQ).
  by case/existsP; exists (to x a); rewrite /= Yxa; exact: mem_imset.
have defQ: Q = orbit (to^*)%act G X.
  apply/eqP; rewrite eqEsubset andbC acts_sub_orbit // QX.
  apply/subsetP=> Y QY; have:= sub0set Y; rewrite subEproper.
  case/predU1P=> [Y0|]; first by rewrite Y0 QY in ntQ.
  case/andP=> _; case/subsetPn=> y Yy _.
  have Sy: y \in S by rewrite -defS; apply/bigcupP; exists Y.
  have [a Ga def_y] := atransP2 trG Sx Sy.
  by apply/imsetP; exists a; rewrite // (toX Y) // -def_y.
rewrite defQ card_orbit; case: (maxCx 'C_G[X | sto]%G) => /= [||->|->].
- apply/subsetP=> a; case/setIP=> Ga cxa; rewrite inE Ga /=.
  by apply/astab1P; rewrite (toX X) // (astab1P cxa).
- exact: subsetIl.
- by right; rewrite -card_orbit (atransP trG).
by left; rewrite indexgg.
Qed.

Lemma prim_trans_norm : forall H : {group aT},
  [primitive G, on S | to] -> H <| G ->
     H \subset 'C_G(S | to) \/ [transitive H, on S | to].
Proof.
move=> H primG; case/andP=> sHG nHG; rewrite subsetI sHG.
have [trG _] := andP primG; have [x Sx defS] := imsetP trG.
move: primG; rewrite (trans_prim_astab Sx) //; case/maximal_eqP=> _.
case/(_ ('C_G[x | to] <*> H)%G) => /= [||cxH|]; first exact: mulgen_subl.
- by rewrite mulgen_subG subsetIl.
- have{cxH} cxH: H \subset 'C_G[x | to] by rewrite -cxH mulgen_subr.
  rewrite subsetI sHG /= in cxH; left; apply/subsetP=> a Ha.
  apply/astabP=> y Sy; have [b Gb ->] := atransP2 trG Sx Sy.
  rewrite actCJV [to x (a ^ _)](astab1P _) ?(subsetP cxH) //.
  by rewrite -mem_conjg (normsP nHG).
rewrite norm_mulgenEl 1?subIset ?nHG //.
by move/(subgroup_transitiveP Sx sHG trG); right.
Qed.

End Primitive.

Section NactionDef.

Variables (gT : finGroupType) (sT : finType).

Variable to : {action gT &-> sT}.
Variable n :  nat.

Definition n_act (t : n.-tuple sT) a := [tuple of map (to^~ a) t].

Lemma n_act_is_action : is_action setT n_act.
Proof.
by apply: is_total_action => [t|t a b]; apply: eq_from_tnth => i;
    rewrite !tnth_map ?act1 ?actM.
Qed.

Canonical Structure n_act_action := Action n_act_is_action.

End NactionDef.

Notation "to * n" := (n_act_action to n) : action_scope.

Section NTransitive.

Variables (gT : finGroupType) (sT : finType).
Variable n :  nat.
Variable A : {set gT}.
Variable S : {set sT}.
Variable to : {action gT &-> sT}.

Definition dtuple_on := [set t : n.-tuple sT | uniq t && (t \subset S)].
Definition ntransitive := [transitive A, on dtuple_on | to * n].

Lemma dtuple_onP : forall t,
  reflect (injective (tnth t) /\ forall i, tnth t i \in S) (t \in dtuple_on).
Proof.
move=> t; rewrite inE subset_all -map_tnth_enum.
case: (uniq _) / (injectiveP (tnth t)) => f_inj; last by right; case.
rewrite -[all _ _]negbK -has_predC has_map has_predC negbK /=.
by apply: (iffP allP) => [Sf|[]//]; split=> // i; rewrite Sf ?mem_enum.
Qed.

Lemma n_act_dtuple : forall t a,
  a \in 'N(S | to) -> t \in dtuple_on -> n_act to t a \in dtuple_on.
Proof.
move=> t a; move/astabsP=> toSa; case/dtuple_onP=> t_inj St; apply/dtuple_onP.
split=> [i j | i]; rewrite !tnth_map ?[_ \in S]toSa //.
by move/act_inj; exact: t_inj.
Qed.

End NTransitive.

Implicit Arguments n_act [gT sT n].

Notation "n .-dtuple ( S )" := (dtuple_on n S)
  (at level 8, format "n .-dtuple ( S )") : set_scope.

Notation "[ 'transitive' ^ n A , 'on' S | to ]" := (ntransitive n A S to)
  (at level 0, n at level 8,
   format "[ 'transitive' ^ n  A ,  'on'  S  |  to ]") : form_scope.

Section NTransitveProp.

Variable (gT : finGroupType) (sT : finType).
Variable to : {action gT &-> sT}.
Variable G : {group gT}.
Variable S : {set sT}.

Lemma card_uniq_tuple n (t : n.-tuple sT) : uniq t -> #|t| = n.
Proof. move=> n t; move/card_uniqP->; exact: size_tuple. Qed.

Lemma n_act0 (t : 0.-tuple sT) a : n_act to t a = [tuple].
Proof. move=> *; exact: tuple0. Qed.

Lemma dtuple_on_add : forall n x (t : n.-tuple sT),
  ([tuple of x :: t] \in n.+1.-dtuple(S)) =
     [&& x \in S, x \notin t & t \in n.-dtuple(S)].
Proof. move=> *; rewrite !inE memtE !subset_all -!andbA; do !bool_congr. Qed.

Lemma dtuple_on_add_D1 : forall n x (t : n.-tuple sT),
  ([tuple of x :: t] \in n.+1.-dtuple(S))
     = (x \in S) && (t \in n.-dtuple(S :\ x)).
Proof.
move=> n x t; rewrite dtuple_on_add !inE (andbCA (~~ _)); do 2!congr (_ && _).
rewrite -!(eq_subset (in_set (mem t))) setDE setIC subsetI; congr (_ && _).
by rewrite -setCS setCK sub1set !inE.
Qed.

Lemma dtuple_on_subset : forall n (S1 S2 : {set sT}) t,
  S1 \subset S2 -> t \in n.-dtuple(S1) -> t \in n.-dtuple(S2).
Proof.
move=> n S1 S2 t sS12; rewrite !inE; case/andP=> ->; move/subset_trans; exact.
Qed.

Lemma n_act_add n x (t : n.-tuple sT) a :
  n_act to [tuple of x :: t] a = [tuple of to x a :: n_act to t a].
Proof. by move=> *; exact: val_inj. Qed.

Lemma ntransitive0 : [transitive^0 G, on S | to].
Proof.
have dt0: [tuple] \in 0.-dtuple(S) by rewrite inE memtE subset_all.
apply/imsetP; exists [tuple of Nil sT] => //.
by apply/setP=> x; rewrite [x]tuple0 orbit_refl.
Qed.

Lemma ntransitive_weak : forall k m,
  k <= m -> [transitive^m G, on S | to] -> [transitive^k G, on S | to].
Proof.
move=> k m; move/subnKC <-; rewrite addnC; elim: {m}(m - k) => // m IHm.
rewrite addSn => tr_m1; apply: IHm; move: {m k}(m + k) tr_m1 => m tr_m1.
have ext_t: forall t, t \in dtuple_on m S ->
  exists x, [tuple of x :: t] \in m.+1.-dtuple(S).
- move=> /= t dt; case sSt: (S \subset t); last first.
    case/subsetPn: sSt => x Sx ntx.
    by exists x; rewrite dtuple_on_add andbA /= Sx ntx.
  case/imsetP: tr_m1 dt => t1.
  rewrite !inE; case/andP=> Ut1 St1 _; case/andP=> Ut _.
  have:= subset_trans St1 sSt; move/subset_leq_card.
  by rewrite !card_uniq_tuple // ltnn.
case/imsetP: (tr_m1); case/tupleP=> x t; rewrite dtuple_on_add.
case/and3P=> Sx ntx dt; set xt := [tuple of _] => tr_xt.
apply/imsetP; exists t => //.
apply/setP=> u; apply/idP/imsetP=> [du | [a Ga ->{u}]].
  case: (ext_t u du) => y; rewrite tr_xt.
  by case/imsetP=> a Ga [_ def_u]; exists a => //; exact: val_inj.
have: n_act to xt a \in dtuple_on _ S by rewrite tr_xt mem_imset.
by rewrite n_act_add dtuple_on_add; case/and3P.
Qed.

Lemma ntransitive1 : forall m,
  0 < m -> [transitive^m G, on S | to] -> [transitive G, on S | to].
Proof.
have trdom1: forall x, ([tuple x] \in 1.-dtuple(S)) = (x \in S).
  by move=> x; rewrite dtuple_on_add !inE memtE subset_all andbT.
move=> m m_gt0; move/(ntransitive_weak m_gt0)=> {m m_gt0}.
case/imsetP; case/tupleP=> x t0; rewrite {t0}(tuple0 t0) trdom1 => Sx trx.
apply/imsetP; exists x => //; apply/setP=> y; rewrite -trdom1 trx.
apply/imsetP/imsetP; case=> a Ga [->]; exists a => //; exact: val_inj.
Qed.

Lemma ntransitive_primitive : forall m,
  1 < m -> [transitive^m G, on S | to] -> [primitive G, on S | to].
Proof.
move=> m lt1m; move/(ntransitive_weak lt1m) => {m lt1m} tr2G.
have trG: [transitive G, on S | to] by exact: ntransitive1 tr2G.
have [x Sx _]:= imsetP trG; rewrite (trans_prim_astab Sx trG).
apply/maximal_eqP; split=> [|H]; first exact: subsetIl; rewrite subEproper.
case/predU1P; first by [left]; case/andP=> sCH; case/subsetPn=> a Ha nCa sHG.
right; rewrite -(subgroup_transitiveP Sx sHG trG _) ?mulSGid //.
have actH := subset_trans sHG (atrans_acts trG).
pose y := to x a; have Sy: y \in S by rewrite (actsP actH).
have{nCa} yx: y != x by rewrite inE (sameP astab1P eqP) (subsetP sHG) in nCa.
apply/imsetP; exists y => //; apply/eqP.
rewrite eqEsubset acts_sub_orbit // Sy andbT; apply/subsetP=> z Sz.
case: (z =P x) => [->|]; last move/eqP=> zx.
  by rewrite orbit_sym mem_orbit.
pose ty := [tuple y; x]; pose tz := [tuple z; x].
have [Sty Stz]: ty \in 2.-dtuple(S) /\ tz \in 2.-dtuple(S).
  rewrite !inE !memtE !subset_all /= !mem_seq1 !andbT; split; exact/and3P.
case: (atransP2 tr2G Sty Stz) => b Gb [->]; move/esym; move/astab1P=> cxb.
by rewrite mem_orbit // (subsetP sCH) // inE Gb.
Qed.

End NTransitveProp.

Section NTransitveProp1.

Variable (gT : finGroupType) (sT : finType).

Variable to : {action gT &-> sT}.
Variable G : {group gT}.
Variable S : {set sT}.

(* Corresponds to => of 15.12.1 Aschbacher *)
Theorem stab_ntransitive : forall m x,
     0 < m -> x \in S ->  [transitive^m.+1 G, on S | to]
  -> [transitive^m 'C_G[x | to], on S :\ x | to].
Proof.
move=> m x m_gt0 Sx Gtr; have sSxS: S :\ x \subset S by rewrite subsetDl.
case: (imsetP Gtr); case/tupleP=> x1 t1; rewrite dtuple_on_add.
case/and3P=> Sx1 nt1x1 dt1 trt1; have Gtr1 := ntransitive1 (ltn0Sn _) Gtr.
case: (atransP2 Gtr1 Sx1 Sx) => // a Ga x1ax.
pose t := n_act to t1 a.
have dxt: [tuple of x :: t] \in m.+1.-dtuple(S).
  rewrite trt1 x1ax; apply/imsetP; exists a => //; exact: val_inj.
apply/imsetP; exists t.
  by rewrite dtuple_on_add_D1 Sx in dxt.
apply/setP=> t2; apply/idP/imsetP => [dt2|[b]].
  have: [tuple of x :: t2] \in dtuple_on _ S by rewrite dtuple_on_add_D1 Sx.
  case/(atransP2 Gtr dxt)=> b Gb [xbx tbt2].
  exists b; [rewrite inE Gb; exact/astab1P | exact: val_inj].
case/setIP=> Gb; move/astab1P=> xbx ->{t2}.
rewrite n_act_dtuple //; last by rewrite dtuple_on_add_D1 Sx in dxt.
apply/astabsP=> y; rewrite !inE -{1}xbx (inj_eq (act_inj _ _)).
by rewrite (actsP (atrans_acts Gtr1)).
Qed.

(* Correspond to <= of 15.12.1 Aschbacher *)
Theorem stab_ntransitiveI : forall m x,
     x \in S ->  [transitive G, on S | to]
  -> [transitive^m 'C_G[x | to], on S :\ x | to]
  -> [transitive^m.+1 G, on S | to].
Proof.
move=> m x Sx Gtr Gntr.
have t_to_x: forall t, t \in m.+1.-dtuple(S) ->
  exists2 a, a \in G & exists2 t', t' \in m.-dtuple(S :\ x)
                                 & t = n_act to [tuple of x :: t'] a.
- case/tupleP=> y t St.
  have Sy: y \in S by rewrite dtuple_on_add_D1 in St; case/andP: St.
  rewrite -(atransP Gtr _ Sy) in Sx; case/imsetP: Sx => a Ga toya.
  exists a^-1; first exact: groupVr.
  exists (n_act to t a); last by rewrite n_act_add toya !actK.
  move/(n_act_dtuple (subsetP (atrans_acts Gtr) a Ga)): St.
  by rewrite n_act_add -toya dtuple_on_add_D1; case/andP.
case: (imsetP Gntr) => t dt S_tG; pose xt := [tuple of x :: t].
have dxt: xt \in m.+1.-dtuple(S) by rewrite dtuple_on_add_D1 Sx.
apply/imsetP; exists xt => //; apply/setP=> t2.
symmetry; apply/imsetP/idP=> [[a Ga ->] | ].
  by apply: n_act_dtuple; rewrite // (subsetP (atrans_acts Gtr)).
case/t_to_x=> a2 Ga2 [t2']; rewrite S_tG.
case/imsetP=> a; case/setIP=> Ga; move/astab1P=> toxa -> -> {t2 t2'}.
by exists (a * a2); rewrite (groupM, actM) //= !n_act_add toxa.
Qed.

End NTransitveProp1.