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

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

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

Contents : Rezk completion

 - Construction of the Rezk completion via Yoneda

 - Universal property of the Rezk completion

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.precomp_fully_faithful.
Require Import UniMath.CategoryTheory.precomp_ess_surj.

(** * Construction of the Rezk completion via Yoneda *)

Section rezk.

  Context (A : category).

Definition category_Rezk_completion : category.
Proof.
  exists (full_img_sub_precategory (yoneda A)).
  exact (has_homsets_full_img_sub_precategory (yoneda A)).
Defined.

Definition Rezk_completion : univalent_category.
Proof.
  exists category_Rezk_completion.
  apply is_univalent_full_subcat.
  apply (is_univalent_functor_category _ _ is_univalent_HSET).
Defined.

Definition Rezk_eta : functor A Rezk_completion.
Proof.
  apply (functor_full_img (yoneda A)).
Defined.

Lemma Rezk_eta_fully_faithful : fully_faithful Rezk_eta.
Proof.
  apply (functor_full_img_fully_faithful_if_fun_is _ _ (yoneda A)).
  apply yoneda_fully_faithful.
Defined.

Lemma Rezk_eta_essentially_surjective : essentially_surjective Rezk_eta.
Proof.
  apply (functor_full_img_essentially_surjective _ _ (yoneda A)).
Defined.

End rezk.

(** * Universal property of the Rezk completion *)

Definition functor_from (C : precategory) : UU
  := ∑ D : univalent_category, functor C D.

Coercion target_category (C : precategory) (X : functor_from C) : univalent_category := pr1 X.
Definition func_functor_from {C : precategory} (X : functor_from C) : functor C X := pr2 X.

Definition is_initial_functor_from (C : precategory) (X : functor_from C) : UU
  := ∏ X' : functor_from C,
     ∃! H : functor X X',
       functor_composite (func_functor_from X) H = func_functor_from X'.

Section rezk_universal_property.

  Context (A : category).

Section fix_a_category.

  Context (C : category) (Ccat : is_univalent C).

Lemma pre_comp_rezk_eta_is_fully_faithful :
  fully_faithful
    (pre_composition_functor _ _  C (Rezk_eta A)).
Proof.
  apply pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful.
  - apply Rezk_eta_essentially_surjective.
  - apply Rezk_eta_fully_faithful.
Defined.

Lemma pre_comp_rezk_eta_is_ess_surj :
  essentially_surjective (pre_composition_functor _ _ C (Rezk_eta A)).
Proof.
  apply pre_composition_essentially_surjective.
  - apply Ccat.
  - apply Rezk_eta_essentially_surjective.
  - apply Rezk_eta_fully_faithful.
Defined.

Definition Rezk_adj_equiv : adj_equivalence_of_cats
  (pre_composition_functor _ _ C (Rezk_eta A)).
Proof.
  apply (@rad_equivalence_of_cats
           (functor_category (Rezk_completion A) C)
           (functor_category A C)
           (is_univalent_functor_category _ _ Ccat )
           _
           (pre_comp_rezk_eta_is_fully_faithful)
           (pre_comp_rezk_eta_is_ess_surj)).
Defined.

Theorem Rezk_eta_Universal_Property :
  isweq (pre_composition_functor _ _ C (Rezk_eta A)).
Proof.
  apply adj_equiv_of_cats_is_weq_of_objects.
  - apply is_univalent_functor_category;
    assumption.
  - apply is_univalent_functor_category;
    assumption.
  - apply Rezk_adj_equiv.
Defined.

Definition Rezk_weq : [Rezk_completion A, C] ≃ [A, C ]
  := make_weq _ Rezk_eta_Universal_Property.

End fix_a_category.

Lemma Rezk_initial_functor_from : is_initial_functor_from A
      (tpair _ (Rezk_completion A) (Rezk_eta A)).
Proof.
  intro D.
  destruct D as [D F].
  set (T:= Rezk_eta_Universal_Property D (pr2 D)).
  apply T.
Defined.

Definition Rezk_completion_endo_is_identity (D : functor_from A)
           (DH : is_initial_functor_from A D)
  : ∏ X : functor D D, functor_composite (func_functor_from D) X = func_functor_from D
        ->
        X = functor_identity D.
Proof.
  intros X H.
  set (DH' := DH D).
  intermediate_path (pr1 (pr1 DH')).
  - apply path_to_ctr.
    apply H.
  - apply pathsinv0.
    apply path_to_ctr.
    apply functor_identity_right.
Defined.

End rezk_universal_property.

Section opp_rezk_universal_property.

  Context (A : category).

Section fix_a_category.

  Context (C : category) (Ccat : is_univalent C).

Lemma pre_comp_rezk_eta_opp_is_fully_faithful :
    fully_faithful
       (pre_composition_functor A^op (Rezk_completion A)^op C
                (functor_opp (Rezk_eta A))).
Proof.
  apply pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful.
  - apply opp_functor_essentially_surjective.
    apply Rezk_eta_essentially_surjective.
  - apply opp_functor_fully_faithful.
    apply Rezk_eta_fully_faithful.
Defined.

Lemma pre_comp_rezk_eta_opp_is_ess_surj :
   essentially_surjective
      (pre_composition_functor A^op (Rezk_completion A)^op C
                         (functor_opp (Rezk_eta A))).
Proof.
  apply pre_composition_essentially_surjective.
  - apply Ccat.
  - apply opp_functor_essentially_surjective.
    apply Rezk_eta_essentially_surjective.
  - apply opp_functor_fully_faithful.
    apply Rezk_eta_fully_faithful.
Defined.

Definition Rezk_op_adj_equiv :
 adj_equivalence_of_cats
     (pre_composition_functor A^op (Rezk_completion A)^op C
        (functor_opp (Rezk_eta A))).
Proof.
  apply (@rad_equivalence_of_cats
           [(Rezk_completion A)^op, C]
           [A^op, C]
           (is_univalent_functor_category _ _ Ccat )
           _
           (pre_comp_rezk_eta_opp_is_fully_faithful)
           (pre_comp_rezk_eta_opp_is_ess_surj)).
Defined.

Theorem Rezk_eta_opp_Universal_Property :
  isweq (pre_composition_functor A^op (Rezk_completion A)^op C
          (functor_opp (Rezk_eta A))).
Proof.
  apply adj_equiv_of_cats_is_weq_of_objects.
  - apply is_univalent_functor_category;
    assumption.
  - apply is_univalent_functor_category;
    assumption.
  - apply Rezk_op_adj_equiv.
Defined.

Definition Rezk_opp_weq : [(Rezk_completion A)^op, C] ≃ [A^op, C]
  := make_weq _ Rezk_eta_opp_Universal_Property.

End fix_a_category.

End opp_rezk_universal_property.


Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Module PCF.

Inductive Sorts :=
  | Nat : Sorts
  | Bool : Sorts
  | Arrow : Sorts -> Sorts -> Sorts.

Notation "a '~>' b" := (Arrow a b) (at level 60, right associativity).

End PCF.


(** *** Full Syntax Operations & Properties *)

From Equations Require Import Equations.
Require Export DecidableEnumerable.
Require Export FullSyntax.
Require Export Lia.

Coercion var_term : fin >-> term.

Notation "phi --> psi" := (Impl phi psi) (right associativity, at level 55).
Notation "phi ∧ psi" := (Conj phi psi) (right associativity, at level 55).
Notation "phi ∨ psi" := (Disj phi psi) (right associativity, at level 55).
Notation "∀ phi" := (All phi) (at level 56, right associativity).
Notation "∃ phi" := (Ex phi) (at level 56, right associativity).
Notation "⊤" := (Top).
Notation "⊥" := (Fal).
Notation "¬ phi" := (phi --> ⊥) (at level 20).

(** **** Tactics *)

Ltac capply H := eapply H; try eassumption.
Ltac comp := repeat (progress (cbn in *; autounfold in *; asimpl in *)).
Hint Unfold idsRen.

Ltac resolve_existT :=
  match goal with
  | [ H2 : existT _ _ _ = existT _ _ _ |- _ ] => rewrite (inj_pair2 _ _ _ _ _ H2) in *
  | _ => idtac
  end.

Ltac inv H :=
  inversion H; subst; repeat (progress resolve_existT).

Section FullFOL.
  Context {Sigma : Signature}.

  Definition form_shift n := var_term (S n).
  Notation "↑" := form_shift.

  (** **** Subformula *)

  Inductive sf : form -> form -> Prop :=
  | SImplL phi psi : sf phi (phi --> psi)
  | SImplR phi psi : sf psi (phi --> psi)
  (* | SEq s t s' t' : sf (Pr s' t') (Eq s t) *)
  | SDisjL phi psi : sf phi (phi ∨ psi)
  | SDisjR phi psi : sf psi (phi ∨ psi)
  | SConjL phi psi : sf phi (phi ∧ psi)
  | SConjR phi psi : sf psi (phi ∧ psi)
  | SAll phi t : sf (phi [t .: ids]) (∀ phi)
  | SEx phi t : sf (phi [t .: ids]) (∃ phi).

  Lemma sf_acc phi rho :
    Acc sf (phi [rho]).
  Proof.
    revert rho; induction phi; intros rho; constructor; intros psi Hpsi; asimpl in *; inversion Hpsi;
      subst; asimpl in *; eauto.
  Qed.

  Lemma sf_well_founded :
    well_founded sf.
  Proof.
    intros phi. pose proof (sf_acc phi ids) as H. comp. erewrite -> idSubst_form in H; firstorder.
  Qed.

  (** **** Forall and Vector.t technology **)

  Inductive Forall (A : Type) (P : A -> Type) : forall n, vector A n -> Type :=
  | Forall_nil : Forall P (@Vector.nil A)
  | Forall_cons : forall n (x : A) (l : vector A n), P x -> Forall P l -> Forall P (@Vector.cons A x n l).

  Inductive vec_in (A : Type) (a : A) : forall n, vector A n -> Type :=
  | vec_inB n (v : vector A n) : vec_in a (cons a v)
  | vec_inS a' n (v :vector A n) : vec_in a v -> vec_in a (cons a' v).
  Hint Constructors vec_in.

  Lemma strong_term_ind' (p : term -> Type) :
    (forall x, p (var_term x)) -> (forall F v, (Forall p v) -> p (Func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. fix 1. destruct t as [n|F v].
    - apply f1.
    - apply f2. induction v.
      + econstructor.
      + econstructor. now eapply strong_term_ind'. eauto.
  Qed.

  Lemma strong_term_ind (p : term -> Type) :
    (forall x, p (var_term x)) -> (forall F v, (forall t, vec_in t v -> p t) -> p (Func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. eapply strong_term_ind'.
    - apply f1.
    - intros. apply f2. intros t. induction 1; inv X; eauto.
  Qed.

  (** **** Free variables *)

  Inductive unused_term (n : nat) : term -> Prop :=
  | uft_var m : n <> m -> unused_term n (var_term m)
  | uft_Func F v : (forall t, vec_in t v -> unused_term n t) -> unused_term n (Func F v).

  Inductive unused (n : nat) : form -> Prop :=
  | uf_Fal : unused n Fal
  | uf_Top : unused n Top
  | uf_Pred P v : (forall t, vec_in t v -> unused_term n t) -> unused n (Pred P v)
  | uf_I phi psi : unused n phi -> unused n psi -> unused n (Impl phi psi)
  | uf_A phi psi : unused n phi -> unused n psi -> unused n (Conj phi psi)
  | uf_O phi psi : unused n phi -> unused n psi -> unused n (Disj phi psi)
  | uf_All phi : unused (S n) phi -> unused n (All phi)
  | uf_Ex phi : unused (S n) phi -> unused n (Ex phi).

  Definition unused_L n A := forall phi, phi el A -> unused n phi.
  Definition closed phi := forall n, unused n phi.

  Lemma vec_unused n (v : vector term n)  :
    (forall t, vec_in t v -> { n | forall m, n <= m -> unused_term m t }) ->
    { k | forall t, vec_in t v -> forall m, k <= m -> unused_term m t }.
  Proof.
    intros Hun. induction v in Hun |-*.
    - exists 0. intros n H. inv H.
    - destruct IHv as [k H]. 1: eauto. destruct (Hun h (vec_inB h v)) as [k' H'].
      exists (k + k'). intros t H2. inv H2; intros m Hm; [apply H' | apply H]; now try omega.
  Qed.

  Lemma find_unused_term t :
    { n | forall m, n <= m -> unused_term m t }.
  Proof.
    induction t using strong_term_ind.
    - exists (S x). intros m Hm. constructor. omega.
    - destruct (vec_unused X) as [k H]. exists k. eauto using unused_term.
  Qed.

  Lemma find_unused phi :
    { n | forall m, n <= m -> unused m phi }.
  Proof with eauto using unused.
    induction phi.
    - exists 0...
    - exists 0...
    - destruct (@vec_unused _ t) as [k H]. 1: eauto using find_unused_term. exists k. eauto using unused.
    - destruct IHphi1, IHphi2. exists (x + x0). intros m Hm. constructor; [ apply u | apply u0 ]; omega.
    - destruct IHphi1, IHphi2. exists (x + x0). intros m Hm. constructor; [ apply u | apply u0 ]; omega.
    - destruct IHphi1, IHphi2. exists (x + x0). intros m Hm. constructor; [ apply u | apply u0 ]; omega.
    - destruct IHphi. exists x. intros m Hm. constructor. apply u. omega.
    - destruct IHphi. exists x. intros m Hm. constructor. apply u. omega.
  Qed.

  Lemma find_unused_L A :
    { n | forall m, n <= m -> unused_L m A }.
  Proof.
    induction A.
    - exists 0. unfold unused_L. intuition.
    - destruct IHA. destruct (find_unused a).
      exists (x + x0). intros m Hm. intros phi []; subst.
      + apply u0. omega.
      + apply u. omega. auto.
  Qed.

  (** **** Substituting unused variables *)

  Definition shift_P P n :=
    match n with
    | O => False
    | S n' => P n'
    end.

  Lemma vec_map_ext X Y (f g : X -> Y) n (v : vector X n) :
    (forall x, vec_in x v -> f x = g x) -> map f v = map g v.
  Proof.
    intros Hext; induction v in Hext |-*; cbn.
    - reflexivity.
    - rewrite IHv, (Hext h). 1: reflexivity. all: eauto.
  Qed.

  Lemma subst_unused_term xi sigma P t :
    (forall x, dec (P x)) -> (forall m, ~ P m -> xi m = sigma m) -> (forall m, P m -> unused_term m t) ->
    subst_term xi t = subst_term sigma t.
  Proof.
    intros Hdec Hext Hunused. induction t using strong_term_ind; cbn; asimpl.
    - destruct (Hdec x) as [H % Hunused | H % Hext].
      + inversion H; subst; congruence.
      + congruence.
    - f_equal. apply vec_map_ext. intros t H'. apply (H t H'). intros n H2 % Hunused. inv H2. eauto.
  Qed.

  Lemma subst_unused_form xi sigma P phi :
    (forall x, dec (P x)) -> (forall m, ~ P m -> xi m = sigma m) -> (forall m, P m -> unused m phi) ->
    subst_form xi phi = subst_form sigma phi.
  Proof.
    induction phi in xi,sigma,P |-*; intros Hdec Hext Hunused; cbn; asimpl.
    - reflexivity.
    - reflexivity.
    - f_equal. apply vec_map_ext. intros s H. apply (subst_unused_term Hdec Hext).
      intros m H' % Hunused. inv H'. eauto.
    - rewrite IHphi1 with (sigma := sigma) (P := P). rewrite IHphi2 with (sigma := sigma) (P := P).
      all: try tauto. all: intros m H % Hunused; now inversion H.
    - rewrite IHphi1 with (sigma := sigma) (P := P). rewrite IHphi2 with (sigma := sigma) (P := P).
      all: try tauto. all: intros m H % Hunused; now inversion H.
    - rewrite IHphi1 with (sigma := sigma) (P := P). rewrite IHphi2 with (sigma := sigma) (P := P).
      all: try tauto. all: intros m H % Hunused; now inversion H.
    - erewrite IHphi with (P := shift_P P). 1: reflexivity.
      + intros [| x]; [now right| now apply Hdec].
      + intros [| m]; [reflexivity|]. intros Heq % Hext; unfold ">>"; cbn; congruence.
      + intros [| m]; [destruct 1| ]. intros H % Hunused; now inversion H.
    - erewrite IHphi with (P := shift_P P). 1: reflexivity.
      + intros [| x]; [now right| now apply Hdec].
      + intros [| m]; [reflexivity|]. intros Heq % Hext; unfold ">>"; cbn; congruence.
      + intros [| m]; [destruct 1| ]. intros H % Hunused; now inversion H.
  Qed.

  Lemma subst_unused_single xi sigma n phi :
    unused n phi -> (forall m, n <> m -> xi m = sigma m) -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hext Hunused. apply subst_unused_form with (P := fun m => n = m). all: intuition.
    now subst.
  Qed.

  Lemma subst_unused_range xi sigma phi n :
    (forall m, n <= m -> unused m phi) -> (forall x, x < n -> xi x = sigma x) -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hle Hext. apply subst_unused_form with (P := fun x => n <= x); [apply le_dec| |assumption].
    intros ? ? % not_le; intuition.
  Qed.

  Lemma subst_unused_closed xi sigma phi :
    closed phi -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hcl. apply subst_unused_range with (n := 0); intuition. omega.
  Qed.

  Lemma subst_unused_closed' xi phi :
    closed phi -> subst_form xi phi = phi.
  Proof.
    intros Hcl. rewrite <- idSubst_form with (sigmaterm := ids).
    apply subst_unused_range with (n := 0). all: intuition; omega.
  Qed.

  Lemma vec_forall_map X Y (f : X -> Y) n (v : vector X n) (p : Y -> Type) :
    (forall x, vec_in x v -> p (f x)) -> forall y, vec_in y (map f v) -> p y.
  Proof.
    intros H y Hmap. induction v; cbn; inv Hmap; eauto.
  Qed.

  (** **** Theories *)

  Definition theory := form -> Prop.
  Definition contains phi (T : theory) := T phi.
  Definition contains_L (A : list form) (T : theory) := forall f, f el A -> contains f T.
  Definition subset_T (T1 T2 : theory) := forall (phi : form), contains phi T1 -> contains phi T2.
  Definition list_T A : theory := fun phi => phi el A.

  Infix "⊏" := contains_L (at level 20).
  Infix "⊑" := subset_T (at level 20).
  Infix "∈" := contains (at level 70).

  Hint Unfold contains.
  Hint Unfold contains_L.
  Hint Unfold subset_T.

  Global Instance subset_T_trans : Transitive subset_T.
  Proof.
    intros T1 T2 T3. intuition.
  Qed.

  Definition extend T (phi : form) := fun psi => T psi \/ psi = phi.
  Infix "⋄" := extend (at level 20).

  Definition closed_T (T : theory) := forall phi n, contains phi T -> unused n phi.
  Lemma closed_T_extend T phi :
    closed_T T -> closed phi -> closed_T (T ⋄ phi).
  Proof.
    intros ? ? ? ? []; subst; intuition.
  Qed.

  Section ContainsAutomation.
    Lemma contains_nil T :
      List.nil ⊏ T.
    Proof. intuition. Qed.

    Lemma contains_cons a A T :
      a ∈ T -> A ⊏ T -> (a :: A) ⊏ T.
    Proof. intros ? ? ? []; subst; intuition. Qed.

    Lemma contains_cons2 a A T :
      (a :: A) ⊏ T -> A ⊏ T.
    Proof. firstorder. Qed.

    Lemma contains_app A B T :
      A ⊏ T -> B ⊏ T -> (A ++ B) ⊏ T.
    Proof. intros ? ? ? [] % in_app_or; intuition. Qed.

    Lemma contains_extend1 phi T :
      phi ∈ (T ⋄ phi).
    Proof. now right. Qed.

    Lemma contains_extend2 phi psi T :
      phi ∈ T -> phi ∈ (T ⋄ psi).
    Proof. intros ?. now left. Qed.

    Lemma contains_extend3 A T phi :
      A ⊏ T -> A ⊏ (T ⋄ phi).
    Proof.
      intros ? ? ?. left. intuition.
    Qed.
  End ContainsAutomation.
End FullFOL.

Definition tmap {S1 S2 : Signature} (f : @form S1 -> @form S2) (T : @theory S1) : @theory S2 :=
  fun phi => exists psi, T psi /\ f psi = phi.

Lemma enum_tmap {S1 S2 : Signature} (f : @form S1 -> @form S2) (T : @theory S1) L :
  enum T L -> enum (tmap f T) (L >> List.map f).
Proof.
  intros []. split; unfold ">>".
  - intros n. destruct (H n) as [A ->]. exists (List.map f A). apply map_app.
  - intros x; split.
    + intros (phi & [m Hin] % H0 & <-). exists m. apply in_map_iff. firstorder.
    + intros (m & (phi & <- & Hphi) % in_map_iff). firstorder.
Qed.

Lemma tmap_contains_L {S1 S2 : Signature} (f : @form S1 -> @form S2) T A :
  contains_L A (tmap f T) -> exists B, A = List.map f B /\ contains_L B T.
Proof.
  induction A.
  - intros. now exists List.nil.
  - intros H. destruct IHA as (B & -> & HB). 1: firstorder.
    destruct (H a (or_introl eq_refl)) as (b & Hb & <-).
    exists (b :: B). split. 1: auto. intros ? []; subst; auto.
Qed.

Hint Constructors vec_in.

Infix "⊏" := contains_L (at level 20).
Infix "⊑" := subset_T (at level 20).
Infix "∈" := contains (at level 70).
Infix "⋄" := extend (at level 20).

Hint Resolve contains_nil contains_cons contains_cons2 contains_app : contains_theory.
Hint Resolve contains_extend1 contains_extend2 contains_extend3 : contains_theory.
Ltac use_theory A := exists A; split; [eauto 15 with contains_theory|].

(** **** Equality deciders *)

Lemma dec_vec_in X n (v : vector X n) :
  (forall x, vec_in x v -> forall y, dec (x = y)) -> forall v', dec (v = v').
Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
  intros Hv. induction v; intros v'; dependent destruction v'...
  destruct (Hv h (vec_inB h v) h0)... destruct (IHv (fun x H => Hv x (vec_inS h0 H)) v')...
Qed.

Instance dec_vec X {HX : eq_dec X} n : eq_dec (vector X n).
Proof.
  intros v. refine (dec_vec_in _).
Qed.

Section EqDec.
  Context {Sigma : Signature}.

  Hypothesis eq_dec_Funcs : eq_dec Funcs.
  Hypothesis eq_dec_Preds : eq_dec Preds.

  Global Instance dec_term : eq_dec term.
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    intros t. induction t using strong_term_ind; intros []...
    - decide (x = n)...
    - decide (F = f)... destruct (dec_vec_in X t)...
  Qed.

  Global Instance dec_form : eq_dec form.
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    intros phi. induction phi; intros []...
    - decide (P = P0)... decide (t = t0)...
    - decide (phi1 = f)... decide (phi2 = f0)...
    - decide (phi1 = f)... decide (phi2 = f0)...
    - decide (phi1 = f)... decide (phi2 = f0)...
    - decide (phi = f)...
    - decide (phi = f)...
  Qed.
End EqDec.

Notation "↑" := form_shift.


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

- Frederic Blanqui, 2009-06-24

infinite sets of rules
*)

Set Implicit Arguments.

From CoLoR Require Import ATrs ListUtil RelUtil ARelation LogicUtil SetUtil.

Section defs.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation rule := (rule Sig).
  Notation rules := (set rule).

(***********************************************************************)
(** rewriting *)

  Definition red (R : rules) : relation term :=
    fun u v => exists l, exists r, exists c, exists s,
      R (mkRule l r) /\ u = fill c (sub s l) /\ v = fill c (sub s r).

  Definition hd_red (R : rules) : relation term :=
    fun u v => exists l, exists r, exists s,
      R (mkRule l r) /\ u = sub s l /\ v = sub s r.

  Definition red_mod E R := red E # @ red R.

  Definition hd_red_mod E R := red E # @ hd_red R.

End defs.

Ltac redtac := repeat
  match goal with
    | H : red _ _ _ |- _ =>
      let l := fresh "l" in let r := fresh "r" in
      let c := fresh "c" in let s := fresh "s" in
      let lr := fresh "lr" in let xl := fresh "xl" in
      let yr := fresh "yr" in
        destruct H as [l [r [c [s [lr [xl yr]]]]]]
    | H : transp (red _) _ _ |- _ => unfold transp in H; redtac
    | H : hd_red _ _ _ |- _ =>
      let l := fresh "l" in let r := fresh "r" in
      let s := fresh "s" in let lr := fresh "lr" in
      let xl := fresh "xl" in let yr := fresh "yr" in
        destruct H as [l [r [s [lr [xl yr]]]]]
    | H : transp (hd_red _) _ _ |- _ => unfold transp in H; redtac
    | H : red_mod _ _ _ _ |- _ =>
      let t := fresh "t" in let h := fresh in
        destruct H as [t h]; destruct h; redtac
    | H : hd_red_mod _ _ _ _ |- _ =>
      let t := fresh "t" in let h := fresh in
        destruct H as [t h]; destruct h; redtac
  end.

(***********************************************************************)
(** monotony properties *)

From Coq Require Import Morphisms.

Global Instance red_incl Sig : Proper (subset ==> inclusion) (@red Sig).

Proof. intros R R' RR' t t' tt'. redtac. ex l r c s. fo. Qed.

Global Instance hd_red_incl Sig : Proper (subset ==> inclusion) (@hd_red Sig).

Proof. intros R R' RR' t t' tt'. redtac. ex l r s. fo. Qed.

Global Instance red_mod_incl Sig :
  Proper (subset ==> subset ==> inclusion) (@red_mod Sig).

Proof. intros E E' EE' R R' RR'. unfold red_mod. rewrite EE', RR'. refl. Qed.

Global Instance hd_red_mod_incl Sig :
  Proper (subset ==> subset ==> inclusion) (@hd_red_mod Sig).

Proof. intros E E' EE' R R' RR'. unfold hd_red_mod. rewrite EE', RR'. refl. Qed.

(***********************************************************************)
(** properties of rewriting *)

Section props.

  Variable Sig : Signature.

  Notation rule := (rule Sig). Notation rules := (set rule).

  Lemma red_rule (R : rules) l r c s :
    R (mkRule l r) -> red R (fill c (sub s l)) (fill c (sub s r)).

  Proof. intro. unfold red. ex l r c s. auto. Qed.

  Lemma hd_red_rule (R : rules) l r s :
    R (mkRule l r) -> hd_red R (sub s l) (sub s r).

  Proof. intro. unfold hd_red. ex l r s. auto. Qed.

  Lemma context_closed_red (R : rules) : context_closed (red R).

  Proof.
    intros t u c h. redtac. subst. rewrite !fill_fill. ex l r (comp c c0) s.
    intuition.
  Qed.

  Lemma red_Rules (R : list rule) : red (of_list R) == ATrs.red R.

  Proof.
    split; intros t u H. redtac. subst. apply ATrs.red_rule. hyp.
    ATrs.redtac. subst. apply red_rule. hyp.
  Qed.

  Lemma hd_red_Rules (R : list rule) : hd_red (of_list R) == ATrs.hd_red R.

  Proof.
    split; intros t u H. redtac. subst. apply ATrs.hd_red_rule. hyp.
    ATrs.redtac. subst. apply hd_red_rule. hyp.
  Qed.

  Lemma rt_red_empty : red (@empty rule) # == eq.

  Proof.
    split; intros t u h. elim h; intros. redtac. contr. refl.
    trans y; hyp. subst. apply rt_refl.
  Qed.

(***********************************************************************)
(** properties of rewriting modulo *)

  Lemma context_closed_red_mod (E R : rules) : context_closed (red_mod E R).

  Proof.
    apply context_closed_comp. apply context_closed_rtc.
    apply context_closed_red. apply context_closed_red.
  Qed.

  Lemma red_mod_union (E R : rules) : red_mod E R << red (union E R) #.

  Proof.
    intros t u [h [h1 h2]]. revert h1 h2. induction 1; intro.
    apply rt_trans with y.
    apply rt_step. apply red_incl with E. apply subset_union_l. hyp.
    apply rt_step. apply red_incl with R. apply subset_union_r. hyp.
    apply rt_step. apply red_incl with R. apply subset_union_r. hyp.
    apply rt_trans with y.
    eapply incl_elim. eapply rtc_incl. eapply red_incl.
    apply subset_union_l. hyp.
    auto.
  Qed.

  Lemma rt_red_mod_union (E R : rules) : red_mod E R # << red (union E R) #.

  Proof.
    intros. incl_trans (red(union E R)##). rewrite red_mod_union. refl.
    rewrite rtc_invol. refl.
  Qed.

  Lemma red_mod_Rules (E R : list rule) :
    red_mod (of_list E) (of_list R) == ATrs.red_mod E R.

  Proof. unfold red_mod, ATrs.red_mod. rewrite !red_Rules. refl. Qed.

  Lemma hd_red_mod_Rules (E R : list rule) :
    hd_red_mod (of_list E) (of_list R) == ATrs.hd_red_mod E R.

  Proof.
    intros. unfold hd_red_mod, ATrs.hd_red_mod.
    rewrite !red_Rules, !hd_red_Rules. refl.
  Qed.

  Lemma red_mod_empty (R : rules) : red_mod empty R == red R.

  Proof.
    unfold red_mod. rewrite rt_red_empty. split; intros t u h.
    destruct h. intuition. subst. hyp. exists t. auto.
  Qed.

End props.


(* 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                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                       Pullbacks                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export CatProperty.

Set Implicit Arguments.
Unset Strict Implicit.

(* Pullbacks *)

Section pulbs_def.

Variables (C : Category) (a b c : C) (f : a --> b) (g : c --> b).

 Section pulbs_laws.

 Variables (Fibred_prod : C) (Fibred_p : Fibred_prod --> a)
   (Fibred_q : Fibred_prod --> c).

 Definition Pullback_eq1 (r : C) (t1 : r --> a) (t2 : r --> c) :=
   t1 o f =_S t2 o g.

 Definition Pullback_law1 := Pullback_eq1 Fibred_p Fibred_q.

 Variable
   Pb_diese :
     forall (r : C) (t1 : r --> a) (t2 : r --> c),
     Pullback_eq1 t1 t2 -> (r --> Fibred_prod).

 Definition Pullback_eq2 (x y z : C) (f1 : x --> y)
   (f2 : z --> y) (f3 : x --> z) := f1 =_S f3 o f2.

 Definition Pullback_law2 :=
   forall (r : C) (t1 : r --> a) (t2 : r --> c) (pe : Pullback_eq1 t1 t2),
   Pullback_eq2 t1 Fibred_p (Pb_diese pe).

 Definition Pullback_law3 :=
   forall (r : C) (t1 : r --> a) (t2 : r --> c) (pe : Pullback_eq1 t1 t2),
   Pullback_eq2 t2 Fibred_q (Pb_diese pe).

 Definition Pullback_law4 :=
   forall (r : C) (t1 : r --> a) (t2 : r --> c) (pe : Pullback_eq1 t1 t2)
     (g : r --> Fibred_prod),
   Pullback_eq2 t1 Fibred_p g ->
   Pullback_eq2 t2 Fibred_q g -> g =_S Pb_diese pe.

 End pulbs_laws.

Structure Pullback : Type :=
  {Fibred_prod : C;
   Fibred_p : Fibred_prod --> a;
   Fibred_q : Fibred_prod --> c;
   Prf_pb_law1 : Pullback_law1 Fibred_p Fibred_q;
   Pb_diese :
    forall (r : C) (t1 : r --> a) (t2 : r --> c),
    Pullback_eq1 t1 t2 -> (r --> Fibred_prod);
   Prf_pb_law2 : Pullback_law2 Fibred_p Pb_diese;
   Prf_pb_law3 : Pullback_law3 Fibred_q Pb_diese;
   Prf_pb_law4 : Pullback_law4 Fibred_p Fibred_q Pb_diese}.

End pulbs_def.


(** * Operations S and St on carriers of lB-systems and their properties SSt and StSt .

by Vladimir Voevodsky, file created on Jan. 6, 2015 *)

Require Import UniMath.Foundations.All.
(* Require Export UniMath.Foundations.Sets. *)

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.lB_carriers.

(** ** Operation(s) S

Note: both the domain of definition of operations S and the type of the axiom 1a of operations
S are obtainable from the same for operations T by removing the condition [T_dom_gt0] and
replacing [ft X1] by [dd r]. This leads to the possibility of almost direct copy-and-paste
of many proofs concerning T into the context of S.

Operations T and S are different in the forms of axiom 0 and axiom 1b .

*)

(** *** Domains of definition of operations of type S *)

Definition S_dom { BB : lBsystem_carrier } ( r : Tilde BB ) ( X : BB ) :=
  isabove X ( dd r ) .

Identity Coercion S_dom_to_isabove : S_dom >-> isabove .

Notation S_dom_constr := isabove_constr .
Notation S_dom_gth := isabove_gth .

Definition S_dom_gt1 { BB : lBsystem_carrier } { r : Tilde BB } { Y : BB } ( inn : S_dom r Y ) :
  ll Y > 1 .
Proof .
  exact ( natgthgehtrans _ _ _ ( isabove_gth inn ) ( natgthtogehsn _ _ ( ll_dd _ ) ) ) .

Defined.

Definition S_dom_gt0 { BB : lBsystem_carrier } { r : Tilde BB } { Y : BB } ( inn : S_dom r Y ) :
  ll Y > 0 .
Proof .
  exact ( istransnatgth _ _ _ ( isabove_gth inn ) ( ll_dd _ ) )  .

Defined.

Definition S_dom_ge1 { BB : lBsystem_carrier } { r : Tilde BB } { Y : BB } ( inn : S_dom r Y ) :
  ll Y >= 1 .
Proof .
  exact ( natgthtogehsn _ _ ( S_dom_gt0 inn ) ) .

Defined.

Lemma isaprop_S_dom { BB : lBsystem_carrier } ( r : Tilde BB ) ( Y : BB ) :
  isaprop ( S_dom r Y ) .
Proof.
  apply isaprop_isabove .
Defined.

Lemma noparts_S_dom { BB : lBsystem_carrier } { r : Tilde BB } { Y : BB }
      ( inn1 inn2 : S_dom r Y ) : inn1 = inn2 .
Proof .
  apply ( proofirrelevance _ ( isaprop_S_dom r Y ) ) .
Defined .

(** *** The type objects of which are candidates for operations S on an lB-system. *)

Definition S_ops_type ( BB : lBsystem_carrier ) :=
  forall ( r : Tilde BB ) ( Y : BB ) ( inn : S_dom r Y ) , BB .

(** Notice that the indices in [BB] are not specified here, see [S_ax0_type] below. *)

Lemma S_equals_2 { BB : lBsystem_carrier } { r : Tilde BB } { Y Y' : BB } ( S : S_ops_type BB )
      ( eq : Y = Y' ) ( inn : S_dom r Y ) ( inn' : S_dom r Y' )  :
  S r Y inn = S r Y' inn' .
Proof.
  revert inn inn'.
  rewrite eq .
  intros . rewrite ( noparts_S_dom inn inn' ) .
  apply idpath .

Defined.

(** *** The zeroth property (later an axiom) of an operation of type S *)

Definition S_ax0_type { BB : lBsystem_carrier } ( S : S_ops_type BB ) :=
  forall ( r : Tilde BB ) ( Y : BB ) ( inn : S_dom r Y ) , ll ( S r Y inn ) = ll Y - 1 .

(** This definition gives the missing element of Definition 2.1.4(c) in arXiv:1410.5389v1 *)

Identity Coercion S_ax0_to_Fun: S_ax0_type >-> Funclass .

Lemma ll_S_gt0 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 :  S_ax0_type S )
      { r : Tilde BB } { X : BB } ( inn : S_dom r X ) : ll ( S r X inn ) > 0 .
Proof.
  rewrite ax0 .
  exact ( minusgth0 _ _ ( S_dom_gt1 inn ) ) .

Defined.

(** *** The first property (later an axiom) of an operation of type S *)

Definition S_ax1a_type { BB : lBsystem_carrier } ( S : S_ops_type BB ) :=
  forall ( r : Tilde BB ) ( Y : BB ) ( inn : S_dom r Y ) ( isab : isabove ( ft Y ) ( dd r ) ) ,
    ft ( S r Y inn ) = S r ( ft Y ) isab .

(** This definition corresponds to the first case in Definition 2.5.4 in arXiv:1410.5389v1.

Typo in the preprint: X comes from B{m+2} without tilde.
 *)

Identity Coercion S_ax1a_to_Fun: S_ax1a_type >-> Funclass .

Definition S_ax1b_type { BB : lBsystem_carrier } ( S : S_ops_type BB ) :=
  forall ( r : Tilde BB ) ( Y : BB ) ( inn : S_dom r Y ) ,
    isabove ( S r Y inn ) ( ft ( dd r ) ) .

(** This is not the second case in Definition 2.5.4 in arXiv:1410.5389v1 *)

Identity Coercion S_ax1b_to_Fun: S_ax1b_type >-> Funclass .

(** *** The computation of the iterated ft of ( S r Y ) .  *)

Lemma ftn_S { BB : lBsystem_carrier } { S : S_ops_type BB } ( ax1a : S_ax1a_type S )
      ( n : nat ) { r : Tilde BB } { Y : BB } ( isab : isabove ( ftn n Y ) ( dd r ) )
      ( inn : S_dom r Y ) :
  ftn n (S r Y inn ) = S r ( ftn n Y ) isab .
Proof .
  revert r Y isab inn. induction n as [ | n IHn ] .
  + intros .
    rewrite ( noparts_S_dom inn isab ) .
    apply idpath .
  + intros .
  change ( ftn (Preamble.S n) (S r Y inn) ) with ( ft ( ftn n (S r Y inn) ) ) .
  assert ( isab' : isabove ( ftn n Y ) ( dd r ) ) by exact ( isabove_ft_inv isab ) .
  rewrite ( IHn r Y isab' inn ) .
  use ax1a.
Defined.

(** Now get the second case in Definition 2.5.4 in arXiv:1410.5389v1 from [S_ax1b_type]

Typo in the preprint: Y there is undefined and should be replaced by dd(s).
*)

Lemma ft_S { BB : lBsystem_carrier } { S : S_ops_type BB } { r : Tilde BB } { Y : BB }
      ( ax0 : S_ax0_type S ) ( ax1b : S_ax1b_type S ) ( iseq : ft Y = dd r )
      ( inn : S_dom r Y ) : ft ( S r Y inn ) = ft ( dd r ) .
Proof.
  assert ( isov := ax1b r Y inn : isover ( S r Y inn ) ( ft ( dd r ) ) ) .
  unfold isover in isov .
  rewrite ll_ft in isov .  rewrite ax0 in isov . rewrite <- ll_ft  in isov .
  rewrite iseq in isov .
  assert ( int : (ll (dd r) - (ll (dd r) - 1)) = 1 ) . use natminusmmk.
  exact ( natgthtogehsn _ _ ( ll_dd _ ) ) .

  rewrite int in isov .
  exact ( ! isov ) .

Defined.

(** *** The isover and isabove properties of the expressions S r Y *)
(** We prove just monotonicity in the second argument with respect to [isover] and [isabove] *)

Lemma isover_S_S_2 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 :  S_ax0_type S ) ( ax1a : S_ax1a_type S )
      { r : Tilde BB } { Y Y' : BB } ( inn : S_dom r Y ) ( inn' : S_dom r Y' )
      ( is : isover Y Y' ) : isover ( S r Y inn ) ( S r Y' inn' ) .
Proof .
  unfold isover in * .
  do 2 rewrite ax0 .
  simpl .
  assert ( isab : isabove ( ftn ( ll Y - ll Y') Y ) ( dd r ) ) .
  rewrite <- is .
  exact inn' .

  rewrite ( natmiusmius1mminus1 ( S_dom_gt0 inn ) ( S_dom_gt0 inn' ) ) .
  rewrite ( ftn_S ax1a _ isab inn ) .
  exact ( S_equals_2 _ is _ _ ) .

Defined.

Lemma isabove_S_S_2 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 :  S_ax0_type S ) ( ax1a : S_ax1a_type S )
      { r : Tilde BB } { Y Y' : BB } ( inn : S_dom r Y ) ( inn' : S_dom r Y' )
      ( is : isabove Y Y' ) : isabove ( S r Y inn ) ( S r Y' inn' ) .
Proof .
  use isabove_constr.
  do 2 rewrite ax0 .
  use natgthandminusinvr.
  exact ( isabove_gth is ) .

  exact ( S_dom_ge1 inn' ) .

  exact ( isover_S_S_2 ax0 ax1a _ _ is ) .

Defined.

(** ** Operation(s) St (S tilde in the paper)  *)

(** *** Domains of definition of operations of type St *)

Definition St_dom { BB : lBsystem_carrier } ( r : Tilde BB ) ( s : Tilde BB ) :=
  S_dom r ( dd s ) .

(** Notice that r and s are interchanged w.r.t. Definition 2.1.4(d) in arXiv:1410.5389v1,
but not the order of arguments. *)

Identity Coercion St_dom_to_S_dom : St_dom >-> S_dom .

Notation St_dom_constr := S_dom_constr .
Notation St_dom_gth := S_dom_gth .

Lemma St_S_dom_comp { BB : lBsystem_carrier } { r s : Tilde BB } { Y : BB }
      ( innrs : St_dom r s ) ( inn : S_dom s Y ) : S_dom r Y .
Proof .
  exact ( isabove_trans inn innrs ) .

Defined.

Lemma St_St_dom_comp { BB : lBsystem_carrier } { r s t : Tilde BB }
      ( innrs : St_dom r s ) ( innst : St_dom s t ) : St_dom r t .
Proof .
  unfold St_dom in * .
  unfold S_dom in * .
  exact ( isabove_trans innst innrs ) .

Defined.

(** *** The type objects of which are candidates for operations St on an lB-system. *)

Definition St_ops_type ( BB : lBsystem_carrier ) :=
  forall ( r : Tilde BB ) ( s : Tilde BB ) ( inn : St_dom r s ) , Tilde BB .

(** Notice that the indices in [Tilde BB] are not specified here, see [St_ax0_type] below. *)

Identity Coercion St_ops_to_Fun: St_ops_type >-> Funclass .

(** *** The zeroth property (later an axiom) of an operation of type St
It will be shown to be a corollary of the first property of St and the zeroth property of S.
However it is convenient to have it separately for the use in the definition of a pre-lB-system. *)

Definition St_ax0_type { BB : lBsystem_carrier } ( St : St_ops_type BB ) :=
  forall ( r s : Tilde BB ) ( inn : St_dom r s ) ,
    ll ( dd ( St r s inn ) ) = ll ( dd s ) - 1 .

(** *** The first property (later an axiom) of an operation of type St *)

Definition St_ax1_type { BB : lBsystem_carrier }
           ( S : S_ops_type BB )
           ( St : St_ops_type BB ) :=
  forall ( r : Tilde BB ) ( s : Tilde BB ) ( inn : St_dom r s ) ,
    dd ( St r s inn ) = S r ( dd s ) inn .

(** This definition corresponds to Definition 2.5.5 in arXiv:1410.5389v1 *)

Identity Coercion St_ax1_to_Fun: St_ax1_type >-> Funclass .

Lemma St_ax1_to_St_ax0 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S )
      { St : St_ops_type BB } ( ax1 : St_ax1_type S St ) : St_ax0_type St .
Proof .
  unfold St_ax0_type .
  intros .
  rewrite ax1 .
  exact ( ax0 _ _ _ ) .

Defined.

(** *** Implications of the zeroth and first properties of operations of type S and St that are required for the formulation of the properties StS and StSt *)
(** Those two announced properties have the unique name SS-condition in the paper. *)

Lemma ll_dd_St { BB : lBsystem_carrier } { S : S_ops_type BB } { St : St_ops_type BB }
      ( ax0 : S_ax0_type S ) ( ax1 : St_ax1_type S St )
      { r s : Tilde BB } ( inn : St_dom r s ) :
  ll ( dd ( St r s inn ) ) = ll ( dd s ) - 1 .
Proof .
  rewrite ax1 .
  exact ( ax0 _ _ inn ) .

Defined .

Lemma S_dom_rs_sY_to_Strs_SrY { BB : lBsystem_carrier } { S : S_ops_type BB }
           ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S )
           { St : St_ops_type BB } ( ax1t : St_ax1_type S St )
           { r s : Tilde BB } { Y : BB } ( innrs : St_dom r s ) ( inn : S_dom s Y ) :
  S_dom ( St r s innrs ) ( S r Y ( St_S_dom_comp innrs inn ) ) .
Proof .
  unfold S_dom .
  rewrite ax1t .
  exact ( isabove_S_S_2 ax0 ax1a _ _ inn ) .

Defined.

Lemma S_dom_rs_sY_to_r_SsY { BB : lBsystem_carrier } { S : S_ops_type BB }
      ( ax1b : S_ax1b_type S ) { r s : Tilde BB } { Y : BB }
      ( innrs : St_dom r s ) ( inn : S_dom s Y ) :
  S_dom r ( S s Y inn ) .
Proof .
  unfold S_dom .
  use ( isabov_trans ( ax1b _ _ _ ) ) .
  exact ( isover_ft' innrs ) .

Defined.

Lemma  St_dom_rs_st_to_Strs_Strt { BB : lBsystem_carrier } { S : S_ops_type BB }
           ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S )
           { St : St_ops_type BB } ( ax1t : St_ax1_type S St )
           { r s t : Tilde BB } ( innrs : St_dom r s ) ( innst : St_dom s t ) :
  St_dom ( St r s innrs ) ( St r t ( St_St_dom_comp innrs innst ) ) .
Proof .
  unfold St_dom .
  rewrite ax1t .
  exact ( S_dom_rs_sY_to_Strs_SrY ax0 ax1a ax1t innrs innst ) .

Defined.

Lemma St_dom_rs_st_to_r_Stst { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax1b : S_ax1b_type S )
      { St : St_ops_type BB } ( ax1t : St_ax1_type S St )
      { r s t : Tilde BB } ( innrs : St_dom r s ) ( innst : St_dom s t ) :
  St_dom r ( St s t innst ) .
Proof .
  unfold St_dom .
  rewrite ax1t .
  exact ( S_dom_rs_sY_to_r_SsY ax1b innrs innst ) .

Defined.

(** Property SSt *)

Definition SSt_type { BB : lBsystem_carrier } { S : S_ops_type BB }
           ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
           { St : St_ops_type BB } ( ax1t : St_ax1_type S St ) :=
  forall ( r s : Tilde BB ) ( Y : BB ) ( innrs : St_dom r s ) ( inn : S_dom s Y ) ,
    S ( St r s innrs ) ( S r Y ( St_S_dom_comp innrs inn ) )
      ( S_dom_rs_sY_to_Strs_SrY ax0 ax1a ax1t innrs inn ) =
    S r ( S s Y inn ) ( S_dom_rs_sY_to_r_SsY ax1b innrs inn ) .

(** This definition corresponds to Definition 3.1.2(a) in arXiv:1410.5389v1 *)

Identity Coercion SSt_to_Fun: SSt_type >-> Funclass .

(** Property StSt *)

Definition StSt_type { BB : lBsystem_carrier } { S : S_ops_type BB }
           ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
           { St : St_ops_type BB } ( ax1t : St_ax1_type S St ) :=
  forall ( r s t : Tilde BB ) ( innrs : St_dom r s ) ( innst : St_dom s t ) ,
    St ( St r s innrs ) ( St r t ( St_St_dom_comp innrs innst ) )
      ( St_dom_rs_st_to_Strs_Strt ax0 ax1a ax1t innrs innst ) =
    St r ( St s t innst ) ( St_dom_rs_st_to_r_Stst ax1b ax1t innrs innst ) .

(** This definition corresponds to Definition 3.1.2(b) in arXiv:1410.5389v1 *)

Identity Coercion StSt_to_Fun: StSt_type >-> Funclass .

(* End of the file S_St.v *)


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

Require Import CoRN.algebra.CSetoids.
Require Import CoRN.algebra.CSemiGroups.
Require Import CoRN.algebra.CMonoids.
Require Import CoRN.algebra.CGroups.
Require Import CoRN.tactics.CornTac.
Require Import CoRN.algebra.CAbGroups.
Require Import CoRN.algebra.CRings.
Require Import CoRN.algebra.CFields.
Require Import CoRN.algebra.COrdFields.
Require Import CoRN.reals.CReals.
Require Import Coq.Reals.RIneq.
Require Import Coq.Reals.Rcomplete.
Require Import Coq.Reals.Rlimit.
Require Import Coq.Reals.Rbasic_fun.
From Coq Require Import Lra.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Open Scope R_scope.

(** * Coq Real Numbers

 Warning: The Coq real numbers depend on classical logic.  Importing this
 module will give you classical logic, the axioms of Coq's real number
 structure, plus all the logical consquences of these axioms.  To avoid
 these consequences, use CoRN's real number structure [IR] instead.

 Here we show that the real numbers from the Coq standard library form
 a real number structure.  This is done in the usual way by building up
 the algebraic heirarchy. *)

(** ** Coq real numbers form a setoid *)

Lemma R_is_CSetoid: is_CSetoid R (@eq R) (fun x y : R => x <> y).
Proof.
 constructor.
    unfold irreflexive.
    intros x H.
    apply H; reflexivity.
   unfold Csymmetric.
   intros x y H.
   auto.
  unfold cotransitive.
  intros x y H z.
  elim (total_order_T x z); intro H1.
   elim H1; intro H2.
    left.
    apply Rlt_not_eq; assumption.
   right.
   rewrite <- H2.
   assumption.
  left.
  apply Rgt_not_eq; assumption.
 unfold tight_apart.
 intros x y.
 constructor.
  intro xy.
  elim (total_order_T x y); intro H1.
   elim H1; clear H1; intro H2.
    exfalso.
    apply xy.
    apply Rlt_not_eq; assumption.
   assumption.
  exfalso.
  apply xy.
  apply Rgt_not_eq; assumption.
 intros H H0.
 apply H0; assumption.
Qed.

Definition RCSetoid : CSetoid := Build_CSetoid R (@eq R) (fun x y => x <> y) R_is_CSetoid.
Canonical Structure RCSetoid.
Canonical Structure RSetoid := cs_crr RCSetoid.

(** ** Coq real numbers form a semigroup *)

(** addition *)

Lemma RPlus_is_setoid_bin_fun: bin_fun_strext RCSetoid RCSetoid RCSetoid Rplus.
Proof.
 unfold bin_fun_strext.
 intros x1 x2 y1 y2 H.
 elim (total_order_T x1 x2); intro H1.
  elim H1; clear H1; intro H2.
   left.
   apply: Rlt_not_eq; assumption.
  right.
  intro H0.
  apply H.
  rewrite H2.
  rewrite H0.
  reflexivity.
 left.
 apply: Rgt_not_eq; assumption.
Qed.

Definition RPlus_sbinfun : CSetoid_bin_op RCSetoid := Build_CSetoid_bin_op RCSetoid Rplus RPlus_is_setoid_bin_fun.

Lemma R_is_CSemiGroup : is_CSemiGroup RCSetoid RPlus_sbinfun.
Proof.
 unfold is_CSemiGroup.
 unfold associative.
 intros x y z.
 apply eq_symmetric.
 apply Rplus_assoc.
Qed.

Definition RSemiGroup : CSemiGroup := Build_CSemiGroup RCSetoid RPlus_sbinfun R_is_CSemiGroup.
Canonical Structure RSemiGroup.

(** ** Coq real numbers form a monoid *)

Lemma R_is_CMonoid : is_CMonoid RSemiGroup (0%R).
Proof.
 constructor.
  unfold is_rht_unit.
  intro x.
  apply Rplus_0_r.
 unfold is_lft_unit.
 apply Rplus_0_l.
Qed.

Definition RMonoid : CMonoid := Build_CMonoid _ _ R_is_CMonoid.
Canonical Structure RMonoid.

(** ** Coq real numbers form a group *)

(** negation *)

Lemma RNeg_sunop : fun_strext (S1:=RCSetoid) (S2:=RCSetoid) Ropp.
Proof.
 unfold fun_strext.
 intros x y H H0.
 apply H.
 rewrite H0.
 reflexivity.
Qed.

Definition RNeg_op : CSetoid_un_op RMonoid := Build_CSetoid_un_op RCSetoid Ropp RNeg_sunop.

Lemma R_is_Group : is_CGroup RMonoid RNeg_op.
Proof.
 unfold is_CGroup.
 intro x.
 unfold is_inverse.
 split.
  apply Rplus_opp_r.
 apply Rplus_opp_l.
Qed.

Definition RGroup := Build_CGroup _ _ R_is_Group.
Canonical Structure RGroup.

(** ** Coq real numbers form an abelian group *)

Lemma R_is_AbGroup : is_CAbGroup RGroup.
Proof.
 unfold is_CAbGroup.
 unfold commutes.
 intros x y.
 apply Rplus_comm.
Qed.

Definition RAbGroup := Build_CAbGroup _ R_is_AbGroup.
Canonical Structure RAbGroup.

(** ** Coq real numbers form a ring *)

(** multiplication *)

Lemma RMul_is_csbinop : bin_fun_strext RCSetoid RCSetoid RCSetoid Rmult.
Proof.
 unfold bin_fun_strext.
 intros x1 x2 y1 y2 H.
 elim (total_order_T x1 x2); intro H1.
  elim H1; clear H1; intro H2.
   left.
   apply: Rlt_not_eq; assumption.
  right.
  Focus 2.
 left.
 apply: Rgt_not_eq; assumption.
 intro H0.
 apply H.
 rewrite H0.
 rewrite H2.
 reflexivity.
Qed.

Definition RMul_op : CSetoid_bin_op RMonoid := Build_CSetoid_bin_op RCSetoid Rmult RMul_is_csbinop.

Lemma RMul_assoc : associative (S:=RAbGroup) RMul_op.
Proof.
 unfold associative.
 intros x y z.
 apply eq_symmetric.
 apply Rmult_assoc.
Qed.

Lemma R_is_Ring : is_CRing RAbGroup (1%R) RMul_op.
Proof.
 exists RMul_assoc.
    constructor.
     unfold is_rht_unit; intro x.
     apply Rmult_1_r.
    unfold is_lft_unit; intro x.
    apply Rmult_1_l.
   unfold commutes.
   apply Rmult_comm.
  unfold distributive; intros x y z.
  apply Rmult_plus_distr_l.
 apply R1_neq_R0.
Qed.

Definition RRing := Build_CRing _ _ _ R_is_Ring.
Canonical Structure RRing.

(** ** Coq real numbers form a field *)

(** reciprocal *)

Definition Rrecip : forall x : RRing, x [#] [0] -> RRing := fun x _ => Rinv x.

Lemma R_is_Field : is_CField RRing Rrecip.
Proof.
 constructor.
  apply Rinv_r.
  assumption.
 apply Rinv_l.
 assumption.
Qed.

Lemma R_is_Field2: forall (x y : RRing) (x_ : x[#][0]) (y_ : y[#][0]),
   Rrecip x x_[#]Rrecip y y_ -> x[#]y.
Proof.
 intros x y x1 y1 H.
 intro.
 apply H.
 clear H.
 unfold Rrecip.
 rewrite H0.
 trivial.
Qed.

Definition RField : CField := Build_CField _ _ R_is_Field R_is_Field2.
Canonical Structure RField.

(** ** Coq real numbers form an ordered field *)

(** less-than *)

Lemma Rlt_strext : Crel_strext RField Rlt.
Proof.
 unfold Crel_strext.
 intros x1 x2 y1 y2 H.
 elim (total_order_T x2 y2); intro H1.
  elim H1; clear H1; intro H2.
   left; assumption.
  right.
  elim (total_order_T x1 x2); intro H1.
   elim H1; clear H1; intro H3.
    left.
    apply: Rlt_not_eq; assumption.
   right.
   rewrite <- H2.
   rewrite <- H3.
   apply: Rgt_not_eq; assumption.
  left.
  apply: Rgt_not_eq; assumption.
 right.
 elim (total_order_T x1 x2); intro H2.
  elim H2; clear H2; intro H3.
   left; apply: Rlt_not_eq; assumption.
  right.
  apply: Rgt_not_eq.
  apply Rgt_trans with x1.
   assumption.
  rewrite H3; assumption.
 left; apply: Rgt_not_eq; assumption.
Qed.

Definition Rless_rel : CCSetoid_relation RField := Build_CCSetoid_relation RField Rlt Rlt_strext.

(** greater-than *)

Lemma Rgt_strext : Crel_strext RField Rgt.
Proof.
 intros x1 x2 y1 y2.
 pose (G := Rlt_strext y1 y2 x1 x2).
 tauto.
Qed.

Definition Rgt_rel : CCSetoid_relation RField := Build_CCSetoid_relation RField Rgt Rgt_strext.

Lemma R_is_OrdField : is_COrdField RField Rless_rel Rle Rgt_rel Rge.
Proof.
 constructor.
       constructor.
        unfold Ctransitive.
        apply Rlt_trans.
       unfold CSetoids.antisymmetric.
       apply Rlt_asym.
      intros x y xy z.
      apply Rplus_lt_compat_r.
      assumption.
     intros x y x0 y0.
     apply Rmult_gt_0_compat; assumption.
    intros x y.
    constructor.
     intro xy.
     elim (total_order_T x y); intro H2.
      elim H2; clear H2; intro H3.
       left; assumption.
      exfalso; apply xy; assumption.
     right; assumption.
    intro H; destruct H.
     apply: Rlt_not_eq; assumption.
    apply: Rgt_not_eq; assumption.
   intros x y.
   simpl in *.
   unfold Not; split.
    intros; lra.
   intro.
   apply Rnot_lt_le.
   assumption.
  auto with *.
 auto with *.
Qed.

Definition ROrdField : COrdField := Build_COrdField _ _ _ _ _ R_is_OrdField.
Canonical Structure ROrdField.

(** ** Coq real numbers form a real number structure *)

Lemma cauchy_prop_cauchy_crit : (CauchySeq ROrdField) ->
  forall s : (nat -> ROrdField), (Cauchy_prop (R:=ROrdField) s) -> (Rseries.Cauchy_crit s).
Proof.
 intros x seq cprop.
 unfold Cauchy_prop in cprop.
 unfold Rseries.Cauchy_crit.
 intros eps epsgt.
 elim (cprop ((eps / 2 / 2)%R) (eps2_Rgt_R0 _ (eps2_Rgt_R0 _ epsgt))).
 intros N NProp.
 exists N.
 intros n m ngt mgt.
 assert (AbsSmall (eps / 2) ((seq n) - (seq m)) )%R.
  stepr ((seq n - seq N) + (seq N - seq m))%R.
   stepl (eps / 2 / 2 + eps / 2 / 2)%R.
    apply AbsSmall_plus.
     apply NProp; assumption.
    apply (AbsSmall_minus).
    apply NProp; assumption.
   simpl; field.
  simpl; ring.
 destruct H.
 unfold Rfunctions.R_dist.
 apply Rabs_def1.
  clear - H0 epsgt.
  simpl in *.
  lra.
 clear - H epsgt.
 simpl in *.
 lra.
Qed.

(** limit *)

Definition RLim : CauchySeq ROrdField -> ROrdField.
Proof.
 intro x.
 elim x.
 intros seq cprop.
 cut (Rseries.Cauchy_crit seq).
  intro crit.
  elim (R_complete seq crit).
  intros lim uncv.
  exact lim.
 apply (cauchy_prop_cauchy_crit x).
 exact cprop.
Defined.

(** INR is isomorphic to nring *)

Lemma R_INR_as_IR : forall n : nat, INR n = nring (R:=RRing) n.
Proof.
 induction n.
  simpl; trivial.
 induction n.
  simpl; auto with *.
 simpl in *.
 rewrite IHn.
 trivial.
Qed.

#[global]
Hint Rewrite R_INR_as_IR : RtoIR.

Lemma RisReals : is_CReals ROrdField RLim.
Proof.
 constructor.
  intros [s hs].
  unfold SeqLimit.
  unfold RLim.
  intros e e0.
  simpl.
  destruct (R_complete s ((cauchy_prop_cauchy_crit (Build_CauchySeq ROrdField s hs) s hs))).
  unfold Rseries.Un_cv in u.
  simpl in *.
  destruct (hs (e/4)) as [N HN].
   simpl.
   lra.
  exists N.
  intros m Hm.
  destruct (u (e/2)).
   lra.
  set (z:=max x0 m).
  rstepr (((s m[-]s N)[+](s N[-]s z))[+](s z[-]x)).
  apply AbsSmall_eps_div_two.
   apply AbsSmall_eps_div_two.
    stepl (e/4).
     apply HN; auto.
    change (e / 4 = e * / (0 + 1 + 1) * / (0 + 1 + 1)).
    field.
   apply AbsSmall_minus.
   stepl (e/4).
    unfold z.
    apply HN; eauto with *.
   change (e / 4 = e * / (0 + 1 + 1) * / (0 + 1 + 1)).
   field.
  assert (Hz:(z >= x0)%nat).
   unfold z; eauto with *.
  destruct (Rabs_def2 _ _ (H _ Hz)) as [A0 A1].
  stepl (e/2).
   split; unfold cg_minus; simpl; auto with *.
  change (e / 2 = e * / (0 + 1 + 1)).
  field.
 intro x.
 exists (Z.abs_nat (up x)).
 unfold Z.abs_nat.
 elim (archimed x).
 destruct (up x).
   simpl; intros; lra.
  rewrite <- positive_nat_Z.
  intros H _.
  apply Rlt_le.
  rewrite <- R_INR_as_IR.
  now rewrite INR_IZR_INZ.
 intros I _.
 cut (x < 0%R).
  intro H; clear I.
  rewrite <- R_INR_as_IR.
  cut (0 <= INR (nat_of_P p)).
   intro.
   apply Rlt_le.
   lra.
  apply pos_INR.
 cut (0 <= INR (nat_of_P p)).
  rewrite INR_IZR_INZ.
  intro.
  change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))) in I.
  rewrite <- positive_nat_Z in I.
  lra.
 apply pos_INR.
Qed.

Definition RReals : CReals := Build_CReals ROrdField RLim RisReals.
Canonical Structure RReals.


(** Examples for TAL-0: Control-Flow-Safety *)

Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import TAL.Maps.
Require Import TAL.TAL0.Eval.
Require Import TAL.TAL0.Syntax.
Require Import TAL.TAL0.TypeSyntax.
Require Import TAL.TAL0.TypeSystem.
Import ListNotations.

(** * The TAL-0 Examples *)
(*-----------------------*)

(** An example of a TAL-0 program:
<<
prod: r3 := 0;           // res := 0
      jump loop

loop: if r1 jump done;   // if a = 0 goto done
      r3 := r3 + r2;     // res := res + b
      r1 := r1 + -1;     // a := a - 1
      jump loop

done: jump r4            // return
>>
*)

Definition lbl_prod : nat := 1.
Definition lbl_loop : nat := 2.
Definition lbl_done : nat := 3.
Definition lbl_exit : nat := 4.

Definition reg_1 : nat := 1.
Definition reg_2 : nat := 2.
Definition reg_3 : nat := 3.
Definition reg_4 : nat := 4.

Definition iseq_prod : instr_seq :=
  R(reg_3) := 0;;
  JMP lbl_loop.
Definition iseq_loop : instr_seq :=
  JIF R(reg_1) lbl_done;;
  R(reg_3) +:= R(reg_2);;
  R(reg_1) +:= -1;;
  JMP lbl_loop.
Definition iseq_done : instr_seq :=
  JMP R(reg_4).

(** The initial heap:
<<
H = {prod = iseq_prod, loop = iseq_loop, done = iseq_done}
>>
*)

Definition init_heap : heap :=
  fold_right (fun p H => p_update H (Id (fst p)) (snd p))
             empty_heap
             [(lbl_prod, iseq_prod); (lbl_loop, iseq_loop);
              (lbl_done, iseq_done)].

(** The initial register file:
<<
R_0 = {r_1 = 2, r_2 = 2, r_3 = 0, r_4 = exit, …}
>>
*)

Definition init_regs : regs :=
  fold_right (fun p R => t_update R (Id (fst p)) (snd p))
             empty_regs
             [(reg_1, RNum (Z.two)); (reg_2, RNum (Z.two));
              (reg_3, RNum (Z.zero)); (reg_4, RLbl (lbl_exit))].

(** The initial machine state:
<<
M_0 = (H, R_0, jump prod)
>>
*)

Definition init_mstate : mstate := MSt init_heap init_regs (JMP lbl_prod).

(** Check whether the execution successfully terminates after thirteen steps: *)

Example ex_mseval_succ :
  mseval_n 13 init_mstate = ESSucc.
Proof.
  simpl.
  reflexivity.
Qed.

(** Check whether the execution terminates with the expected result: *)

Example ex_mseval_res :
  match mseval_n 12 init_mstate with
    | ESTrans (MSt _ R (JMP R(4))) => Some (R (Id reg_3))
    | _                            => None
  end = Some (RNum (Z.of_nat 4)).
Proof.
  simpl.
  unfold t_update.
  simpl.
  reflexivity.
Qed.

(** Check whether the [loop] label is reached: *)

Example ex_mseval_prop_jump_to_loop :
  mseval_prop_n init_mstate (MSt init_heap init_regs iseq_loop).
Proof.
  unfold init_mstate.
  apply R_Seq2 with (ms' := MSt init_heap init_regs iseq_prod).
  - eapply R_Jump; reflexivity.
  - apply R_Seq2 with (ms' := MSt init_heap init_regs (JMP lbl_loop)).
    + unfold iseq_prod.
      eapply R_Mov.
      * reflexivity.
      * rewrite t_update_same.
        reflexivity.
    + apply R_Seq1.
      eapply R_Jump; reflexivity.
Qed.

(** Let us verify that the instruction sequence associated with [loop] is
    indeed well-formed with the type that we have assigned it.
*)

(** The register file type:
<<
Γ = {r_1 : int, r_2 : int, r_3 : int,
     r_4 : ∀α.code{r_1 : int, r_2 : int, r_3 : int, r_4 : α}, …}
>>
*)

Definition gamma_reg_4 : ty_map :=
  ty_update_list empty_ty_map [(reg_1, int); (reg_2, int); (reg_3, int);
                               (reg_4, TAlpha 0)].

Definition gamma : ty_map :=
  ty_update_list empty_ty_map [(reg_1, int); (reg_2, int); (reg_3, int);
                               (reg_4, ∀0.>code(gamma_reg_4))].

(** The heap type:
<<
Ψ = {prod : code(Γ), loop : code(Γ), done : code(Γ),
     exit : ∀α.code{r_1 : int, r_2 : int, r_3 : int, r_4 : α}}
>>
*)

Definition psi : ty_map :=
  ty_update_list empty_ty_map [(lbl_prod, code(gamma)); (lbl_loop, code(gamma));
                               (lbl_done, code(gamma));
                               (lbl_exit, ∀0.>code(gamma_reg_4))].

Example ex_loop_type_check :
  instr_seq_has_type (PsiCtx psi) iseq_loop code(gamma).
Proof.
  unfold iseq_loop.
  eapply S_Seq.
  - apply S_If.
    + apply S_Reg.
      reflexivity.
    + apply S_Val.
      apply S_Lab.
      reflexivity.
  - eapply S_Seq.
    + apply S_Add.
      * apply S_Reg.
        reflexivity.
      * apply S_Reg.
        reflexivity.
      * reflexivity.
    + eapply S_Seq.
      * apply S_Add.
        -- apply S_Reg.
           reflexivity.
        -- apply S_Val.
           apply S_Int.
        -- reflexivity.
      * apply S_Jump.
        apply S_Val.
        apply S_Lab.
        reflexivity.
Qed.

Example ex_loop_type_check_b :
  match instr_seq_type (PsiCtx psi) gamma iseq_loop with
    | Some code(Γ) => beq_ty_map gamma Γ
    | _            => false
  end = true.
Proof.
  simpl.
  reflexivity.
Qed.

(** Let us verify that the register file from above is well-formed with the
    register file type that we have assigned it.
*)

Example ex_regs_type_check_b :
  regs_typed (PsiCtx psi) gamma init_regs = true.
Proof.
  simpl.
  reflexivity.
Qed.

(** Let us verify that the heap from above is well-formed with the heap type
    that we have assigned it.
*)

Example ex_heap_type_check_b :
  heap_typed psi gamma init_heap = true.
Proof.
  unfold heap_typed.
  simpl.
  reflexivity.
Qed.

(** Let us verify that the machine state from above is well-formed with the heap
    type and register file type that we have assigned it.
*)

Example ex_mstate_type_check_b :
  mstate_ok_b psi gamma init_mstate = true.
Proof.
  simpl.
  reflexivity.
Qed.

(** Check whether the register file type from above contains no free type
    variables:
*)

Example ex_ftv_null_b_gamma :
  ftv_null_b code(gamma) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example ex_ftv_null_gamma :
  ftv_null code(gamma).
Proof.
  apply FTV_Code.
  intros l.
  repeat (destruct l; try apply FTV_Int).
  simpl.
  apply FTV_ForAll.
  simpl.
  apply FTV_Code.
  intros l.
  repeat (destruct l; try apply FTV_Int).
Qed.


From Coq Require Import Strings.String.

Inductive ty : Type :=
  | Bool  : ty
  | Nat   : ty
  | List  : ty -> ty
  | Arrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test0 : tm -> tm -> tm -> tm
  | test : tm -> tm -> tm -> tm

  (* basic STLC *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm

  (* Boolean comparison *)
  | BBool : bool -> tm
  | BEq : tm -> tm -> tm
  | BGe : tm -> tm -> tm
  | BNot : tm -> tm
  | BAnd : tm -> tm -> tm

  (* Chaining comparison *)
  | CBGe : tm -> tm -> tm -> tm
  | Ctest : tm -> tm -> tm -> tm -> tm -> tm

  (* generator *)
  | gen : tm -> tm -> tm
  | genob : tm -> tm
  | next : tm -> tm

  (* numbers *)
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm

  (* lists *)
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | LHead : tm -> tm

  (* fix *)
  | tfix  : tm -> tm.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).
Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Fixpoint beq_nat n m :=
  match n, m  with
    | O, O => true
    | O, _ => false
    | S n', O => false
    | S n', S m' => beq_nat n' m'
  end.

Fixpoint ble_nat n m  :=
  match n, m  with
    | O, _ => true
    | S n', O => false
    | S n', S m' => ble_nat n' m'
  end.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  (* boolean *)
  | tru => tru
  | fls => fls

  | test0 t1 t2 t3 =>
      test0 (subst x s t1) (subst x s t2) (subst x s t3)
  | test t1 t2 t3 =>
      test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)

  (* pure STLC *)
  | 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)

  (* boolean operation *)
  | BEq t1 t2 => BEq (subst x s t1) (subst x s t2)
  | BGe t1 t2 => BGe (subst x s t1) (subst x s t2)
  | BNot t1 => BNot (subst x s t1)
  | BAnd t1 t2 => BAnd (subst x s t1) (subst x s t2)

  (* chaining comparison *)
  | CBGe t1 t2 t3 =>
      CBGe (subst x s t1) (subst x s t2) (subst x s t3)
  | Ctest t1 t2 t3 t4 t5 =>
      Ctest (subst x s t1) (subst x s t2) (subst x s t3) (subst x s t4) (subst x s t5)

  (* generator *)
  | gen t1 t2 => gen (subst x s t1) (subst x s t2)
  | genob t1 => genob (subst x s t1)
  | next t1 => next (subst x s t1)

  (* numbers *)
  | const n =>
      const n
  | scc t1 =>
      scc (subst x s t1)
  | prd t1 =>
      prd (subst x s t1)

  (* lists *)
  | tnil T => tnil T
  | tcons t1 t2 => tcons (subst x s t1) (subst x s t2)
  | LHead t1 => LHead (subst x s t1)

  | tfix t1 => tfix (subst x s t1)

  (* unit *)
  | unit => unit
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive value : tm -> Prop :=
  (* basic pure STLC values*)
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)

  (* Numbers are values: *)
  | v_nat : forall n1,
      value (const n1)

  (* A list is a value iff its head and tail are values: *)
  | v_lnil : forall T, value (tnil T)
  | v_lcons : forall v1 vl,
      value v1 ->
      value vl ->
      value (tcons v1 vl).

Reserved Notation "t1 '-->' t2" (at level 40).
Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive step : tm -> tm -> Prop :=
  (* pure STLC *)
  | 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')

  (* Test nat and Test bool *)
  | ST_Test1 : forall t1 t1' t2 t3,
       t1 --> t1' ->
       test0 t1 t2 t3 --> test0 t1' t2 t3
  | ST_TestZero : forall t2 t3,
       (test0 (const 0) t2 t3) --> t2
  | ST_TestNonzero : forall n t2 t3,
       (test0 (const (S n)) t2 t3) --> t3

  | ST_TestTru : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_TestFls : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3

  (* Boolean operations *)
  | ST_BEq : forall t1 t1' t2,
              t1 --> t1' ->
              BEq t1 t2 --> BEq t1' t2
  | ST_BEqNat : forall n1 n2,
              BEq (const n1) (const n2) --> BBool(beq_nat n1 n2)
  | ST_BEqString : forall s1 s2,
              (BEq (var s1) (var s2)) --> BBool(eqb_string s1 s2)
  | ST_BEqVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                (BEq v1 t2) --> (BEq v1 t2')

  | ST_BGe : forall t1 t1' t2,
              t1 --> t1' ->
              BGe t1 t2 --> BGe t1' t2
  | ST_BGeVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                (BGe v1 t2) --> (BGe v1 t2')
  | ST_BGeConst:  forall n1 n2,
                  BGe (const n1) (const n2) --> BBool(ble_nat n2 n1)

  | ST_BNot : forall t1 t1',
              t1 --> t1' ->
              BNot t1 --> BNot t1'
  | ST_BNotVal: forall b1,
                BNot (BBool b1) --> BBool(negb b1)

  | ST_BAnd : forall t1 t1' t2,
              t1 --> t1' ->
              BAnd t1 t2 --> BAnd t1' t2
  | ST_BAndBool: forall b1 b2,
                BAnd (BBool b1) (BBool b2) --> BBool(andb b1 b2)
  | ST_BAndVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                BAnd v1 t2 --> BAnd v1 t2'

  (* chaining comparison *)
  | ST_CBGe : forall t1 t1' t2 t3,
              t1 --> t1' ->
              CBGe t1 t2 t3 --> CBGe t1' t2 t3
  | ST_CBGeVal1: forall v1 t2 t2' t3,
                value v1 ->
                t2 --> t2' ->
                CBGe v1 t2 t3 --> CBGe v1 t2' t3
  | ST_CBGeVal2: forall v1 v2 t2 t3 t3',
                value v1 ->
                value v2 ->
                t3 --> t3' ->
                CBGe v1 t2 t3 --> CBGe v1 t2 t3'
  | ST_CBGeConst: forall n1 n2 n3,
                  CBGe (const n1) (const n2) (const n3) --> BAnd(BGe (const n1) (const n2)) (BGe (const n2) (const n3))

  | ST_CTest : forall t1 t2 t3 t4 t5,
      Ctest t1 t2 t3 t4 t5 --> test (CBGe t1 t2 t3) t4 t5

  (* numbers *)
  | ST_Succ : forall t1 t1',
       t1 --> t1' ->
       (scc t1) --> (scc t1')
  | ST_SuccNat : forall n1,
       (scc (const n1)) --> (const (S n1))
  | ST_Pred : forall t1 t1',
       t1 --> t1' ->
       (prd t1) --> (prd t1')
  | ST_PredNat : forall n1,
       (prd (const n1)) --> (const (pred n1))

  (* lists *)
  | ST_Cons1 : forall t1 t1' t2,
       t1 --> t1' ->
       (tcons t1 t2) --> (tcons t1' t2)
  | ST_Cons2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (tcons v1 t2) --> (tcons v1 t2')
  | ST_Head : forall t1 t1',
              t1 --> t1'->
              LHead t1 --> LHead t1'
  | ST_HeadVal : forall h1 l1,
              value h1->
              LHead (tcons h1 l1)--> h1

  (* recursive functions *)
  | ST_Fix1 : forall t1 t1',
         t1 --> t1' ->
         (tfix t1) --> (tfix t1')
  | ST_FixAbs : forall y T t1,
         (tfix (abs y T t1)) --> [y:=(tfix (abs y T t1))]t1
  | ST_AppFunc : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12

  (* Generator *)
  | ST_Gen1 : forall t1 t1' t2,
              t1 --> t1' ->
              gen t1 t2 --> gen t1' t2

  | ST_Gen2 : forall v1 t2 t2',
              value v1 ->
              t2 --> t2' ->
              gen v1 t2 --> gen v1 t2'

  | ST_Gen : forall v1 v2 t1 t2 f,
       value v1 -> value v2 ->
       gen (abs t1 Bool v1) (abs t2 Nat v2) -->
       tfix
        (abs f (Arrow (Arrow Bool Nat) (List Nat) )
          (abs t1 Bool
            (abs t2 Nat
              (test (var t1)
                (tcons (var t2)(
                  (test0 (var t2)
                    (app (var f)(app (fls)(const 0)))
                    (app (var f)(app (tru) (prd (var t2)) )) ) ) )
                (tnil Nat) ) ) ) )

  (* Generator Object *)
  | ST_Genob : forall t1 t1',
         t1 --> t1' ->
         genob t1 --> genob t1'
  | ST_GenobVal : forall v1,
         genob v1 --> v1

 (* Next Call to Generator Object *)
  | ST_Next : forall t1 t1',
       t1 --> t1' ->
       next t1 --> next t1'
  | ST_NextVal : forall v1,
       next v1 --> LHead (v1)

where "t1 '-->' t2" := (step t1 t2).


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (plus lv1 Zero)) (plus lv1 lv0)).
Admitted.
QuickChick conj14synthconj3.