(** ** Full sub(pre)categories

Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013)
Reorganized: Langston Barrett (@siddharthist) (March 2018)

*)

(** ** Contents

    Image of a functor, full subcat specified by a functor

    The inclusion of a full subcategory is fully faithful
      Fullness
      Faithfulness

    Subcategories, back to
      Inclusion functor
      Full image of a functor
      Factorization of a functor via its
          full image
      This factorization is fully faithful
          if the functor is
          [functor_full_img_fully_faithful_if_fun_is]

      Isos in full subcategory are equiv
        to isos in the precategory

      Full subcategory of a univalent_category is
        a univalent_category
        [is_univalent_full_subcat]

*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

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.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.

Local Open Scope cat.

(** A full subcategory has the true predicate on morphisms *)

Lemma is_sub_precategory_full (C : category)
         (C':hsubtype (ob C)) : is_sub_precategory C' (λ a b, λ f, htrue).
Proof.
  split;
  intros; exact tt.
Defined.

Definition full_sub_precategory {C : category}
         (C': hsubtype (ob C)) :
   sub_precategories C :=
  tpair _  (make_dirprod C' (λ a b f, htrue)) (is_sub_precategory_full C C').

(** Any morphism between appropriate objects is a morphism of the full subprecategory *)
Definition morphism_in_full_subcat {C : category} {C' : hsubtype (ob C)}
   {a b : ob (full_sub_precategory C')} (f : pr1 a --> pr1 b) :
    precategory_morphisms a b := precategory_morphisms_in_subcat f tt.

Lemma has_homsets_full_sub_precategory (C : category)
         (C':hsubtype (ob C)) : has_homsets (full_sub_precategory C').
Proof.
  intros H x y. apply is_set_sub_precategory_morphisms.
Qed.

Definition full_sub_category (C : category)
           (C':hsubtype (ob C))
  : category
  := make_category _ (has_homsets_full_sub_precategory C C').

(** ** The inclusion of a full subcategory is fully faithful *)

Section FullyFaithful.
  Context (C : category) (C' : hsubtype (ob C)).

  (** *** Fullness *)

  Lemma full_sub_precategory_inclusion :
    full (sub_precategory_inclusion C (full_sub_precategory C')).
  Proof.
    intros a b f.
    apply hinhpr.
    unfold hfiber.
    exists (f,, tt).
    reflexivity.
  Defined.

  (** *** Faithfulness *)

  Lemma faithful_sub_precategory_inclusion :
    faithful (sub_precategory_inclusion C (full_sub_precategory C')).
  Proof.
    intros a b; cbn.
    apply isinclpr1.
    intro; apply isapropunit.
  Defined.

  Lemma fully_faithful_sub_precategory_inclusion :
    fully_faithful (sub_precategory_inclusion C (full_sub_precategory C')).
  Proof.
    apply full_and_faithful_implies_fully_faithful.
    split.
    - apply full_sub_precategory_inclusion.
    - apply faithful_sub_precategory_inclusion.
  Defined.

End FullyFaithful.

(** ** The (full) image of a functor *)

Definition full_img_sub_precategory {C D : category}(F : functor C D) :
    sub_precategories D :=
       full_sub_precategory (sub_img_functor F).

Lemma has_homsets_full_img_sub_precategory {C : category} {D : category} (F : functor C D)
  : has_homsets (full_img_sub_precategory F).
Proof.
  apply  has_homsets_full_sub_precategory.
Qed.

(** ** Given a functor F : C -> D, we obtain a functor F : C -> Img(F) *)

Definition full_img_functor_obj {C D : category}(F : functor C D) :
   ob C -> ob (full_img_sub_precategory F).
Proof.
  intro c.
  exists (F c).
  intros a b.
  apply b.
  exists c.
  apply identity_z_iso.
Defined.

Definition full_img_functor_data {C D : category}(F : functor C D) :
  functor_data C (full_img_sub_precategory F).
Proof.
  exists (full_img_functor_obj F).
  intros a b f.
  exists (#F f).
  exact tt.
Defined.

Lemma is_functor_full_img (C D: category) (F : functor C D) :
  is_functor (full_img_functor_data F).
Proof.
  split.
  intro a; simpl.
  apply subtypePath.
    intro; apply pr2.
  apply functor_id.
  intros a b c f g.
  set ( H := eq_in_sub_precategory D (full_img_sub_precategory F)).
  apply (H (full_img_functor_obj F a)(full_img_functor_obj F c)).
  simpl; apply functor_comp.
Qed.

Definition functor_full_img {C D: category}
       (F : functor C D) :
   functor C (full_img_sub_precategory F) :=
   tpair _ _ (is_functor_full_img C D F).

(** *** Morphisms in the full subprecat are equiv to morphisms in the precategory *)
(** does of course not need the univalent_category hypothesis *)

Definition hom_in_subcat_from_hom_in_precat (C : category)
 (C' : hsubtype (ob C))
  (a b : ob (full_sub_precategory C'))
      (f : pr1 a --> pr1 b) : a --> b :=
       tpair _ f tt.

Definition hom_in_precat_from_hom_in_full_subcat (C : category)
 (C' : hsubtype (ob C))
  (a b : ob (full_sub_precategory C')) :
     a --> b -> pr1 a --> pr1 b := @pr1 _ _ .

Lemma isweq_hom_in_precat_from_hom_in_full_subcat (C : category)
 (C' : hsubtype (ob C))
    (a b : ob (full_sub_precategory C')):
 isweq (hom_in_precat_from_hom_in_full_subcat _ _ a b).
Proof.
  apply (isweq_iso _
         (hom_in_subcat_from_hom_in_precat _ _ a b)).
  intro f.
  destruct f. simpl.
  apply eq_in_sub_precategory.
  apply idpath.
  intros. apply idpath.
Defined.

Lemma isweq_hom_in_subcat_from_hom_in_precat (C : category)
 (C' : hsubtype (ob C))
    (a b : ob (full_sub_precategory C')):
 isweq (hom_in_subcat_from_hom_in_precat  _ _ a b).
Proof.
  apply (isweq_iso _
         (hom_in_precat_from_hom_in_full_subcat _ _ a b)).
  intro f.
  intros. apply idpath.
  intro f.
  destruct f. simpl.
  apply eq_in_sub_precategory.
  apply idpath.
Defined.

Definition weq_hom_in_subcat_from_hom_in_precat (C : category)
     (C' : hsubtype (ob C))
    (a b : ob (full_sub_precategory C')): (pr1 a --> pr1 b) ≃ (a-->b) :=
  tpair _ _ (isweq_hom_in_subcat_from_hom_in_precat C C' a b).

Lemma image_is_in_image (C D : precategory) (F : functor C D)
     (a : ob C): is_in_img_functor F (F a).
Proof.
  apply hinhpr.
  exists a.
  apply identity_z_iso.
Defined.

Lemma functor_full_img_fully_faithful_if_fun_is (C D : category)
   (F : functor C D) (H : fully_faithful F) :
   fully_faithful (functor_full_img F).
Proof.
  unfold fully_faithful in *.
  intros a b.
  set (H' := weq_hom_in_subcat_from_hom_in_precat).
  set (H'' := H' D (is_in_img_functor F)).
  set (Fa := tpair (λ a : ob D, is_in_img_functor F a)
        (F a) (image_is_in_image _ _ F a)).
  set (Fb := tpair (λ a : ob D, is_in_img_functor F a)
        (F b) (image_is_in_image _ _ F b)).
  set (H3 := (H'' Fa Fb)).
  assert (H2 : functor_on_morphisms (functor_full_img F) (a:=a) (b:=b) =
                  funcomp (functor_on_morphisms F (a:=a) (b:=b))
                          ((H3))).
  apply funextsec. intro f.
  apply idpath.
  rewrite H2.
  apply (twooutof3c #F H3).
  apply H.
  apply pr2.
Qed.

(** *** Image factorization C -> Img(F) -> D *)

Local Lemma functor_full_img_factorization_ob (C D: category)
   (F : functor C D):
  functor_on_objects F =
  functor_on_objects (functor_composite
       (functor_full_img F)
            (sub_precategory_inclusion D _)).
Proof.
  reflexivity.
Defined.

(**  works up to eta conversion *)

(*
Lemma functor_full_img_factorization (C D: precategory)
                (F : functor C D) :
    F = functor_composite _ _ _ (functor_full_img F)
            (sub_precategory_inclusion D _).
Proof.
  apply functor_eq. About functor_full_img_factorization_ob.
  set (H := functor_full_img_factorization_ob C D F).
  simpl in *.
  destruct F as [F Fax].
  simpl.
  destruct F as [Fob Fmor]; simpl in *.
  apply (two_arg_paths_f (H)).
  unfold functor_full_img_factorization_ob in H.
  simpl in *.
  apply dep_funextfun.
  intro a.
  apply dep_funextfun.
  intro b.
  apply funextfun.
  intro f.

  generalize Fmor.
  clear Fax.
  assert (H' : Fob = (λ a : ob C, Fob a)).
   apply H.

  generalize dependent a .
  generalize dependent b.
  clear Fmor.
    generalize H.
  clear H.
  intro H.
  clear H'.
  destruct H.
  tion H.
  induction  H'.
  induction H'.
  clear H.

*)

(** ** Any full subprecategory of a univalent_category is a univalent_category. *)

Section full_sub_cat.

Variable C : category.

Variable C' : hsubtype (ob C).

(** *** Isos in the full subcategory are equivalent to isos in the precategory *)

  Lemma iso_in_subcat_is_iso_in_precat (a b : ob (full_sub_category C C'))
       (f : z_iso a b): is_z_isomorphism (C:=C) (a:=pr1 a) (b:=pr1 b)
     (pr1 (pr1 f)).
Proof.
  exists (pr1 (inv_from_z_iso f)).
  split; simpl.
  - set (T:=z_iso_inv_after_z_iso f).
    apply (base_paths _ _ T).
  - set (T:=z_iso_after_z_iso_inv f).
    apply (base_paths _ _ T).
Defined.

Lemma iso_in_precat_is_iso_in_subcat (a b : ob (full_sub_category C C'))
     (f : z_iso (pr1 a) (pr1 b)) :
   is_z_isomorphism (C:=full_sub_category C C')
     (precategory_morphisms_in_subcat f tt).
Proof.
  exists (precategory_morphisms_in_subcat (inv_from_z_iso f) tt).
  split; simpl.
  - apply eq_in_sub_precategory; simpl.
    apply z_iso_inv_after_z_iso.
  - apply eq_in_sub_precategory; simpl.
    apply z_iso_after_z_iso_inv.
Qed.

Definition iso_from_iso_in_sub (a b : ob (full_sub_category C C'))
       (f : z_iso a b) : z_iso (pr1 a) (pr1 b) :=
   tpair _ _ (iso_in_subcat_is_iso_in_precat a b f).

Definition iso_in_sub_from_iso (a b : ob (full_sub_category C C'))
   (f : z_iso (pr1 a) (pr1 b)) : z_iso a b :=
    tpair _ _ (iso_in_precat_is_iso_in_subcat a b f).

Lemma isweq_iso_from_iso_in_sub (a b : ob (full_sub_category C C')):
     isweq (iso_from_iso_in_sub a b).
Proof.
  apply (isweq_iso _ (iso_in_sub_from_iso a b)).
  - intro f.
    apply z_iso_eq; simpl.
    apply eq_in_sub_precategory, idpath.
  - intro f; apply z_iso_eq, idpath.
Defined.

Lemma isweq_iso_in_sub_from_iso (a b : ob (full_sub_category C C')):
     isweq (iso_in_sub_from_iso a b).
Proof.
  apply (isweq_iso _ (iso_from_iso_in_sub a b)).
  intro f; apply z_iso_eq, idpath.
  intro f; apply z_iso_eq; simpl.
  apply eq_in_sub_precategory, idpath.
Defined.

(** *** From Identity in the subcategory to isos in the category  *)
(** This gives a weak equivalence *)

Definition Id_in_sub_to_iso (a b : ob (full_sub_category C C')):
     a = b -> z_iso (pr1 a) (pr1 b) :=
       funcomp (@idtoiso _ a b) (iso_from_iso_in_sub a b).

Lemma Id_in_sub_to_iso_equal_iso
  (a b : ob (full_sub_category C C')) :
    Id_in_sub_to_iso a b = funcomp (total2_paths_hProp_equiv C' a b)
                                    (@idtoiso _ (pr1 a) (pr1 b)).
Proof.
  apply funextfun.
  intro p.
  destruct p.
  apply z_iso_eq.
  simpl; apply idpath.
Qed.

Lemma isweq_Id_in_sub_to_iso (a b : ob (full_sub_category C C')) (H : is_univalent C) :
    isweq (Id_in_sub_to_iso a b).
Proof.
  rewrite Id_in_sub_to_iso_equal_iso.
  apply (twooutof3c _ idtoiso).
  apply pr2.
  apply H.
Defined.

(** *** Decomp of map from id in the subcat to isos in the subcat via isos in ambient precat  *)

Lemma precat_paths_in_sub_as_3_maps
   (a b : ob (full_sub_category C C')):
     @idtoiso _ a b = funcomp (Id_in_sub_to_iso a b)
                                        (iso_in_sub_from_iso a b).
Proof.
  apply funextfun.
  intro p; destruct p.
  apply z_iso_eq; simpl.
  unfold precategory_morphisms_in_subcat.
  apply eq_in_sub_precategory, idpath.
Qed.

(** *** The aforementioned decomposed map is a weak equivalence  *)

Lemma isweq_sub_precat_paths_to_iso
  (a b : ob (full_sub_category C C')) (H : is_univalent C) :
 isweq (@idtoiso _ a b).
Proof.
  rewrite precat_paths_in_sub_as_3_maps.
  match goal with |- isweq (funcomp ?f ?g) => apply (twooutof3c f g) end.
  - apply isweq_Id_in_sub_to_iso; assumption.
  - apply isweq_iso_in_sub_from_iso.
Defined.

(** ** Proof of the targeted theorem: full subcats of cats are cats *)

Lemma is_univalent_full_subcat (H : is_univalent C) : is_univalent (full_sub_category C C').
Proof.
  unfold is_univalent.
  intros; apply isweq_sub_precat_paths_to_iso; assumption.
Defined.

End full_sub_cat.

(** The carrier of a subcategory of a univalent category is itself univalent. *)
Definition subcategory_univalent (C : univalent_category) (C' : hsubtype (ob C)) :
  univalent_category.
Proof.
  use make_univalent_category.
  - exact (subcategory C (full_sub_precategory C')).
  - apply is_univalent_full_subcat, univalent_category_is_univalent.
Defined.

Definition univalent_image
           {C₁ C₂ : univalent_category}
           (F : C₁ ⟶ C₂)
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact (full_img_sub_precategory F).
  - use is_univalent_full_subcat.
    exact (pr2 C₂).
Defined.

Lemma functor_full_img_essentially_surjective (A B : category)
     (F : functor A B) :
  essentially_surjective (functor_full_img F).
Proof.
  intro b.
  use (pr2 b).
  intros [c h] q Hq.
  apply Hq.
  exists c.
  apply iso_in_sub_from_iso.
  apply h.
Qed.

(**
 Commuting triangle for factorization
 *)
Definition full_image_inclusion_commute
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : functor_full_img F ∙ sub_precategory_inclusion C₂ (full_img_sub_precategory F)
    ⟹
    F.
Proof.
  use make_nat_trans.
  - exact (λ _, identity _).
  - abstract
      (intros x y f ; cbn ;
       rewrite id_left, id_right ;
       apply idpath).
Defined.

Definition full_image_inclusion_commute_nat_iso
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : nat_z_iso
      (functor_full_img F ∙ sub_precategory_inclusion C₂ (full_img_sub_precategory F))
      F.
Proof.
  use make_nat_z_iso.
  - exact (full_image_inclusion_commute F).
  - intro.
    apply identity_is_z_iso.
Defined.

(** Isos in full subcategory *)
Definition is_iso_full_sub
           {C : category}
           {P : hsubtype C}
           {x y : full_sub_category C P}
           {f : x --> y}
           (Hf : is_z_isomorphism (pr1 f))
  : is_z_isomorphism f.
Proof.
  exists (inv_from_z_iso (_,,Hf) ,, tt).
  split.
    + abstract
        (use subtypePath ; [ intro ; apply isapropunit | ] ;
         exact (z_iso_inv_after_z_iso (_,,Hf))).
    + abstract
        (use subtypePath ; [ intro ; apply isapropunit | ] ;
         exact (z_iso_after_z_iso_inv (_,,Hf))).
Defined.

(**
 Functors between full subcategories
 *)
Definition full_sub_category_functor_data
           {C₁ C₂ : category}
           {P : hsubtype C₁}
           {Q : hsubtype C₂}
           {F : C₁ ⟶ C₂}
           (HF : ∏ (x : C₁), P x → Q (F x))
  : functor_data
      (full_sub_category C₁ P)
      (full_sub_category C₂ Q).
Proof.
  use make_functor_data.
  - exact (λ x, F (pr1 x) ,, HF (pr1 x) (pr2 x)).
  - exact (λ x y f, #F (pr1 f) ,, tt).
Defined.

Definition full_sub_category_is_functor
           {C₁ C₂ : category}
           {P : hsubtype C₁}
           {Q : hsubtype C₂}
           {F : C₁ ⟶ C₂}
           (HF : ∏ (x : C₁), P x → Q (F x))
  : is_functor (full_sub_category_functor_data HF).
Proof.
  split ; intro ; intros ; cbn ; (use subtypePath ; [ intro ; apply isapropunit | ]).
  - apply functor_id.
  - apply functor_comp.
Qed.

Definition full_sub_category_functor
           {C₁ C₂ : category}
           (P : hsubtype C₁)
           (Q : hsubtype C₂)
           (F : C₁ ⟶ C₂)
           (HF : ∏ (x : C₁), P x → Q (F x))
  : full_sub_category C₁ P ⟶ full_sub_category C₂ Q.
Proof.
  use make_functor.
  - exact (full_sub_category_functor_data HF).
  - exact (full_sub_category_is_functor HF).
Defined.


Module Foo.
  Inductive True2:Prop:= I2: (False->True2)->True2.

  Axiom Heq: (False->True2)=True2.

  Fail Fixpoint con (x:True2) :False :=
    match x with
        I2 f => con (match Heq with @eq_refl _ _ => f end)
    end.
End Foo.

Require Import ClassicalFacts.

Inductive True1 : Prop := I1 : True1
with True2 : Prop := I2 : True1 -> True2.

Section func_unit_discr.

Hypothesis Heq : True1 = True2.

Fail Fixpoint contradiction (u : True2) : False :=
contradiction (
    match u with
      | I2 Tr =>
         match Heq in (_ = T) return T with
         | eq_refl => Tr
         end
    end).

End func_unit_discr.

Require Import Vectors.VectorDef.

About caseS.
About tl.
Open Scope vector_scope.
Local Notation "[]" := (@nil _).
Local Notation "h :: t" := (@cons _ h _ t) (at level 60, right associativity).
Definition is_nil {A n} (v : t A n) : bool := match v with [] => true | _ => false end.

Fixpoint id {A n} (v : t A n) : t A n :=
  match v in t _ n' return t A n' with
    | (h :: t) as v' => h :: id (tl v')
    |_ => []
  end.


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

Require Import type.

Section induction.

Variable (P1 : deep -> Type).
Variable (P2 : option deep -> Type).
Variable (P3 : list (option deep) -> Type).
Variable (HD : forall l, P3 l -> P1 (D l)).
Variable (HS : forall d, P1 d -> P2 (Some d)).
Variable (HN : P2 None).
Variable (Hn : P3 nil).
Variable (Hc : forall o, P2 o -> forall l, P3 l -> P3 (o::l)).

Definition deep_rect : forall d, P1 d :=
  fix deep_rect d :=
    let fix option_deep_rect o : P2 o :=
      match o with
      | Some d => HS d (deep_rect d)
      | None => HN
      end
      in
    let fix list_deep_rect l : P3 l :=
      match l with
      | nil => Hn
      | o :: l => Hc o (option_deep_rect o) l (list_deep_rect l)
      end%list
    in
    match d with
    | D l => HD l (list_deep_rect l)
    end.

Definition option_deep_rect : forall o, P2 o :=
  fix option_deep_rect o :=
    match o with
    | Some d => HS d (deep_rect d)
    | None => HN
    end.

Definition list_deep_rect : forall l, P3 l :=
  fix list_deep_rect l :=
    match l with
    | nil => Hn
    | o :: l => Hc o (option_deep_rect o) l (list_deep_rect l)
    end%list.

Combined Scheme deep_list_option_rect from deep_rect, option_deep_rect, list_deep_rect.

End induction.

Module M2.

Section induction2.

Variable (P1 : deep -> Type).
Variable (P2 : list (option deep) -> Type).
Variable (HD : forall l, P2 l -> P1 (D l)).
Variable (HS : forall d, P1 d -> forall l, P2 l -> P2 (cons (Some d) l)).
Variable (HN : forall l, P2 l -> P2 (cons None l)).
Variable (Hn : P2 nil).

Definition deep_rect : forall d, P1 d :=
  fix deep_rect d :=
    let fix list_deep_rect l : P2 l :=
      match l with
      | nil => Hn
      | o :: l =>
        match o with
        | Some d => HS d (deep_rect d) l (list_deep_rect l)
        | None => HN l (list_deep_rect l)
        end
      end%list
    in
    match d with
    | D l => HD l (list_deep_rect l)
    end.

Definition list_deep_rect : forall l, P2 l :=
  fix list_deep_rect l :=
    match l with
    | nil => Hn
    | o :: l =>
      match o with
      | Some d => HS d (deep_rect d) l (list_deep_rect l)
      | None => HN l (list_deep_rect l)
      end
    end%list.

Combined Scheme deep_list_option_rect from deep_rect, list_deep_rect.

End induction2.

End M2.

Time Definition deep_indDef := [indDef for deep_list_option_rect].
Canonical deep_indType := IndType deep deep_indDef.

Time Definition deep_eqMixin := [derive eqMixin for deep].
Canonical deep_eqType := EqType deep deep_eqMixin.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   lfind. Admitted.


From Coq Require Import ssreflect ssrbool ssrfun Eqdep_dec FunctionalExtensionality.
From mathcomp Require Import ssrnat eqtype.

Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Basic definitions *)

(** We shall allow universal and existential quantification over arbitrary inhabited types.
   The usual interpretation allows quantification over the natural numbers (and possibly
   functionals over the natural numbers), which are of course inhabited. *)

Record Inhabited := inhabit { ty :> Set; member : ty }.

(** The inhabited natural numbers. *)

Definition N := inhabit 0.

(** The inductive type [prp] is a "deep embedding" of the abstract syntax of
   the object language that we shall interpret into Coq. We admit only decidable primitive
   predicates, as is usual in the basic Dialectica variant.

   Our embedding allows us to express "exotic" propositional functions [p : ty -> prp] in
   which the logical structure of [p x] may depend on [x]. Because of this phenomenon we
   will be forced later on to introduce certain type dependencies where there are none in
   the usual Dialectica interpretation. *)

Inductive prp : Type :=
  | atm : bool -> prp
  | pls (A B : prp)
  | tns (A B : prp)
  | bng (A : prp)
  | opp (A : prp)
  | unv : forall {ty : Inhabited}, (ty -> prp) -> prp.

Definition neg A := opp (bng A).
Definition wth A B := opp (pls (opp A) (opp B)).
Definition arr A B := opp (tns A (opp B)).
Definition ext {ty : Inhabited} (f: ty -> prp) : prp := opp (@unv ty (opp \o f)).
Definition whn A := opp (bng (opp A)).

(** Convenient notation for the object language. *)

Notation "'[' p ']'" := (atm p).
Notation "¬ x" := (neg x) (at level 70, no associativity).
Notation "x ＆ y" := (wth x y) (at level 74, left associativity).
Notation "x ⊕ y" := (pls x y) (at level 76, left associativity).
Notation "x ⊗ y" := (tns x y) (at level 76, left associativity).
Notation "x ⊸ y" := (arr x y) (at level 78, right associativity).
Notation "! x" := (bng x) (at level 1, format "! x").
Notation "? x" := (whn x) (at level 1, format "? x").
Notation "∀ x : t , p" :=  (@unv t (fun x => p)) (at level 80, x at level 99).
Notation "∃ x : t , p" :=  (@ext t (fun x => p)) (at level 80, x at level 99).

(** With each proposition [p] we associate the types [W p] and [C p] of "witnesses" and
   "counters", respectively. Think of them as moves in a game between a player [W] and an
   opponent [C]. We make two changes to the standard Dialectica representation.

   First, we use sum for counters of conjunctions, where normally a product is used. This
   gives us symmetry between conjunction and disjunction, simplifies the notorious
   conjunction contraction [and_contr], but complicates the adjunction between implication
   and conjunction. Thomas Streicher pointed out that the change is inessential in the
   sense that we could prove a separate lemma which allows us to pass from counters for [p
   and q] as pairs to counters as elements of a sum (such a lemma relies in decidability
   of the [rel] relation defined below).

   Second, because we allow the structure of a propositional function to depend on the
   argument, we are forced to introduce type dependency into [W p] and [C p] when [p] is a
   quantified statement. This is not a big surprise, but what is a little more surprising
   is that the counters for existentials, [C (existential ty p')], involve a dependency
   not only on [ty] but also on [W (p' x)]. The dependency is needed in the rule
   [exists_elim]. The rest of Dialectica interpetation is not influenced by this change,
   with the exception of the Independence of Premise where we have to impose a condition
   that is not required in the usual interpretation.

   These type-dependencies clearly towards an even more type-dependent Dialectica variant.
   Indeed, we are going to investigate it in a separate file. For now we are just trying
   to faithfully represent the Dialectica interpretation. *)

Section LinDia.

Variable ctx : Type.
Variable daimon : ctx.

Fixpoint W (p : prp) : Type :=
  match p with
    | atm _ => unit
    | pls p1 p2 => W p1 + W p2
    | tns p1 p2 => W p1 * W p2
    | bng p => W p
    | opp p => C p
    | unv ty p' => forall x : ty, W (p' x)
  end

with C p :=
  match p with
    | atm _ => ctx
    | pls p1 p2 => C p1 * C p2
    | tns p1 p2 => (W p1 -> C p2) * (W p2 -> C p1)
    | bng p => W p -> C p
    | opp p => W p
    | unv ty p' => { x : ty & C (p' x) }
  end.

(** The types [W] and [C] are always inhabited because we restrict quantifiers to inhabited
   types. *)

Definition WC_member (A : prp) : W A * C A.
Proof.
elim: A=>//=. (* atm case needs the daimon *)
- by move=>?[??]?[??]; do!split=>//; right.
- by move=>?[??]?[??].
- by move=>?[??].
- by move=>?[??].
move=>ty ? H; split.
- by move=>x; case: (H x).
- by exists (member ty); case: (H (member ty)).
Defined.

Definition W_member (A : prp) := (WC_member A).1.
Definition C_member (A : prp) := (WC_member A).2.

Notation "⊢ A" := (W A) (at level 89).
Notation "⊣ A" := (C A) (at level 89).

(** The relation [rel p w c] is what is usually written as [p_D] in the Dialectica
    interpretation, i.e., the matrix of the interpreted formula.

    In terms of games, [rel p w c] tells whether the player move [w] wins against the
    opponent move [c] in the game determined by the proposition [p].
*)

Fixpoint rel (A : prp) : W A -> C A -> Prop :=
  match A return W A -> C A -> Prop with
    | atm p => fun _ _ => p
    | pls A B => fun w z => match w with
                 | inl u => rel u z.1
                 | inr v => rel v z.2
                 end
    | tns A B => fun w z => match w, z with
                 | (u, v), (zl, zr) => rel u (zr v) /\ rel v (zl u)
                 end
    | bng A => fun u y => @rel A u (y u)
    | opp A => fun x u => ~ rel u x
    | unv T A => fun w z => match z with
                 | existT t u => rel (w t) u
                 end
  end.

(** The [rel] relation is decidable. *)

Fixpoint relb (A : prp) : W A -> C A -> bool :=
  match A return W A -> C A -> bool with
    | atm p => fun _ _ => p
    | pls A B => fun w z => match w with
                 | inl u => relb u z.1
                 | inr v => relb v z.2
                 end
    | tns A B => fun w z => match w, z with
                 | (u, v), (zl, zr) => relb u (zr v) && relb v (zl u)
                 end
    | bng A => fun u y => @relb A u (y u)
    | opp A => fun x u => ~~ relb u x
    | unv T A => fun w z => match z with
                 | existT t u => relb (w t) u
                 end
  end.

Theorem relP (p : prp) (a : W p) (b : C p) : reflect (rel a b) (relb a b).
Proof.
elim: p a b=>//=.
- by move=>? _ _; exact: idP.
- by move=>? H1 ? H2; case=>??; [exact: H1|exact: H2].
- move=>? H1 ? H2 [??][??] /=; case: H1=>/=; last by move=>?; apply: ReflectF; case.
  by case: H2=>??; [apply: ReflectT | apply: ReflectF; case].
- by move=>? H ??; case: H=>/= ?; [apply: ReflectF|apply: ReflectT].
by move=>?? H ?[??] /=; apply: H.
Qed.

(** Of course, a decidable proposition is stable for double negation. *)

Lemma rel_not_not (A : prp) (u : W A) (x : C A) : ~ ~ rel u x -> rel u x.
Proof. by move/classicP=>H; apply/relP/H => /relP. Qed.

Lemma rel_arr : forall A B (w : W (A ⊸ B)) (z : C (A ⊸ B)),
  rel w z <-> (rel z.1 (w.2 z.2) -> rel (w.1 z.1) z.2).
Proof.
move=>?? /= [??][??]; split=>/= H.
- by move=>?; apply: rel_not_not=>?; apply: H.
by move=>[?]; apply; apply: H.
Qed.

(** The predicate [valid p] is the Dialectica interpretation of [p]. It says that there is
   [w] such that [rel p w c] holds for any [c]. In terms of games semantics this means
   that [W] has a winning strategy (which amounts to a winning move [w]). *)

Structure Valid {X} (w : ⊢ X) := V { valid_spec : forall c : ⊣ X, rel w c }.

Definition app {X Y} : ⊢ X ⊸ Y -> ⊢ X -> ⊢ Y.
Proof. by move=>/= []. Defined.

Lemma Valid_app {X Y} : forall (f : ⊢ X ⊸ Y) x, Valid f -> Valid x -> Valid (app f x).
Proof.
move=>/=[??] x [Hf][?] /=; split=>b.
by move: (Hf (x,b)); rewrite rel_arr /=; apply.
Qed.

Definition identity {X} : ⊢ X ⊸ X.
Proof. by []. Defined.

Lemma Valid_id {X}: Valid (@identity X).
Proof. by split=>/= [[??]]; case. Qed.

Definition compose {X Y Z}: ⊢ X ⊸ Y -> ⊢ Y ⊸ Z -> ⊢ X ⊸ Z.
Proof.
move=>/=[fl fr][gl gr].
by split=>/=?; [apply/gl/fl|apply/fr/gr].
Defined.

Lemma Valid_compose {X Y Z}: forall (f : ⊢ X ⊸ Y) (g : ⊢ Y ⊸ Z),
  Valid f -> Valid g -> Valid (compose f g).
Proof.
move=>/=[fl ?][? gr][Hf][Hg]; split=>/= [[u z]].
move: (Hg (fl u, z)); move: (Hf (u, gr z)); rewrite !rel_arr /= =>H1 H2 [?]; apply.
by apply/H2/H1.
Qed.

Notation "t ; u" := (compose t u) (at level 60).

Lemma compose_id_l {X Y}: forall (f : ⊢ X ⊸ Y), identity; f = f.
Proof. by move=>/= []. Qed.

Lemma compose_id_r {X Y}: forall (f : ⊢ X ⊸ Y), f; identity = f.
Proof. by move=>/= []. Qed.

Lemma compose_assoc {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ Q ⊸ R) (h : ⊢ R ⊸ S),
  f; g; h = f; (g ; h).
Proof. by move=>/=[??][??][??]. Qed.

(** Tensoriality *)

Definition tns_fun {P Q R S}: ⊢ P ⊸ Q -> ⊢ R ⊸ S -> ⊢ P ⊗ R ⊸ Q ⊗ S.
Proof.
move=>/=[fl fr][gl gr]; split.
- by move=>[??]; split; [apply: fl|apply: gl].
by move=>[hl hr]; split=>?; [apply/gr/hl/fl|apply/fr/hr/gl].
Defined.

Lemma Valid_tns_fun {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ R ⊸ S),
  Valid f -> Valid g -> Valid (tns_fun f g).
Proof.
move=>/=[fl ?][gl ?][Hf][Hg]; split=>/=[[[u v][hl hr]]].
move: (Hf (u, hr (gl v))); move: (Hg (v, hl (fl u))); rewrite !rel_arr /= =>H1 H2 [[??]]; apply.
by split; [apply: H2|apply:H1].
Qed.

Definition tns_assoc {X Y Z} : ⊢ X ⊗ Y ⊗ Z ⊸ X ⊗ (Y ⊗ Z).
Proof.
split=>/=.
- by move=>[[??]?].
move=>[hl hr]; do!split.
- by move=>[??]; case: hl=>// +?; apply.
- by move=>?; case: hl=>// ?; apply.
by move=>?; apply: hr.
Defined.

Lemma Valid_tns_assoc {X Y Z}: Valid (@tns_assoc X Y Z).
Proof.
split=>/= [[[[u ?]?][hl ?]]] /=.
by case: (hl u)=>??[[[??]?]]; apply.
Qed.

(** *)

Definition lam {X Y Z}: ⊢ X ⊗ Y ⊸ Z -> ⊢ X ⊸ Y ⊸ Z.
Proof.
move=>/=[fl fr]; split.
- move=>?; split=>?; first by apply: fl.
  by case: fr=>// +?; apply.
by move=>[??]; case: fr=>// ?; apply.
Defined.

Lemma Valid_lam {X Y Z}: forall (f : ⊢ X ⊗ Y ⊸ Z), Valid f -> Valid (lam f).
Proof.
move=>/=[? fr][Hf].
split=>/=[[u [v z]]].
move: (Hf (u,v,z)); rewrite !rel_arr /=.
case: (fr z)=>?? H [?]; apply; case=>?; apply.
by apply: H.
Qed.

Lemma natural_lam {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ Q ⊗ R ⊸ S),
  f; lam g = lam (tns_fun f identity; g).
Proof.
move=>/=[??][? gr] /=; f_equal.
- apply: functional_extensionality=>?; f_equal.
  apply: functional_extensionality=>?; f_equal.
  by case: (gr _).
apply: functional_extensionality; case=>??; f_equal.
by case: (gr _).
Qed.

Definition eval {X Y} : ⊢ (X ⊸ Y) ⊗ X ⊸ Y.
Proof.
split=>/=.
- by move=>[[]].
by move=>?; do!split=>// [[?]]; apply.
Defined.

Lemma Valid_eval {X Y} : Valid (@eval X Y).
Proof.
split=>/= [[[[??]??]]][[H1 ?]?].
by apply: H1.
Qed.

(** Cartesian structure *)

Definition prd {X Y Z}: ⊢ Z ⊸ X -> ⊢ Z ⊸ Y -> ⊢ Z ⊸ X ＆ Y.
Proof.
move=>/=[fl fr][gl gr]; split.
- by move=>?; split; [apply: fl|apply: gl].
by case.
Defined.

Lemma Valid_prd {X Y Z}: forall (f : ⊢ Z ⊸ X) (g : ⊢ Z ⊸ Y),
  Valid f -> Valid g -> Valid (prd f g).
Proof.
move=>/=[fl ?][gl ?][Hf][Hg] /=; split.
case; rewrite -/W -/C =>z; case=>[x|y]; rewrite rel_arr /=.
- by move: (Hf (z,x)) => /= H ??; apply: H.
by move: (Hg (z,y)) => /= H ??; apply: H.
Qed.

Definition projl {X Y}: ⊢ X ＆ Y ⊸ X.
Proof. by split=>/=; [case|left]. Defined.

Lemma Valid_projl {X Y}: Valid (@projl X Y).
Proof. by split=>/=[[[??]?]][]. Qed.

Definition projr {X Y}: ⊢ X ＆ Y ⊸ Y.
Proof. by split=>/=; [case|right]. Defined.

Lemma Valid_projr {X Y}: Valid (@projr X Y).
Proof. by split=>/=[[[??]?]][]. Qed.

(** Exponentials *)

Definition wth_tns {X Y} : ⊢ !(X ＆ Y) ⊸ !X ⊗ !Y.
Proof.
split=>//= [[hl hr][u v]].
move: (hl u v)=>l; move: (hr v u)=>r.
by case: (relP v l)=>?; [left|right].
Defined.

Lemma Valid_wth_tns {X Y} : Valid (@wth_tns X Y).
Proof.
split=>/=[[[??][??]]] /=.
case: relP=>?[H1 H2]; apply: H1=>? //.
by apply: H2.
Qed.

Definition tns_wth {X Y} : ⊢ !X ⊗ !Y ⊸ !(X ＆ Y).
Proof.
split=>//= f; split=>u v.
- by case: (f (u,v))=>// ?; apply: C_member.
by case: (f (v,u))=>// ?; apply: C_member.
Defined.

Lemma Valid_tns_wth {X Y} : Valid (@tns_wth X Y).
Proof.
split=>/=[[[??]z]] /=.
by case: z; rewrite -/W -/C=>?[[??]]; apply; apply.
Qed.

Definition bng_fun {X Y}: ⊢ X ⊸ Y -> ⊢ !X ⊸ !Y.
Proof.
move=>/=[fl fr]; split=>//.
by move=>h ?; apply/fr/h/fl.
Defined.

Lemma Valid_bng_fun {X Y} : forall (f : ⊢ X ⊸ Y),
  Valid f -> Valid (bng_fun f).
Proof.
move=>/=[fl fr][Hf]; split=>/= [[u g]].
by move: (Hf (u,g (fl u))).
Qed.

Lemma compose_bng_fun {X Y Z} : forall (f : ⊢ X ⊸ Y) (g : ⊢ Y ⊸ Z),
  bng_fun (f; g) = bng_fun f; bng_fun g.
Proof. by move=>/=[??][??]. Qed.

Lemma id_bng_fun {X}: bng_fun (@identity X) = identity.
Proof. by []. Qed.

Definition bng_mon {X Y}: ⊢ !X ⊗ !Y ⊸ !(X ⊗ Y).
Proof.
split=>//= z; split.
- by move=>??; case: z=>// +?; apply.
by move=>??; case: z=>// ?; apply.
Defined.

Lemma Valid_bng_mon {X Y}: Valid (@bng_mon X Y).
Proof. by split=>/=[[[u v] y]]; case: (y (u,v))=>?? []. Qed.

Lemma natural_bng_mon {P Q R S}: forall (f : ⊢ P ⊸ R) (g : ⊢ Q ⊸ S),
  tns_fun (bng_fun f) (bng_fun g); bng_mon = bng_mon; bng_fun (tns_fun f g).
Proof.
move=>/=[fl fr][gl gr]/=; f_equal.
apply: functional_extensionality=>y; f_equal.
- apply: functional_extensionality=>u; apply: functional_extensionality=>v.
  by case: (y (fl u, gl v)).
apply: functional_extensionality=>v; apply: functional_extensionality=>u.
by case: (y (fl u, gl v)).
Qed.

Definition der {X}: ⊢ !X ⊸ X.
Proof. by split=>/=. Defined.

Lemma Valid_der {X}: Valid (@der X).
Proof. by split=>/=[[??]][]. Qed.

Lemma natural_der {X Y}: forall (f : ⊢ X ⊸ Y),
  der; f = bng_fun f; der.
Proof. by move=>/=[??]. Qed.

Definition dig {X} : ⊢ !X ⊸ !!X.
Proof.
split=>//=.
by move=>x ?; apply: x.
Defined.

Lemma Valid_dig {X} : Valid (@dig X).
Proof. by split=>/=[[??]][]. Qed.

Lemma natural_dig {X Y}: forall (f : ⊢ X ⊸ Y),
  dig; bng_fun (bng_fun f) = bng_fun f; dig.
Proof. by move=>/=[??]. Qed.

Lemma dig_der_id_1 {X}: @dig X; der = identity.
Proof. by []. Qed.

Lemma dig_der_id_2 {X}: @dig X; bng_fun der = identity.
Proof. by []. Qed.

Lemma dig_assoc {X}: @dig X; dig = dig; bng_fun dig.
Proof. by []. Qed.

Lemma der_mon {X Y}: @bng_mon X Y; der = tns_fun der der.
Proof. by move=>/=; f_equal; apply: functional_extensionality; case. Qed.

Lemma dig_mon {X Y}: @bng_mon X Y; dig = tns_fun dig dig; bng_mon; bng_fun bng_mon.
Proof. by move=>/=; f_equal; apply: functional_extensionality; case. Qed.

Definition dup {X} : ⊢ !X ⊸ !X ⊗ !X.
Proof.
split=>//= [[hl hr]] u.
move: (hl u u)=>l; move: (hr u u)=>r.
case: (relP u l)=>?; [|exact l].
case: (relP u r)=>?; [|exact r].
apply: C_member.
Defined.

Lemma Valid_dup {X} : Valid (@dup X).
Proof.
split=>/=[[u[hl hr]]].
case: relP.
- by case: relP=>??[?]; apply.
by move=>?[?].
Qed.

Lemma dup_coalg {X}: @dig X; bng_fun dup = dup; tns_fun dig dig; bng_mon.
Proof.
move=>/=; f_equal.
apply: functional_extensionality=>h; apply functional_extensionality=>u.
by case: (h (u,u)).
Qed.

Lemma dig_comon {X}: @dig X; dup = dup; tns_fun dig dig.
Proof.
move=>/=; f_equal.
apply: functional_extensionality=>[[??]]; apply functional_extensionality=>?.
do!case: relP=>//=.
by rewrite /C_member /=; case: (WC_member X).
Qed.

Lemma dup_mon_comm {P Q R S} : ⊢ (!P ⊗ !Q) ⊗ (!R ⊗ !S) ⊸ (!P ⊗ !R) ⊗ (!Q ⊗ !S).
Proof.
split=>/=.
- by move=>[[??][??]].
move=>[hl hr]; split; move=>[??]; split=>??.
- by case: hl=>// +?; apply.
- by case: hr=>// +?; apply.
- by case: hl=>// ?; apply.
by case: hr=>// ?; apply.
Defined.

Definition undual {X}: ⊢ ((X ⊸ [false]) ⊸ [false]) ⊸ X.
Proof. by split=>//= [[? g]]; case: g. Defined.

Lemma Valid_undual {X}: Valid (@undual X).
Proof.
split=>/= [[[? fr]?]].
case: (fr daimon)=>??[H1 ?]; apply: H1.
by split=>//; case.
Qed.

Definition wkn {A} : ⊢ A ⊸ [true].
Proof. by split=>//= ?; apply: C_member. Defined.

Lemma Valid_wkn {A}: Valid (@wkn A).
Proof. by split=>/= [[??]][]. Qed.

Definition absurd {X} : ⊢ [false] ⊸ X.
Proof. by split=>//= _; apply: W_member. Defined.

Lemma Valid_absurd {X}: Valid (@absurd X).
Proof. by split=>/= [[[] ?]][]. Qed.

Definition forall_intro {ty : Inhabited} (A : prp) (B : ty -> prp) :
  (forall x : ty, ⊢ A ⊸ B x) -> ⊢ A ⊸ ∀ x : ty, B x.
Proof.
move=>p; split=>/=.
- by move=>u ?; apply/app/u.
by move=>[x ?]; move: (p x)=>/=[?]; apply.
Defined.

Lemma Valid_forall_intro {ty A B f}:
  (forall t, Valid (f t)) -> Valid (@forall_intro ty A B f).
Proof.
move=>Hf; split=>/= [[u [x y]]]; move: (Hf x)=>[].
move: (f x)=>/=[??]H[? /= ?].
by apply: (H (u,y)).
Qed.

Definition forall_elim {ty : Inhabited} (t : ty) (A : ty -> prp) :
  ⊢ (∀ t : ty, A t) ⊸ A t.
Proof. by split=>//= ?; exists t. Defined.

Lemma Valid_forall_elim {ty t A}: Valid (@forall_elim ty t A).
Proof. by split=>/= [[??]][]. Qed.

Definition exists_intro {ty : Inhabited} (t : ty) (A : ty -> prp) :
  ⊢ A t ⊸ ∃ x : ty, A x.
Proof. by split=>//= ?; exists t. Defined.

Lemma Valid_exists_intro {ty t A} : Valid (@exists_intro ty t A).
Proof. by split=>/= [[??]][?]; apply. Qed.

(** This is the rule in which we need the dependency of counters in existential statements. *)

Definition exists_elim {ty : Inhabited} (A : prp) (B : ty -> prp)
                       (f : forall x : ty, ⊢ B x ⊸ A) :
 ⊢ (∃ x : ty, B x) ⊸ A.
Proof.
split=>/=.
- by move=>[x ?]; move: (f x)=>/= [+?]; apply.
by move=>? x; move: (f x)=>/= [?]; apply.
Defined.

Lemma Valid_exists_elim {ty A B f} :
  (forall x, Valid (f x)) -> Valid (@exists_elim ty A B f).
Proof.
move=>Hf; split=>/= [[[x v] u]]; move: (Hf x)=>[].
move: (f x)=>/= [??] H [??].
apply: (H (v,u)); split=>//.
by apply: rel_not_not.
Qed.

Lemma exists_id {ty : Inhabited} (A : ty -> prp) (B : prp) (t : ty)
                (f : forall t : ty, ⊢ A t ⊸ B) :
  @exists_intro ty t A; @exists_elim ty B A f = f t.
Proof. by move=>/=; move: (f t)=>/=[]. Qed.

Definition Exists_elim {ty : Inhabited} (A : prp) (B : ty -> prp)
                       (f : forall x : ty, ⊢ !(B x) ⊸ A) :
  ⊢ (∃ x : ty, !(B x)) ⊸ A.
Proof.
split=>/=.
- by move=>[x ?]; move: (f x)=>/=[+?]; apply.
by move=>? x ?; move: (f x)=>/=[?]; apply.
Defined.

Lemma Valid_Exists_elim {ty A B f}:
  (forall x, Valid (f x)) -> Valid (@Exists_elim ty A B f).
Proof.
move=>Hf; split=>/= [[[x v] u]]; move: (Hf x)=>[].
move: (f x)=>/=[??] H [??].
apply: (H (v,u)); split=>//.
by apply: rel_not_not.
Qed.

End LinDia.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Import ZArith Znumtheory.

Open Scope Z_scope.

(** * NSig *)

(** Interface of a rich structure about natural numbers.
    Specifications are written via translation to Z.
*)

Module Type NType.

 Parameter t : Type.

 Parameter to_Z : t -> Z.
 Local Notation "[ x ]" := (to_Z x).
 Parameter spec_pos: forall x, 0 <= [x].

 Parameter of_N : N -> t.
 Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x.
 Definition to_N n := Zabs_N (to_Z n).

 Definition eq n m := [n] = [m].
 Definition lt n m := [n] < [m].
 Definition le n m := [n] <= [m].

 Parameter compare : t -> t -> comparison.
 Parameter eq_bool : t -> t -> bool.
 Parameter max : t -> t -> t.
 Parameter min : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter two : t.
 Parameter succ : t -> t.
 Parameter pred : t -> t.
 Parameter add  : t -> t -> t.
 Parameter sub : t -> t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter pow_pos : t -> positive -> t.
 Parameter pow_N : t -> N -> t.
 Parameter pow : t -> t -> t.
 Parameter sqrt : t -> t.
 Parameter log2 : t -> t.
 Parameter div_eucl : t -> t -> t * t.
 Parameter div : t -> t -> t.
 Parameter modulo : t -> t -> t.
 Parameter gcd : t -> t -> t.
 Parameter even : t -> bool.
 Parameter odd : t -> bool.
 Parameter testbit : t -> t -> bool.
 Parameter shiftr : t -> t -> t.
 Parameter shiftl : t -> t -> t.
 Parameter land : t -> t -> t.
 Parameter lor : t -> t -> t.
 Parameter ldiff : t -> t -> t.
 Parameter lxor : t -> t -> t.
 Parameter div2 : t -> t.

 Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y].
 Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y].
 Parameter spec_max : forall x y, [max x y] = Zmax [x] [y].
 Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
 Parameter spec_0: [zero] = 0.
 Parameter spec_1: [one] = 1.
 Parameter spec_2: [two] = 2.
 Parameter spec_succ: forall n, [succ n] = [n] + 1.
 Parameter spec_add: forall x y, [add x y] = [x] + [y].
 Parameter spec_pred: forall x, [pred x] = Zmax 0 ([x] - 1).
 Parameter spec_sub: forall x y, [sub x y] = Zmax 0 ([x] - [y]).
 Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
 Parameter spec_square: forall x, [square x] = [x] *  [x].
 Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
 Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z_of_N n.
 Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
 Parameter spec_sqrt: forall x, [sqrt x] = Zsqrt [x].
 Parameter spec_log2: forall x, [log2 x] = Zlog2 [x].
 Parameter spec_div_eucl: forall x y,
  let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
 Parameter spec_div: forall x y, [div x y] = [x] / [y].
 Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
 Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
 Parameter spec_even: forall x, even x = Zeven_bool [x].
 Parameter spec_odd: forall x, odd x = Zodd_bool [x].
 Parameter spec_testbit: forall x p, testbit x p = Ztestbit [x] [p].
 Parameter spec_shiftr: forall x p, [shiftr x p] = Zshiftr [x] [p].
 Parameter spec_shiftl: forall x p, [shiftl x p] = Zshiftl [x] [p].
 Parameter spec_land: forall x y, [land x y] = Zand [x] [y].
 Parameter spec_lor: forall x y, [lor x y] = Zor [x] [y].
 Parameter spec_ldiff: forall x y, [ldiff x y] = Zdiff [x] [y].
 Parameter spec_lxor: forall x y, [lxor x y] = Zxor [x] [y].
 Parameter spec_div2: forall x, [div2 x] = Zdiv2 [x].

End NType.

Module Type NType_Notation (Import N:NType).
 Notation "[ x ]" := (to_Z x).
 Infix "==" := eq (at level 70).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "2" := two.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Infix "^" := pow.
 Infix "<=" := le.
 Infix "<" := lt.
End NType_Notation.

Module Type NType' := NType <+ NType_Notation.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Wellfounded.

Set Implicit Arguments.

Reserved Notation " e '⇢' x " (at level 58).
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0, left associativity).
Reserved Notation "e ⦃ x '⇠' v ⦄" (at level 57, v at level 0, x at level 0, format "e ⦃ x ⇠ v ⦄", left associativity).

Definition eqdec X := forall x y : X, { x = y } + { x <> y }.

Section env.

  Variable (X Y : Type) (X_eq_dec : eqdec X) (Y_default : Y).

  Definition env := X -> Y.

  Implicit Type e : env.

  Definition get_env e x := e x.

  Definition set_env e x v : env := fun y => if X_eq_dec x y then v else e y.

  Definition nil_env : env := fun _ => Y_default.

  Fact get_set_env_eq e v p q : p = q -> get_env (set_env e p v) q = v.
  Proof. intros []; unfold set_env, get_env; destruct (X_eq_dec p p) as [ | [] ]; auto. Qed.

  Fact get_set_env_neq e v p q : p <> q -> get_env (set_env e p v) q = get_env e q.
  Proof. simpl; intros H; unfold set_env, get_env; destruct (X_eq_dec p q); auto; destruct H; auto. Qed.

End env.

Arguments nil_env {X}.

Local Notation "e ⇢ x" := (@get_env _ _ e x).
Local Notation "e ⦃  x ⇠ v ⦄" := (@set_env _ _ _ e x v).

(* find the value of x inside the environment t *)

Ltac find_val x t :=
  match t with
    | ?s⦃x⇠?v⦄ => v
    | ?s⦃_⇠_⦄ => find_val x s
  end.

Tactic Notation "rew" "env" :=
  repeat lazymatch goal with
    |              |- context[ _⦃ ?x⇠_⦄⇢?x ] => rewrite get_set_env_eq  with (1 := eq_refl x)
    | _ : ?x = ?y  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    |              |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y);
                                                  [ | discriminate ]
  end; auto.

Tactic Notation "rew" "env" "in" hyp(H) := revert H; rew env; intros H.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype.
Require Import bigops prime paths finset groups commutators automorphism.
Require Import morphisms normal cyclic center gprod gfunc gseries.

(******************************************************************************)
(*   This file defines nilpotent and solvable groups, and give some of their  *)
(* elementary properties; more will be added later (e.g., the nilpotence of   *)
(* p-groups in sylow.v, or the fact that minimal normal subgroups of solvable *)
(* groups are elementary abelian in maximal.v). This file defines:            *)
(*   nilpotent G == G is nilpotent, i.e., [~: H, G] is a proper subgroup of H *)
(*                  for all nontrivial H <| G.                                *)
(*    solvable G == G is solvable, i.e., H^`(1) is a proper subgroup of H for *)
(*                  all nontrivial subgroups H of G.                          *)
(*       'L_n(G) == the nth term of the lower central series, namely          *)
(*                  [~: G, ..., G] (n Gs) if n > 0, with 'L_0(G) = G.         *)
(*                  G is nilpotent iff 'L_n(G) = 1 for some n.                *)
(*       'Z_n(G) == the nth term of the upper central series, i.e.,           *)
(*                  with 'Z_0(G) = 1, 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)). *)
(*   nil_class G == the nilpotence class of G, i.e., the least n such that    *)
(*                  'L_n.+1(G) = 1 (or, equivalently, 'Z_n(G) = G), if G is   *)
(*                  nilpotent; we take nil_class G = #|G| when G is not       *)
(*                  nilpotent, so nil_class G < #|G| iff G is nilpotent.      *)
(******************************************************************************)

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

Import GroupScope.

Section SeriesDefs.

Variables (n : nat) (gT : finGroupType) (A : {set gT}).

Definition lower_central_at_rec := iter n (fun B => [~: B, A]) A.

Definition upper_central_at_rec := iter n (fun B => coset B @*^-1 'Z(A / B)) 1.

End SeriesDefs.

(* By convention, the lower central series starts at 1 while the upper series *)
(* starts at 0 (sic).                                                         *)
Definition lower_central_at n := lower_central_at_rec n.-1.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section    *)
(* "cooking" destroys it.                                                     *)
Definition upper_central_at := nosimpl upper_central_at_rec.

Notation "''L_' n ( G )" := (lower_central_at n G)
  (at level 8, n at level 2, format "''L_' n ( G )") : group_scope.

Notation "''Z_' n ( G )" := (upper_central_at n G)
  (at level 8, n at level 2, format "''Z_' n ( G )") : group_scope.

Section PropertiesDefs.

Variables (gT : finGroupType) (A : {set gT}).

Definition nilpotent :=
  forallb G : {group gT}, (G \subset A :&: [~: G, A]) ==> (G :==: 1).

Definition nil_class := index 1 (mkseq (fun n => 'L_n.+1(A)) #|A|).

Definition solvable :=
  forallb G : {group gT}, (G \subset A :&: [~: G, G]) ==> (G :==: 1).

End PropertiesDefs.

Prenex Implicits nil_class nilpotent solvable.

Section NilpotentProps.

Variable gT: finGroupType.

Implicit Type A B : {set gT}.
Implicit Type G H : {group gT}.

Lemma nilpotent1 : nilpotent [1 gT].
Proof. apply/forallP=> H; rewrite commG1 setIid -subG1; exact/implyP. Qed.

Lemma nilpotentS : forall A B, B \subset A -> nilpotent A -> nilpotent B.
Proof.
move=> A B sBA nilA; apply/forallP=> H; apply/implyP=> sHR.
have:= forallP nilA H; rewrite (subset_trans sHR) //.
by apply: subset_trans (setIS _ _) (setSI _ _); rewrite ?commgS.
Qed.

Lemma nil_comm_properl : forall G H A,
    nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) ->
  [~: H, A] \proper H.
Proof.
move=> G H A nilG sHG ntH; rewrite subsetI properE; case/andP=> sAG nHA.
rewrite (subset_trans (commgS H (subset_gen A))) ?commg_subl ?gen_subG //.
apply: contra ntH => sHR; have:= forallP nilG H; rewrite subsetI sHG.
by rewrite (subset_trans sHR) ?commgS.
Qed.

Lemma nil_comm_properr : forall G A H,
    nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) ->
  [~: A, H] \proper H.
Proof. by move=> G A H; rewrite commGC; exact: nil_comm_properl. Qed.

Lemma centrals_nil : forall (s : seq {group gT})(G : {group gT}),
  G.-central.-series 1%G s -> last 1%G s = G -> nilpotent G.
Proof.
move=> s G cs ls; apply/forall_inP=> H; rewrite subsetI; case/andP=> sHG sHR.
suff: forall n,  n <= size s -> H \subset nth G (1%G :: s) ((size s) - n).
  move/(_ (size s)) => /=; rewrite subnn -subG1 leqnn; exact.
elim=> [|n ihn ltns]; first by rewrite subn0 nth_last last_cons ls.
apply: subset_trans sHR _; apply: subset_trans (commSg _ (ihn (ltnW ltns))) _.
have e: (size s - n.+1 < size s) by rewrite -ltn_subS // leq_subr.
by rewrite ltn_subS //=; case/and3P: {e} (pathP G cs (size s - n.+1) e).
Qed.

End NilpotentProps.

Section LowerCentral.

Variable gT : finGroupType.
Notation sT := {set gT}.
Implicit Type A B : {set gT}.
Implicit Type G H : {group gT}.

Lemma lcn0 : forall A, 'L_0(A) = A. Proof. by []. Qed.
Lemma lcn1 : forall A, 'L_1(A) = A. Proof. by []. Qed.
Lemma lcnSn : forall n A, 'L_n.+2(A) = [~: 'L_n.+1(A), A]. Proof. by []. Qed.
Lemma lcnSnS : forall n G, [~: 'L_n(G), G] \subset 'L_n.+1(G).
Proof. by case=> [|n] A; rewrite ?der1_subG // lcnSn. Qed.
Lemma lcnE : forall n A, 'L_n.+1(A) = lower_central_at_rec n A.
Proof. by []. Qed.
Lemma lcn2 : forall A, 'L_2(A) = A^`(1). Proof. by []. Qed.

Lemma lcn_group_set : forall n G, group_set 'L_n(G).
Proof. move=> n G; case: n; last elim=> *; exact: groupP. Qed.

Canonical Structure lower_central_at_group n G := Group (lcn_group_set n G).

Lemma lcn_char : forall n G, 'L_n(G) \char G.
Proof.
by case=> [|n] G; last elim: n => [|n IHn]; rewrite ?lcnSn ?charR ?char_refl.
Qed.

Lemma lcn_normal : forall n G, 'L_n(G) <|  G.
Proof. move=> n G; apply: char_normal; exact: lcn_char. Qed.

Lemma lcn_sub : forall n G, 'L_n(G) \subset G.
Proof. by move=> n G; case/andP: (lcn_normal n G). Qed.

Lemma lcn_norm : forall n G, G \subset 'N('L_n(G)).
Proof. by move=> n G; case/andP: (lcn_normal n G). Qed.

Lemma lcn_subS : forall n G, 'L_n.+1(G) \subset 'L_n(G).
Proof.
move=> [|n] G //; rewrite lcnSn commGC commg_subr.
by case/andP: (lcn_normal n.+1 G).
Qed.

Lemma lcn_normalS : forall n G, 'L_n.+1(G) <| 'L_n(G).
Proof.
by move=> G n; apply: normalS (lcn_normal _ _); rewrite (lcn_subS, lcn_sub).
Qed.

Lemma lcn_central : forall n G,
  'L_n(G) / 'L_n.+1(G) \subset 'Z(G / 'L_n.+1(G)).
Proof.
case=> [|n] G; first by rewrite trivg_quotient sub1G.
by rewrite subsetI quotientS ?lcn_sub ?quotient_cents2r.
Qed.

Lemma lcn_sub_leq : forall m n G, n <= m -> 'L_m(G) \subset 'L_n(G).
Proof.
move=> m n G; move/subnK <-; elim: {m}(m - n) => // m.
exact: subset_trans (lcn_subS _ _).
Qed.

Lemma lcnS : forall n A B, A \subset B -> 'L_n(A) \subset 'L_n(B).
Proof.
by case=> // n A B sAB; elim: n => // n IHn; rewrite !lcnSn genS ?imset2S.
Qed.

Lemma lcn_cprod : forall n A B G, A \* B = G -> 'L_n(A) \* 'L_n(B) = 'L_n(G).
Proof.
move=> [|n] // A B G; case/cprodP=> [[H K -> ->{A B}] defG cKH].
have sL := subset_trans (lcn_sub _ _); rewrite cprodE ?(centSS _ _ cKH) ?sL //.
symmetry; elim: n => // n; rewrite lcnSn => ->; rewrite commMG /=; last first.
  by apply: subset_trans (commg_normr _ _); rewrite sL // -defG mulG_subr.
rewrite -!(commGC G) -defG {1}(centC cKH).
rewrite !commMG ?normsR ?lcn_norm ?cents_norm // 1?centsC //.
by rewrite -!(commGC 'L__(_)) -!lcnSn !(commG1P _) ?mul1g ?sL // centsC.
Qed.

Lemma der_cprod : forall n A B G, A \* B = G -> A^`(n) \* B^`(n) = G^`(n).
Proof.
by move=> n A B G defG; elim: n => {defG}// n; apply: (lcn_cprod 2).
Qed.

Lemma nilpotent_class : forall G, nilpotent G = (nil_class G < #|G|).
Proof.
move=> G; rewrite /nil_class; set s := mkseq _ _.
transitivity (1 \in s); last by rewrite -index_mem size_mkseq.
apply/idP/mapP=> {s}/= [nilG | [n _ Ln1]]; last first.
  apply/forallP=> H; rewrite subsetI; apply/implyP; case/andP=> sHG sHR.
  rewrite -subG1 {}Ln1; elim: n => // n IHn.
  by rewrite (subset_trans sHR) ?commSg.
pose m := #|G|.-1; exists m; first by rewrite mem_iota /= prednK.
rewrite ['L__(G)]card_le1_trivg //= -(subnn m).
elim: {-2}m => [|n]; [by rewrite subn0 prednK | rewrite lcnSn -predn_sub].
case: (eqsVneq 'L_n.+1(G) 1) => [-> | ntLn]; first by rewrite comm1G cards1.
case: (m - n) => [|m' /= IHn]; first by rewrite leqNgt cardG_gt1 ntLn.
rewrite -ltnS (leq_trans (proper_card _) IHn) //.
by rewrite (nil_comm_properl nilG) ?lcn_sub // subsetI subxx lcn_norm.
Qed.

Lemma lcn_nil_classP : forall n G,
  nilpotent G -> reflect ('L_n.+1(G) = 1) (nil_class G <= n).
Proof.
move=> n G; rewrite nilpotent_class /nil_class; set s := mkseq _ _.
set c := index 1 s => lt_c_G; case: leqP => [le_c_n | lt_n_c].
  have Lc1: nth 1 s c = 1 by rewrite nth_index // -index_mem size_mkseq.
  by left; apply/trivgP; rewrite -Lc1 nth_mkseq ?lcn_sub_leq.
right; apply/eqP; apply/negPf; rewrite -(before_find 1 lt_n_c) nth_mkseq //.
exact: ltn_trans lt_n_c lt_c_G.
Qed.

Lemma lcnP : forall G, reflect (exists n, 'L_n.+1(G) = 1) (nilpotent G).
Proof.
move=> G; apply: (iffP idP) => [nilG | [n Ln1]].
  by exists (nil_class G); exact/lcn_nil_classP.
apply/forallP=> H; apply/implyP; rewrite subsetI; case/andP=> sHG sHR.
rewrite -subG1 -{}Ln1; elim: n => // n IHn.
by rewrite (subset_trans sHR) ?commSg.
Qed.

Lemma abelian_nil : forall G, abelian G -> nilpotent G.
Proof. move=> G abG; apply/lcnP; exists 1%N; exact/commG1P. Qed.

Lemma nil_class0 : forall G, (nil_class G == 0) = (G :==: 1).
Proof.
move=> G; apply/idP/eqP=> [nilG | ->].
  by apply/(lcn_nil_classP 0); rewrite ?nilpotent_class (eqP nilG) ?cardG_gt0.
by rewrite -leqn0; apply/(lcn_nil_classP 0); rewrite ?nilpotent1.
Qed.

Lemma nil_class1 : forall G, (nil_class G <= 1) = abelian G.
Proof.
move=> G; case: (eqsVneq G 1) => [-> | ntG].
  by rewrite abelian1 leq_eqVlt ltnS leqn0 nil_class0 eqxx orbT.
apply/idP/idP=> cGG.
  apply/commG1P; apply/(lcn_nil_classP 1); rewrite // nilpotent_class.
  by rewrite (leq_ltn_trans cGG) // cardG_gt1.
by apply/(lcn_nil_classP 1); rewrite ?abelian_nil //; apply/commG1P.
Qed.

Lemma cprod_nil : forall A B G,
  A \* B = G -> nilpotent (G) = nilpotent A && nilpotent B.
Proof.
move=> A B G defG; case/cprodP: defG (defG) => [[H K -> ->{A B}] defG _] defGc.
apply/idP/andP=> [nilG | []].
  by rewrite !(nilpotentS _ nilG) // -defG (mulG_subr, mulG_subl).
case/lcnP=> m LmH1; case/lcnP=> n LnK1; apply/lcnP; exists (m + n.+1).
apply/trivgP; case/cprodP: (lcn_cprod (m.+1 + n.+1) defGc) => _ <- _.
by rewrite mulG_subG /= -{1}LmH1 -LnK1 !lcn_sub_leq ?leq_addl ?leq_addr.
Qed.

Lemma mulg_nil : forall G H,
  G \subset 'C(H) -> nilpotent (G * H) = nilpotent G && nilpotent H.
Proof.
by move=> G H cHG; rewrite -(cprod_nil (cprodEgen cHG)) /= cent_mulgenEl.
Qed.

Lemma dprod_nil : forall A B G,
   A \x B = G -> nilpotent G = nilpotent A && nilpotent B.
Proof.
by move=> A B G; case/dprodP=> [[H K -> ->] <- cKH _]; rewrite mulg_nil.
Qed.

Lemma bigdprod_nil : forall I r (P : pred I) (A_ : I -> {set gT}) G,
  \big[dprod/1]_(i <- r | P i) A_ i = G
  -> (forall i, P i -> nilpotent (A_ i)) -> nilpotent G.
Proof.
move=> I r P A_ G defG nilA; rewrite -defG; move: G defG.
apply big_prop => [| A B IHA IHB G defG | i Pi]; rewrite ?nilpotent1 ?nilA //.
rewrite defG (dprod_nil defG).
by case/dprodP: defG => [[H K]]; move/IHA->; move/IHB.
Qed.

End LowerCentral.

Notation "''L_' n ( G )" := (lower_central_at_group n G) : subgroup_scope.

Lemma lcn_cont : forall n, cont (lower_central_at n).
Proof.
case=> //; elim=> // n IHn g0T h0T H phi.
by rewrite !lcnSn morphimR ?lcn_sub // commSg ?IHn.
Qed.

Canonical Structure bgFunc_lcn n :=
  [bgFunc by fun gT => @lcn_sub gT n & lcn_cont n].

Canonical Structure gFunc_lcn n := GFunc (lcn_cont n).

Canonical Structure mgFunc_lcn n := MGFunc (fun _ G H => @lcnS _ n G H).

Section UpperCentralFunctor.

Variable n : nat.
Implicit Type gT : finGroupType.

Lemma ucn_hgFunc : exists hZ : hgFunc, @upper_central_at n = hZ.
Proof.
elim: n => [|n' [hZ defZ]]; first by exists hgFunc_triv.
by exists [hgFunc of appmod center hZ]; rewrite /= -defZ.
Qed.

(* Now extract all the intermediate facts of the last proof. *)

Lemma ucn_group_set : forall gT (G : {group gT}), group_set 'Z_n(G).
Proof. by case: ucn_hgFunc => hZ ->; exact: bgFunc_groupset. Qed.

Canonical Structure upper_central_at_group gT G := Group (@ucn_group_set gT G).

Lemma ucn_sub : forall gT (G : {group gT}), 'Z_n(G) \subset G.
Proof. by case: ucn_hgFunc => hZ ->; exact: bgFunc_clos. Qed.

Lemma ucn_cont : cont (upper_central_at n).
Proof. by case: ucn_hgFunc => hZ ->; exact: gFunc_cont. Qed.

Lemma ucn_hereditary : hereditary (upper_central_at n).
Proof. by case: ucn_hgFunc => hZ ->; exact: hgFunc_hereditary. Qed.

Canonical Structure bgFunc_ucn := [bgFunc by ucn_sub & ucn_cont].
Canonical Structure gFunc_ucn := GFunc ucn_cont.
Canonical Structure hgFunc_ucn := HGFunc ucn_hereditary.

Variable (gT : finGroupType) (G : {group gT}).

Lemma ucn_char : 'Z_n(G) \char G. Proof. exact: bgFunc_char. Qed.
Lemma ucn_norm : G \subset 'N('Z_n(G)). Proof. exact: bgFunc_norm. Qed.
Lemma ucn_normal : 'Z_n(G) <| G. Proof. exact: bgFunc_normal. Qed.

End UpperCentralFunctor.

Notation "''Z_' n ( G )" := (upper_central_at_group n G) : subgroup_scope.

Section UpperCentral.

Variable gT : finGroupType.
Notation sT := {set gT}.
Implicit Type A B : {set gT}.
Implicit Type G H : {group gT}.

Lemma ucn0 : forall A, 'Z_0(A) = 1.
Proof. by []. Qed.

Lemma ucnSn : forall n A, 'Z_n.+1(A) = coset 'Z_n(A) @*^-1 'Z(A / 'Z_n(A)).
Proof. by []. Qed.

Lemma ucnE : forall n A, 'Z_n(A) = upper_central_at_rec n A.
Proof. by []. Qed.

Lemma ucn_subS : forall n G, 'Z_n(G) \subset 'Z_n.+1(G).
Proof. by move=> n G; rewrite -{1}['Z_n(G)]ker_coset morphpreS ?sub1G. Qed.

Lemma ucn_sub_geq : forall m n G, n >= m -> 'Z_m(G) \subset 'Z_n(G).
Proof.
move=> m n G; move/subnK <-; elim: {n}(n - m) => // n IHn.
exact: subset_trans (ucn_subS _ _).
Qed.

Lemma ucn_central : forall n G, 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)).
Proof. by move=> n G; rewrite ucnSn cosetpreK. Qed.

Lemma ucn_normalS : forall n G, 'Z_n(G) <| 'Z_n.+1(G).
Proof.
by move=> n G; rewrite (normalS _ _ (ucn_normal n G)) ?ucn_subS ?ucn_sub.
Qed.

Lemma ucn_comm : forall n G, [~: 'Z_n.+1(G), G] \subset 'Z_n(G).
Proof.
move=> G n; rewrite -quotient_cents2 ?normal_norm ?ucn_normal ?ucn_normalS //.
by rewrite ucn_central subsetIr.
Qed.

Lemma ucn1 : forall G, 'Z_1(G) = 'Z(G).
Proof.
move=> G; apply: (quotient_inj (normal1 _) (normal1 _)).
by rewrite /= (ucn_central 0) -bgFunc_ascont ?norms1 ?coset1_injm.
Qed.

Lemma ucnSnR : forall n G,
  'Z_n.+1(G) = [set x \in G | [~: [set x], G] \subset 'Z_n(G)].
Proof.
move=> n G; apply/setP=> x; rewrite inE -(setIidPr (ucn_sub n.+1 G)) inE ucnSn.
case Gx: (x \in G) => //=; have nZG := ucn_norm n G.
rewrite -sub1set -sub_quotient_pre -?quotient_cents2 ?sub1set ?(subsetP nZG) //.
by rewrite subsetI quotientS ?sub1set.
Qed.

Lemma ucn_lcnP : forall n G, ('L_n.+1(G) == 1) = ('Z_n(G) == G).
Proof.
move=> n G; rewrite !eqEsubset sub1G ucn_sub /= andbT -(ucn0 G).
elim: {1 3}n 0 (addn0 n) => [j <- //|i IHi j].
rewrite addSnnS; move/IHi=> <- {IHi}; rewrite ucnSn lcnSn.
have nZG := normal_norm (ucn_normal j G).
have nZL := subset_trans (lcn_sub _ _) nZG.
by rewrite -sub_morphim_pre // subsetI morphimS ?lcn_sub // quotient_cents2.
Qed.

Lemma ucnP : forall G, reflect (exists n, 'Z_n(G) = G) (nilpotent G).
Proof.
move=> G; apply: (iffP (lcnP G)) => [] [n]; move/eqP=> clGn;
  by exists n; apply/eqP; rewrite ucn_lcnP in clGn *.
Qed.

Lemma ucn_nil_classP : forall n G,
  nilpotent G -> reflect ('Z_n(G) = G) (nil_class G <= n).
Proof.
move=> n G nilG; rewrite (sameP (lcn_nil_classP n nilG) eqP) ucn_lcnP.
exact: eqP.
Qed.

Lemma ucn_id : forall n G, 'Z_n('Z_n(G)) = 'Z_n(G).
Proof. by move=> n G; rewrite -{2}['Z_n(G)]hereditary_idem. Qed.

Lemma ucn_nilpotent : forall n G, nilpotent 'Z_n(G).
Proof. by move=> n G; apply/ucnP; exists n; rewrite ucn_id. Qed.

Lemma nil_class_ucn : forall n G, nil_class 'Z_n(G) <= n.
Proof. by move=> n G; apply/ucn_nil_classP; rewrite ?ucn_nilpotent ?ucn_id. Qed.

End UpperCentral.

Section MorphNil.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Implicit Type G : {group aT}.

Lemma morphim_lcn : forall n G, G \subset D -> f @* 'L_n(G) = 'L_n(f @* G).
Proof.
case=> // n G sHG; elim: n => // n IHn.
by rewrite !lcnSn -IHn morphimR // (subset_trans _ sHG) // lcn_sub.
Qed.

Lemma morphim_ucn : forall n G, f @* 'Z_n(G) \subset 'Z_n(f @* G).
Proof. by move=> n G; exact: hgFunc_morphim. Qed.

Lemma injm_ucn : forall n G,
  'injm f -> G \subset D -> f @* 'Z_n(G) = 'Z_n(f @* G).
Proof. move=> n G; exact: injm_sFunctor. Qed.

Lemma morphim_nil : forall G, nilpotent G -> nilpotent (f @* G).
Proof.
move=> G; case/ucnP=> n ZnG; apply/ucnP; exists n.
by apply/eqP; rewrite eqEsubset ucn_sub /= -{1}ZnG morphim_ucn.
Qed.

Lemma injm_nil : forall G,
  'injm f -> G \subset D -> nilpotent (f @* G) = nilpotent G.
Proof.
move=> G injf sGD; apply/idP/idP; last exact: morphim_nil.
case/ucnP=> n; rewrite -injm_ucn //; move/injm_morphim_inj=> // defZ.
by apply/ucnP; exists n; rewrite defZ ?(subset_trans (ucn_sub n G)).
Qed.

Lemma nil_class_morphim : forall G,
  nilpotent G -> nil_class (f @* G) <= nil_class G.
Proof.
move=> G nilG; rewrite (sameP (ucn_nil_classP _ (morphim_nil nilG)) eqP) /=.
by rewrite eqEsubset ucn_sub -{1}(ucn_nil_classP _ nilG (leqnn _)) morphim_ucn.
Qed.

Lemma nil_class_injm : forall G,
  'injm f -> G \subset D -> nil_class (f @* G) = nil_class G.
Proof.
move=> G injf sGD; case nilG: (nilpotent G).
  apply/eqP; rewrite eqn_leq nil_class_morphim //.
  rewrite (sameP (lcn_nil_classP _ nilG) eqP) -subG1.
  rewrite -(injmSK injf) ?(subset_trans (lcn_sub _ _)) // morphim1.
  by rewrite morphim_lcn // (lcn_nil_classP _ _ (leqnn _)) //= injm_nil.
transitivity #|G|; apply/eqP; rewrite eqn_leq.
  rewrite -(card_injm injf sGD) (leq_trans (index_size _ _)) ?size_mkseq //.
  by rewrite leqNgt -nilpotent_class injm_nil ?nilG.
rewrite (leq_trans (index_size _ _)) ?size_mkseq // leqNgt -nilpotent_class.
by rewrite nilG.
Qed.

End MorphNil.

Section QuotientNil.

Variables gT : finGroupType.
Implicit Types G H : {group gT}.

Lemma quotient_ucn_add : forall m n G,
  'Z_(m + n)(G) / 'Z_n(G) = 'Z_m(G / 'Z_n(G)).
Proof.
move=> m n G; elim: m => [|m IHm]; first exact: trivg_quotient.
apply/setP=> Zx; have [x Nx ->{Zx}] := cosetP Zx.
have [sZG nZG] := andP (ucn_normal n G).
rewrite (ucnSnR m) inE -!sub1set -morphim_set1 //= -quotientR ?sub1set // -IHm.
rewrite !quotientSGK ?(ucn_sub_geq, leq_addl, comm_subG _ nZG, sub1set) //=.
by rewrite addSn /= ucnSnR inE.
Qed.

Lemma isog_nil : forall (rT : finGroupType) G (L : {group rT}),
  G \isog L -> nilpotent G = nilpotent L.
Proof. by move=> rT G L; case/isogP=> f injf <-; rewrite injm_nil. Qed.

Lemma isog_nil_class : forall (rT : finGroupType) G (L : {group rT}),
  G \isog L -> nil_class G = nil_class L.
Proof. by move=> rT G L; case/isogP=> f injf <-; rewrite nil_class_injm. Qed.

Lemma quotient_nil : forall G H, nilpotent G -> nilpotent (G / H).
Proof. move=> G H; exact: morphim_nil. Qed.

Lemma quotient_center_nil : forall G, nilpotent (G / 'Z(G)) = nilpotent G.
Proof.
move=> G; rewrite -ucn1; apply/idP/idP; last exact: quotient_nil.
case/ucnP=> c nilGq; apply/ucnP; exists c.+1; have nsZ1G := ucn_normal 1 G.
apply: (quotient_inj _ nsZ1G); last by rewrite /= -(addn1 c) quotient_ucn_add.
by rewrite (normalS _ _ nsZ1G) ?ucn_sub ?ucn_sub_geq.
Qed.

Lemma nil_class_quotient_center : forall G,
  nilpotent (G) -> nil_class (G / 'Z(G)) = (nil_class G).-1.
Proof.
move=> G nilG; have nsZ1G := ucn_normal 1 G.
apply/eqP; rewrite -ucn1 eqn_leq; apply/andP; split.
  apply/ucn_nil_classP; rewrite ?quotient_nil //= -quotient_ucn_add ucn1.
  by rewrite (ucn_nil_classP _ _ _) ?addn1 ?leqSpred.
rewrite -subn1 leq_sub_add addnC; apply/ucn_nil_classP => //=.
apply: (quotient_inj _ nsZ1G) => /=.
  by apply: normalS (ucn_sub _ _) nsZ1G; rewrite /= addnS ucn_sub_geq.
by rewrite quotient_ucn_add; apply/ucn_nil_classP; rewrite //= quotient_nil.
Qed.

Lemma nilpotent_sub_norm : forall G H,
  nilpotent G -> H \subset G -> 'N_G(H) \subset H -> G :=: H.
Proof.
move=> G H nilG sHG sNH; apply/eqP; rewrite eqEsubset sHG andbT.
apply/negP=> nsGH.
have{nsGH} [i sZH []]: exists2 i, 'Z_i(G) \subset H & ~ 'Z_i.+1(G) \subset H.
  case/ucnP: nilG => n ZnG; rewrite -{}ZnG in nsGH.
  elim: n => [|i IHi] in nsGH *; first by rewrite sub1G in nsGH.
  by case sZH: ('Z_i(G) \subset H); [exists i | apply: IHi; rewrite sZH].
apply: subset_trans sNH; rewrite subsetI ucn_sub -commg_subr.
apply: subset_trans sZH; apply: subset_trans (ucn_comm i G); exact: commgS.
Qed.

Lemma nilpotent_proper_norm : forall G H,
  nilpotent G -> H \proper G -> H \proper 'N_G(H).
Proof.
move=> G H nilG; rewrite properEneq properE subsetI normG; case/andP=> neHG sHG.
by rewrite sHG; apply: contra neHG; move/(nilpotent_sub_norm nilG)->.
Qed.

Lemma nilpotent_subnormal : forall G H,
  nilpotent G -> H \subset G -> H <|<| G.
Proof.
move=> G H nilG; elim: {H}_.+1 {-2}H (ltnSn (#|G| - #|H|)) => // m IHm H.
rewrite ltnS => leGHm sHG; have:= sHG; rewrite subEproper.
case/predU1P=> [->|]; first exact: subnormal_refl.
move/(nilpotent_proper_norm nilG); set K := 'N_G(H) => prHK.
have snHK: H <|<| K by rewrite normal_subnormal ?normalSG.
have sKG: K \subset G by rewrite subsetIl.
apply: subnormal_trans snHK (IHm _ (leq_trans _ leGHm) sKG).
by rewrite ltn_sub2l ?proper_card ?(proper_sub_trans prHK).
Qed.

Lemma nil_TI_Z : forall G H,
  nilpotent G -> H <| G -> H :&: 'Z(G) = 1 -> H :=: 1.
Proof.
move=> G H nilG; case/andP=> sHG nHG trHZ.
rewrite -{1}(setIidPl sHG); case/ucnP: nilG => n <-.
elim: n => [|n IHn]; apply/trivgP; rewrite ?subsetIr // -trHZ.
rewrite [H :&: 'Z(G)]setIA subsetI setIS ?ucn_sub //= (sameP commG1P trivgP).
rewrite -commg_subr commGC in nHG.
rewrite -IHn subsetI (subset_trans _ nHG) ?commSg ?subsetIl //=.
by rewrite (subset_trans _ (ucn_comm n G)) ?commSg ?subsetIr.
Qed.

Lemma nil_meet_Z : forall G H,
  nilpotent G -> H <| G -> H :!=: 1 -> H :&: 'Z(G) != 1.
Proof. by move=> G H nilG nsHG; apply: contra; move/eqP; move/nil_TI_Z->. Qed.

End QuotientNil.

Section Solvable.

Variable gT : finGroupType.
Implicit Types G H : {group gT}.

Lemma nilpotent_sol : forall G, nilpotent G -> solvable G.
Proof.
move=> G nilG; apply/forallP=> H; rewrite subsetI.
apply/implyP; case/andP=> sHG sHH'; apply: (implyP (forallP nilG H)).
by rewrite subsetI sHG (subset_trans sHH') ?commgS.
Qed.

Lemma abelian_sol : forall G, abelian G -> solvable G.
Proof. move=> G; move/abelian_nil; exact: nilpotent_sol. Qed.

Lemma solvableS : forall G H, H \subset G -> solvable G -> solvable H.
Proof.
move=> G H sHG solG; apply/forallP=> K; rewrite subsetI.
apply/implyP; case/andP=> sKH sKK'; apply: (implyP (forallP solG K)).
by rewrite subsetI (subset_trans sKH).
Qed.

Lemma sol_der1_proper : forall G H,
  solvable G -> H \subset G -> H :!=: 1 -> H^`(1) \proper H.
Proof.
move=> G H solG sHG ntH; rewrite properE comm_subG //; apply: implyP ntH.
by have:= forallP solG H; rewrite subsetI sHG implybN.
Qed.

Lemma derivedP : forall G, reflect (exists n, G^`(n) = 1) (solvable G).
Proof.
move=> G; apply: (iffP idP) => [solG | [n solGn]]; last first.
  apply/forallP=> H; rewrite subsetI; apply/implyP; case/andP=> sHG sH'H.
  rewrite -subG1 -{}solGn; elim: n => // n IHn.
  exact: subset_trans sH'H (commgSS _ _).
suffices IHn: forall n, #|G^`(n)| <= (#|G|.-1 - n).+1.
  by exists #|G|.-1; rewrite [G^`(_)]card_le1_trivg ?(leq_trans (IHn _)) ?subnn.
elim=> [|n IHn]; [by rewrite subn0 prednK | rewrite dergSn -predn_sub -ltnS].
case: (eqVneq G^`(n) 1) => [-> | ntGn]; first by rewrite commG1 cards1.
case: (_ - _) IHn => [|n']; first by rewrite leqNgt cardG_gt1 ntGn.
by apply: leq_trans (proper_card _); exact: sol_der1_proper (der_sub _ _) _.
Qed.

End Solvable.

Section MorphSol.

Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}).
Variable G : {group gT}.

Lemma morphim_sol : solvable G -> solvable (f @* G).
Proof.
move/(solvableS (subsetIr D G)); case/derivedP=> n Gn1; apply/derivedP.
by exists n; rewrite /= -morphimIdom -morphim_der ?subsetIl // Gn1 morphim1.
Qed.

Lemma injm_sol : 'injm f -> G \subset D -> solvable (f @* G) = solvable G.
Proof.
move=> injf sGD; apply/idP/idP; last exact: morphim_sol.
case/derivedP=> n Gn1; apply/derivedP; exists n; apply/trivgP.
rewrite -(injmSK injf) ?(subset_trans (der_sub _ _)) ?morphim_der //.
by rewrite Gn1 morphim1.
Qed.

End MorphSol.

Section QuotientSol.

Variables gT rT : finGroupType.
Implicit Types G H K : {group gT}.

Lemma isog_sol : forall G (L : {group rT}),
  G \isog L -> solvable G = solvable L.
Proof. by move=> G L; case/isogP=> f injf <-; rewrite injm_sol. Qed.

Lemma quotient_sol : forall G H, solvable G -> solvable (G / H).
Proof. move=> G H; exact: morphim_sol. Qed.

Lemma series_sol : forall G H,
  H <| G -> solvable G = solvable H && solvable (G / H).
Proof.
move=> G H; case/andP=> sHG nHG; apply/idP/andP=> [solG | [solH solGH]].
  by rewrite quotient_sol // (solvableS sHG).
apply/forallP=> K; rewrite subsetI; apply/implyP; case/andP=> sKG sK'K.
suffices sKH: K \subset H.
  by apply: (implyP (forallP solH K)); rewrite subsetI sKH.
have nHK := subset_trans sKG nHG.
rewrite -quotient_sub1 // subG1 (implyP (forallP solGH _)) //.
by rewrite subsetI -morphimR ?morphimS.
Qed.

End QuotientSol.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Imp.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.

Module STLCExtendedRecords.

Module FirstTry.
Definition alist (X : Type) := list (string * X).
Inductive ty : Type :=
  | Base : string -> ty
  | Arrow : ty -> ty -> ty
  | TRcd : (alist ty) -> ty.

Check  ty_ind.
(* type detail of list is missing *)
End FirstTry.

Inductive ty : Type :=
  | Base : string -> ty
  | Arrow : ty -> ty -> ty
  | RNil : ty
  | RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  (* records *)
  | rproj : tm -> string -> tm
  | trnil : tm
  | rcons : string -> tm -> tm -> tm.

Open Scope string_scope.
Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation A := (Base "A").
Notation B := (Base "B").
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".

(* illegal *)
Definition weird_type := RCons X A B.

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty RNil
  | RTcons : forall i T1 T2,
      record_ty (RCons i T1 T2).

(* construct well-formed definition *)
Inductive well_formed_ty : ty -> Prop :=
  | wfBase : forall i,
        well_formed_ty (Base i)
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (Arrow T1 T2)
  | wfRNil :
        well_formed_ty RNil
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (RCons i T1 T2).
Hint Constructors record_ty well_formed_ty.

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (rcons i t1 t2).
Hint Constructors record_tm.

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 => abs y T
                     (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | rproj t1 i => rproj (subst x s t1) i
  | trnil => trnil
  | rcons i t1 tr1 => rcons i (subst x s t1) (subst x s tr1)
  end.
Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (rcons i v1 vr).

Hint Constructors value.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | rcons i' t tr' => if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '-->' t2" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 --> t1' ->
        (rproj t1 i) --> (rproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (rproj tr i) --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        (rcons i t1 tr2) --> (rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        (rcons i v1 tr2) --> (rcons i v1 tr2')

where "t1 '-->' t2" := (step t1 t2).
Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).
Hint Constructors step.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | RCons i' T Tr' =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Definition context := partial_map ty.
Reserved Notation "Gamma '|-' t '∈' T" (at level 40).
Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- (var x) ∈ T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (update Gamma x T11) |- t12 ∈ T12 ->
      Gamma |- (abs x T11 t12) ∈ (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 ∈ (Arrow T1 T2) ->
      Gamma |- t2 ∈ T1 ->
      Gamma |- (app t1 t2) ∈ T2
  (* records: *)
  | T_Proj : forall Gamma i t Ti Tr,
      Gamma |- t ∈ Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (rproj t i) ∈ Ti
  | T_RNil : forall Gamma,
      Gamma |- trnil ∈ RNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t ∈ T ->
      Gamma |- tr ∈ Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- (rcons i t tr) ∈ (RCons i T Tr)

where "Gamma '|-' t '∈' T" := (has_type Gamma t T).
Hint Constructors has_type.

Lemma typing_example_2 :
  empty |-
    (app (abs a (RCons i1 (Arrow A A)
                      (RCons i2 (Arrow B B)
                       RNil))
              (rproj (var a) i2))
            (rcons i1 (abs a A (var a))
            (rcons i2 (abs a B (var a))
             trnil))) ∈
    (Arrow B B).
Proof.
  econstructor.
  - repeat econstructor.
  - repeat econstructor.
Qed.

Example typing_nonexample :
  not (exists T,
      (update empty a (RCons i2 (Arrow A A)
                                RNil)) |-
               (rcons i1 (abs a B (var a)) (var a)) ∈
               T).
Proof.
  intros contra.
  destruct contra.
  destruct x; try solve_by_invert.
  inversion H;subst. inversion H10.
Qed.

Example typing_nonexample_2 : forall y,
  not (exists T,
    (update empty y A) |-
           (app (abs a (RCons i1 A RNil)
                     (rproj (var a) i1))
                   (rcons i1 (var y) (rcons i2 (var y) trnil))) ∈
           T).
Proof.
  intros y Contra.
  destruct Contra.
  inversion H; subst.
  inversion H3;subst.
  inversion H5;subst.
  inversion H11.
Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...
    inversion H0. subst... Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  Gamma |- t ∈ T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
Qed.

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v ∈ T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti ∈ Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  induction Htyp; subst; try solve_by_invert...
  - (* T_RCons *)
    simpl in Hget. simpl. destruct (eqb_string i i0).
    + (* i is first *)
      simpl. inversion Hget. subst.
      exists t...
    + (* get tail *)
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

Theorem progress : forall t T,
     empty |- t ∈ T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  (* Theorem: Suppose empty ⊢ t : T.  Then either
       1. t is a value, or
       2. t --> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  induction Ht; intros HeqGamma; subst.
  - (* T_Var *)
    (* The final rule in the given typing derivation cannot be
       T_Var, since it can never be the case that
       empty ⊢ x : T (since the context is empty). *)
    inversion H.
  - (* T_Abs *)
    (* If the T_Abs rule was the last used, then
       t = abs x T11 t12, which is a value. *)
    left...
  - (* T_App *)
    (* If the last rule applied was T_App, then t = t1 t2,
       and we know from the form of the rule that
         empty ⊢ t1 : T1 → T2
         empty ⊢ t2 : T1
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
      (* If both t1 and t2 are values, then we know that
         t1 = abs x T11 t12, since abstractions are the only
         values that can have an arrow type.  But
         (abs x T11 t12) t2 --> [x:=t2]t12 by ST_AppAbs. *)
        inversion H; subst; try solve_by_invert.
        exists ([x:=t2]t12)...
      * (* t2 steps *)
        (* If t1 is a value and t2 --> t2', then
           t1 t2 --> t1 t2' by ST_App2. *)
        destruct H0 as [t2' Hstp]. exists(app t1 t2')...
    + (* t1 steps *)
      (* Finally, If t1 --> t1', then t1 t2 --> t1' t2
         by ST_App1. *)
      destruct H as [t1' Hstp]. exists(app t1' t2)...
  - (* T_Proj *)
    (* If the last rule in the given derivation is T_Proj, then
       t = rproj t i and
           empty ⊢ t : (TRcd Tr)
       By the IH, t either is a value or takes a step. *)
    right. destruct IHHt...
    + (* rcd is value *)
      (* If t is a value, then we may use lemma
         lookup_field_in_value to show tlookup i t = Some ti
         for some ti which gives us rproj i t --> ti by
         ST_ProjRcd. *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H)
        as [ti [Hlkup _]].
      exists ti...
    + (* rcd_steps *)
      (* On the other hand, if t --> t', then
         rproj t i --> rproj t' i by ST_Proj1. *)
      destruct H0 as [t' Hstp]. exists(rproj t' i)...
  - (* T_RNil *)
    (* If the last rule in the given derivation is T_RNil,
       then t = trnil, which is a value. *)
    left...
  - (* T_RCons *)
    (* If the last rule is T_RCons, then t = rcons i t tr and
         empty ⊢ t : T
         empty ⊢ tr : Tr
       By the IH, each of t and tr either is a value or can
       take a step. *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2; try reflexivity.
      * (* tail is a value *)
      (* If t and tr are both values, then rcons i t tr
         is a value as well. *)
        left...
      * (* tail steps *)
        (* If t is a value and tr --> tr', then
           rcons i t tr --> rcons i t tr' by
           ST_Rcd_Tail. *)
        right. destruct H2 as [tr' Hstp].
        exists (rcons i t tr')...
    + (* head steps *)
      (* If t --> t', then
         rcons i t tr --> rcons i t' tr
         by ST_Rcd_Head. *)
      right. destruct H1 as [t' Hstp].
      exists (rcons i t' tr)... Qed.

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (rproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (rcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (rcons i ti tr).
Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t ∈ S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t ∈ S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (eqb_stringP x y)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons... Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t ∈ T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  - (* T_Abs *)
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (update Gamma x U) |- t ∈ S ->
     empty |- v ∈ U ->
     Gamma |- ([x:=v]t) ∈ S.
Proof with eauto.
  (* Theorem: If x⊢>U;Gamma ⊢ t : S and empty ⊢ v : U, then
     Gamma ⊢ (x:=vt) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow
     directly from the IH, with the exception of var,
     abs, rcons. The former aren't automatic because we
     must reason about how the variables interact. In the
     case of rcons, we must do a little extra work to show
     that substituting into a term doesn't change whether
     it is a record term. *)
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  - (* var *)
    simpl. rename s into y.
    (* If t = y, we know that
         empty ⊢ v : U and
         x⊢>U; Gamma ⊢ y : S
       and, by inversion, update Gamma x U y = Some S.
       We want to show that Gamma ⊢ [x:=v]y : S.

       There are two cases to consider: either x=y or x≠y. *)
    unfold update, t_update in H0.
    destruct (eqb_stringP x y) as [Hxy|Hxy].
    + (* x=y *)
    (* If x = y, then we know that U = S, and that
       [x:=v]y = v. So what we really must show is that
       if empty ⊢ v : U then Gamma ⊢ v : U.  We have
        already proven a more general version of this theorem,
        called context invariance! *)
      subst.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra)
        as [T' HT']...
      inversion HT'.
    + (* x<>y *)
    (* If x ≠ y, then Gamma y = Some S and the substitution
       has no effect.  We can show that Gamma ⊢ y : S by
       T_Var. *)
      apply T_Var...
  - (* abs *)
    rename s into y. rename t into T11.
    (* If t = abs y T11 t0, then we know that
         x⊢>U; Gamma ⊢ abs y T11 t0 : T11→T12
         x⊢>U; y⊢>T11; Gamma ⊢ t0 : T12
         empty ⊢ v : U
       As our IH, we know that forall S Gamma,
         x⊢>U; Gamma ⊢ t0 : S → Gamma ⊢ [x:=v]t0 S.

       We can calculate that
        [x:=v]t = abs y T11 (if eqb_string x y then t0 else [x:=v]t0) ,
       and we must show that Gamma ⊢ [x:=v]t : T11→T12.  We know
       we will do so using T_Abs, so it remains to be shown that:
         y⊢>T11; Gamma ⊢ if eqb_string x y then t0 else [x:=v]t0 : T12
       We consider two cases: x = y and x ≠ y. *)
    apply T_Abs...
    destruct (eqb_stringP x y) as [Hxy|Hxy].
    + (* x=y *)
      (* If x = y, then the substitution has no effect.  Context
         invariance shows that y:U,y:T11 and Gamma,y:T11 are
         equivalent.  Since t0 : T12 under the former context,
         this is also the case under the latter. *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    + (* x<>y *)
      (* If x ≠ y, then the IH and context invariance allow
         us to show that
           x⊢>U; y⊢>T11; Gamma ⊢ t0 : T12       =>
           y⊢>T11; x⊢>U; Gamma ⊢ t0 : T12       =>
           y⊢>T11; Gamma ⊢ [x:=v]t0 : T12 *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst. rewrite false_eqb_string...
  - (* rcons *)
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     empty |- t ∈ T ->
     t --> t' ->
     empty |- t' ∈ T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If empty ⊢ t : T and t --> t', then
     empty ⊢ t' : T. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.
     Many cases are contradictory (T_Var, T_Abs) or follow
     directly from the IH (T_RCons).  We show just the
     interesting ones. *)
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    (* If the last rule used was T_App, then t = t1 t2,
       and three rules could have been used to show t --> t':
       ST_App1, ST_App2, and ST_AppAbs. In the first two
       cases, the result follows directly from the IH. *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      (* For the third case, suppose
           t1 = abs x T11 t12
         and
           t2 = v2.  We must show that empty ⊢ [x:=v2]t12 : T2.
         We know by assumption that
             empty ⊢ abs x T11 t12 : T1→T2
         and by inversion
             x:T1 ⊢ t12 : T2
         We have already proven that substitution_preserves_typing and
             empty ⊢ v2 : T1
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  - (* T_Proj *)
    (* If the last rule was T_Proj, then t = rproj t1 i.
       Two rules could have caused t --> t': T_Proj1 and
       T_ProjRcd.  The typing of t' follows from the IH
       in the former case, so we only consider T_ProjRcd.

       Here we have that t is a record value.  Since rule
       T_Proj was used, we know empty ⊢ t ∈ Tr and
       Tlookup i Tr = Some Ti for some i and Tr.
       We may therefore apply lemma lookup_field_in_value
       to find the record element this projection steps to. *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    (* If the last rule was T_RCons, then t = rcons i t tr
       for some i, t and tr such that record_tm tr.  If
       the step is by ST_Rcd_Head, the result is immediate by
       the IH.  If the step is by ST_Rcd_Tail, tr --> tr2'
       for some tr2' and we must also use lemma step_preserves_record_tm
       to show record_tm tr2'. *)
    apply T_RCons... eapply step_preserves_record_tm...
Qed.

End STLCExtendedRecords.