(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Ensembles.
Require Import Powerset.
Require Import ClassicalFacts.

(** * Infinite Union *)

Inductive Infinite_Union (U:Type) (I:Type) (Ai : I -> Ensemble U) : Ensemble U :=
  Infinite_Union_intro : forall x:U,
    (exists i:I, In _ (Ai i) x) ->
    In _ (Infinite_Union U I Ai) x.

(** * Topological space *)

Class Topological_Space
    (X:Type)
    (set : Ensemble X)
    (topology : Ensemble (Ensemble _))
  := {
  open_empty_set : In (Ensemble X) topology (Empty_set X);

  open_full_set : In (Ensemble X) topology set;

  intersection_stable : forall A B : Ensemble X,
    In (Ensemble X) topology A ->
    In (Ensemble X) topology B ->
    In (Ensemble X) topology (Intersection _ A B);

  union_stable : forall I : Type, forall (Ai : I -> Ensemble X),
    (forall i : I, In (Ensemble _) topology (Ai i)) ->
    In (Ensemble X) topology (Infinite_Union X I Ai)
}.

(** * Separation *)

Definition separated_space X set topology :=
 forall x y:X,
   In _ set x -> In _ set y ->
   (forall Ox Oy, In _ topology Ox -> In _ topology Oy -> In _ Ox x -> In _ Oy y ->
      exists z, In _ Ox z /\ In _ Oy z)
   -> x = y.

(** * Sets properties *)

(* These lemmas probably have other names *)
(* They should be in MySets, but they probably are already *)
Lemma intersection_empty_set_absorbing_l :
  forall U:Type, forall A:Ensemble U,
  Intersection U (Empty_set U) A = Empty_set U.
intuition.
Qed.

Lemma intersection_empty_set_absorbing_r :
  forall U:Type, forall A:Ensemble U,
  Intersection U A (Empty_set U) = Empty_set U.
intuition.
Qed.

Lemma intersection_idempotent :
  forall U:Type, forall A:Ensemble U,
  Intersection U A A = A.
intros U A.
apply Extensionality_Ensembles.
unfold Same_set; split; intuition.
Qed.

(** * Infinite_Union Properties*)

Lemma subsets_stable_by_Infinite_Union :
  forall (U : Type) (I : Type) (Ai : I -> Ensemble U) (B : Ensemble U),
    (forall i:I, Included U (Ai i) B) ->
    Included U (Infinite_Union U I Ai) B.
intros U I Ai B HAi x HIU.
destruct HIU.
elim H; intros i HxAi.
apply (HAi i); assumption.
Qed.

Lemma Infinite_Union_absorbs_subset :
  forall (U : Type) (I : Type) (Ai : I -> Ensemble U) (B : Ensemble U),
    (exists i:I, Included U B (Ai i)) ->
    Included U B (Infinite_Union U I Ai).
intros U I Ai B HAi.
elim HAi.
intros i HIi x HxB.
apply Infinite_Union_intro; exists i.
apply HIi; assumption.
Qed.

Lemma effective_empty : forall (U:Type) (A:Ensemble U),
  (forall x:U, ~ In U A x) -> A = Empty_set U.
intros U A Nox.
apply Extensionality_Ensembles.
split.

intros x HxA.
  apply False_ind.
  apply (Nox x); assumption.

intros x Hxnowhere.
induction Hxnowhere.
Qed.

(** * Trivial topology *)

Section Trivial_Topology.

  Variable U : Type.
  Variable set : Ensemble U.

  Definition trivial := (Couple (Ensemble U) (Empty_set U) set).

  Definition open e := In (Ensemble U) trivial e.

  Fact trivial_open_empty_set : open (Empty_set U).
  apply Couple_l.
  Qed.

  Fact trivial_open_full_set : open set.
  apply Couple_r.
  Qed.

  Fact trivial_intersection_stable : forall A B : Ensemble U,
    open A -> open B -> open (Intersection U A B).
  intros A B OA OB.
  induction OA.
  rewrite intersection_empty_set_absorbing_l.
  apply Couple_l.
  induction OB.
  rewrite intersection_empty_set_absorbing_r.
  apply Couple_l.
  rewrite intersection_idempotent.
  apply Couple_r.
  Qed.

  Lemma open_included_in_set : forall A, open A -> Included U A set.
  intros A OA.
  destruct OA; intuition.
  Qed.

  (* excluded_middle is used because of undecidability of Type *)

  Lemma disjonction_exists : excluded_middle -> forall (X:Type) (P:X->Prop),
    (exists x:X, P x) \/ (forall x:X, ~ P x).
  intros EM X P.
  elim (EM (exists x, P x)).
  left; assumption.
  right.
    intros x Px.
    apply H.
    exists x; assumption.
  Qed.

  (* begin hide *)
  Lemma eq_imply : forall X (P:X->Prop) A x, P x -> A = x -> P A.
  intros X P A x Px Eax; rewrite Eax; exact Px.
  Qed.
  (* end hide *)
  Fact trivial_union_stable : excluded_middle ->
    forall (I:Type) (Ai:I -> Ensemble U),
     (forall i : I, open (Ai i)) -> open (Infinite_Union U I Ai).

  intros EM I Ai OAi.
  assert (DISJ :
    (exists x : U,   In U (Infinite_Union U I Ai) x) \/
    (forall x : U, ~ In U (Infinite_Union U I Ai) x)   ).
   apply (disjonction_exists EM).

   elim DISJ; clear DISJ.
    intros Hexists; elim Hexists; intros x Hx.
    assert (exists i : _, In U (Ai i) x) as Geti.
     inversion Hx; assumption.

     elim Geti; intros i HxAi.
     assert (Ai i = set).
    assert (Ai i = set \/ Ai i = Empty_set U) as HAi.
     assert (open (Ai i)).
      apply OAi.

      inversion H.
       right; reflexivity.

       left; reflexivity.

     elim HAi.
      trivial.

      intro Hinv; rewrite Hinv in HxAi; inversion HxAi.

    assert (EqUnion : Infinite_Union U I Ai = set).
     apply Extensionality_Ensembles.
     split.
      apply subsets_stable_by_Infinite_Union.
      intros i0.
      apply open_included_in_set.
      apply OAi.

      apply (Infinite_Union_absorbs_subset U I Ai).
      exists i; rewrite H in |- *; intuition.

     rewrite EqUnion in |- *.
     apply Couple_r.

    intros Hfn.
    apply (effective_empty U (Infinite_Union U I Ai)) in Hfn.
    rewrite Hfn in |- *.
    constructor.
  Qed.

  Parameter EM : excluded_middle.

  Instance trivial_topology : Topological_Space U set trivial := {
    open_empty_set := trivial_open_empty_set;
    open_full_set := trivial_open_full_set;
    intersection_stable := trivial_intersection_stable;
    union_stable := (trivial_union_stable EM)
  }.
End Trivial_Topology.

(** * Discrete topology *)

Section Discrete_Topology.

  Variable U : Type.
  Variable set : Ensemble U.

  Definition discrete := Power_set U set.

  Definition part e := In (Ensemble U) discrete e.

  Fact discrete_open_empty_set : part (Empty_set U).
  apply Definition_of_Power_set.
  intuition.
  Qed.

  Fact discrete_open_full_set : part set.
  apply Definition_of_Power_set.
  intuition.
  Qed.

  Fact discrete_intersection_stable : forall A B : Ensemble U,
    part A -> part B -> part (Intersection U A B).
  intros A B pA _.
  apply Definition_of_Power_set.
  intros x xI.
  destruct xI; clear H0.
  destruct pA.
  apply H0.
  assumption.
  Qed.

  Fact discrete_union_stable : forall I : Type, forall Ai : I -> Ensemble U,
   (forall i : I, part (Ai i)) -> part (Infinite_Union U I Ai).
  intros I Ai pAi.

  apply  Definition_of_Power_set.
  apply subsets_stable_by_Infinite_Union.
  intros i x HxAi.
  assert (Included U (Ai i) set).
    assert (part (Ai i)).
      apply pAi.
    destruct H; assumption.

  unfold Included in * |-  .
  apply H; assumption.
  Qed.

  Instance discrete_topology : Topological_Space U set discrete := {
    open_empty_set := discrete_open_empty_set;
    open_full_set := discrete_open_full_set;
    intersection_stable := discrete_intersection_stable;
    union_stable := discrete_union_stable
  }.
End Discrete_Topology.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ *)

Require Import nm_graph_def.

Set Implicit Arguments.

Unset Elimination Schemes.

(* Version with a mutuall inductive domain
   for one-step small inversions *)
(*
Inductive d_nm : Ω → Prop :=
  | in_dnm_0 :             d_nm α
  | in_dnm_1 : ∀ y z,      d_nm y
                         → d_nm z
                         → d_nm (ω α y z)
  | in_dnm_2 : ∀ a b c y z,
                           d_nm (ω b y z)
                         → d_nm (ω c y z)
               → (∀ nb nc, ω b y z ⟼n nb
                         → ω c y z ⟼n nc
                         → d_nm (ω a nb nc))
                         → d_nm (ω (ω a b c) y z).
*)

Inductive 𝔻nm1 (D: Ω → Prop) y z : Prop :=
  | in_dnm1 :       D y
                         → D z
                         → 𝔻nm1 D y z.
Inductive 𝔻nm2 (D: Ω → Prop) a b c y z : Prop :=
  | in_dnm2 :
                           D (ω b y z)
                         → D (ω c y z)
               → (∀ nb nc, ω b y z ⟼n nb
                         → ω c y z ⟼n nc
                         → D (ω a nb nc))
                         → 𝔻nm2 D a b c y z.
Inductive 𝔻nm : Ω → Prop :=
  | in_dnm_0 :                𝔻nm α
  | in_dnm_1 : ∀ y z, 𝔻nm1 𝔻nm y z → 𝔻nm (ω α y z)
  | in_dnm_2 : ∀ a b c y z, 𝔻nm2 𝔻nm a b c y z → 𝔻nm (ω (ω a b c) y z).

Local Definition 𝔻nm1' := 𝔻nm1 𝔻nm.
Local Definition 𝔻nm2' := 𝔻nm2 𝔻nm.

Section nm_pwc.

  (** TODO repair comment
      The two next inversions

        inv_𝔻nm_1 y z : 𝔻 (ω α y z) -> 𝔻1
        prj_𝔻nm_2 a b c y z : 𝔻 (ω (ω a b c) y z) -> 𝔻2

       construct a structurally simpler (ie. a sub-term) of the input domain
       term of type 𝔻.  This is *critically* important because these lemmas
       justify termination of the below fixpoint computation of nm_rec *)

  (* First we show how to get prj_𝔻nm_1 in a tightly controlled
     way by hand writting its term using a variant of small inversions

       "Handcrafted Inversions Made Operational on Operational Semantics"
                by JF. Monin and X. Shi  (ITP 2013)

     The technique is based on dependent pattern-matching.

     Looking at the code of inv_𝔻nm_1 below, it is obvious that
     every branch produces a sub-term of the input term.
     Notice that the "match C with end" has ZERO branches hence
     obviously satisfies a universal property over branches *)

  (* An arbitrary value of type Ω *)
  Let 𝔻nm_shape_1 x := match x with ω α y z => True | _ => False end.
  Let 𝔻nm_pred_1 x  := match x with ω α y z => y    | _ => x    end.
  Let 𝔻nm_pred_2 x  := match x with ω α y z => z    | _ => x    end.
  Let res_inv1 x := 𝔻nm1' (𝔻nm_pred_1 x) (𝔻nm_pred_2 x).
  Local Definition inv_𝔻nm_1 {y z} (d : 𝔻nm (ω α y z)) : 𝔻nm1' y z :=
    match d in 𝔻nm x return 𝔻nm_shape_1 x -> res_inv1 x with
      | in_dnm_1 d => λ _, d
      | _              => λ G, match G with end
    end I.

  (* Fails, cf old letters with Bruno Barras *)
  Let res_inv1' x :=
    match x with ω α y z => True → 𝔻nm1' y z    | _ => False → False end.
  Local Definition inv_𝔻nm_1_no_struct {y z} (d : 𝔻nm (ω α y z)) : 𝔻nm1' y z :=
    match d in 𝔻nm x return res_inv1' x with
      | in_dnm_1 d => λ G', d
      | _              => λ G', match G' with end
    end I.

  Let 𝔻nm_shape_2 x := match x with ω (ω a b c) y z => True | _ => False end.
  Let 𝔻nm_pred_a x := match x with ω (ω a b c) y z => a | _ => x  end.
  Let 𝔻nm_pred_b x := match x with ω (ω a b c) y z => b | _ => x  end.
  Let 𝔻nm_pred_c x := match x with ω (ω a b c) y z => c | _ => x  end.
  Let 𝔻nm_pred_y x := match x with ω (ω a b c) y z => y | _ => x  end.
  Let 𝔻nm_pred_z x := match x with ω (ω a b c) y z => z | _ => x  end.
  Let res_inv2 x := 𝔻nm2' (𝔻nm_pred_a x) (𝔻nm_pred_b x) (𝔻nm_pred_c x) (𝔻nm_pred_y x) (𝔻nm_pred_z x).
  Local Definition inv_𝔻nm_2 {a b c y z} (d : 𝔻nm (ω (ω a b c) y z)) : 𝔻nm2' a b c y z :=
    match d in 𝔻nm x return 𝔻nm_shape_2 x → res_inv2 x with
      | in_dnm_2 d => λ _, d
      | _          => λ G, match G with end
    end I.

  Let Fixpoint nm_pwc e (D : 𝔻nm e) {struct D} : {n | e ⟼n n}.
  Proof. refine(
    match e return 𝔻nm e → _ with
        | α               => λ _,

                          exist _ α _

        | ω α y z         => λ D,
          let (dy, dz) := (inv_𝔻nm_1 D) in
          let (ny,Cy) := nm_pwc y dy in
          let (nz,Cz) := nm_pwc z  dz in

                          exist _ (ω α ny nz) _

        | ω (ω a b c) y z => λ D,
          let (db, dc, da) := (inv_𝔻nm_2 D) in
          let (nb,Cb) := nm_pwc (ω b y z)   db in
          let (nc,Cc) := nm_pwc (ω c y z)   dc in
          let (na,Ca) := nm_pwc (ω a nb nc) (da _ _ Cb Cc) in

                          exist _ na _
    end D).
    + constructor 1.
    + now constructor 2.
    + now constructor 3 with (3 := Ca).
  Qed.

  (** Then we derive nm and nm_spec by projection *)

  Definition nm e D := proj1_sig (@nm_pwc e D).

  Fact nm_spec e D : e ⟼n @nm e D.
  Proof. apply (proj2_sig _). Qed.

End nm_pwc.

Arguments nm e D : clear implicits.

(** Inductive-Recursive domain constructors *)

Fact 𝔻nm_1 : 𝔻nm α.
Proof. constructor; auto. Qed.

Fact 𝔻nm_2 y z : 𝔻nm y → 𝔻nm z → 𝔻nm (ω α y z).
Proof. constructor 2. constructor; assumption. Qed.

Fact 𝔻nm_3 u v w y z Dv Dw : 𝔻nm (ω u (nm (ω v y z) Dv) (nm (ω w y z) Dw))
                           → 𝔻nm (ω (ω u v w) y z).
Proof.
  constructor 3. constructor; auto.
  intros na nb nma nmb.
  rewrite (𝔾nm_fun nma (nm_spec Dv)).
  rewrite (𝔾nm_fun nmb (nm_spec Dw)).
  assumption.
Qed.

(** Inductive-Recursive Type-bounded eliminator/induction principle *)

(* → λ ∀ ∃ ↔ ∧ ∨ *)

Section 𝔻nm_rect.

  Variables (P   : ∀ e, 𝔻nm e → Type)
            (HPi : ∀ e D1 D2, @P e D1 → @P e D2)
            (HP1 : P 𝔻nm_1)
            (HP2 : ∀ y z D1 (_ : P D1) D2 (_ : P D2), P (@𝔻nm_2 y z D1 D2))
            (HP3 : ∀ u v w y z D1 (_ : P D1) D2 (_ : P D2) D3 (_ : P D3), P (@𝔻nm_3 u v w y z D1 D2 D3)).

  Fixpoint 𝔻nm_rect e D { struct D } : @P e D.
  Proof.
    destruct e as [ | [ | a b c ] y z ].
    + apply HPi with (1 := HP1).
    + destruct (inv_𝔻nm_1 D) as [dy dz].
      refine (HPi _ (HP2 (𝔻nm_rect _ _) (𝔻nm_rect _ _))); assumption.
    + destruct (inv_𝔻nm_2 D) as [db dc da].
      refine (HPi _ (HP3 (𝔻nm_rect _ db) (𝔻nm_rect _ dc) (𝔻nm_rect _ (da _ _ _ _)))).
      all: apply nm_spec.
  Qed.

End 𝔻nm_rect.


Require Import init.
Require Import set.

Require Export category_base.

Class Functor `(C1 : Category) `(C2 : Category) := {
    functor_f : cat_U C1 → cat_U C2;
    functor_morphism : ∀ {A B},
        cat_morphism C1 A B → cat_morphism C2 (functor_f A) (functor_f B);
    functor_compose : ∀ {A B C} (f : cat_morphism C1 B C) (g : cat_morphism C1 A B),
        functor_morphism (f ∘ g) = functor_morphism f ∘ functor_morphism g;
    functor_id : ∀ A, functor_morphism (cat_id _ A) = 𝟙;
}.

Arguments functor_f {C1 C2} Functor A.
Arguments functor_morphism {C1 C2} Functor {A B} f.

Coercion functor_f : Functor >-> Funclass.

(*Notation "F ⌈ A ⌉" := (functor_f F A) (at level 69).*)
Notation "⌈ F ⌉" := (functor_morphism F) (at level 40).

(* begin show *)
Local Program Instance id_functor `(C0 : Category) : Functor C0 C0 := {
    functor_f A := A;
    functor_morphism {A B} f := f;
}.
(* end show *)

Notation "𝟏" := (id_functor _).

(* begin show *)
Local Program Instance compose_functor `{C1 : Category, C2 : Category, C3 : Category}
    `(F : @Functor C2 C3) `(G : @Functor C1 C2) : Functor C1 C3 :=
{
    functor_f a := functor_f F (functor_f G a);
    functor_morphism {A B} (f : cat_morphism C1 A B) := ⌈F⌉ (⌈G⌉ f);
}.
(* end show *)
Next Obligation.
    rewrite functor_compose.
    rewrite functor_compose.
    reflexivity.
Qed.
Next Obligation.
    rewrite functor_id.
    rewrite functor_id.
    reflexivity.
Qed.

Notation "F ○ G" := (compose_functor F G) (at level 40, left associativity).

(* begin show *)
Local Program Instance inclusion_functor `{C : Category} `(S : @SubCategory C)
    : Functor (subcategory S) C :=
{
    functor_f x := [x|];
    functor_morphism {A B} (f : cat_morphism _ A B) := [f|];
}.
(* end show *)
Global Remove Hints id_functor compose_functor inclusion_functor : typeclass_instances.

Definition faithful_functor `(F : Functor) := ∀ A B,
    Injective (functor_morphism F (A:=A) (B:=B)).
Definition full_functor `(F : Functor) := ∀ A B,
    Surjective (functor_morphism F (A:=A) (B:=B)).

Theorem id_functor_faithful : ∀ C, faithful_functor (id_functor C).
    intros C0 A B.
    split.
    intros f g eq.
    cbn in eq.
    exact eq.
Qed.
Theorem id_functor_full : ∀ C, full_functor (id_functor C).
    intros C0 A B.
    split.
    intros f.
    cbn in f.
    exists f.
    cbn.
    reflexivity.
Qed.

Theorem inclusion_functor_faithful : ∀ `(S : SubCategory),
        faithful_functor (inclusion_functor S).
    intros C0 S A B.
    split.
    intros f g eq.
    cbn in eq.
    apply set_type_eq in eq.
    exact eq.
Qed.
Theorem inclusion_functor_full : ∀ `(S : SubCategory), full_subcategory S →
        full_functor (inclusion_functor S).
    intros H S S_full A B.
    split.
    intros f.
    cbn in *.
    unfold full_subcategory in S_full.
    specialize (S_full [A|] [B|]).
    rewrite S_full.
    exists [f|true].
    reflexivity.
Qed.

Definition essentially_surjective `{C1 : Category, C2 : Category}
    `(F : @Functor C1 C2)
    := ∀ B, ∃ A, isomorphic (F A) B.

(* begin hide *)
Section Functor.

Context `{C1 : Category, C2 : Category, F : @Functor C1 C2}.

(* end hide *)
Theorem functor_isomorphism : ∀ A B,
        isomorphic A B → isomorphic (F A) (F B).
    intros A B [f [g [fg gf]]].
    exists (⌈F⌉ f).
    exists (⌈F⌉ g).
    rewrite <- functor_compose.
    rewrite <- functor_compose.
    rewrite fg, gf.
    split; apply functor_id.
Qed.

(* begin hide *)
End Functor.

(* end hide *)
Definition functor_morphism_convert_type `{C1 : Category, C2 : Category}
        `{F : @Functor C1 C2, G : @Functor C1 C2} {A B} (H : ∀ A, F A = G A)
        (f : cat_morphism C2 (F A) (F B)) : cat_morphism C2 (G A) (G B).
    rewrite (H A) in f.
    rewrite (H B) in f.
    exact f.
Defined.

Theorem functor_eq `{C1 : Category, C2 : Category} : ∀ {F G : @Functor C1 C2},
        ∀ (H : ∀ A, F A = G A),
        (∀ {A B} (f : cat_morphism C1 A B),
            functor_morphism_convert_type H (⌈F⌉ f) = ⌈G⌉ f) →
        F = G.
    intros [f1 morphism1 compose1 id1] [f2 morphism2 compose2 id2] H eq'.
    cbn in *.
    assert (f1 = f2) as eq.
    {
        apply functional_ext.
        exact H.
    }
    subst f2.
    assert (morphism1 = morphism2) as eq.
    {
        apply functional_ext; intros A.
        apply functional_ext; intros B.
        apply functional_ext; intros f.
        rewrite <- eq'.
        unfold functor_morphism_convert_type.
        pose (HA := Logic.eq_refl (f1 A)).
        pose (HB := Logic.eq_refl (f1 B)).
        rewrite (proof_irrelevance (H A) HA).
        rewrite (proof_irrelevance (H B) HB).
        cbn.
        reflexivity.
    }
    subst morphism2; clear H eq'.
    rewrite (proof_irrelevance compose2 compose1).
    rewrite (proof_irrelevance id2 id1).
    reflexivity.
Qed.

Theorem functor_lid `{C1 : Category, C2 : Category} : ∀ (F : @Functor C1 C2),
        𝟏 ○ F = F.
    intros F.
    assert (∀ A, (𝟏 ○ F) A = F A) as H by reflexivity.
    apply (functor_eq H).
    intros A B f.
    cbn.
    unfold functor_morphism_convert_type.
    cbn in *.
    pose (HA := Logic.eq_refl (F A)).
    pose (HB := Logic.eq_refl (F B)).
    rewrite (proof_irrelevance (H A) HA).
    rewrite (proof_irrelevance (H B) HB).
    cbn.
    reflexivity.
Qed.

Theorem functor_rid `{C1 : Category, C2 : Category} : ∀ (F : @Functor C1 C2),
        F ○ 𝟏 = F.
    intros F.
    assert (∀ A, (F ○ 𝟏) A = F A) as H by reflexivity.
    apply (functor_eq H).
    intros A B f.
    cbn.
    unfold functor_morphism_convert_type.
    cbn in *.
    pose (HA := Logic.eq_refl (F A)).
    pose (HB := Logic.eq_refl (F B)).
    rewrite (proof_irrelevance (H A) HA).
    rewrite (proof_irrelevance (H B) HB).
    cbn.
    reflexivity.
Qed.

Theorem functor_assoc
        `{C1 : Category, C2 : Category, C3 : Category, C4 : Category} :
        ∀ (F : @Functor C3 C4) (G : @Functor C2 C3) (H : @Functor C1 C2),
        F ○ (G ○ H) = (F ○ G) ○ H.
    intros F G H.
    assert (∀ A, (F ○ (G ○ H)) A = ((F ○ G) ○ H) A) as H' by reflexivity.
    apply (functor_eq H').
    intros A B f.
    unfold functor_morphism_convert_type.
    cbn in *.
    pose (HA := Logic.eq_refl (F (G (H A)))).
    pose (HB := Logic.eq_refl (F (G (H B)))).
    rewrite (proof_irrelevance (H' A) HA).
    rewrite (proof_irrelevance (H' B) HB).
    cbn.
    reflexivity.
Qed.

Local Program Instance CATEGORY : Category := {
    cat_U := Category;
    cat_morphism A B := Functor A B;
    cat_compose {A B C} f g := f ○ g;
    cat_id A := id_functor A;
}.
Next Obligation.
    apply functor_assoc.
Qed.
Next Obligation.
    apply functor_lid.
Qed.
Next Obligation.
    apply functor_rid.
Qed.

Global Remove Hints CATEGORY : typeclass_instances.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)

(* basic lemmas on natural operations *)
(* December, 2003 *)
(* $Header: /local_home/cvs/cvs-base/XPathCoq/v8/Basics/nat_basics.v,v 1.7 2004/09/30 14:54:39 cvs Exp $
   $Log: nat_basics.v,v $
   Revision 1.7  2004/09/30 14:54:39  cvs
   Added banners.

   Revision 1.6  2004/09/01 08:14:50  cvs
   update

   Revision 1.5  2004/05/05 14:30:15  cvs
   fix v8.2 syntactic incompatibilities + changed name matching in SemanS (XPathSemantics.v)

   Revision 1.4  2004/04/23 10:13:10  cvs
   *** empty log message ***

   Revision 1.3  2004/04/22 14:35:31  cvs
   *** empty log message ***

   Revision 1.2  2004/04/20 14:22:06  cvs
   SXPath/Containment/XPCcomplete.v

   Revision 1.1  2004/03/31 13:08:26  cvs
   translated to v8

   Revision 1.1  2004/03/31 09:49:50  cvs
   *** empty log message ***

   Revision 1.2  2003/12/09 16:05:21  cvs
   added cvs log

 *)
Require Export Max.
Require Export Le.
Require Export Plus.
Require Export Bool.

(* Some useful nat related lemma used for inductive proofs on
numerical hypotheses CXP and CXQ *)

Lemma plus_m_n_O : forall m n : nat, m + n = 0 -> m = 0 /\ n = 0.
simple induction m.
simpl in |- *.
auto.

intros n H.
intros.
rewrite plus_Sn_m in H0.
discriminate.
Qed.

Lemma plus_m_S : forall m n : nat, m + S n = S (m + n).
simple induction m.
simpl in |- *.
auto.

simpl in |- *.
intros n H n0.
rewrite H.
auto.
Qed.

Axiom Eq_P_Q : forall P Q : Prop, (P -> Q) -> (Q -> P) -> P = Q.

Lemma le_S_S : forall m n : nat, (S m <= S n) = (m <= n).
intros m n; apply Eq_P_Q.
intro.
apply le_S_n.
auto.

intro; apply le_n_S; auto.
Qed.

Lemma max_le_r : forall m n : nat, max m n = n -> m <= n.
double induction m n.
auto.

auto.

simpl in |- *.
intros.
rewrite H0; trivial.

intros.
apply le_n_S.
apply H0.
cut (max (S n1) (S n) = S (max n1 n)).
intro H2; rewrite H2 in H1.
injection H1.
trivial.

symmetry  in |- *.
apply max_SS.
Qed.

Lemma max_le_l : forall m n : nat, max m n = m -> n <= m.
double induction m n.
auto.
simpl in |- *.
intros n0 H H1.
rewrite H1; trivial.
auto with arith.
auto with arith.
Qed.

Lemma max_le : forall x1 x2 x3 : nat, max x1 x2 <= x3 -> x1 <= x3 /\ x2 <= x3.
intros x1 x2 x3.
cut ({max x1 x2 = x1} + {max x1 x2 = x2}).
intros H0 H.
elim H0.
intro H1; split.
rewrite H1 in H; trivial.

apply le_trans with (m := x1).
apply max_le_l.
trivial.

rewrite H1 in H; trivial.

intro H1; split.
apply le_trans with (m := x2).
apply max_le_r; trivial.

rewrite H1 in H; trivial.

rewrite H1 in H; trivial.

apply max_dec.
Qed.

Lemma le_Smn_mn : forall m n : nat, S m <= n -> m <= n.
auto with arith.
Qed.

Lemma max_assoc :
 forall n1 n2 n3 : nat, max n1 (max n2 n3) = max (max n1 n2) n3.
simple induction n1; simple induction n2;
 try (intros; simpl in |- *; reflexivity).
intros.
case n3.
simpl in |- *.
reflexivity.

intro; repeat rewrite <- max_SS.
apply eq_S; apply H.
Qed.

Lemma max_0 :
 forall n1 n2 : nat, (le n1 n2) -> (le (max n1 0) n2).
 induction n1.
 intros.
   simpl in |- *.
   assumption.
 intros.
   simpl in |- *.
   assumption.
Qed.

(* reminder
Check eq_add_S
(m,n:nat) (S m)=(S n)->m=s.

Check Le.le_S_n:
(n,m:nat)(le (S n) (S m))->(le n m)

Check Le.le_n_S:
(n,m:nat)(le n m)->(le (S n) (S m)).

Check Le.le_Sn_O:
(n:nat)~(le (S n) O).

*)

Lemma le_plus_s1 : forall a b c : nat, a + S b <= S c -> a + b <= c.
Proof.
  Require Import Arith.
  intros a b c.
  rewrite <- plus_n_Sm.
  apply le_S_n.
Qed.

Lemma le_plus_s2 : forall a b c : nat, S a + b <= S c -> a + b <= c.
Proof.
  intros a b c.
  rewrite plus_Snm_nSm.
  apply le_plus_s1.
Qed.

Ltac ElimBAnd H :=
  match goal with
  | H:(andb ?X1 ?X2 = true) |- _ => elim (andb_prop X1 X2 H); intro; intro
  end.

Ltac AbsurdLe :=
  match goal with
  | _:(S ?X1 <= 0) |- _ =>
      absurd (S X1 <= 0); [ apply le_Sn_O | assumption ]
  end.

Ltac LeS4 :=
  match goal with
  | Hle:(S ?X1 <= S ?X2) |- _ =>
      generalize (le_S_n X1 X2 Hle); clear Hle; intros Hle
  end.

Ltac LeS :=
  match goal with
  | Hle:(S ?X1 <= S ?X2) |- _ =>
      generalize (le_S_n X1 X2 Hle); clear Hle; intros Hle
  | Hle:(S ?X1 <= ?X2) |- _ =>
      generalize (le_Smn_mn X1 X2 Hle); clear Hle;
       intros Hle
       (*	|
       	[ H:(le (max ?1 ?2) ?3) |- ? ] ->
       	     Generalize (max_le ?1 ?2 ?3 H);
       	     Clear H;Intros H;
       	     Elim H;
       	     Intro;Intro
       *)
  end.

Ltac MaxLe4 :=
  match goal with
  | H:(max ?X1 ?X2 <= ?X3) |- _ =>
      generalize (max_le X1 X2 X3 H); clear H; intros H; elim H; intro; intro
  end.

Ltac BAndDec :=
  match goal with
  |  |- {andb ?X1 ?X2 = true} + {andb ?X1 ?X2 = false} =>
      cut ({X1 = true} + {X1 = false});
       [ intros _H; elim _H; clear _H; intros _H; rewrite _H; clear _H;
          simpl in |- *; (left; reflexivity) || (right; reflexivity) || idtac
       | idtac ]
  end.

Lemma le_max_n : forall l m n : nat, l <= m -> m <= n -> max l m <= n.
double induction l m.
auto.

auto.

simpl in |- *; intros; AbsurdLe.

intros.
cut (max (S n0) (S n) = S (max n0 n)).
intro H3; rewrite H3.
generalize H1 H2; case n1.
intros; AbsurdLe.

intros; apply le_n_S; apply H0.
repeat LeS4; trivial.

repeat LeS4; trivial.

symmetry  in |- *.
apply max_SS.
Qed.

Lemma le_max_n2 : forall l m n : nat, l <= n -> m <= n -> max l m <= n.
double induction l m.
auto.

auto.

auto.

intros.
cut (max (S n0) (S n) = S (max n0 n));
 [ intro H3; rewrite H3 | symmetry  in |- *; apply max_SS ].
generalize H1 H2; case n1.
intros; AbsurdLe.

intros; apply le_n_S.
apply H0; repeat LeS4; auto.
Qed.

Lemma max_idem: forall m : nat, max m m = m.
induction m;auto with arith.
Qed.

Lemma max_le_L: forall n m k:nat, max n m <= k -> n<=k.
intros;assert (H1:=max_le n m k H);elim H1;auto.
Qed.

Lemma max_le_R: forall n m k:nat, max n m <= k -> m<=k.
intros;assert (H1:=max_le n m k H);elim H1;auto.
Qed.

Hint Rewrite plus_0_l plus_0_r plus_m_S le_S_S : rwNat.

Ltac redNat := repeat progress (simpl;autorewrite with rwNat).

Ltac doitNat :=
match goal with
[ H: (?d + ?b) <= ?c  |-  ?a + ?b <= ?c ]
	=> eapply le_trans;[apply plus_le_compat_r]

end.


Require Export Lists.

Inductive list (X:Type) : Type :=
| nil : list X
| cons : X -> list X -> list X.

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
    | nil => 0
    | cons h t => S (length X t)
  end.

Fixpoint app (X:Type) (l1 l2 : list X) :=
  match l1 with
    | nil => l2
    | cons h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
    | nil => cons X v (nil X)
    | cons h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
    | nil => nil X
    | cons h t => snoc X (rev X t) h
  end.

Fixpoint app' X l1 l2 : list X :=
  match l1 with
    | nil => l2
    | cons h t => cons X h (app' X t l2)
  end.

Fixpoint length' (X:Type) (l:list X) : nat :=
  match l with
    | nil => 0
    | cons h t => S (length' _ t)
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

Fixpoint length'' {X:Type} (l:list X) : nat :=
  match l with
    | nil => 0
    | cons h t => S (length'' t)
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Fixpoint repeat {X:Type} (n:X) (count:nat) : list X :=
  match count with
    | 0 => []
    | 1 => [n]
    | S x => n :: (repeat n x)
  end.

Example test_repeat1:
  repeat true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X:Type, forall l:list X,
                    app [] l = l.
Proof.
  intros X l.
  reflexivity.
Qed.

Theorem rev_snoc :
  forall X:Type, forall v:X, forall s:list X,
    rev (snoc s v) = v :: (rev s).
Proof.
  intros X v s. induction s as [|v' s'].
  Case "s = nil". reflexivity.
  Case "s = v' :: s'".
    simpl.
    rewrite -> IHs'.
    reflexivity.
Qed.

Theorem rev_involutive : forall X:Type, forall l:list X,
                           rev (rev l) = l.
Proof.
  intros X l. induction l as [|x l'].
  Case "l = nil". reflexivity.
  Case "l = x :: l'".
    simpl.
    rewrite -> rev_snoc. rewrite -> IHl'.
    reflexivity.
Qed.

Theorem snoc_with_append :
  forall X:Type, forall l1 l2 : list X, forall v : X,
    snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros X l1 l2 v. induction l1 as [|x l1'].
  Case "l1 = nil". reflexivity.
  Case "l2 = x :: l1'".
    simpl.
    rewrite -> IHl1'.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y : Type} (p: X * Y) : Y :=
  match p with (x,y) => y end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match (lx, ly) with
    | ([], _) => []
    | (_, []) => []
    | (x::tx, y::ty) => (x, y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  match l with
    | nil => (nil, nil)
    | (x, y) :: lxs => match split lxs with
                         | (xs, ys) => (x :: xs, y :: ys)
                       end
  end.

Example test_split: split [(1, false); (2, false)] = ([1;2], [false;false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
| Some : X -> option X
| None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint index {X:Type} (n:nat) (l:list X) : option X :=
  match l with
    | [] => None
    | a :: l' => if beq_nat n 0 then Some a else index (pred n) l'
  end.

Example test_index1 : index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 1 [[1];[2]] = Some [2].
Proof. reflexivity. Qed.
Example test_index3 : index 2 [true] = None.
Proof. reflexivity. Qed.

Definition hd_opt {X:Type} (l:list X) : option X :=
  match l with
    | nil => None
    | x :: t => Some x
  end.

Example test_hd_opt1 : hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition prod_curry {X Y Z : Type}
           (f : X * Y -> Z) (x:X) (y:Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
           (f : X -> Y -> Z) (p: X * Y) : Z :=
  f (fst p) (snd p).

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
                          prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type) (f: (X * Y) -> Z) (p: X * Y),
                          prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  simpl.
  destruct p.
  reflexivity.
Qed.

Fixpoint filter {X:Type} (test : X -> bool) (l:list X) : (list X) :=
  match l with
    | nil => nil
    | h :: t => if test h
                then h :: (filter test t)
                else filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X:Type} (l:list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
  filter length_is_1 [[1;2]; [3]; [4]; [5;6;7]; []; [8]]
  = [[3]; [4]; [8]].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l:list nat) : list nat :=
  filter (fun n => andb (evenb n) (negb (ble_nat n 7))) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X:Type} (test:X -> bool) (l:list X) : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f:X -> Y) (l:list X) : (list Y) :=
  match l with
    | [] => []
    | h :: t => (f h) :: (map f t)
  end.

Lemma snoc_append : forall (X:Type) (l:list X) (x:X),
                      snoc l x = l ++ [x].
Proof.
  intros X l x. induction l as [|x' l'].
  Case "l = []". reflexivity.
  Case "l = x' :: l'".
  simpl.
  rewrite -> IHl'.
  reflexivity.
Qed.

Lemma map_app : forall (X Y:Type) (f:X -> Y) (l1 l2:list X),
                  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2.
  induction l1 as [|x l1'].
  Case "l1 = []". reflexivity.
  Case "l1 = x :: l1'".
    simpl.
    rewrite -> IHl1'.
    reflexivity.
Qed.

 Theorem map_rev : forall (X Y : Type) (f:X -> Y) (l:list X),
                    map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [| x l'].
  Case "l = []". reflexivity.
  Case "l = x :: l'".
    simpl.
    repeat rewrite -> snoc_append.
    rewrite -> map_app.
    rewrite -> IHl'.
    reflexivity.
Qed.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X) : (list Y) :=
  match l with
    | [] => []
    | x :: xs => f x ++ flat_map f xs
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y:Type} (f:X -> Y) (xo:option X) : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y:Type} (f:X -> Y -> Y) (l:list X) (b:Y) : Y :=
  match l with
    | [] => b
    | h :: t => f h (fold f t b)
  end.

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X:Type} (x:X) : nat -> X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.
Definition ffalse := constfun false.

Definition override {X:Type} (f:nat->X) (k:nat) (x:X) : nat -> X :=
  fun (k':nat) => if beq_nat k k' then x else f k'.

Theorem override_example : forall (b:bool),
                             (override (constfun b) 3 true) 2 = b.
Proof.
  intros b; destruct b; reflexivity.
Qed.

Theorem override_eq :
  forall {X:Type} x k (f:nat->X),
    (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Theorem override_neq :
  forall (X:Type) x1 x2 k1 k2 (f:nat->X),
    f k1 = x1 ->
    beq_nat k2 k1 = false ->
    (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f H1 H2.
  unfold override.
  rewrite -> H2.
  rewrite -> H1.
  reflexivity.
Qed.

Definition fold_length {X:Type} (l:list X) : nat :=
  fold (fun _ n => S n) l 0.

Theorem fold_length_correct : forall X (l:list X),
                                fold_length l = length l.
Proof.
  intros X l. induction l as [| x l'].
  Case "l = []".
    reflexivity.
  Case "l = x :: l'".
    simpl.
    rewrite <- IHl'.
    reflexivity.
Qed.

Definition fold_map {X Y:Type} (f:X->Y) (l:list X) : list Y :=
  fold (fun x acc => f x :: acc) l [].

Theorem fold_map_correct :
  forall X Y (f:X->Y) (l:list X),
    fold_map f l = map f l.
Proof.
  intros X Y f l. induction l as [| x l'].
  Case "l = []". reflexivity.
  Case "l = x :: l'".
    simpl.
    rewrite <- IHl'.
    reflexivity.
Qed.

Module Church.

  Definition nat := forall X : Type, (X -> X) -> X -> X.

  Definition one : nat :=
    fun (X:Type) (f:X->X) (x:X) => f x.

  Definition two : nat :=
    fun (X:Type) (f:X->X) (x:X) => f (f x).

  Definition three : nat :=
    fun (X:Type) (f:X->X) (x:X) => f (f (f x)).

  Definition zero : nat :=
    fun (X:Type) (f:X->X) (x:X) => x.

  Definition succ (n:nat) : nat :=
    fun (X:Type) (f:X->X) (x:X) => f (n X f x).

  Example succ_1 : succ zero = one.
  Proof. reflexivity. Qed.
  Example succ_2 : succ one = two.
  Proof. reflexivity. Qed.
  Example succ_3 : succ two = three.
  Proof. reflexivity. Qed.

  Definition plus (n m : nat) : nat :=
    fun (X:Type) (f:X->X) (x:X) => m X f (n X f x).

  Example plus_1 : plus zero one = one.
  Proof. reflexivity. Qed.
  Example plus_2 : plus two three = plus three two.
  Proof. reflexivity. Qed.
  Example plus_3 : plus (plus two two) three = plus one (plus three three).
  Proof. reflexivity. Qed.

  Definition mult (n m : nat) : nat :=
    fun (X:Type) (f:X->X) (x:X) => m X (n X f) x.

  Example mult_1 : mult one one = one.
  Proof. reflexivity. Qed.
  Example mult_2 : mult zero (plus three three) = zero.
  Proof. reflexivity. Qed.
  Example mult_3 : mult two three = plus three three.
  Proof. reflexivity. Qed.

End Church.


Inductive fin : nat -> Type :=
| fin_O : forall n, fin n
| fin_S : forall n, fin n -> fin (S n).

Inductive fin' (n : nat) : Type :=
| fin'_O : fin' n
| fin'_S : forall m, S m = n -> fin' m -> fin' n.

Definition fin_S' : forall n, fin' n -> fin' (S n).
Proof.
 intros n x.
 apply fin'_S with n.
 -
  apply eq_refl.
 -
  apply x.
Defined.

Definition fin_to : forall (n : nat), fin n -> fin' n.
Proof.
 apply fin_rect.
 -
  apply fin'_O.
 -
  intros n _ x.
  apply fin_S'.
  apply x.
Defined.

Definition fin'_to : forall (n : nat), fin' n -> fin n.
Proof.
 apply fin'_rect.
 -
  apply fin_O.
 -
  intros n m h _ x.
  apply eq_rect with (S m).
  +
   apply fin_S.
   apply x.
  +
   apply h.
Defined.

Inductive lambda : nat -> Type :=
| var : forall n, fin n -> lambda (S n)
| abs : forall n, lambda (S n) -> lambda n
| app : forall n, lambda n -> lambda n -> lambda n.

Inductive lambda' (n : nat) : Type :=
| var' : forall (m : nat), S m = n -> fin' m -> lambda' n
| abs' : lambda' (S n) -> lambda' n
| app' : lambda' n -> lambda' n -> lambda' n.

Definition var'' : forall n, fin' n -> lambda' (S n).
Proof.
 intros n x.
 apply var' with n.
 -
  apply eq_refl.
 -
  apply x.
Defined.

Definition lambda_to : forall n, lambda n -> lambda' n.
Proof.
 apply lambda_rect.
 -
  intros n x.
  apply var''.
  apply fin_to.
  apply x.
 -
  intros n _ x.
  apply abs'.
  apply x.
 -
  intros n _ x _ y.
  apply app'.
  +
   apply x.
  +
   apply y.
Defined.

Definition lambda'_to : forall n, lambda' n -> lambda n.
Proof.
 apply lambda'_rect.
 -
  intros n m h x.
  apply eq_rect with (S m).
  +
   apply var.
   apply fin'_to.
   apply x.
  +
   apply h.
 -
  intros n _ x.
  apply abs.
  apply x.
 -
  intros n _ x _ y.
  apply app.
  +
   apply x.
  +
   apply y.
Defined.

Definition beta_var : forall n, fin' n -> lambda' n -> lambda' n.
Proof.
 intros n fn x.
 case fn; clear fn.
 -
  apply x.
 -
  intros m h fm.
  apply eq_rect with (S m).
  +
   apply var''.
   apply fm.
  +
   apply h.
Defined.

Definition beta_abs_var : nat -> forall n, fin' n -> fin' (S n).
Proof.
 fix go 3.
 intros m n fn.
 case fn; clear fn.
 -
  apply fin'_O.
 -
  intros o h x.
  apply fin_S'.
  case m; clear m.
  +
   apply fin'_S with o.
   *
    apply h.
   *
     apply x.
  +
   intros m.
   apply eq_rect with (S o).
   *
    apply go.
    --
     apply m.
    --
     apply x.
   *
    apply h.
Defined.

Definition beta_abs (m : nat) : forall n, lambda' n -> lambda' (S n).
Proof.
 fix go 2.
 intros n x.
 case x; clear x.
 -
  intros o h fo.
  apply var' with (S o).
  +
   apply f_equal.
   apply h.
  +
   apply beta_abs_var.
   *
    apply m.
   *
    apply fo.
 -
  intros x.
  apply abs'.
  apply go.
  apply x.
 -
  intros x y.
  apply app'.
  +
   apply go.
   apply x.
  +
   apply go.
   apply x.
Defined.

Definition beta : forall n, lambda' (S n) -> lambda' n -> lambda' n.
Proof.
 fix go 2.
 intros n x y.
 case x; clear x.
 -
  intros m h fm.
  apply beta_var.
  +
   apply eq_rect with m.
   *
    apply fm.
   *
    apply eq_add_S.
    apply h.
  +
   apply y.
 -
  intros x.
  apply abs'.
  apply go.
  +
   apply x.
  +
   apply beta_abs.
   *
    apply n.
   *
    apply y.
 -
  intros x1 x2.
  apply app'.
  +
   apply go.
   *
    apply x1.
   *
    apply y.
  +
   apply go.
   *
    apply x2.
   *
    apply y.
Defined.

Notation "'λ' x" := (abs' _ x) (at level 75, right associativity).
Notation "x '$' y" := (app' _ x y) (at level 70, right associativity).

Eval compute in beta 0 (abs' 1 (var' 2 1 eq_refl (fin_O' 1))) (abs' 0 (var' 1 0 eq_refl (fin_O' 0))).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := lf1.


Definition pierce := forall (p q : Prop), ((p -> q) -> p) -> p.
Definition lem := forall (p : Prop), p \/ ~p.

Theorem pierce_lem_equiv : pierce <-> lem.
Proof.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~(p \/ ~p)).
  firstorder.


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

(**
   exp.
   Exponential function on Z.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Require Import ZArith.

Require Import lemmas.
Require Import natZ.

(** * Exponential function with exponent in nat. *)

Fixpoint Exp (a : Z) (n : nat) {struct n} : Z :=
  match n with
  | O => 1%Z
  | S m => (a * Exp a m)%Z
  end.

Lemma exp_0 : forall n : nat, Exp 0 (S n) = 0%Z.
Proof.
   simpl in |- *. intros. reflexivity.
Qed.

Lemma exp_1 : forall n : nat, Exp 1 n = 1%Z.
Proof.
   simple induction n.
   simpl in |- *. reflexivity.
   simpl in |- *. intros m IH. rewrite IH. reflexivity.
Qed.

Lemma exp_S : forall (a : Z) (n : nat), Exp a (S n) = (a * Exp a n)%Z.
Proof.
   simpl in |- *. reflexivity.
Qed.

Lemma exp_plus :
 forall (a : Z) (n m : nat), Exp a (n + m) = (Exp a n * Exp a m)%Z.
Proof.
   simple induction n.
   simpl in |- *. intros. elim (Exp a m). reflexivity. reflexivity. reflexivity.
   intros n1 IH. simpl in |- *. intros.
   rewrite (IH m).
   apply Zmult_assoc.
Qed.

Lemma exp_abn :
 forall (a b : Z) (n : nat), Exp (a * b) n = (Exp a n * Exp b n)%Z.
Proof.
   simple induction n.
   simpl in |- *. reflexivity.
   intros m IH. simpl in |- *.
   rewrite IH.
   rewrite (Zmult_assoc (a * Exp a m) b (Exp b m)).
   rewrite (Zmult_assoc_reverse a (Exp a m) b).
   rewrite (Zmult_comm (Exp a m) b).
   rewrite (Zmult_assoc a b (Exp a m)).
   apply Zmult_assoc.
Qed.

Lemma exp_mult : forall (a : Z) (n m : nat), Exp a (n * m) = Exp (Exp a n) m.
Proof.
   simple induction n.
   simpl in |- *. intro. rewrite exp_1. reflexivity.
   intros m IH. simpl in |- *. intros.
   rewrite exp_plus.
   rewrite exp_abn.
   rewrite IH.
   reflexivity.
Qed.

Lemma exp_not0 : forall a : Z, a <> 0%Z -> forall m : nat, Exp a m <> 0%Z.
Proof.
   intros a Ha. simple induction m.
   simpl in |- *. discriminate.
   intros n IH. simpl in |- *. intro.
   elim (Zmult_ab0a0b0 a (Exp a n)).
   assumption. assumption. assumption.
Qed.

(** Convenience lemma for changing exponent. *)

Lemma exp_eq : forall (n m : nat) (a : Z), n = m -> Exp a n = Exp a m.
Proof.
   intros. rewrite H. reflexivity.
Qed.

Lemma exp_pred_succ : forall (a : Z) (n : nat), Exp a (pred (S n)) = Exp a n.
Proof.
   intros. simpl in |- *. reflexivity.
Qed.

(** * Exponential function with exponent in Z. *)

Definition ZExp (a n : Z) : Z :=
  match n with
  | Z0 => 1%Z
  | Zpos p => Exp a (nat_of_P p)
  | Zneg p => Exp a (nat_of_P p)
  end.

Lemma zexp_pred_succ : forall a x : Z, ZExp a (x + 1 - 1) = ZExp a x.
Proof.
   unfold Zminus in |- *.
   intros.
   rewrite Zplus_assoc_reverse.
   rewrite Zplus_opp_r.
   rewrite <- Zplus_0_r_reverse.
   reflexivity.
Qed.

(** Convenience lemma for changing exponent. *)

Lemma zexp_eq : forall x y a : Z, x = y -> ZExp a x = ZExp a y.
Proof.
   intros.
   rewrite H.
   reflexivity.
Qed.

Lemma inj_zexp : forall (n : nat) (a : Z), ZExp a (Z_of_nat n) = Exp a n.
Proof.
   simple induction n.
   simpl in |- *. reflexivity.
   intros m IH. intros.
   simpl in |- *. rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
   simpl in |- *. reflexivity.
Qed.

Lemma expzexp : forall x a : Z, ZExp a x = Exp a (Z.abs_nat x).
Proof.
   intros.
   induction  x as [| p| p].
   simpl in |- *. reflexivity.
   simpl in |- *. reflexivity.
   simpl in |- *. reflexivity.
Qed.

Lemma zexp_S1 :
 forall a n : Z, (0 <= n)%Z -> ZExp a (n + 1) = (a * ZExp a n)%Z.
Proof.
   intros.
   rewrite expzexp.
   rewrite expzexp.
   rewrite abs_plus_pos.
   rewrite plus_comm.
   change (Exp a (S (Z.abs_nat n)) = (a * Exp a (Z.abs_nat n))%Z) in |- *.
   apply exp_S.
   assumption.
   unfold Z.le in |- *.
   simpl in |- *.
   discriminate.
Qed.

Lemma zexp_S :
 forall a n : Z, (0 <= n)%Z -> ZExp a (Z.succ n) = (a * ZExp a n)%Z.
Proof.
   intros.
   change (ZExp a (n + 1) = (a * ZExp a n)%Z) in |- *.
   apply zexp_S1.
   assumption.
Qed.

Lemma zexp_plus :
 forall a n m : Z,
 (0 <= n)%Z -> (0 <= m)%Z -> ZExp a (n + m) = (ZExp a n * ZExp a m)%Z.
Proof.
   intros.
   rewrite expzexp.
   rewrite expzexp.
   rewrite expzexp.
   rewrite abs_plus_pos.
   apply exp_plus. assumption. assumption.
Qed.

Lemma zexp_mult :
 forall a n m : Z,
 (0 <= n)%Z -> (0 <= m)%Z -> ZExp a (n * m) = ZExp (ZExp a n) m.
Proof.
   intros.
   rewrite expzexp.
   rewrite expzexp.
   rewrite expzexp.
   rewrite abs_mult.
   apply exp_mult.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
From SLF (* TLC *) Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Sum type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

    Inductive sum A B : Type :=
      | inl : A -> sum A B
      | inr : B -> sum A B.

    Hint Constructors sum : core.
    Notation "x + y" := (sum x y) : type_scope.

  Remark: ideally, constructors would be renamed to [sum_l] and [sum_r];
  to follow conventions.

*)

Arguments inl {A} {B}.
Arguments inr {A} {B}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance sum_inhab_l : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inl arbitrary)). Qed.

Instance sum_inhab_r : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inr arbitrary)). Qed.

Definition Inhab_sum : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Testing the branch of the sum *)

Definition is_inl (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Stripping of the branch tag *)

Section Get.
Context `{IA1:Inhab A1} `{IA2:Inhab A2}.
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Lifting functions over sum types *)

Section Fget.
Context {A1:Type} {A2:Type} `{IB1:Inhab B1} `{IB2:Inhab B2}.
Implicit Types f : A1+A2->B1+B2.

Definition fun_get21 f :=
  fun x => get21 (f (inl x)).
Definition fun_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.

(* 2020-03-09 15:04:12 (UTC+01) *)


(*
Copyright 2017 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq path eqtype.
From pcm Require Import options pred.

(****************************************************)
(* A theory of permutations over non-equality types *)
(****************************************************)

Section Permutations.
Variable A : Type.

Inductive perm : seq A -> seq A -> Prop :=
| permutation_nil : perm [::] [::]
| permutation_skip x s1 s2 of perm s1 s2 : perm (x :: s1) (x :: s2)
| permutation_swap x y s1 s2 of perm s1 s2 : perm [:: x, y & s1] [:: y, x & s2]
| permutation_trans t s1 s2 of perm s1 t & perm t s2 : perm s1 s2.

Lemma pperm_refl (s : seq A) : perm s s.
Proof. by elim: s=>*; [apply: permutation_nil | apply: permutation_skip]. Qed.

Hint Resolve pperm_refl : core.

Lemma pperm_nil (s : seq A) : perm [::] s <-> s = [::].
Proof.
split; last by move=>->; apply: permutation_nil.
move E: {1}[::]=>l H; move: H {E}(esym E).
by elim=>//??? _ IH1 _ IH2 /IH1/IH2.
Qed.

Lemma pperm_sym s1 s2 : perm s1 s2 <-> perm s2 s1.
Proof.
suff {s1 s2} L : forall s1 s2, perm s1 s2 -> perm s2 s1 by split; apply: L.
apply: perm_ind=>[|||??? _ H1 _ H2] *;
by [apply: permutation_nil | apply: permutation_skip |
    apply: permutation_swap | apply: permutation_trans H2 H1].
Qed.

Lemma pperm_trans s2 s1 s3 : perm s1 s2 -> perm s2 s3 -> perm s1 s3.
Proof. by apply: permutation_trans. Qed.

Lemma pperm_in s1 s2 x : perm s1 s2 -> x \In s1 -> x \In s2.
Proof. elim=>//??? =>[|?|_ I1 _ I2 /I1/I2]; rewrite ?InE; tauto. Qed.

Lemma pperm_catC s1 s2 : perm (s1 ++ s2) (s2 ++ s1).
Proof.
elim: s1 s2=>[|x s1 IH1] s2 /=; first by rewrite cats0.
apply: (@pperm_trans (x::s2++s1)); first by apply: permutation_skip.
elim: s2=>[|y s2 IH2] //=.
apply: (@pperm_trans (y::x::s2++s1)); first by apply: permutation_swap.
by apply: permutation_skip.
Qed.

Hint Resolve pperm_catC : core.

Lemma pperm_cat2lL s s1 s2 : perm s1 s2 -> perm (s ++ s1) (s ++ s2).
Proof. by elim: s=>[//|e s IH /IH]; apply: permutation_skip. Qed.

Lemma pperm_cat2rL s s1 s2 : perm s1 s2 -> perm (s1 ++ s) (s2 ++ s).
Proof.
move=>?.
apply: (@pperm_trans (s ++ s1)); first by apply: pperm_catC.
apply: (@pperm_trans (s ++ s2)); last by apply: pperm_catC.
by apply: pperm_cat2lL.
Qed.

Lemma pperm_catL s1 t1 s2 t2 :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ t1) (s2 ++ t2).
Proof. by move/(pperm_cat2rL t1)=>H1/(pperm_cat2lL s2); apply: pperm_trans. Qed.

Lemma pperm_cat_consL s1 t1 s2 t2 x :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ x :: t1) (s2 ++ x :: t2).
Proof. by move=>*; apply: pperm_catL=>//; apply: permutation_skip. Qed.

Lemma pperm_cons_catCA s1 s2 x : perm (x :: s1 ++ s2) (s1 ++ x :: s2).
Proof.
rewrite -cat1s -(cat1s _ s2) !catA.
by apply/pperm_cat2rL/pperm_catC.
Qed.

Lemma pperm_cons_catAC s1 s2 x : perm (s1 ++ x :: s2) (x :: s1 ++ s2).
Proof. by apply/pperm_sym/pperm_cons_catCA. Qed.

Hint Resolve pperm_cons_catCA pperm_cons_catAC : core.

Lemma pperm_cons_cat_consL s1 s2 s x :
        perm s (s1 ++ s2) -> perm (x :: s) (s1 ++ x :: s2).
Proof.
move=>?.
apply: (@pperm_trans (x :: (s1 ++ s2))); first by apply: permutation_skip.
by apply: pperm_cons_catCA.
Qed.

Lemma pperm_size l1 l2: perm l1 l2 -> size l1 = size l2.
Proof. by elim=>//=???? =>[|?|]->. Qed.

Lemma pperm_cat_consR s1 s2 t1 t2 x :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) -> perm (s1 ++ t1) (s2 ++ t2).
Proof.
move: s1 t1 s2 t2 x.
suff H:
  forall r1 r2, perm r1 r2 -> forall x s1 t1 s2 t2,
    r1 = s1 ++ x :: t1 -> r2 = s2 ++ x :: t2 -> perm (s1 ++ t1) (s2 ++ t2).
- by move=>s1 t1 s2 t2 x /H; apply.
apply: perm_ind; last 1 first.
- move=>s2 s1 s3 H1 IH1 H2 IH2 x r1 t1 r2 t2 E1 E2.
  case: (@In_split _ x s2).
  - by apply: pperm_in H1 _; rewrite E1 Mem_cat; right; left.
  move=>s4 [s5] E; apply: (@pperm_trans (s4++s5)); first by apply: IH1 E1 E.
  by apply: IH2 E E2.
- by move=>x [].
- move=>x t1 t2 H IH y [|b s1] s2 [|c p1] p2 /= [E1 E2] [E3 E4]; subst x;
    rewrite ?E1 ?E2 ?E3 ?E4 in H * =>//.
  - by subst y; apply: pperm_trans H _.
  - by apply: pperm_trans H.
  by apply: permutation_skip=>//; apply: IH E2 E4.
move=>x y p1 p2 H IH z [|b s1] t1 [|c s2] t2 /= [E1 E2] [E3 E4]; subst x y;
  rewrite -?E2 -?E4 in H IH * =>//.
- by apply: permutation_skip.
- case: s2 E4=>/=[|a s2][<-]=>[|E4]; apply: permutation_skip=>//.
  by subst p2; apply: pperm_trans H _; apply pperm_cons_catAC.
- case: s1 E2=>/=[|a s1][<-]=>[|E2]; apply: permutation_skip=>//.
  by subst p1; apply: pperm_trans H; apply pperm_cons_catCA.
case: s1 E2=>/=[|a s1][->]=>E2; case: s2 E4=>/=[|d s2][->]=>E4;
  rewrite ?E2 ?E4 in H IH *.
- by apply: permutation_skip.
- apply: (@pperm_trans [:: d, z & s2 ++ t2]); last by apply: permutation_swap.
  by apply: permutation_skip=>//; apply/(pperm_trans H _ )/pperm_cons_catAC.
- apply: (@pperm_trans [:: a, z & s1 ++ t1]); first by apply: permutation_swap.
  by apply: permutation_skip=>//; apply/pperm_trans/H/pperm_cons_catCA.
by apply: permutation_swap; apply: IH.
Qed.

Lemma pperm_cons x s1 s2 : perm (x :: s1) (x :: s2) <-> perm s1 s2.
Proof.
by split; [apply/(@pperm_cat_consR [::] [::]) | apply: permutation_skip].
Qed.

Lemma pperm_cat2l s s1 s2: perm (s ++ s1) (s ++ s2) <-> perm s1 s2.
Proof. by split; [elim: s=>// ??? /pperm_cons | apply: pperm_cat2lL]. Qed.

Lemma pperm_cat2r s s1 s2 : perm (s1 ++ s) (s2 ++ s) <-> perm s1 s2.
Proof.
split; last by apply: pperm_cat2rL.
by elim: s=>[|??? /pperm_cat_consR]; rewrite ?cats0.
Qed.

Lemma pperm_catAC s1 s2 s3 : perm ((s1 ++ s2) ++ s3) ((s1 ++ s3) ++ s2).
Proof. by move=>*; rewrite -!catA pperm_cat2l. Qed.

Lemma pperm_catCA s1 s2 s3 : perm (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3).
Proof. by move=>*; rewrite !catA pperm_cat2r. Qed.

Lemma pperm_cons_cat_cons x s1 s2 s :
        perm (x :: s) (s1 ++ x :: s2) <-> perm s (s1 ++ s2).
Proof.
by split; [apply: (@pperm_cat_consR [::]) | apply: pperm_cons_cat_consL].
Qed.

Lemma pperm_cat_cons x s1 s2 t1 t2 :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) <-> perm (s1 ++ t1) (s2 ++ t2).
Proof.
split=>[|H]; first by apply: pperm_cat_consR.
apply: (@pperm_trans (x::s1++t1))=>//; apply: (@pperm_trans (x::s2++t2))=>//.
by apply/pperm_cons.
Qed.

End Permutations.

#[export]
Hint Resolve pperm_refl pperm_catC pperm_cons_catCA
             pperm_cons_catAC pperm_catAC pperm_catCA : core.

(* perm and map *)
Lemma pperm_map A B (f : A -> B) (s1 s2 : seq A) :
        perm s1 s2 -> perm (map f s1) (map f s2).
Proof.
elim=>[//|||??? _ IH1 _ IH2]*;
by [apply/pperm_cons | apply/permutation_swap | apply/(pperm_trans IH1 IH2)].
Qed.

(* mapping to ssreflect decidable perm *)
Lemma perm_eq_perm (A : eqType) (s1 s2 : seq A) :
        reflect (perm s1 s2) (perm_eq s1 s2).
Proof.
apply: (iffP idP); last first.
- elim=>[|||??? _ H1 _ H2]*.
  - by apply seq.perm_refl.
  - by rewrite seq.perm_cons.
  - by rewrite -![[:: _, _ & _]]/([::_] ++ [::_] ++ _) seq.perm_catCA;
       rewrite !seq.perm_cat2l.
  by apply: seq.perm_trans H1 H2.
elim: s2 s1 =>[s1 /seq.perm_size/size0nil->// | x s2 IH s1 H].
move: (seq.perm_mem H x); rewrite mem_head=>H'; move: H' H.
move/splitPr=>[p1 p2]; rewrite -cat1s seq.perm_catCA seq.perm_cons=>/IH.
by rewrite -[_::s2]cat0s pperm_cat_cons.
Qed.


Require Import XR_Rsqr.
Require Import XR_Rlt_irrefl.
Require Import XR_Rmult_0_l.

Local Open Scope R_scope.

Lemma Rsqr_gt_0_0 : forall x:R, R0 < Rsqr x -> x <> R0.
Proof.
  intros x h.
  intro heq.
  subst x.
  unfold Rsqr in h.
  rewrite Rmult_0_l in h.
  apply Rlt_irrefl with R0.
  exact h.
Qed.


From Coq Require Import ssreflect ssrfun ssrbool.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Coq.Program.Equality.
Require Import Coq.Init.Datatypes.
Require Export Bool.

Inductive TermType := | Value | Type_ | rule_jugd .

Inductive Symbol (x : TermType) :=
  | initial : Symbol x
  | next : Symbol x -> Symbol x.

Inductive TypeDef :=
  | SimplyT : Symbol Type_ -> TypeDef
  | Arrow : TypeDef -> TypeDef -> TypeDef
  | Udnf : TypeDef.

Inductive Expression :=
  |Var : Symbol Value -> TypeDef -> Expression
  |Abs : Expression -> Expression -> TypeDef -> Expression
  |App : Expression -> Expression -> TypeDef -> Expression.

Definition type_of_T (e' : Expression) :=
  match e' return TypeDef with
    |Var _ t => t
    |Abs _ _ t => t
    |App _ _ t => t
  end.

Inductive Enviroment :=
  |empty : Enviroment
  |bind : forall T {H : T <> Udnf}, Expression -> Enviroment -> Enviroment.

Notation "T*" := Enviroment.

Notation "{}" := empty.

Inductive Judgment env (P : Enviroment -> Prop) :=
  |Assume : P env -> Judgment env P.

Fixpoint same_symbol {F} (x : Symbol F) (y : Symbol F) :=
  match (x, y) with
    |(next _ k, next _ k') => same_symbol k k'
    |(initial _, initial _) => true
    |_ => false
  end.

Fixpoint same_type (x : TypeDef) (y : TypeDef) :=
   match (x, y) with
     | (SimplyT k, SimplyT k') => same_symbol k k'
     | (Arrow k k', Arrow u u') => (same_type k u) && (same_type k' u')
     | (Udnf, Udnf) => true
     | _ => false
   end.

Fixpoint has_type (x : TypeDef) (env : Enviroment) : bool :=
  match env with
    |empty => false
    |bind T LT es => match T with
                          |Udnf => (has_type x es)
                          |_ => if (same_type x T) then true else (has_type x es)
                        end
  end.

Fixpoint same_expression (x : Expression) (y : Expression) : bool :=
   match (x, y) with
     | (Var x t, Var y t') => same_type t t' && same_symbol x y
     | (Abs s x t, Abs s' x' t') => same_type t t' && same_expression s s' && (same_expression x x')
     | (App x y t, App x' y' t') => same_type t t'&& same_expression x x' && same_expression y y'
     | _ => false
   end.

Fixpoint varType (x : Expression) (env : Enviroment) : TypeDef :=
  match env with
    |empty => Udnf
    |bind T LT es => if (same_expression x LT) then T else varType x es
  end.

Notation "x |- y" := (Judgment x (fun p => (has_type (varType y x) x) = true)) (at level 202, right associativity).
Notation "x |- { y ::: T }" := (Judgment x (fun p => (has_type (varType y x) x) = true /\ (varType y x) = T)) (at level 201, right associativity).
Notation "x ∈ y" := (varType x y <> Udnf) (at level 50, left associativity, only parsing).

Definition ArrowIsDef : forall T1 T2, Arrow T1 T2 <> Udnf. by []. Defined.

Inductive typed_rules : T* -> Symbol Value -> Expression -> Type :=
  |Tvar : forall (env : Enviroment) (s : Symbol _) T {H' : T <> Udnf}, (env |- {(Var s T) ::: T}) -> typed_rules env s (Var s T)
  |TAbs : forall (env : Enviroment) (k : Symbol Value) x T2 {H' : T2 <> Udnf} s,
    typed_rules env k x -> (env |- {(Var s T2) ::: T2}) ->
       (fun t =>
         typed_rules (@bind (Arrow T2 (type_of_T x)) (ArrowIsDef _ _) t env) (next _ k) t) (Abs (Var s T2) x (Arrow T2 (type_of_T x)))
  |TApp : forall (env : Enviroment) (k : Symbol Value) (x : Expression) T T' T1 T2 {H : T2 <> Udnf},
    typed_rules env k x -> (env |- {T ::: Arrow T1 T2}) -> (env |- {T' ::: T1}) ->
      (fun t => (typed_rules (@bind T2 H t env) k t)) (App T T' T2).

Theorem well_typed_context_has_type : forall {K} (env : Enviroment) (s : Symbol _) (H : typed_rules env s K), (env |- K) -> K ∈ env.
intros.
destruct H0;destruct (varType K env); cbv.
discriminate.
discriminate.
have : forall env, has_type Udnf env = false.
move => H'; elim : H'; trivial.
intros.
rewrite <- H1.
destruct T.
auto.
auto.
simpl; trivial.
assert (forall x, x = false -> x <> true).
move => H'.
destruct H'; move => SH.
discriminate.
discriminate.
move => l;contradiction (H0 _ (l env)).
Qed.

Lemma H0_symbol : forall {T} (s : Symbol T), same_symbol s s = true.
move => f; elim; trivial.
Defined.

Hint Resolve H0_symbol.

Lemma H1_expression : forall e, same_expression e e = true.

have : forall s', same_type s' s' = true.
elim.
move => //=.
move => Eq k k' H.
move => /=.
rewrite k H.
done.
done.

move => H.
elim.
move => /= s t.
rewrite -> (H t).
move => //=.
move => s e t H' t0 /=.
rewrite e H' (H t0); move => /=; intuition.
move => e e0 t H' t0 //=.
rewrite e0 H'; intuition.
Defined.

Lemma H3_type : forall e, same_type e e = true.
elim.
move => q /=; by [].
move => q k' v H' /=.
rewrite k' //.
done.
Defined.

Ltac type_eq_solver :=
  let rewrite_type_axioms :=
     try (do ! (rewrite -> (H0_symbol _)));
     try (do ! (rewrite -> (H1_expression _)));
     try (do ! (rewrite -> (H3_type _))) in
  let rewrite_type_axioms_H H :=
     try (do ! (rewrite (H0_symbol _)) in H);
     try (do ! (rewrite (H1_expression _)) in H);
     try (do ! (rewrite -> (H3_type _)) in H) in
   do ! (simpl; rewrite_type_axioms); match goal with
    |  [ H : _ |- _ ] => generalize H; do ! (simpl; rewrite_type_axioms_H H); clear H; type_eq_solver; intro H
    |  [ |- _ ] => match goal with
            | [ H : _ |- _ ] => fail 1
            | [ |- _ ] => simpl
            end
   end.

Theorem type_context_abs :
  forall (env : Enviroment) (s : Symbol _) T k y (H : typed_rules env s (Abs k y T)), (env |- {(Abs k y T) ::: T}).
intros.

have :
  has_type (varType (Abs k y T) env) env = true /\ varType (Abs k y T) env = T -> Judgment env (fun _ : T* => has_type (varType (Abs k y T) env) env = true /\ varType (Abs k y T) env = T).
move => D; constructor; trivial.
apply.

remember (Abs k y T).
destruct H.
discriminate Heqe.
constructor.
 - simpl; destruct j; type_eq_solver; reflexivity.
 - destruct j.
   generalize (Abs (Var s T2) x (Arrow T2 (type_of_T x))).
   case;simpl.
   move => s' t';type_eq_solver.
   injection Heqe; trivial.
   intros;type_eq_solver.
   simpl;injection Heqe; intros; assumption.
   intros;type_eq_solver;simpl;injection Heqe; intros; assumption.
 - inversion Heqe.
Qed.

Theorem Types_of_terms_are_well_defined : forall T x s env, typed_rules env s x -> varType x env = T -> T <> Udnf.
intros.
destruct H.
do 2 destruct j as [j].
rewrite -> H in H0;rewrite H0 in H'.
exact H'.
do 2 destruct j as [j].
subst;type_eq_solver.
apply : ArrowIsDef.
do 2 destruct j as [j];do 2 destruct j0 as [j0].
subst;simpl;type_eq_solver;assumption.
Qed.

Lemma conservation_of_types : forall T x s env, typed_rules env s x -> varType x env = T -> type_of_T x = T.
intros.
set H' := (@Types_of_terms_are_well_defined _ _ _ _ H H0).
induction env.
simpl in H0;cbv in H'.
destruct (H' (eq_sym H0)).
destruct H.
do 2 destruct j as [j];simpl in *;clear H';rewrite -> e0 in H0.
assumption.
do 2 destruct j as [j].
simpl in *;subst;type_eq_solver; reflexivity.
do 2 destruct j as [j].
do 2 destruct j0 as [j0].
subst.
simpl.
type_eq_solver.
trivial.
Qed.

Theorem type_context :
  forall (env : Enviroment) (s : Symbol _) T K (H : typed_rules env s K), type_of_T K = T -> (env |- {K ::: T}).
intros.

have : has_type (varType K env) env = true /\ varType K env = T -> Judgment env
  (fun _ : T* => has_type (varType K env) env = true /\ varType K env = T).
move => H'.
destruct H'.
constructor.
constructor.
assumption.
assumption.
apply.

constructor.
destruct H.
do 2 destruct j as [j].
assumption.
simpl;type_eq_solver;trivial;subst.
do 2 destruct j as [j].
do 2 destruct j0 as [j0].
type_eq_solver;destruct T2.
trivial.
trivial.
contradiction H;trivial.
destruct H.
do 2 destruct j as [j].
simpl in H0.
rewrite <- H0.
assumption.
do 2 destruct j as [j].
subst;simpl;type_eq_solver;trivial.
do 2 destruct j as [j];do 2 destruct j0 as [j0].
subst;type_eq_solver; trivial.
Qed.

Lemma eq_symb : forall {T} (x : Symbol T) y, same_symbol x y = true -> x = y.
intros.
(*try to proof this normally induction is bit hard cause' the x and y are evaluated in same time so the
   induction have to reason about two mutually, so a new mutual scheme was set*)
set mutually_symbol := fun (x : TermType) (P : Symbol x -> Symbol x -> Prop)
         (f_2initial : P (initial x) (initial x))
         (f_2next : forall s s' : Symbol x,
                    P s s' -> P (next x s) (next x s'))
         (f_contr0' : forall s s' : Symbol x,
                      P s s' -> P (initial x) (next x s'))
         (f_contr1' : forall s s' : Symbol x,
                      P s s' -> P (next x s) (initial x)) =>
       fix Ffix (x0 : Symbol x) : forall x1 : Symbol x, P x0 x1 :=
         match x0 as c return (forall x1 : Symbol x, P c x1) with
         | initial _ =>
             fix Ffix0 (x1 : Symbol x) : P (initial x) x1 :=
               match x1 as c return (P (initial x) c) with
               | initial _ => f_2initial
               | next _ x2 => f_contr0' (initial x) x2 (Ffix0 x2)
               end
         | next _ x1 =>
             fun x2 : Symbol x =>
             match x2 as c return (P (next x x1) c) with
             | initial _ => f_contr1' x1 (initial x) (Ffix x1 (initial x))
             | next _ x3 => f_2next x1 x3 (Ffix x1 x3)
             end
         end.
move : H.
elim/mutually_symbol : x/y.
done.
move => /= s s' H q.
set f := (H q).
rewrite -> f.
done.
done.
done.
Qed.

(*A specialized ssreflect based tatic for working induction in equal types*)
Ltac induction_eqType k y:=
   move => k; move => y;
   set type_mutual_induction := (fun (P : TypeDef -> TypeDef -> Prop)
         (f_2SimplyT : forall k k' : Symbol Type_, P (SimplyT k) (SimplyT k'))
         (f_2Udnf : P Udnf Udnf)
         (f_Simply_Arrow : forall (k : Symbol Type_) (s s' : TypeDef),
                           P (SimplyT k) (Arrow s s'))
         (f_Arrow_Simply : forall (k : Symbol Type_) (s s' : TypeDef),
                           P (Arrow s s') (SimplyT k))
         (f_Simply_Udnf : forall k : Symbol Type_, P (SimplyT k) Udnf)
         (f_Udnf_Simply : forall k : Symbol Type_, P Udnf (SimplyT k))
         (f_2Arrow : forall s s' q q' : TypeDef,
                     P s q -> P s' q' -> P (Arrow s s') (Arrow q q'))
         (f_Arrow_Udnf : forall s s' : TypeDef, P (Arrow s s') Udnf)
         (f_Udnf_Arrow : forall s s' : TypeDef, P Udnf (Arrow s s')) =>
       fix Ffix (x : TypeDef) : forall x0 : TypeDef, P x x0 :=
         match x as c return (forall x0 : TypeDef, P c x0) with
         | SimplyT x0 =>
             fun x1 : TypeDef =>
             match x1 as c return (P (SimplyT x0) c) with
             | SimplyT x2 => f_2SimplyT x0 x2
             | Arrow x2 x3 => f_Simply_Arrow x0 x2 x3
             | Udnf => f_Simply_Udnf x0
             end
         | Arrow x0 x1 =>
             fix Ffix0 (x2 : TypeDef) : P (Arrow x0 x1) x2 :=
               match x2 as c return (P (Arrow x0 x1) c) with
               | SimplyT x3 => f_Arrow_Simply x3 x0 x1
               | Arrow x3 x4 =>
                   f_2Arrow x0 x1 x3 x4 (Ffix x0 x3) (Ffix x1 x4)
               | Udnf => f_Arrow_Udnf x0 x1
               end
         | Udnf =>
             fun x0 : TypeDef =>
             match x0 as c return (P Udnf c) with
             | SimplyT x1 => f_Udnf_Simply x1
             | Arrow x1 x2 => f_Udnf_Arrow x1 x2
             | Udnf => f_2Udnf
             end
         end);
     elim/type_mutual_induction : k/y; clear.

Lemma eq_type : forall k y, same_type k y = true-> k = y.
induction_eqType k y.
intros.
unfold same_type in H.
rewrite -> (eq_symb _ _ H).
trivial.
trivial.
intros;inversion H.
intros;inversion H.
intros;inversion H.
intros;inversion H.
intros.
simpl in H1.
apply andb_true_iff in H1.
destruct H1.
apply H in H1.
apply H0 in H2.
rewrite H1 H2.
trivial.
intros; inversion H.
intros; inversion H.
Qed.

(*False injection was the more easy way to prove somes check that the typed_rules do is wrong,
 fortunately the "bind" construct a false injection equality*)

Lemma False_injection_nextC : forall (t : TypeDef) t0, t = Arrow t0 t -> False.
induction t.
intros.
discriminate.
move => H H1.
injection H1.
intros.
rewrite -> H2 in H1.
injection H1.
intros.
apply IHt2 in H3.
trivial.
discriminate.
Qed.

Theorem lambda_type_return :
  forall (env : Enviroment) (s : Symbol _) k y T1 T2 x (H : typed_rules env s x), x = (Abs k y (Arrow T1 T2)) ->
    (env |- {(Abs k y (Arrow T1 T2)) ::: Arrow T1 T2}) -> (env |- {y ::: T2}).
intros.
remember s; destruct H.
inversion H0.
constructor.
simpl in *; injection H0; intros; destruct H1.
destruct y; simpl in *.
constructor.
subst; do 2 destruct j as [j].
type_eq_solver.
destruct (same_type (varType (Var s0 t) env) (Arrow T1 t)); trivial.
assert(type_of_T (Var s0 t) = t).
trivial.
pose(type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
destruct (same_type (varType (Var s1 t) env) (Arrow T1 t)).
trivial.
assumption.
destruct (same_type (varType (Var s1 t) env) (Arrow T1 t)).
trivial.
assert(type_of_T (Var s1 t) = t).
trivial.
pose (type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
assumption.
destruct a.
destruct j.
destruct a.
injection H0; intros.
rewrite <- H4; rewrite <- H2.
pose(type_context _ _ _ _ H H9).
do 2 destruct j as [j].
subst; assumption.
constructor.
do 2 destruct j as [j].
subst; type_eq_solver.
case : (same_type t (Arrow T1 t) && same_expression y1 (Var s0 T1) &&
  same_expression y2 (Abs y1 y2 t)).
type_eq_solver; trivial.
destruct (same_type (varType (Abs y1 y2 t) env) (Arrow T1 t)).
trivial.
assert(type_of_T (Abs y1 y2 t) = t).
trivial.
pose(type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
trivial.

do 2 destruct j as [j].
simpl in *; subst; type_eq_solver.
remember (if
  same_type t (Arrow T1 t) && same_expression y1 (Var s0 T1) &&
  same_expression y2 (Abs y1 y2 t)
 then Arrow T1 t
 else varType (Abs y1 y2 t) env).
remember (same_type t (Arrow T1 t)).
remember (same_expression y1 (Var s0 T1) && same_expression y2 (Abs y1 y2 t)).
destruct b.
symmetry in Heqb; apply eq_type in Heqb; destruct (False_injection_nextC _ _ Heqb).
simpl in Heqt0; rewrite -> Heqt0.
assert(type_of_T (Abs y1 y2 t) = t).
trivial.
pose (type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
assumption.

subst; type_eq_solver; constructor.
destruct (same_type (varType (App y1 y2 t) env) (Arrow T1 t)).
trivial.
destruct H.
do 2 destruct j0 as [j0]; exact j0.
type_eq_solver; trivial.
simpl in *; type_eq_solver; destruct T2; trivial.
trivial.
contradiction H; apply : eq_refl.
remember (App y1 y2 t); destruct H.
do 2 destruct j0 as [j0].
inversion Heqe.
simpl in *; type_eq_solver.
inversion Heqe.
simpl in *; type_eq_solver; injection Heqe; intros; assumption.
inversion H0.
Qed.

(*this lemma is a counter implication of conservation_of_types so, we able to construct a strong <-> relation between enviroment and their types*)
Lemma strong_enviroment_conservation : forall T2 env y, same_type (varType y env) T2 = true -> varType y env = T2.
move => t2 d; elim.
move => y g Heq.
induction y.
destruct d.
destruct t2; simpl in Heq.
inversion Heq.
inversion Heq.
trivial; simpl; simpl in Heq.
move : Heq; generalize (if
  match e with
  | Var y t' =>
      same_type g t' &&
      match y with
      | initial _ => true
      | next _ _ => false
      end
  | _ => false
  end
 then T
 else varType (Var (initial Value) g) d).
move => t0; apply : eq_type.
destruct d; simpl in *.
apply IHy in Heq; assumption.
apply eq_type in Heq; trivial.
intros; apply eq_type in H1; trivial.
intros;apply eq_type in H1;trivial.
Qed.

Theorem lambda_symbol_uniqueness :
  forall (env : Enviroment) (s : Symbol _) k y T
    (H : typed_rules env (next _ s) (Abs k y T)),
    k = Var s (type_of_T k).
intros.
remember s.
remember (Abs k y T).
remember k.
destruct H.
inversion Heqe.
remember k0.
destruct H.
Admitted.

Theorem well__lambda_typed_context_has_type :
  forall (env : Enviroment) (s : Symbol _) k y T (H : typed_rules env (next _ s) (Abs k y T)) T1 T2 R1 R2,
    (env |- {k ::: T1}) -> (env |- {(Abs k y T) ::: Arrow R1 R2}) -> R2 = T2.

Admitted.


(* https://eng-cs.syr.edu/wp-content/uploads/2017/11/QE1_CISE_Jan16.pdf *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From QE Require Import Maps.

Inductive expr : Type  :=
| Num (n: nat)
| Var (x: string)
| Inc (x: string)
| Plus (e1: expr) (e2: expr)
| Mult (e1: expr) (e2: expr)
| Assign (x: string) (e1: expr)
| Clock (e1: expr).

Definition state := total_map nat.

(* original semantic *)
Inductive oeval : expr -> state -> nat -> state -> Prop :=
| OE_Num : forall σ n, oeval (Num n) σ n σ
| OE_Var : forall σ x, oeval (Var x) σ (σ x) σ
| OE_Inc : forall σ x, oeval (Inc x) σ (σ x) (x !-> ((σ x) + 1) ; σ)
| OE_Add : forall σ0 σ1 σ2 e1 e2 n1 n2,
    oeval e1 σ0 n1 σ1 ->
    oeval e2 σ1 n2 σ2 ->
    oeval (Plus e1 e2) σ0 (n1 + n2) σ2
| OE_Mult : forall σ0 σ1 σ2 e1 e2 n1 n2,
    oeval e1 σ0 n1 σ1 ->
    oeval e2 σ1 n2 σ2 ->
    oeval (Plus e1 e2) σ0 (n1 * n2) σ2.

(* cost is a int value *)
Inductive ceval : expr -> state -> nat -> state -> nat -> Prop :=
| CE_Num : forall σ n, ceval (Num n) σ n σ 0
| CE_Var : forall σ x, ceval (Var x) σ (σ x) σ 2
| CE_Inc : forall σ x, ceval (Inc x) σ (σ x) (x !-> ((σ x) + 1) ; σ) 3
| CE_Assign : forall σ0 σ1 x e n1 c1,
    ceval e σ0 n1 σ1 c1 ->
    ceval (Assign x e) σ1 n1 (x !-> n1 ; σ1) (c1 + 3)
| CE_Clock : forall σ0 σ1 e n1 c1,
    ceval e σ0 n1 σ1 c1 ->
    ceval (Clock e) σ1 n1 σ1 (n1 + c1)
| CE_Add : forall σ0 σ1 σ2 e1 e2 n1 n2 c1 c2,
    ceval e1 σ0 n1 σ1 c1 ->
    ceval e2 σ1 n2 σ2 c2 ->
    ceval (Plus e1 e2) σ0 (n1 + n2) σ2 (c1 + c2 + 1)
| CE_Mult : forall σ0 σ1 σ2 e1 e2 n1 n2 c1 c2,
    ceval e1 σ0 n1 σ1 c1 ->
    ceval e2 σ1 n2 σ2 c2 ->
    ceval (Plus e1 e2) σ0 (n1 * n2) σ2 (c1 + c2 + 1).

Hint Constructors oeval : core.
Hint Constructors ceval : core.