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

 Cleaving properties

 There are several definitions of cleaving of bicategories, namely
 local (op)cleavings and global cleavings. If we assume that the
 involved (displayed) bicategories are univalent, then we can show
 that these notions are propositional

 Contents
 1. Propositionality of preservation of cartesian cells
 2. Propositionality of local (op)cleavings
 3. Propositionality of global cleavings

 ********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Cartesians.
Require Import UniMath.Bicategories.DisplayedBicats.EquivalenceBetweenCartesians.

Local Open Scope cat.

(**
 1. Propositionality of preservation of cartesian cells
 *)
Definition isaprop_lwhisker_cartesian
           {B : bicat}
           (D : disp_bicat B)
  : isaprop (lwhisker_cartesian D).
Proof.
  do 15 (use impred ; intro).
  apply isaprop_is_cartesian_2cell.
Qed.

Definition isaprop_rwhisker_cartesian
           {B : bicat}
           (D : disp_bicat B)
  : isaprop (rwhisker_cartesian D).
Proof.
  do 15 (use impred ; intro).
  apply isaprop_is_cartesian_2cell.
Qed.

Definition isaprop_lwhisker_opcartesian
           {B : bicat}
           (D : disp_bicat B)
  : isaprop (lwhisker_opcartesian D).
Proof.
  do 15 (use impred ; intro).
  apply isaprop_is_opcartesian_2cell.
Qed.

Definition isaprop_rwhisker_opcartesian
           {B : bicat}
           (D : disp_bicat B)
  : isaprop (rwhisker_opcartesian D).
Proof.
  do 15 (use impred ; intro).
  apply isaprop_is_opcartesian_2cell.
Qed.

(**
 2. Propositionality of local (op)cleavings
 *)
Definition isaprop_local_cleaving
           {B : bicat}
           (HB : is_univalent_2_1 B)
           (D : disp_bicat B)
           (HD : disp_univalent_2_1 D)
  : isaprop (local_cleaving D).
Proof.
  use (isofhlevelweqb 1 (local_fib_weq_local_cleaving D)).
  use impred ; intro x.
  use impred ; intro y.
  use impred ; intro xx.
  use impred ; intro yy.
  use (@isaprop_cleaving (univ_hom HB x y)).
  use is_univalent_disp_disp_hom.
  exact HD.
Defined.

Definition isaprop_local_opcleaving
           {B : bicat}
           (HB : is_univalent_2_1 B)
           (D : disp_bicat B)
           (HD : disp_univalent_2_1 D)
  : isaprop (local_opcleaving D).
Proof.
  use (isofhlevelweqb 1 (local_opfib_weq_local_opcleaving D)).
  unfold local_opfib.
  use impred ; intro x.
  use impred ; intro y.
  use impred ; intro xx.
  use impred ; intro yy.
  use (isofhlevelweqb 1 (opcleaving_weq_cleaving _)).
  use (@isaprop_cleaving (op_unicat (univ_hom HB x y))).
  apply is_univalent_op_disp_cat.
  apply is_univalent_disp_disp_hom.
  exact HD.
Defined.

(**
 3. Propositionality of global cleavings
 *)
Definition eq_cartesian_lift
           {B : bicat}
           (D : disp_bicat B)
           (HD : disp_univalent_2_1 D)
           {x y : B}
           {yy : D y}
           {f : x --> y}
           (ℓ₁ ℓ₂ : ∑ (xx : D x) (ff : xx -->[ f ] yy), cartesian_1cell D ff)
           (p₁ : pr1 ℓ₁ = pr1 ℓ₂)
           (p₂ : transportf (λ z, z -->[ f ] yy) p₁ (pr12 ℓ₁) = pr12 ℓ₂)
  : ℓ₁ = ℓ₂.
Proof.
  induction ℓ₁ as [ xx₁ [ ff₁ Hff₁ ]].
  induction ℓ₂ as [ xx₂ [ ff₂ Hff₂ ]].
  cbn in *.
  induction p₁ ; cbn in *.
  induction p₂ ; cbn in *.
  do 2 apply maponpaths.
  apply isaprop_cartesian_1cell.
  apply HD.
Defined.

Definition eq_cartesian_lift_from_adjequiv_transport
           {B : bicat}
           (HB : is_univalent_2 B)
           {D : disp_bicat B}
           (HD : disp_univalent_2 D)
           {x y : B}
           (f : x --> y)
           (yy : D y)
           {xx₁ xx₂ : D x}
           (p : xx₁ = xx₂)
           (ff : xx₂ -->[ f] yy)
  : transportb
      (λ z, z -->[ f ] yy)
      p
      ff
    =
    transportf
      (λ z, _ -->[ z ] _)
      (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell _))
      (disp_idtoiso_2_0 _ (idpath _) _ _ p ;; ff)%mor_disp.
Proof.
  induction p.
  cbn.
  refine (!_).
  refine (disp_isotoid_2_1
            _
            (pr2 HD)
            (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell f))
            _ _
            (transportf
               (λ z, disp_invertible_2cell z _ _)
               _
               (disp_invertible_2cell_lunitor ff))).
  use subtypePath.
  {
    intro.
    apply isaprop_is_invertible_2cell.
  }
  cbn.
  rewrite idtoiso_2_1_isotoid_2_1.
  apply idpath.
Qed.

Definition eq_cartesian_lift_from_adjequiv
           {B : bicat}
           (HB : is_univalent_2 B)
           (D : disp_bicat B)
           (HD : disp_univalent_2 D)
           {x y : B}
           {yy : D y}
           {f : x --> y}
           (ℓ₁ ℓ₂ : ∑ (xx : D x) (ff : xx -->[ f ] yy), cartesian_1cell D ff)
           (e : disp_adjoint_equivalence
                  (internal_adjoint_equivalence_identity x)
                  (pr1 ℓ₁)
                  (pr1 ℓ₂))
           (γ : disp_invertible_2cell
                  (lunitor_invertible_2cell _)
                  (e ;; pr12 ℓ₂)
                  (pr12 ℓ₁))
  : ℓ₁ = ℓ₂.
Proof.
  use eq_cartesian_lift.
  - apply HD.
  - exact (disp_isotoid_2_0 (pr1 HD) e).
  - pose (disp_isotoid_2_1
            _
            (pr2 HD)
            (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell _))
            _ _
            (transportb
               (λ z, disp_invertible_2cell z _ _)
               (idtoiso_2_1_isotoid_2_1 _ _)
               γ))
      as p.
    use (@transportf_transpose_left _ (λ z, z -->[ f ] yy)).
    refine (!_).
    refine (_ @ p) ; clear p.
    refine (eq_cartesian_lift_from_adjequiv_transport HB HD _ _ _ _ @ _).
    apply maponpaths.
    apply maponpaths_2.
    rewrite disp_idtoiso_2_0_isotoid_2_0.
    apply idpath.
Qed.

Definition isaprop_global_cleaving
           {B : bicat}
           (HB : is_univalent_2 B)
           (D : disp_bicat B)
           (HD : disp_univalent_2 D)
  : isaprop (global_cleaving D).
Proof.
  use impred ; intro x.
  use impred ; intro y.
  use impred ; intro xx.
  use impred ; intro f.
  use invproofirrelevance.
  intros ℓ₁ ℓ₂.
  use eq_cartesian_lift_from_adjequiv.
  - apply HB.
  - apply HD.
  - refine (map_between_cartesian_1cell (pr2 HB) (pr12 ℓ₁) (pr22 ℓ₂) ,, _).
    refine (transportf
              (λ z, disp_left_adjoint_equivalence z _)
              _
              (pr2 (disp_adj_equiv_between_cartesian_1cell (pr2 HB) (pr22 ℓ₁) (pr22 ℓ₂)))).
    use unique_internal_adjoint_equivalence.
    apply HB.
  - cbn.
    apply map_between_cartesian_1cell_commute.
Defined.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export NAdd.

Module NOrderProp (Import N : NAxiomsMiniSig').
Include NAddProp N.

(* Theorems that are true for natural numbers but not for integers *)

Theorem lt_wf_0 : well_founded lt.
Proof.
setoid_replace lt with (fun n m => 0 <= n < m).
apply lt_wf.
intros x y; split.
intro H; split; [apply le_0_l | assumption]. now intros [_ H].
Defined.

(* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *)

Theorem nlt_0_r : forall n, ~ n < 0.
Proof.
intro n; apply le_ngt. apply le_0_l.
Qed.

Theorem nle_succ_0 : forall n, ~ (S n <= 0).
Proof.
intros n H; apply le_succ_l in H; false_hyp H nlt_0_r.
Qed.

Theorem le_0_r : forall n, n <= 0 <-> n == 0.
Proof.
intros n; split; intro H.
le_elim H; [false_hyp H nlt_0_r | assumption].
now apply eq_le_incl.
Qed.

Theorem lt_0_succ : forall n, 0 < S n.
Proof.
induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r].
Qed.

Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n.
Proof.
cases n.
split; intro H; [now elim H | intro; now apply lt_irrefl with 0].
intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0].
Qed.

Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n.
Proof.
cases n.
now left.
intro; right; apply lt_0_succ.
Qed.

Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n.
Proof.
setoid_rewrite one_succ.
induct n. now left.
cases n. intros; right; now left.
intros n IH. destruct IH as [H | [H | H]].
false_hyp H neq_succ_0.
right; right. rewrite H. apply lt_succ_diag_r.
right; right. now apply lt_lt_succ_r.
Qed.

Theorem lt_1_r : forall n, n < 1 <-> n == 0.
Proof.
setoid_rewrite one_succ.
cases n.
split; intro; [reflexivity | apply lt_succ_diag_r].
intros n. rewrite <- succ_lt_mono.
split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0].
Qed.

Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1.
Proof.
setoid_rewrite one_succ.
cases n.
split; intro; [now left | apply le_succ_diag_r].
intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd.
split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]].
Qed.

Theorem lt_lt_0 : forall n m, n < m -> 0 < m.
Proof.
intros n m; induct n.
trivial.
intros n IH H. apply IH; now apply lt_succ_l.
Qed.

Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p.
Proof.
intros. apply lt_1_l with m; auto.
apply le_lt_trans with n; auto. now apply le_0_l.
Qed.

(** Elimination principlies for < and <= for relations *)

Section RelElim.

Variable R : relation N.t.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem le_ind_rel :
   (forall m, R 0 m) ->
   (forall n m, n <= m -> R n m -> R (S n) (S m)) ->
     forall n m, n <= m -> R n m.
Proof.
intros Base Step; induct n.
intros; apply Base.
intros n IH m H. elim H using le_ind.
solve_proper.
apply Step; [| apply IH]; now apply eq_le_incl.
intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto.
Qed.

Theorem lt_ind_rel :
   (forall m, R 0 (S m)) ->
   (forall n m, n < m -> R n m -> R (S n) (S m)) ->
   forall n m, n < m -> R n m.
Proof.
intros Base Step; induct n.
intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]].
rewrite H; apply Base.
intros n IH m H. elim H using lt_ind.
solve_proper.
apply Step; [| apply IH]; now apply lt_succ_diag_r.
intros k H1 H2. apply lt_succ_l in H1. auto.
Qed.

End RelElim.

(** Predecessor and order *)

Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n.
Proof.
intros n H; apply succ_pred; intro H1; rewrite H1 in H.
false_hyp H lt_irrefl.
Qed.

Theorem le_pred_l : forall n, P n <= n.
Proof.
cases n.
rewrite pred_0; now apply eq_le_incl.
intros; rewrite pred_succ;  apply le_succ_diag_r.
Qed.

Theorem lt_pred_l : forall n, n ~= 0 -> P n < n.
Proof.
cases n.
intro H; exfalso; now apply H.
intros; rewrite pred_succ;  apply lt_succ_diag_r.
Qed.

Theorem le_le_pred : forall n m, n <= m -> P n <= m.
Proof.
intros n m H; apply le_trans with n. apply le_pred_l. assumption.
Qed.

Theorem lt_lt_pred : forall n m, n < m -> P n < m.
Proof.
intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption.
Qed.

Theorem lt_le_pred : forall n m, n < m -> n <= P m.
 (* Converse is false for n == m == 0 *)
Proof.
intro n; cases m.
intro H; false_hyp H nlt_0_r.
intros m IH. rewrite pred_succ; now apply lt_succ_r.
Qed.

Theorem lt_pred_le : forall n m, P n < m -> n <= m.
 (* Converse is false for n == m == 0 *)
Proof.
intros n m; cases n.
rewrite pred_0; intro H; now apply lt_le_incl.
intros n IH. rewrite pred_succ in IH. now apply le_succ_l.
Qed.

Theorem lt_pred_lt : forall n m, n < P m -> n < m.
Proof.
intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l].
Qed.

Theorem le_pred_le : forall n m, n <= P m -> n <= m.
Proof.
intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l].
Qed.

Theorem pred_le_mono : forall n m, n <= m -> P n <= P m.
 (* Converse is false for n == 1, m == 0 *)
Proof.
intros n m H; elim H using le_ind_rel.
solve_proper.
intro; rewrite pred_0; apply le_0_l.
intros p q H1 _; now do 2 rewrite pred_succ.
Qed.

Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m).
Proof.
intros n m H1; split; intro H2.
assert (m ~= 0). apply neq_0_lt_0. now apply lt_lt_0 with n.
now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ;
[apply succ_lt_mono | | |].
assert (m ~= 0). apply neq_0_lt_0. apply lt_lt_0 with (P n).
apply lt_le_trans with (P m). assumption. apply le_pred_l.
apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2.
Qed.

Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
Proof.
intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ.
Qed.

Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m.
 (* Converse is false for n == m == 0 *)
Proof.
intros n m H. apply lt_le_pred. now apply le_succ_l.
Qed.

Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m.
 (* Converse is false for n == m == 0 *)
Proof.
intros n m H. apply lt_succ_r. now apply lt_pred_le.
Qed.

Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m.
Proof.
intros n m; cases n.
rewrite pred_0. split; intro H; apply le_0_l.
intro n. rewrite pred_succ. apply succ_le_mono.
Qed.

End NOrderProp.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable tP_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_extension_1 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_parallelNC_2 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_NCdistinct_3 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_11 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_inequalitysymmetric_12 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_13 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_parallelsymmetric_14 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_parallelflip_15 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_betweennotequal_16 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinearparallel_17 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_paralleldef2B_18 : (forall A B C D : Universe, (par_ A B C D -> tP_ A B C D)).
Variable deftarski_parallel_19 : (forall A B C D : Universe, (tP_ A B C D -> (A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))))).
Variable deftarski_parallel2_20 : (forall A B C D : Universe, ((A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))) -> tP_ A B C D)).
Variable axiom_betweennesssymmetry_21 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defoppositeside_22 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_23 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_planeseparation_24 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_samesidesymmetric_25 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_NCorder_26 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_30helper_27 : (forall A B E F G H : Universe, ((par_ A B E F /\ (betS_ A G B /\ (betS_ E H F /\ ~(cR_ A F G H)))) -> cR_ A E G H)).
Variable lemma_NChelper_28 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable lemma_crossimpliesopposite_29 : (forall A B C D : Universe, ((cR_ A B C D /\ ~(col_ A C D)) -> (tS_ A C D B /\ (tS_ A D C B /\ (tS_ B C D A /\ tS_ B D C A))))).
Variable proposition_30A_30 : (forall A B C D E F G H K : Universe, ((par_ A B E F /\ (par_ C D E F /\ (betS_ G H K /\ (betS_ A G B /\ (betS_ E H F /\ (betS_ C K D /\ (tS_ A G H F /\ tS_ F H K C))))))) -> par_ A B C D)).
Variable defcross_31 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_32 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable defsameside_33 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_34 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable defparallel_35 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_36 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable lemma_collinearbetween_37 : (forall A B C D E F H : Universe, ((col_ A E B /\ (col_ C F D /\ (A <> B /\ (C <> D /\ (A <> E /\ (F <> D /\ (~(meet_ A B C D) /\ (betS_ A H D /\ col_ E F H)))))))) -> betS_ E H F)).
Variable lemma_oppositesidesymmetric_38 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).

Theorem proposition_30_39 : (forall A B C D E F G H K : Universe, ((par_ A B E F /\ (par_ C D E F /\ (betS_ G H K /\ (col_ A B G /\ (col_ E F H /\ (col_ C D K /\ (A <> G /\ (E <> H /\ C <> K)))))))) -> par_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** Coq coding by choukh, Feb 2021 **)

Require Import ZFC.Elements.EST7_6.
Require Import ZFC.Elements.EX7_3.
Require Import ZFC.Elements.EST8_2.
Require Import ZFC.Elements.EST8_4.
Require Import ZFC.Lib.LoStruct.

Section EX8_1_and_2.
Import 𝐎𝐍Operation.
Close Scope Card_scope.
Open Scope omega_scope.

Definition t := Operation 5 Suc.

Example ex8_2_a : ∀α ∈ ω, t α = 5 + α.
Proof with nauto.
  intros α Hα.
  ω_induction α; unfold t in *.
  - rewrite operation_0, add_0_r...
  - rewrite operation_suc, IH...
    rewrite suc, suc, add_assoc... apply add_ran...
Qed.

Example ex8_2_b : ∀α ⋵ 𝐎𝐍, ω ⋸ α → t α = α.
Proof with neauto.
  ord_induction. intros α Hoα IH Hle. unfold t.
  ord_destruct α.
  - subst. destruct Hle. exfalso0. exfalso. apply ω_neq_0...
  - destruct Hsuc as [β [Hoβ Heq]]. subst.
    destruct Hle as [Hlt|Heq].
    + rewrite operation_suc... f_equal.
      apply IH... apply ord_le_iff_lt_suc...
    + exfalso. apply (limord_iff_not_sucord ω)...
      exists β. split...
  - rewrite operation_limit...
    ext Hx.
    + apply FUnionE in Hx as [n [Hn Hx]].
      assert (Hon: n ⋵ 𝐎𝐍). eapply ord_is_ords...
      destruct (classic (ω ⋸ n)) as [Hω|Hω]. {
        rewrite IH in Hx... eapply ord_trans...
      }
      assert (Hnω: n ∈ ω). {
        contra.
        apply Hω. apply ord_le_iff_not_gt...
      }
      rewrite ex8_2_a in Hx...
      apply ord_le_iff_sub in Hle... apply Hle.
      eapply ord_trans... apply add_ran...
    + assert (Hox: x ⋵ 𝐎𝐍). eapply ord_is_ords...
      destruct (classic (ω ⋸ x⁺)) as [Hω|Hω]. {
        eapply FUnionI. apply sucord_in_limord...
        rewrite IH... apply sucord_in_limord...
      }
      assert (Hxpω: x⁺ ∈ ω). {
        contra.
        apply Hω. apply ord_le_iff_not_gt...
      }
      assert (Hxω: x ∈ ω). eapply ω_trans; revgoals...
      eapply FUnionI... rewrite ex8_2_a...
      rewrite <- add_0_r at 1...
      rewrite add_comm... apply add_preserve_lt...
      repeat rewrite pred. do 4 apply BUnionI1. apply BUnionI2...
Qed.

End EX8_1_and_2.

(* ex8_3_a see EST8_2 Fact monotone_operation_preserve_order *)
(* ex8_3_b see EST8_1 Lemma monotone_operation_injective *)
(* ex8_4 see EST8_2 Fact normal_operation_limit_is_limit *)
(* ex8_5 see EST8_2 Lemma monotone_operation_le *)
(* ex8_6_a see EST8_1 Lemma monotone_operation_range_unbounded *)
(* ex8_6_b see EST8_1 Lemma normal_operation_range_closed *)
(* ex8_7 see EST8_2 Corollary ex_least_fixed_point *)
(* ex8_8 see EST8_2 Theorem fixedPoint_normal *)

Section EX8_9.
Import OrderedStruct.

(* ex8_9 不存在包含所有同构结构的集合 *)
Fact no_set_of_all_isomorphic_struct :
  ∀ S, A S ≠ ∅ → ¬ ∃ X, ∀ T, S ≅ T → <A T, R T> ∈ X.
Proof with auto; try congruence.
  intros S Hne [X Hall].
  apply no_set_of_all_set. exists (⋃⋃⋃ X). intros xₒ.
  apply EmptyNE in Hne as [a₀ Ha₀].
  destruct (classic (xₒ ∈ A S)) as [|Hout]. {
    apply UnionAx. exists (A S). split...
    apply UnionAx. exists {A S,}. split...
    apply UnionAx. exists <A S, R S>. split.
    apply Hall. reflexivity. apply PairI1.
  }
  set (λ x, match (ixm (x = a₀)) with
    | inl _ => xₒ
    | inr _ => x
  end) as ReplA.
  set {ReplA x | x ∊ A S} as A'.
  set (λ p, match (ixm (π1 p = a₀)) with
    | inl _ =>
      match (ixm (π2 p = a₀)) with
      | inl _ => <xₒ, xₒ>
      | inr _ => <xₒ, π2 p>
      end
    | inr _ =>
      match (ixm (π2 p = a₀)) with
      | inl _ => <π1 p, xₒ>
      | inr _ => p
  end end) as ReplR.
  set {ReplR x | x ∊ R S} as R'.
  assert (Hbr: is_binRel R' A'). {
    intros x Hx. apply ReplAx in Hx as [p [Hp Hx]]. subst x.
    apply ordered_struct in Hp.
    apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]]. subst p.
    unfold ReplR. zfc_simple.
    destruct (ixm (a = a₀)); destruct (ixm (b = a₀));
    apply CPrdI; apply ReplAx; unfold ReplA.
    - exists a₀. split... destruct (ixm (a₀ = a₀))...
    - exists b. split... destruct (ixm (b = a₀))...
    - exists a. split... destruct (ixm (a = a₀))...
    - exists b. split... destruct (ixm (b = a₀))...
    - exists a. split... destruct (ixm (a = a₀))...
    - exists b. split... destruct (ixm (b = a₀))...
    - exists a. split... destruct (ixm (a = a₀))...
    - exists b. split... destruct (ixm (b = a₀))...
  }
  set (constr A' R' Hbr) as T.
  set (Func (A S) (A T) ReplA) as f.
  assert (Hbi: f: A S ⟺ A T). {
    apply meta_bijection.
    - intros x Hx. eapply ReplI...
    - intros x1 H1 x2 H2 Heq. unfold ReplA in Heq.
      destruct (ixm (x1 = a₀)); destruct (ixm (x2 = a₀))...
    - intros y Hy. apply ReplAx...
  }
  apply bijection_is_func in Hbi as Hf. destruct Hf as [Hf _].
  assert (Hiso: S ≅ T). {
    exists f. split...
    intros x Hx y Hy. split; intros.
    - apply ReplAx. exists <x, y>. split...
      unfold ReplR. zfc_simple.
      destruct (ixm (x = a₀)); destruct (ixm (y = a₀));
      apply op_iff; split; unfold f;
      rewrite meta_func_ap; auto; unfold ReplA;
      destruct (ixm (x = a₀)); destruct (ixm (y = a₀))...
    - apply ReplAx in H as [p [Hp Heq]].
      apply ordered_struct in Hp as H.
      apply CPrdE1 in H as [a [Ha [b [Hb H]]]]. subst p.
      unfold ReplR in Heq. zfc_simple.
      destruct (ixm (a = a₀)); destruct (ixm (b = a₀));
      apply op_iff in Heq as [Hfx Hfy]; unfold f in Hfx, Hfy;
      rewrite meta_func_ap in Hfx, Hfy; auto; unfold ReplA in Hfx, Hfy;
      destruct (ixm (x = a₀)) in Hfx; destruct (ixm (y = a₀)) in Hfy; subst...
  }
  apply UnionAx. exists A'. split.
  apply UnionAx. exists {A',}. split...
  apply UnionAx. exists <A T, R T>. split...
  apply PairI1. apply ReplAx. exists a₀. split...
  unfold ReplA. destruct (ixm (a₀ = a₀))...
Qed.

End EX8_9.

Section EX8_10.
Import Kard.
Import RegularityConsequences.
Hint Resolve all_grounded : core.

Example kard_0 : kard 0 = {0,}.
Proof with auto.
  ext Hx.
  - apply kard_elim in Hx as [Hx _].
    apply eqnum_empty in Hx. subst x...
  - apply SingE in Hx. subst x.
    apply kard_intro. reflexivity.
    intros x Hx. symmetry in Hx.
    apply eqnum_empty in Hx. subst x...
Qed.

Example kard_1 : kard 1 = {1,}.
Proof with neauto.
  ext Hx.
  - apply kard_elim in Hx as [Hqn Hle].
    apply Hle in Hqn as Hx.
    rewrite (rank_of_ord 1) in Hx...
    apply ord_le_iff_lt_suc in Hx...
    apply BUnionE in Hx as [Hx|Hx].
    + rewrite one in Hx. apply SingE in Hx.
      apply rank_0 in Hx. subst x. symmetry in Hqn.
      apply eqnum_empty in Hqn. exfalso. eapply suc_neq_0...
    + apply SingE in Hx. apply rank_1 in Hx. subst x...
  - apply SingE in Hx. subst x.
    apply kard_intro. reflexivity.
    intros x Hx. symmetry in Hx.
    apply eqnum_one_iff in Hx as [a Hx]. subst x.
    rewrite rank_of_single, rank_of_ord...
    apply ord_le_iff_sub... intros x Hx.
    rewrite one in Hx. apply SingE in Hx. subst x.
    apply ord_suc_gt_0...
Qed.

Example kard_2 : kard 2 = {2,}.
Proof with neauto; try congruence.
  assert (Hnqn: 1 ≉ 2). {
    intros Hqn. apply CardAx1 in Hqn.
    rewrite <- card_of_nat, <- card_of_nat in Hqn...
    apply contra_1_2...
  }
  ext Hx.
  - apply kard_elim in Hx as [Hqn Hle].
    apply Hle in Hqn as Hx.
    rewrite (rank_of_ord 2) in Hx...
    apply ord_le_iff_lt_suc in Hx...
    apply BUnionE in Hx as [Hx|Hx].
    + rewrite two in Hx.
      apply TwoE in Hx as [Hx|Hx]; exfalso.
      * apply rank_0 in Hx. subst x. symmetry in Hqn.
        apply eqnum_empty in Hqn. eapply suc_neq_0...
      * rewrite <- one in Hx. apply rank_1 in Hx. subst x...
    + apply SingE in Hx. apply rank_2 in Hx as []; subst x...
      rewrite eqnum_single in Hqn...
  - apply SingE in Hx. subst x.
    apply kard_intro. reflexivity.
    intros x Hx. symmetry in Hx.
    apply eqnum_two_iff in Hx as [a [b [Hnq Hx]]]. subst x.
    assert (Ho: rank a ∪ rank b ⋵ 𝐎𝐍). {
      apply union_of_ords_is_ord.
      intros x Hx. apply PairE in Hx as []; subst...
    }
    rewrite rank_of_pair, rank_of_ord...
    apply ord_le_iff_sub... intros x Hx. rewrite two in Hx.
    apply TwoE in Hx as []; subst. eapply ord_suc_gt_0...
    rewrite <- one. apply ord_lt_suc_iff_sub...
    intros x Hx. rewrite one in Hx. apply SingE in Hx; subst.
    destruct (classic (rank a = 0)).
    + apply BUnionI2. apply ord_neq_0_gt_0...
      intros H0. apply rank_0 in H. apply rank_0 in H0...
    + apply BUnionI1. apply ord_neq_0_gt_0...
Qed.

(* kard 3 = {3, {0, 1, {1}}, {0, {1}, 2}, {1, {1}, 2}} *)

End EX8_10.

(* ex8_11 see EST8_3 Lemma ot_disjointifiable *)

(* ex8_12 *)
Module AlternativeOtAdd.
Import OrderType.
Open Scope LoStruct_scope.

(* 字典序 *)
Definition LoAdd_R := λ S T, BinRel (A S × {0,} ∪ A T × {1,}) (λ p1 p2,
  (π2 p1 <ᵣ π2 p2) (MemberRel 2) ∨
  π2 p1 = π2 p2 ∧ (
    π2 p1 = 0 ∧ (π1 p1 <ᵣ π1 p2) (R S) ∨
    π2 p1 = 1 ∧ (π1 p1 <ᵣ π1 p2) (R T)
  )
).
Notation "S ⨁' T" := (LoAdd_R S T) (at level 70) : LoStruct_scope.

Lemma loAdd_is_binRel : ∀ S T,
  is_binRel (S ⨁' T) (A S × {0,} ∪ A T × {1,}).
Proof with auto.
  intros * x Hx.
  apply binRelE1 in Hx as [s [Hs [t [Ht [Hx _]]]]];
  apply BUnionE in Hs as [Hs|Hs];
  apply BUnionE in Ht as [Ht|Ht];
  apply CPrdE1 in Hs as [a [Ha [b [Hb Hs]]]];
  apply CPrdE1 in Ht as [c [Hc [d [Hd Ht]]]];
  apply SingE in Hb; apply SingE in Hd;
  subst; zfc_simple; apply CPrdI; solve [
    apply BUnionI1; apply CPrdI; auto|
    apply BUnionI2; apply CPrdI; auto].
Qed.

Local Lemma lt_0_0 : (0 <ᵣ 0) (MemberRel 2) → False.
Proof.
  intros H. apply binRelE3 in H. exfalso0.
Qed.

Local Lemma lt_0_1 : (0 <ᵣ 1) (MemberRel 2).
Proof with auto.
  apply binRelI. apply BUnionI1. apply BUnionI2...
  apply BUnionI2... apply BUnionI2...
Qed.

Local Lemma lt_1_0 : (1 <ᵣ 0) (MemberRel 2) → False.
Proof.
  intros H. apply binRelE3 in H. exfalso0.
Qed.

Local Lemma lt_1_1 : (1 <ᵣ 1) (MemberRel 2) → False.
Proof.
  intros H. apply binRelE3 in H.
  eapply nat_irrefl; revgoals; neauto.
Qed.

Lemma loAdd_trans : ∀ S T, tranr (S ⨁' T).
Proof with eauto.
  intros S T x y z Hxy Hyz.
  pose proof lt_0_0 as H00.
  pose proof lt_0_1 as H01.
  pose proof lt_1_0 as H10.
  pose proof lt_1_1 as H11.
  apply binRelE2 in Hxy as [Hx [Hy [Hxy|[Heq1 [[H0 Hxy]|[H0 Hxy]]]]]];
  apply binRelE2 in Hyz as [_  [Hz [Hyz|[Heq2 [[H1 Hyz]|[H1 Hyz]]]]]];
  apply BUnionE in Hx as [Hx|Hx];
  apply BUnionE in Hy as [Hy|Hy];
  apply BUnionE in Hz as [Hz|Hz];
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
  apply CPrdE1 in Hz as [e [He [f [Hf Hz]]]];
  apply SingE in Hb; apply SingE in Hd; apply SingE in Hf;
  subst; zfc_simple; (apply binRelI; zfc_simple; [
    solve [
      apply BUnionI1; apply CPrdI; auto|
      apply BUnionI2; apply CPrdI; auto
    ]|
    solve [
      apply BUnionI1; apply CPrdI; auto|
      apply BUnionI2; apply CPrdI; auto
    ]|
  ]).
  left... left...
  right; split... left; split...
  eapply relLt_trans; revgoals... apply lo.
  right; split... right; split...
  eapply relLt_trans; revgoals... apply lo.
Qed.

Lemma loAdd_irrefl : ∀ S T, irrefl (S ⨁' T).
Proof with neauto.
  intros S T x H.
  apply binRelE2 in H as [Hx [_ [Hlt|[Heq [[H0 Hlt]|[H1 Hlt]]]]]].
  - apply binRelE3 in Hlt. eapply nat_irrefl; revgoals...
    apply BUnionE in Hx as []; apply CPrdE0 in H as [_ H];
    apply SingE in H; rewrite H...
  - eapply relLt_irrefl; revgoals... eapply lo_irrefl. apply lo.
  - eapply relLt_irrefl; revgoals... eapply lo_irrefl. apply lo.
Qed.

Lemma loAdd_connected : ∀ S T,
  connected (S ⨁' T) (A S × {0,} ∪ A T × {1,}).
Proof with eauto; try congruence.
  intros S T x Hx y Hy Hnq.
  apply BUnionE in Hx as [Hx|Hx];
  apply BUnionE in Hy as [Hy|Hy];
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
  apply SingE in Hb; apply SingE in Hd; subst; zfc_simple.
  - destruct (classic (a = c)). subst...
    eapply lo_connected in H; revgoals... apply lo.
    destruct H; [left|right]; (
      apply binRelI; [apply BUnionI1; apply CPrdI; auto..|]
    ); zfc_simple...
  - left. apply binRelI.
    apply BUnionI1. apply CPrdI...
    apply BUnionI2. apply CPrdI...
    zfc_simple. left. apply lt_0_1.
  - right. apply binRelI.
    apply BUnionI1. apply CPrdI...
    apply BUnionI2. apply CPrdI...
    zfc_simple. left. apply lt_0_1.
  - destruct (classic (a = c)). subst...
      eapply lo_connected in H; revgoals... apply lo.
    destruct H; [left|right]; (
      apply binRelI; [apply BUnionI2; apply CPrdI; auto..|]
    ); zfc_simple...
Qed.

Theorem loAdd_loset : ∀ S T,
  loset (A S × {0,} ∪ A T × {1,}) (S ⨁' T).
Proof.
  intros S T.
  apply loset_iff_connected_poset. repeat split.
  - apply loAdd_connected.
  - apply loAdd_is_binRel.
  - eapply binRel_is_rel. apply loAdd_is_binRel.
  - apply loAdd_trans.
  - apply loAdd_irrefl.
Qed.

Definition LoAdd := λ S T,
  constr (A S × {0,} ∪ A T × {1,}) (S ⨁' T) (loAdd_loset S T).
Notation "S +' T" := (LoAdd S T) (at level 50): LoStruct_scope.

Lemma alternative_loAdd_R_correct : ∀ S T,
  (S ⨁' T) = (LoDisj S 0 ⨁ LoDisj T 1).
Proof with auto.
  intros.
  pose proof lt_0_0 as H00.
  pose proof lt_0_1 as H01.
  pose proof lt_1_0 as H10.
  pose proof lt_1_1 as H11.
  ext Hx.
  - apply binRelE1 in Hx as [a [Ha [b [Hb [Hx [Hlt|[Heq [[H0 Hlt]|[H1 Hlt]]]]]]]]];
    apply BUnionE in Ha as [Ha|Ha];
    apply BUnionE in Hb as [Hb|Hb];
    apply CPrdE1 in Ha as [s [Hs [t [Ht Ha]]]];
    apply CPrdE1 in Hb as [u [Hu [v [Hv Hb]]]];
    apply SingE in Ht; apply SingE in Hv; subst; zfc_simple.
    + apply BUnionI2. apply CPrdI; apply CPrdI...
    + apply BUnionI1. apply BUnionI1. apply ReplAx.
      exists <s, u>. split; zfc_simple...
    + apply BUnionI1. apply BUnionI2. apply ReplAx.
      exists <s, u>. split; zfc_simple...
  - apply BUnionE in Hx as [Hx|Hx].
    + destruct (lo S) as [HbrS _].
      destruct (lo T) as [HbrT _].
      apply BUnionE in Hx as [Hx|Hx];
      apply ReplAx in Hx as [p [Hp Heq]];
      [apply HbrS in Hp as H|apply HbrT in Hp as H];
      apply CPrdE1 in H as [a [Ha [b [Hb H]]]];
      subst; zfc_simple; apply binRelI; zfc_simple...
      * apply BUnionI1; apply CPrdI...
      * apply BUnionI1; apply CPrdI...
      * apply BUnionI2; apply CPrdI...
      * apply BUnionI2; apply CPrdI...
    + apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      apply CPrdE1 in Ha as [s [Hs [t [Ht Ha]]]].
      apply CPrdE1 in Hb as [u [Hu [v [Hv Hb]]]].
      apply SingE in Ht. apply SingE in Hv.
      subst. zfc_simple. apply binRelI; zfc_simple...
      apply BUnionI1; apply CPrdI...
      apply BUnionI2; apply CPrdI...
Qed.

Lemma alternative_loAdd_correct : ∀ S T, S + T ≅ S +' T.
Proof with auto.
  intros. replace (S + T) with (S +' T). reflexivity.
  apply eq_intro... simpl. apply alternative_loAdd_R_correct.
Qed.

(* ex8_12 *)
Lemma alternative_otAdd_correct : ∀ S T,
  (ot S + ot T)%ot = ot (S +' T).
Proof with auto.
  intros. rewrite (otAdd_eq_ot_of_loAdd S T).
  apply ot_correct. apply alternative_loAdd_correct.
Qed.

Lemma loAdd_well_defined : ∀ S S' T T',
  S ≅ S' → T ≅ T' → S +' T ≅ S' +' T'.
Proof.
  intros * HS HT. do 2 rewrite <- alternative_loAdd_correct.
  apply EST8_3.loAdd_well_defined; auto.
Qed.

Definition otAdd_spec := λ ρ σ τ,
  ∀ S T, ρ = ot S → σ = ot T → τ = ot (S +' T).
Definition OtAdd := λ ρ σ, describe (otAdd_spec ρ σ).
Notation "ρ +' σ" := (OtAdd ρ σ) : OrderType_scope.

Open Scope OrderType_scope.

Lemma otAdd_spec_intro : ∀ ρ σ ⋵ 𝐎𝐓, otAdd_spec ρ σ (ρ +' σ).
Proof.
  intros ρ [S HS] σ [T HT]. apply (desc_spec (otAdd_spec ρ σ)).
  rewrite <- unique_existence. split.
  - exists (ot (S +' T)%lo). intros S' T' H1 H2. subst.
    apply ot_correct in H1. apply ot_correct in H2.
    apply ot_correct. apply loAdd_well_defined; auto.
  - intros τ1 τ2 H1 H2.
    pose proof (H1 S T HS HT).
    pose proof (H2 S T HS HT). congruence.
Qed.

Lemma otAdd_eq_ot_of_loAdd : ∀ S T, ot S +' ot T = ot (S +' T)%lo.
Proof. intros. erewrite otAdd_spec_intro; auto. Qed.

Theorem otAdd_well_defined : ∀ S S' T T',
  S ≅ S' → T ≅ T' → ot S +' ot T = ot S' +' ot T'.
Proof.
  intros * HisoS HisoT. do 2 rewrite otAdd_eq_ot_of_loAdd.
  apply ot_correct. apply loAdd_well_defined; auto.
Qed.

End AlternativeOtAdd.

(* ex8_13 see EST8_3 Theorem otAdd_well_defined and
  EST8_4 Theorem otMul_well_defined *)

Import OrderType.
Import StructureCasting.

Example ex8_14 : ∀ ρ σ ⋵ 𝐎𝐓,
  ρ ⋅ σ = otⁿ 0 → ρ = otⁿ 0 ∨ σ = otⁿ 0.
Proof with auto.
  intros ρ [S HS] σ [T HT] H0. subst.
  rewrite otMul_eq_ot_of_loMul in H0. unfold otⁿ in H0.
  apply ot_correct in H0 as [f [Hf _]]. simpl in Hf.
  apply bijection_to_empty in Hf.
  apply cprd_to_0 in Hf as []; [left|right];
  apply ot_correct.
  - replace (LOⁿ 0) with S. reflexivity.
    apply eq_intro... ext Hx.
    + destruct (lo S) as [Hbr _].
      apply Hbr in Hx. rewrite H, cprd_0_l in Hx. exfalso0.
    + apply binRelE1 in Hx as [a [Ha _]]. exfalso0.
  - replace (LOⁿ 0) with T. reflexivity.
    apply eq_intro... ext Hx.
    + destruct (lo T) as [Hbr _].
      apply Hbr in Hx. rewrite H, cprd_0_l in Hx. exfalso0.
    + apply binRelE1 in Hx as [a [Ha _]]. exfalso0.
Qed.

(* ex8_15 (ℕ̅ + 1) ⋅ 2 = ℕ̅ 0 ℕ̅ 0 ≠ ℕ̅ ℕ̅ 0 0 = (ℕ̅ ⋅ 2) + (1 ⋅ 2) *)
(* ex8_16 see EST8_4 Theorem otAdd_0_r, otMul_1_r, otMul_0_r *)


Require Import List TheoryList.
Require Import ListUtil Tactics.

Set Implicit Arguments.

Axiom ext_eq : forall (S T : Set) (f g : S -> T),
  (forall x, f x = g x) -> f = g.

Module Type EQ.
  Parameter dom : Set.
  Parameter dom_eq_dec : forall (x y : dom), {x = y} + {x <> y}.
End EQ.

Module Type MAP.
  Variable dom : Set.

  Parameter map : Set -> Set.

  Parameter init : forall (ran : Set), ran -> map ran.
  Parameter sel : forall (ran : Set), map ran -> dom -> ran.
  Parameter upd : forall (ran : Set), map ran -> dom -> ran -> map ran.

  Axiom sel_init : forall (ran : Set) (v : ran) a,
    sel (init v) a = v.

  Axiom sel_upd : forall (ran : Set) (m : map ran) a v a',
    (a = a' /\ sel (upd m a v) a' = v)
    \/ (a <> a' /\ sel (upd m a v) a' = sel m a').

  Axiom sel_upd_eq : forall (ran : Set) (m : map ran) a v,
    sel (upd m a v) a = v.

  Axiom sel_upd_neq : forall (ran : Set) (m : map ran) a v a',
    a <> a'
    -> sel (upd m a v) a' = sel m a'.

  Axiom upd_self : forall (ran : Set) (m : map ran) a,
    upd m a (sel m a) = m.
End MAP.

Module FuncMap (Param : EQ) : MAP with Definition dom := Param.dom.
  Import Param.

  Section Map.
    Variable ran : Set.

    Definition map := dom -> ran.

    Definition init (r : ran) : map :=
      fun _ => r.
    Definition sel (m : map) (d : dom) : ran :=
      m d.
    Definition upd (m : map) (d : dom) (r : ran) : map :=
      fun d' =>
	if dom_eq_dec d d'
	  then r
	  else m d'.

    Theorem sel_init : forall v a,
      sel (init v) a = v.
      trivial.
    Qed.

    Theorem sel_upd : forall m a v a',
      (a = a' /\ sel (upd m a v) a' = v)
      \/ (a <> a' /\ sel (upd m a v) a' = sel m a').
      intros.
      unfold upd, sel.
      destruct (dom_eq_dec a a'); simplify.
    Qed.

    Theorem sel_upd_eq : forall m a v,
      sel (upd m a v) a = v.
      intros.
      unfold upd, sel.
      destruct (dom_eq_dec a a); simplify.
    Qed.

    Theorem sel_upd_neq : forall m a v a',
      a <> a'
      -> sel (upd m a v) a' = sel m a'.
      intros.
      unfold upd, sel.
      destruct (dom_eq_dec a a'); simplify.
    Qed.

    Theorem upd_self : forall m a,
      upd m a (sel m a) = m.
      intros.
      unfold map.
      apply ext_eq.
      intro.
      unfold upd, sel.
      destruct (dom_eq_dec a x); congruence.
    Qed.
  End Map.

  Definition dom := dom.
End FuncMap.

Module Type SET.
  Variable dom : Set.

  Parameter set : Set.

  Parameter empty : set.
  Parameter In : dom -> set -> bool.
  Parameter add : set -> dom -> set.
  Parameter remove : set -> dom -> set.
  Parameter union : set -> set -> set.
  Parameter intersect : set -> set -> set.

  Parameter incl : set -> set -> bool.
  Parameter elems : set -> list dom.

  Axiom In_add : forall s v v',
    In v' (add s v) = true
    <-> v = v' \/ In v' s = true.

  Axiom In_add_eq : forall s v,
    In v (add s v) = true.

  Axiom In_add_neq : forall s v v',
    v <> v'
    -> In v' (add s v) = In v' s.

  Axiom In_union : forall s s' v,
    In v (union s s') = true
    -> In v s = true \/ In v s' = true.

  Axiom In_union' : forall s s' v,
    In v s = true
    -> In v s' = true
    -> In v (union s s') = true.

  Axiom union_idempotent : forall s,
    union s s = s.

  Axiom In_intersect : forall v s' s,
    In v (intersect s s') = true
    -> In v s = true /\ In v s' = true.

  Axiom In_intersect' : forall v s' s,
    In v (intersect s s') = false
    -> In v s = false \/ In v s' = false.

  Axiom incl_ok : forall s1 s2,
    incl s1 s2 = true <-> (forall x, In x s1 = true -> In x s2 = true).

  Axiom incl_empty : forall s,
    incl empty s = true.

  Axiom In_empty : forall x,
    In x empty = false.

  Axiom incl_refl : forall s,
    incl s s = true.

  Axiom incl_false : forall s1 s2,
    incl s1 s2 = false
    -> exists x, In x s1 = true /\ In x s2 = false.

  Axiom incl_trans : forall s1 s2,
    incl s1 s2 = true
    -> forall s3, incl s2 s3 = true
      -> incl s1 s3 = true.

  Axiom incl_In : forall s1 s2,
    incl s1 s2 = true
    -> forall x, In x s1 = true
      -> In x s2 = true.

  Axiom incl_union_left : forall s1 s2,
    incl s1 (union s1 s2) = true.

  Axiom incl_union_right : forall s1 s2,
    incl s2 (union s1 s2) = true.

  Axiom elems_ok : forall s x,
    List.In x (elems s) <-> In x s = true.

  Axiom elems_remove : forall s x ls,
    elems s = x :: ls
    -> elems (remove s x) = ls.

  Axiom In_remove : forall x x' s,
    In x s = true
    -> x <> x'
    -> In x (remove s x') = true.
End SET.

Module ListSet (Param : EQ) : SET with Definition dom := Param.dom.
  Import Param.

  Section Map.
    Definition set := list dom.

    Definition empty : set := nil.

    Definition In (v : dom) (s : set) : bool :=
      if In_eq_dec dom_eq_dec v s
	then true
	else false.

    Definition add (s : set) (v : dom) : set :=
      if In_eq_dec dom_eq_dec v s
	then s
	else v :: s.

    Fixpoint remove (s : set) (v : dom) {struct s} : set :=
      match s with
	| nil => nil
	| v' :: s' =>
	  if dom_eq_dec v v'
	    then s'
	    else v' :: remove s' v
      end.

    Fixpoint union (s1 s2 : set) {struct s1} : set :=
      match s1 with
	| nil => s2
	| v :: s1' => add (union s1' s2) v
      end.

    Fixpoint intersect (s1 s2 : set) {struct s1} : set :=
      match s1 with
	| nil => nil
	| v :: s1' =>
	  if In_eq_dec dom_eq_dec v s2
	    then v :: intersect s1' s2
	    else intersect s1' s2
      end.

    Definition incl (s1 s2 : set) : bool :=
      if incl_eq_dec dom_eq_dec s1 s2
	then true
	else false.
    Definition elems (s : set) : list dom := s.

    Theorem In_add : forall s v v',
      In v' (add s v) = true
      <-> v = v' \/ In v' s = true.
      unfold In, add; intros.
      destruct (In_eq_dec dom_eq_dec v s).
      destruct (In_eq_dec dom_eq_dec v' s); simplify.
      destruct (In_eq_dec dom_eq_dec v' (v :: s)); simplify.
      destruct (In_eq_dec dom_eq_dec v' s); simplify.
      destruct (In_eq_dec dom_eq_dec v' s); simplify.
    Qed.

    Theorem In_add_eq : forall s v,
      In v (add s v) = true.
      unfold In, add; intros.
      destruct (In_eq_dec dom_eq_dec v s); simplify.
      destruct (In_eq_dec dom_eq_dec v s); simplify.
      destruct (In_eq_dec dom_eq_dec v (v :: s)); simplify.
    Qed.

    Theorem In_add_neq : forall s v v',
      v <> v'
      -> In v' (add s v) = In v' s.
      unfold In, add; intros.
      destruct (In_eq_dec dom_eq_dec v s); simplify.
      destruct (In_eq_dec dom_eq_dec v' (v :: s)); simplify;
	destruct (In_eq_dec dom_eq_dec v' s); simplify.
    Qed.

    Theorem In_union : forall s s' v,
      In v (union s s') = true
      -> In v s = true \/ In v s' = true.
      unfold In; induction s; simplify.
      generalize (IHs s' v).
      destruct (In_eq_dec dom_eq_dec v (add (union s s') a)); simplify.
      destruct (In_eq_dec dom_eq_dec v (union s s')); simplify;
	destruct (In_eq_dec dom_eq_dec v (a :: s)); simplify;
	  destruct (In_eq_dec dom_eq_dec v s'); simplify;
	    destruct (In_eq_dec dom_eq_dec v s); simplify.

      wrong.
      generalize (In_add (union s s') a v); simplify.
      apply n.
      unfold In at 1 in H3.
      destruct (In_eq_dec dom_eq_dec v (add (union s s') a)); simplify.
      unfold In in H3.
      destruct (In_eq_dec dom_eq_dec v (union s s')); simplify.
    Qed.

    Theorem In_union' : forall s s' v,
      In v s = true
      -> In v s' = true
      -> In v (union s s') = true.
      unfold In; induction s; simplify.
      generalize (IHs s' v).

      destruct (In_eq_dec dom_eq_dec v (add (union s s') a)); simplify.
      destruct (In_eq_dec dom_eq_dec v s'); simplify.
      destruct (In_eq_dec dom_eq_dec v (a :: s)); simplify.

      wrong.
      apply n.
      generalize (In_add (union s s') v v); unfold In; simplify;
	destruct (In_eq_dec dom_eq_dec v (add (union s s') v)); simplify.

      wrong.
      apply n.
      generalize (In_add (union s s') a v); simplify.
      assert (In v (add (union s s') a) = true).
      apply H4.

      unfold In.
      destruct (In_eq_dec dom_eq_dec v (union s s')); trivial.
      wrong.
      apply n0.
      generalize i.
      clear_all.
      induction s; simplify.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s s')); simplify.

      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s s')).
      generalize i.
      clear_all.
      induction s; simplify.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s s')); simplify.

      right.
      generalize i.
      clear_all.
      induction s; simplify.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s s')); simplify.
    Qed.

    Theorem incl_ok : forall s1 s2,
      incl s1 s2 = true <-> (forall x, In x s1 = true -> In x s2 = true).
      unfold incl, In.
      intros.
      destruct (incl_eq_dec dom_eq_dec s1 s2); simplify.
      destruct (In_eq_dec dom_eq_dec x s1); simplify.
      destruct (In_eq_dec dom_eq_dec x s2); simplify.
      wrong; eauto.
      wrong.
      apply n.
      do 2 intro.
      generalize (H a).
      destruct (In_eq_dec dom_eq_dec a s1); simplify.
      destruct (In_eq_dec dom_eq_dec a s2); simplify.
    Qed.

    Lemma union_idempotent' : forall s s',
      List.incl s s'
      -> union s s' = s'.
      induction s; simplify.
      rewrite IHs.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a s'); simplify.
      wrong; intuition.
      do 2 intro.
      intuition.
    Qed.

    Theorem  In_intersect : forall v s' s,
      In v (intersect s s') = true
      -> In v s = true /\ In v s' = true.
      induction s; simpl; intuition.

      unfold In in H.
      destruct (In_eq_dec dom_eq_dec v nil); try discriminate.
      inversion i.

      destruct (In_eq_dec dom_eq_dec a s').
      unfold In in *; idtac.
      destruct (In_eq_dec dom_eq_dec v (a :: intersect s s')); try discriminate.
      destruct (In_eq_dec dom_eq_dec v (a :: s)); trivial.
      wrong.
      apply n.
      destruct i0; subst; intuition.
      destruct (In_eq_dec dom_eq_dec v (intersect s s')); try tauto.
      destruct (In_eq_dec dom_eq_dec v s); intuition; try discriminate.

      destruct (dom_eq_dec a v); subst.
      wrong.
      intuition.
      unfold In in H2.
      destruct (In_eq_dec dom_eq_dec v s'); intuition; discriminate.

      unfold In.
      destruct (In_eq_dec dom_eq_dec v (a :: s)); trivial.
      intuition.
      wrong; apply n1.
      unfold In in H1.
      destruct (In_eq_dec dom_eq_dec v s); try discriminate.
      intuition.

      destruct (In_eq_dec dom_eq_dec a s').
      unfold In in *; idtac.
      destruct (In_eq_dec dom_eq_dec v (a :: intersect s s')); try discriminate.
      destruct (In_eq_dec dom_eq_dec v s'); trivial.
      wrong.
      destruct (In_eq_dec dom_eq_dec v (intersect s s')); try tauto.
      destruct (In_eq_dec dom_eq_dec v s); intuition; try discriminate.

      destruct i0; subst; intuition.

      intuition.
    Qed.

    Theorem In_intersect' : forall v s' s,
      In v (intersect s s') = false
      -> In v s = false \/ In v s' = false.
      induction s; simpl; intuition.

      destruct (In_eq_dec dom_eq_dec a s').
      unfold In in H.
      destruct (In_eq_dec dom_eq_dec v (a :: intersect s s')); try discriminate.
      destruct (dom_eq_dec a v); subst.
      wrong; intuition.

      unfold In in IHs.
      destruct (In_eq_dec dom_eq_dec v (intersect s s')); intuition.
      wrong; intuition.

      destruct (In_eq_dec dom_eq_dec v s); try discriminate.
      unfold In.
      destruct (In_eq_dec dom_eq_dec v s'); auto.
      destruct (In_eq_dec dom_eq_dec v (a :: s)); auto.
      destruct i1; subst; intuition.

      intuition.
      destruct (dom_eq_dec a v); subst.

      unfold In at 2.
      destruct (In_eq_dec dom_eq_dec v s'); intuition.

      unfold In at 1.
      destruct (In_eq_dec dom_eq_dec v (a :: s)); auto.
      destruct i; subst; intuition.
      unfold In in H1.
      destruct (In_eq_dec dom_eq_dec v s); try discriminate.
      intuition.
    Qed.

    Theorem union_idempotent : forall s,
      union s s = s.
      intros.
      apply union_idempotent'; intuition.
    Qed.

    Theorem incl_empty : forall s,
      incl empty s = true.
      unfold incl, empty.
      intro.
      destruct (incl_eq_dec dom_eq_dec nil s); trivial.
      wrong; apply n.
      red; intuition.
      inversion H.
    Qed.

    Theorem In_empty : forall x,
      In x empty = false.
      unfold In, empty.
      intro.
      destruct (In_eq_dec dom_eq_dec x nil); trivial.
      inversion i.
    Qed.

    Theorem incl_refl : forall s,
      incl s s = true.
      intros.
      unfold incl.
      destruct (incl_eq_dec dom_eq_dec s s); simplify.
      wrong; intuition.
    Qed.

    Theorem incl_false : forall s1 s2,
      incl s1 s2 = false
      -> exists x, In x s1 = true /\ In x s2 = false.
      intros.
      unfold incl in H.
      destruct (incl_eq_dec dom_eq_dec s1 s2); try discriminate.
      clear H.
      induction s1.

      wrong.
      apply n.
      red; intuition.
      inversion H.

      destruct (In_dec dom_eq_dec a s2).

      assert (exists x : dom, In x s1 = true /\ In x s2 = false).
      apply IHs1.
      intro.
      apply n.
      red; simpl; intuition; subst; trivial.

      destruct H as [x Hx].
      exists x; intuition.
      unfold In in *; idtac.
      destruct (In_eq_dec dom_eq_dec x (a :: s1)); trivial.
      destruct (In_eq_dec dom_eq_dec x s1); try discriminate.
      wrong; intuition.

      exists a; intuition.
      unfold In.
      destruct (In_eq_dec dom_eq_dec a (a :: s1)); intuition.
      wrong; intuition.

      unfold In.
      destruct (In_eq_dec dom_eq_dec a s2); intuition.
    Qed.

    Theorem incl_trans : forall s1 s2,
      incl s1 s2 = true
      -> forall s3, incl s2 s3 = true
	-> incl s1 s3 = true.
      unfold incl.
      intros.
      destruct (incl_eq_dec dom_eq_dec s1 s3); simplify.
      destruct (incl_eq_dec dom_eq_dec s1 s2); simplify.
      destruct (incl_eq_dec dom_eq_dec s2 s3); simplify.
      wrong; apply n.
      do 2 intro.
      auto.
    Qed.

    Theorem incl_In : forall s1 s2,
      incl s1 s2 = true
      -> forall x, In x s1 = true
	-> In x s2 = true.
      intros.
      generalize (incl_ok s1 s2).
      intuition.
    Qed.

    Theorem incl_union_left : forall s1 s2,
      incl s1 (union s1 s2) = true.
      intros.
      generalize (incl_ok s1 (union s1 s2)).
      simplify.
      unfold incl.
      destruct (incl_eq_dec dom_eq_dec s1 (union s1 s2)); simplify.
      wrong; apply n.
      clear_all.
      induction s1; simplify.
      do 2 intro.
      inversion H.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s1 s2)); simplify.
    Qed.

    Theorem incl_union_right : forall s1 s2,
      incl s2 (union s1 s2) = true.
      intros.
      generalize (incl_ok s2 (union s1 s2)).
      simplify.
      unfold incl.
      destruct (incl_eq_dec dom_eq_dec s2 (union s1 s2)); simplify.
      wrong; apply n.
      clear_all.
      induction s1; simplify.
      unfold add.
      destruct (In_eq_dec dom_eq_dec a (union s1 s2)); simplify.
    Qed.

    Theorem elems_ok : forall s x,
      List.In x (elems s) <-> In x s = true.
      unfold In, elems; simplify.
      destruct (In_eq_dec dom_eq_dec x s); simplify.
      destruct (In_eq_dec dom_eq_dec x s); simplify.
    Qed.

    Theorem elems_remove : forall s x ls,
      elems s = x :: ls
      -> elems (remove s x) = ls.
      unfold elems, remove.
      simplify.
      destruct (dom_eq_dec x x); simplify.
    Qed.

    Theorem In_remove : forall x x' s,
      In x s = true
      -> x <> x'
      -> In x (remove s x') = true.
      unfold In.
      induction s; simplify.
      destruct (dom_eq_dec x' a); simplify.
      destruct (In_eq_dec dom_eq_dec x s); simplify.
      wrong.
      destruct (In_eq_dec dom_eq_dec x (a :: s)); simplify.
      destruct (In_eq_dec dom_eq_dec x (a :: remove s x')); simplify.
      wrong.
      destruct (In_eq_dec dom_eq_dec x s); simplify;
	destruct (In_eq_dec dom_eq_dec x (a :: s)); simplify.
      destruct (In_eq_dec dom_eq_dec x (remove s x')); simplify.
    Qed.

  End Map.

  Definition dom := dom.
End ListSet.


(*

   We show here that under certain circumstances, finding tail bounds for work-like recurrences
   can be reduced to finding bounds for span-like recurrences of the form covered in span2.v.

 *)
From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp span2.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.
Global Set Bullet Behavior "Strict Subproofs".

Section work_bound_sec.

Variable X: eqType.
Variable size: X → R.
Variable A B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable Ωh: ∀ x, distrib (B x).
Variable T: ∀ x: X, rrvar (ΩT x).
Variable h: ∀ x: X, rvar (Ωh x) [eqType of X * X]%type.
Variable P: X → Prop.
Variable g1 g2: R → R.
Variable a: R → R.
Variable m: R → R.
Variable u u': R → R.
Variable d: R.
Hypothesis umin: R.
Hypothesis umin_non_neg: 0 ≤ umin.
Hypothesis umin_lb: ∀ x, x > d → umin ≤ u x - a x / g2 x.
Variable u_mono: ∀ x y, x ≤ y → u x ≤ u y.
Variable u_strict_inc: ∀ x y, x ≥ d → x < y → u x < u y.
Variable u'_mono: ∀ x y, x ≤ y → u' x ≤ u' y.
Variable u'_pos: ∀ x,  u' x > 0.
Variable u'u: ∀ x, (* d < x → *) x ≤ u' (u x).
Variable u'_inv_above: ∀ z, d < z → u' (u z) = z.
Variable u_inv_above: ∀ z, umin < z → u (u' z) = z.
Variable ud_umin: u d = umin.
Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) (λ x, Rmax (size (fst x)) (size (snd x)))) ≤ m (size x).

Variable u_cont: ∀ x, d < x → continuity_pt u x.
Variable a_cont: ∀ x, d < x → continuity_pt a x.
Variable g_cont: ∀ x, d < x → continuity_pt g2 x.

Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.

Hypothesis Trec:
  ∀ x r, P x → pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') *
                         pr_gt (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                          (fun xy => fst xy + snd xy)) (r - a (size x))).

Hypothesis urec:
  ∀ x, x > d →  u x ≥ a x / g2 x + u (m x).

Hypothesis hP: ∀ x n, P x → P (fst ((h x) n)) ∧ P (snd ((h x) n)).
Hypothesis hg1range_sum:
  ∀ x n, size x > d → g1 (size (fst ((h x) n))) + g1 (size (snd ((h x) n))) ≤ g1 (size x).
Hypothesis hg2range_sum:
  ∀ x n, size x > d → g2 (size (fst ((h x) n))) + g2 (size (snd ((h x) n))) ≤ g2 (size x).
Hypothesis hrange11: ∀ x n, size (fst ((h x) n)) ≤ size x.
Hypothesis hrange21: ∀ x n, size (snd ((h x) n)) ≤ size x.
Hypothesis hrange12: ∀ x n, d < size x →  0 ≤ size (fst ((h x) n)).
Hypothesis hrange22: ∀ x n, d < size x →  0 ≤ size (snd ((h x) n)).

Hypothesis g1_pos: ∀ x, g1 x > 0.
Hypothesis g2_pos: ∀ x, g2 x > 0.
Hypothesis gmin: R.
Hypothesis g_below: ∀ x, x ≤ d → g2 x = gmin.
Hypothesis aglower: ∀ x, x ≤ d → a x / g2 x = 0.
Hypothesis ag_nonneg: ∀ x, a x / g2 x ≥ 0.
Hypothesis ag_mono: Rmono (λ x, a x / g2 x).
Hypothesis ag_pos: ∀ x, d < x → 0 < a x / g2 x.
Hypothesis mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
Hypothesis d_non_neg: 0 ≤ d.
Hypothesis mpos: ∀ x, 0 ≤ x → 0 ≤ m x.
Hypothesis g1d: ∀ x, x > d → g1 x ≥ 1.
Hypothesis g1pos: ∀ x, 0 ≤ x → 0 ≤ g1 x.
Hypothesis g1_mono: Rmono g1.

Definition Bn (nx: nat * X) : finType := B (snd nx).
Definition Ωn (nx: nat * X) := Ωh (snd nx).
Definition hpath (φ: nat → bool) (nx: nat * X) : rvar (Ωn nx) [eqType of nat * X].
  destruct nx as (n, x).
  apply mkRvar.
  intros i.
  exact (match (φ n) with
         | true =>  (S n, fst ((h x) i))
         | false => (S n, snd ((h x) i))
         end).
Defined.

(* This could be weakend; I think what's needed is to say it in the limit
   it's bounded above by 2^-n *)
Hypothesis hinf_0: ∀ a, ∃ n, ∀ φ, pr_gt (rvar_comp (recN_rvar (hpath φ) (O, a) n)
                                                  (λ x, size (snd x))) d = 0.

Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e / gmin  ≤ umin.

Definition K r z := pr (rvar_dist (T z)) (λ n, Rgt_dec ((T z) n) r).

Definition H (x: X) : rrvar (ΩT x) := rvar_comp (T x) (λ v, v / (g2 (size x))).

Definition Kg r z := pr (rvar_dist (H z)) (λ n, Rgt_dec ((H z) n) r).

Lemma umin_lb_simple: ∀ x, x ≥ d → umin ≤ u x.
Proof.
  rewrite /Rge => x [Hgt|Heq].
  - transitivity (u x - a x / g2 x); first auto. assert (a x / g2 x > 0) by (apply ag_pos; auto).
    nra.
  - subst. reflexivity.
Qed.

Lemma Kg_K r z: g2 (size z) > 0 → Kg r z = K (g2 (size z) * r) z.
Proof.
  intros Hsize.
  rewrite /Kg /K /H.
  rewrite pr_gt_alt_comp pr_gt_alt.
  apply eq_bigr => i ?.
  destruct (Rgt_dec) as [Hlt|Hge]; rewrite /is_left.
  - rewrite /Rdiv in Hlt. apply (Rmult_lt_compat_r (g2 (size z))) in Hlt; last first.
    { fourier. }
    rewrite Rmult_assoc Rinv_l in Hlt; last first.
    { apply Rgt_not_eq; eauto. }
    rewrite Rmult_1_r Rmult_comm in Hlt.
    destruct (Rgt_dec) => //=.
  - apply Rnot_gt_ge in Hge.
    rewrite /Rdiv in Hge. apply (Rmult_ge_compat_r (g2 (size z))) in Hge; last first.
    { left. eauto. }
    rewrite Rmult_assoc Rinv_l in Hge; last first.
    { apply Rgt_not_eq; eauto. }
    rewrite Rmult_1_r Rmult_comm in Hge.
    apply Rge_not_lt in Hge.
    destruct (Rgt_dec) => //=.
Qed.

Lemma K_Kg r z: g2 (size z) > 0 → K r z = Kg (r / g2 (size z)) z.
Proof.
  intros; rewrite Kg_K; eauto. replace (g2 (size z) * (r / g2 (size z))) with r; auto.
  field. apply Rgt_not_eq; eauto.
Qed.

Lemma Hrec:
  ∀ x r, P x → size x > d →  pr_gt (H x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                        ((pr_eq (h x) (sval x')) *
                         pr_gt (rvar_comp (rvar_pair (H (fst (sval x'))) (H (snd (sval x'))))
                                        (fun xy => Rmax (fst xy) (snd xy)))
                                              (r - a (size x) / g2 (size x))).
Proof.
 intros.
 rewrite /pr_gt. specialize (Kg_K); rewrite /Kg; intros ->; last by eauto.
 etransitivity. rewrite /K. apply Trec; auto.
 apply Rle_bigr => i Hin.
 apply Rmult_le_compat_l.
 { rewrite /pr_eq. apply Rge_le, ge_pr_0. }
 rewrite /pr_gt /pr.
 rewrite ?SeriesC_fin_big.
 rewrite -?big_mkcondr.
 apply Rle_bigr' => i' Hin'; auto.
 * intros. split; last reflexivity.
   move /andP in Hin'. destruct Hin' as (Hin'&Hgt).
   apply /andP; split; auto.
   destruct (Rgt_dec) as [Hgt'|?] => //= ; [].
   destruct (Rgt_dec) as [?|Hngt] => //=; [].
   exfalso; apply Hngt.
   destruct i as (i&?). rewrite //=.
   assert (∃ n, h x n = i) as (n&Hh).
   { apply img_alt. done. }
   subst.
   generalize Hgt'; intros Hlt%Rgt_lt.
   apply (Rplus_lt_compat_r (a (size x))) in Hlt.
   rewrite /Rminus Rplus_assoc Rplus_opp_l Rplus_0_r in Hlt.
   apply (Rmult_lt_compat_l (/g2 (size x))) in Hlt; last first.
   { apply Rinv_0_lt_compat. apply g2_pos; auto. }
   rewrite -Rmult_assoc Rinv_l in Hlt; last first.
   { apply Rgt_not_eq; eauto. }
   rewrite Rmult_1_l in Hlt.
   rewrite ?Rmult_plus_distr_l in Hlt.
   rewrite /Rminus.
   apply (Rplus_lt_compat_r (- (/ g2 (size x) * a (size x)))) in Hlt.
   rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r in Hlt.
   rewrite /Rdiv. rewrite Rmult_comm. rewrite //= in Hlt.
   eapply Rlt_le_trans.
   { rewrite Rmult_comm. apply Hlt. }
   assert (T ((h x) n).1 i'.1 =
   ( g2 (size ((h x) n).1) * (T ((h x) n).1) i'.1 * / g2 (size ((h x) n).1))) as Hdiv1.
   { rewrite Rmult_comm -Rmult_assoc Rinv_l; first by rewrite Rmult_1_l.
     apply Rgt_not_eq, g2_pos. }
   assert (T ((h x) n).2 i'.2 =
   ( g2 (size ((h x) n).2) * (T ((h x) n).2) i'.2 * / g2 (size ((h x) n).2))) as Hdiv2.
   { rewrite Rmult_comm -Rmult_assoc Rinv_l; first by rewrite Rmult_1_l.
     apply Rgt_not_eq, g2_pos. }
   rewrite {1}Hdiv1.
   rewrite {1}Hdiv2.
   apply Rmax_case_strong => Hle.
   ** etransitivity.
      { apply Rplus_le_compat_l.
        apply Rmult_le_compat_l.
        { apply Rinv_pos, g2_pos. }
        rewrite Rmult_assoc.
        apply Rmult_le_compat_l.
        { left. apply g2_pos. }
        apply Hle.
      }
      rewrite Rmult_assoc.
      rewrite -Rmult_plus_distr_l.
      rewrite (Rmult_comm (T _ _)).
      rewrite -Rmult_plus_distr_r.
      rewrite -Rmult_assoc.
      rewrite -[a in _ ≤ a]Rmult_1_l. apply Rmult_le_compat_r.
      { rewrite Rmult_comm. apply Rle_mult_inv_pos.
        - apply Rge_le, T_non_neg.
        - apply g2_pos.
      }
      apply (Rmult_le_reg_l (g2 (size x))).
      { apply g2_pos. }
      rewrite -Rmult_assoc Rinv_r //; last first.
      { apply Rgt_not_eq, g2_pos. }
      rewrite Rmult_1_l Rmult_1_r. eauto.
   ** etransitivity.
      { apply Rplus_le_compat_r.
        apply Rmult_le_compat_l.
        { apply Rinv_pos, g2_pos. }
        rewrite Rmult_assoc.
        apply Rmult_le_compat_l.
        { left. apply g2_pos. }
        rewrite Rmult_comm; apply Hle.
      }
      rewrite Rmult_assoc.
      rewrite -Rmult_plus_distr_l.
      rewrite -Rmult_plus_distr_r.
      rewrite -Rmult_assoc.
      rewrite -[a in _ ≤ a]Rmult_1_l. apply Rmult_le_compat_r.
      { apply Rle_mult_inv_pos.
        - apply Rge_le, T_non_neg.
        - apply g2_pos.
      }
      apply (Rmult_le_reg_l (g2 (size x))).
      { apply g2_pos. }
      rewrite -Rmult_assoc Rinv_r //; last first.
      { apply Rgt_not_eq, g2_pos. }
      rewrite Rmult_1_l Rmult_1_r. eauto.
 * intros. apply Rge_le, pmf_pos.
Qed.

Lemma Kg_work_bound:
  ∀ r x, P x → Kg r x ≤ span2.D g1 (λ x, a x / g2 x) m u u' d (umin)  r (size x).
Proof.
  intros.
  eapply span_bound; eauto.
  - intros. apply continuity_pt_div; auto.
    apply Rgt_not_eq, g2_pos; fourier.
  - apply Hrec.
  - rewrite /H //=.  intros.
    rewrite g_below /Rdiv; eauto.
Qed.

Lemma work_bound: ∀ r x, P x → K r x ≤ span2.D g1 (λ x, a x / g2 x) m u u' d umin (r / g2 (size x)) (size x).
  intros. rewrite K_Kg; last apply g2_pos.
  apply Kg_work_bound; auto.
Qed.

Lemma work_bound_simple w x:
  g1 (size x) > 1 →
  size x > d →
  P x → pr_gt (T x) (g2 (size x) * u (size x) + INR w * a (size x))
              ≤ g1 (size x) * (m (size x) / size x) ^ w.
Proof.
  set (r := g2 (size x) * (u (size x)) + INR w * (a (size x))).
  intros.
  transitivity (span2.D g1 (λ x, a x / g2 x) m u u' d umin (r / g2 (size x)) (size x)).
  - apply work_bound.  auto.
  - rewrite /D/r.
  destruct (Rle_dec) as [Hle|?].
     { rewrite //=. destruct w; first by (rewrite //=; nra).
         assert (umin <= u (size x)) by (apply umin_lb_simple; nra).
         assert (a (size x) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         specialize (pos_INR w).
         intros. rewrite S_INR in Hle. exfalso.
         rewrite /Rdiv Rmult_plus_distr_r in Hle.
         rewrite /Rdiv in Hag.
         rewrite Rmult_comm in Hle.
         rewrite -Rmult_assoc in Hle.
         rewrite Rinv_l in Hle; last nra.
         rewrite Rmult_1_l in Hle. nra.
     }
     rewrite //=.
     destruct Rle_dec => //=; try nra; [].
     destruct Rle_dec as [Hle|?].
     { intros. rewrite //=.
       destruct w.
       { replace (INR 0) with 0 by auto. rewrite Rmult_0_l Rplus_0_r.
         specialize (g2_pos (size x)).
         rewrite /Rdiv Rmult_comm -Rmult_assoc Rinv_l; last by nra.
         rewrite Rmult_1_l.
         rewrite u'_inv_above; last nra.
         apply Rmax_case_strong; nra.
       }
       assert (umin <= u (size x)) by (apply umin_lb_simple; nra).
         assert (a (size x) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         specialize (pos_INR w).
         intros. rewrite S_INR in Hle. exfalso.
         rewrite /Rdiv Rmult_plus_distr_r in Hle.
         rewrite /Rdiv in Hag.
         rewrite Rmult_comm in Hle.
         rewrite -Rmult_assoc in Hle.
         rewrite Rinv_l in Hle; last nra.
         rewrite Rmult_1_l in Hle. nra.
     }
     rewrite //=.
     assert ((round (λ x0 : R, a x0 / g2 x0) u
         ((g2 (size x) * u (size x) + INR w * a (size x)) / g2 (size x))
         (size x)) = (Z_of_nat w)) as Hround.
     {
       rewrite /round.
       assert ((((g2 (size x) * u (size x) + INR w * a (size x)) / g2 (size x)
                 - u (size x)) / (a (size x) / g2 (size x))) = INR w) as ->.
       { assert (a (size x) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         field.
         split; nra.
       }
        rewrite INR_IZR_INZ Rceil_IZR. done.
     }
     rewrite Hround //= INR_IZR_INZ.
     rewrite (Rmult_comm (IZR _)).
     assert ((g2 (size x) * u (size x) + a (size x) * IZR (Z.of_nat w)) / g2 (size x)
             - a (size x) / g2 (size x) * IZR (Z.of_nat w)
             = u (size x)) as ->.
     { field. specialize (g2_pos (size x)); nra.  }
     rewrite u'_inv_above; last by nra.
     rewrite /Rdiv. rewrite (Rmult_assoc (g1 (size x))).
     rewrite Rinv_r; last by nra. rewrite Rmult_1_r.
      rewrite Nat2Z.id. nra.
Qed.

End work_bound_sec.


(*! Common syntax to ITT and ETT *)

From MetaCoq Require Import Ast.
From Translation Require Import util Sorts.

Section Ast.

Context `{Sorts.notion}.

Inductive sterm : Type :=
| sRel (n : nat)
| sSort (s : sort)
| sProd (nx : name) (A B : sterm)
| sLambda (nx : name) (A B t : sterm)
| sApp (u A B v : sterm)
(* Σ-types *)
| sSum (nx : name) (A B : sterm)
| sPair (A B u v : sterm)
| sPi1 (A B p : sterm)
| sPi2 (A B p : sterm)
(* Homogenous equality *)
| sEq (A u v : sterm)
| sRefl (A u : sterm)
| sJ (A u P w v p : sterm)
| sTransport (T1 T2 p t : sterm)
(* Heterogenous equality *)
| sHeq (A a B b : sterm)
| sHeqToEq (p : sterm)
| sHeqRefl (A a : sterm)
| sHeqSym (p : sterm)
| sHeqTrans (p q : sterm)
| sHeqTransport (p t : sterm)
| sCongProd (B1 B2 pA pB : sterm)
| sCongLambda (B1 B2 t1 t2 pA pB pt : sterm)
| sCongApp (B1 B2 pu pA pB pv : sterm)
| sCongSum (B1 B2 pA pB : sterm)
| sCongPair (B1 B2 pA pB pu pv : sterm)
| sCongPi1 (B1 B2 pA pB pp : sterm)
| sCongPi2 (B1 B2 pA pB pp : sterm)
| sCongEq (pA pu pv : sterm)
| sCongRefl (pA pu : sterm)
| sEqToHeq (p : sterm)
| sHeqTypeEq (A B p : sterm)
(* Packing *)
| sPack (A1 A2 : sterm)
| sProjT1 (p : sterm)
| sProjT2 (p : sterm)
| sProjTe (p : sterm)
(* External axioms *)
| sAx (id : ident)
.

End Ast.


Definition admit {T: Type} : T.  Admitted.

(* --- Towards Realizability Checking of Contracts using Theories --- *)
(* --- Machine-Checked Proofs For Realizability Checking Algorithms --- *)

Inductive id : Type :=
Id : nat -> id.

Inductive inputs : Type :=
input : id -> nat -> inputs.

Inductive state : Type :=
st : id -> nat -> state.

Definition initial := state -> Prop.

Definition transition := state -> inputs -> state -> Prop.

Definition iguarantee := state -> Prop.

Definition tguarantee := state -> inputs -> state -> Prop.

Definition assumption := state -> inputs -> Prop.

Inductive reachable (s:state) (init: initial) (t: transition) (a:assumption) : Prop :=
rch : ((init s) \/ (exists (s':state) (inp:inputs),
                          (reachable s' init t a) /\ (a s' inp) /\ (t s' inp s))) ->
       reachable s init t a.

Inductive realization (init : initial) (t : transition) (a:assumption) (gi:iguarantee) (gt: tguarantee) : Prop :=
real : ((forall (s:state), (init s) -> (gi s)) /\
       (forall (s s':state) (inp : inputs),
          ((reachable s init t a) /\ (a s inp) /\ (t s inp s')) -> gt s inp s') /\
       (exists (s:state), init s) /\
       (forall (s:state) (inp:inputs), (reachable s init t a /\ (a s inp)) ->
         (exists (s':state), t s inp s')))->
       realization init t a gi gt.

Inductive realizable_contract (a:assumption) (gi: iguarantee) (gt: tguarantee) : Prop :=
rc : (exists (init : initial) (t : transition), realization init t a gi gt) -> realizable_contract a gi gt.

CoInductive viable (s:state) (a:assumption) (gi:iguarantee) (gt: tguarantee) : Prop :=
vbl : (forall (i:inputs), (a s i) -> (exists (s':state), gt s i s' /\ viable s' a gi gt)) -> viable s a gi gt.

Inductive realizable (a:assumption) (gi : iguarantee) (gt:tguarantee) : Prop :=
rl : (exists (s:state), gi s /\ viable s a gi gt) -> realizable a gi gt.

Lemma init_reachable : forall (s:state) (init:initial) (t:transition) (a:assumption),
init s -> reachable s init t a.
Proof. intros. apply rch. left. apply H. Qed.

Lemma reachable_viable : forall (s :state) (init:initial) (t:transition) (a:assumption) (gi:iguarantee) (gt:tguarantee),
realization init t a gi gt -> reachable s init t a -> viable s a gi gt.

Proof. cofix. intros. apply vbl. intros. inversion H. inversion H2. inversion H4. inversion H6. destruct H8 with (s:=s) (inp:=i). split. apply H0. apply H1. exists x. split. apply H5.
  split. apply H0. split. apply H1. apply H9. apply reachable_viable with (init:= init) (t:=t). apply H. apply rch. right. exists s. exists i. split. apply H0. split. apply H1. apply H9.
Qed.

Theorem realcontract_implies_real  (init:initial) (t:transition) : forall (a : assumption) (gi : iguarantee) (gt : tguarantee),
realizable_contract a gi gt -> realizable a gi gt.
Proof.
  split.
  intros. apply rl. inversion H. inversion H0. inversion H1. inversion H2. inversion H3.
  inversion H5. inversion H7. inversion H8. exists x1. apply and_comm. split. apply init_reachable with (s:= x1) (t:=x0) (a:=a) in H10. apply reachable_viable with (gi:=gi) (gt:= gt) in H10. apply H10.
  apply H2. apply H4. apply H10.
Qed.

Theorem reach_via : forall (s s0:state) (a:assumption) (gi:iguarantee) (gt:tguarantee),
viable s0 a gi gt -> reachable s (fun s => s = s0) (fun s i s' => gt s i s' /\ viable s' a gi gt) a -> viable s a gi gt.
Proof.
  intros. inversion H0. inversion H1. subst. assumption. inversion H2. inversion H3. inversion H4. inversion H6. inversion H8. assumption.
Qed.

Theorem real_implies_realcontract (init:initial) (t:transition) : forall (a : assumption) (gi : iguarantee) (gt : tguarantee),
realizable a gi gt -> realizable_contract a gi gt.
Proof.
  intros. apply rc. inversion H as [[s0 [gi_s0 viable_s0]]]. exists (fun s => s = s0).
  exists (fun s i s' => gt s i s' /\ viable s' a gi gt). apply real. split.

  intros. rewrite H0. apply gi_s0.

  split. intros. inversion H0. inversion H2. inversion H4. apply H5.

  split. exists s0. reflexivity.

  intros. inversion H0. apply reach_via with (gi:=gi) (gt:=gt) in H1. inversion H1. apply H3. apply H2. assumption.
Qed.

Fixpoint finite_viable (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => True
  | S n' => forall i, a s i -> exists s', gt s i s' /\ finite_viable n' s' a gt
  end.

Fixpoint extendable (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => forall i, a s i -> exists (s':state), gt s i s'
  | S n' => forall i s', a s i -> gt s i s' -> extendable n' s' a gt
  end.

Definition Basecheck (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) :=
exists (s:state), (gi s /\ finite_viable n s a gt).

Definition Extendcheck (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable n s a gt.

Lemma viable_implies_finite_viable : forall a gi gt n s,
viable s a gi gt -> finite_viable n s a gt.
Proof. intros a gi gt n. induction n. intros. simpl. auto.
  intros. simpl. intros.  inversion H. apply H1 in H0.
  inversion H0. inversion H2. exists x.
  intros. split. apply H3. apply IHn. apply H4.
Qed.

Definition Validity_Region := state -> Prop.

Definition valid_formula (vr: Validity_Region) a gt : Prop :=
forall s (i:inputs), ((a s i /\ vr s) <-> exists (s':state), gt s i s').

Lemma Region_implies_exists : forall (vr:Validity_Region) a gt,
valid_formula vr a gt -> (forall s (i:inputs), a s i -> (vr s -> exists (s':state), gt s i s')).
Proof. intros. unfold valid_formula in H. apply H. split. assumption. assumption. Qed.

Lemma Exists_implies_region : forall (vr:Validity_Region) a gt,
valid_formula vr a gt -> (forall s (i:inputs), (a s i /\ exists (s':state), gt s i s') -> vr s).
Proof. intros. unfold valid_formula in H. inversion H0. apply H in H2. inversion H2. assumption.
Qed.

Definition Validity_Region (X Y:Type) (s:X) (i:Y) (A : X -> Y -> Prop) (G : X -> Y -> X -> Prop) : Prop :=
(A s i -> exists s', G s i s').

Lemma Region_implies_exists : forall (X Y:Type) (A: X -> Y -> Prop) (G: X -> Y -> X -> Prop),
forall s i, A s i -> Validity_Region X Y s i A G -> exists s', G s i s'.
Proof. intros. unfold Validity_Region in H0. apply H0. assumption. Qed.

Lemma Exists_implies_region : forall (X Y:Type) (A: X -> Y -> Prop) (G: X -> Y -> X -> Prop),
forall s i, A s i -> exists s', G s i s' -> Validity_Region X Y s i A G.
Proof. intros. assert (H2: (exists s', G s i s' -> Validity_Region X Y s i A G) -> False).
intros. assert (s0:X). assumption. assert (i0:Y). assumption. assert (H1 : (exists s0', G s0 i0 s0') /\ (~Validity_Region X Y s0 i0 A G)).
split.

 split. apply Region_implies_exists with (X:=X) (Y:=Y) (G:=G) (s:=s) (i:=i) in H.
apply H. apply H0.

 exists x. exists i.

Proof. intros. assert (H1: exists s0 i0, A s0 i0 /\ (exists s0', G s0 i0 s0') /\ (Validity_Region X Y A G -> False)).
assert (H1: A s i). assumption.
apply Region_implies_exists with (X:=X) (Y:=Y) (G:=G) (s:=s) (i:=i) in H.
inversion H. exists s. exists i. split. assumption. split.  exists x. assumption. intros.
apply H0. intros. assumption.
unfold Validity_Region. intros. simpl. neg. intros.

inversion H0.
 apply H0. intros. unfold Validity_Region. inversion H1. intros.  apply Region_implies_exists with (X:=X) (Y:=Y) (G:=G) (s:=s0) (i:=i0) in H3.
assumption. unfold Validity_Region. intros. apply H2 with (s0:=s) (i0:=i) (s':=x). intros. inversion H1. exists x. assumption.

A s i -> (Validity_Region s i A G -> exists s', G s i s').
a s i -> (Validity_Region s i a gt -> exists s', gt s i s').
Proof. intros. unfold Validity_Region in H0. apply H0 in H. assumption. Qed.

Definition Validity_Region (s:state) (i:inputs) (a:assumption) (gt:tguarantee) :=
(a s i -> exists s', gt s i s').

Lemma Region_implies_exists : forall s i (a:assumption) gt,
a s i -> (Validity_Region s i a gt -> exists s', gt s i s').
Proof. intros. unfold Validity_Region in H0. apply H0 in H. assumption. Qed.

Lemma Exists_implies_region : forall (a:assumption) gt i s,
a s i -> (~((exists s', gt s i s') -> Validity_Region s i a gt) -> False).
Proof. intros. apply H0. intros. unfold Validity_Region. intros. assumption. Qed.

(*
Fixpoint Validity_Region (n:nat) (s:state) (a:assumption) (gi:iguarantee) :=
match n with
|O => forall i, (a s i -> exists s', gt s i s').
|S n => forall i, (a s i /\ Validity_Region n

Fixpoint F (n:nat) (s :state) (a:assumption) (gi:iguarantee)(gt:tguarantee) :=
match n with
|O => exists s, gi s
|S n' => forall i, a s i -> exists s', gt s i s' -> F n' s' a gi gt
end.

Theorem vbl_f : forall  (i:inputs) a gi gt n (s:state),
exists s' gi s'(gi s /\ viable s a gi gt) -> F n s a gi gt.
Proof. intros i a gi gt n. induction n. intros. simpl. inversion H. exists s. apply H0.
       intros. inversion H. simpl. intros. apply H1 in H2. inversion H2. inversion H3.
       exists x. intros. apply IHn. split

 simpl. inversion H. exists s. assumption.
       simpl. intros. inversion H.  inversion H2.  apply H3 in H0.  inversion H0.
       exists x.  inversion H4. intros. split. assumption. simpl. apply IHn. split. inversion H. inversion H1. apply

 intros s i a gi gt. induction n. intros. inversion H. simpl. exists s. apply H0.
       intros. simpl.  intros. inversion H.  inversion H2. apply H3 in H0.
       inversion H0. exists x. split.  inversion H4. assumption. apply IHn. exists x. exists s.
       split. apply H3 in H0. apply H0. apply H3 in H0. inversion H0.
       exists s. split.
       simpl. intros. inversion H. inversion H2. apply H3 in H0. inversion H0.
       exists x. inversion H4. split. assumption. apply IHn.*)

Theorem unrealizable_soundness : forall (s:state) (init:initial) (t:transition) a gi gt,
(exists n, ~Basecheck n a gi gt) -> ~ realizable_contract a gi gt.
Proof.
  intros. unfold not. intros. apply realcontract_implies_real in H0. inversion H0. inversion H1. inversion H2. inversion H. apply viable_implies_finite_viable with (n:=x0) in H4.
  apply H5. unfold Basecheck. exists x. split. assumption. assumption. apply init. apply t.
Qed.

Lemma finite_viable_plus_one : forall n a gt (gi:iguarantee) (i:inputs) s,
(extendable n s a gt /\ finite_viable n s a gt) -> finite_viable (S n) s a gt.
Proof. intros n a gt gi i. induction n.
  intros. simpl. intros. inversion H. simpl in H1. apply H1 in H0.
  inversion H0. exists x. intros. auto.

  intros. simpl. intros. inversion H. assert (H3: a s i0).
  apply H0. simpl in H2. simpl in H1. apply H2 in H3. inversion H3.
  exists x. intros. split. inversion H4. apply H5.
  assert (H5: extendable n x a gt). apply H1 with (i:=i0).
  apply H0. inversion H4. apply H5. inversion H4.
  apply conj with (A:=extendable n x a gt) in H7.
  apply IHn in H7. simpl in H7. intros. apply H7 in H8.
  apply H8. apply H5.
Qed.

Lemma extend_viable_shift : forall (n : nat) (a : assumption) (gi : iguarantee) (gt : tguarantee) (s : state) (i : inputs),
(extendable n s a gt /\ finite_viable n s a gt /\ a s i) -> (exists s', gt s i s' /\ finite_viable n s' a gt).
Proof. intros n a gi gt. induction n.
  intros. inversion H. simpl in H0. inversion H1.
  apply H0 in H3. inversion H3. exists x. intros. simpl. auto.

  intros. inversion H. simpl in H0. inversion H1. assert (H4: a s i).
  apply H3. simpl in H2. apply H2 in H3. inversion H3.
  exists x. intros. simpl. intros.
  assert (H8: a s i -> gt s i x -> extendable n x a gt).
  apply H0. apply H8 in H4. inversion H5.
  split. apply H6. intros. apply conj with (A:=extendable n x a gt) in H7.
  apply finite_viable_plus_one in H7. simpl in H7. apply H7. apply H9.
  apply gi. apply i. apply H4. inversion H5. apply H6.
Qed.

Lemma fv_ex_implies_viable : forall n (a:assumption) gi gt (init:initial) (t:transition) (s:state),
(finite_viable n s a gt /\ Extendcheck n a gt) -> viable s a gi gt.
Proof.
 cofix. intros n a gi gt init t. intros. apply vbl.
 intros. inversion H. unfold Extendcheck in H2.
 assert (H3: extendable n s a gt). apply H2.
 apply conj with (A:=finite_viable n s a gt) in H0.
 apply conj with (A:= extendable n s a gt) in H0.
 apply extend_viable_shift in H0. inversion H0.
 exists x. inversion H4. split. apply H5.
 apply fv_ex_implies_viable with (n:=n). apply init.
 apply t. split. apply H6. inversion H. apply H8.
 apply gi.  apply H3. apply H1.
Qed.

Theorem realizable_soundness : forall (s:state) (init:initial) (t:transition) a gi gt,
(exists n, (Basecheck n a gi gt /\ Extendcheck n a gt)) -> realizable_contract a gi gt.
Proof.
  intros. apply real_implies_realcontract. apply init. apply t. apply rl.
  inversion H. inversion H0. inversion H1. subst. inversion H3. unfold Basecheck in H4.
  exists x0. split. assumption. apply fv_ex_implies_viable with (n:=x). apply gi. apply t. split.
  assumption. assumption.
Qed.

Definition Basecheck_simple (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable n s a gt.

Theorem basecheck_soundness_one_way : forall n a (gi:iguarantee) gt (i:inputs),
((exists s, gi s) /\
(forall k, (k<=n) -> Basecheck_simple k a gi gt)) -> Basecheck n a gi gt.
Proof.
  intros. induction n. unfold Basecheck. assert (H0: 0<=0). apply le_n.
  inversion H. inversion H1. exists x. split. assumption. constructor.

  unfold Basecheck. inversion H.
  assert (H3: (forall k : nat, k <= n -> Basecheck_simple k a gi gt)).
  intros. apply le_S in H2. inversion H. apply H4 in H2.
  assumption. apply conj with (A:= exists s : state, gi s) in H3.
  apply IHn in H3. inversion H3. inversion H2.
  exists x. split. assumption.

  apply finite_viable_plus_one. assumption. assumption. split. unfold Basecheck_simple in H1.
  apply H1. apply le_S. apply le_n. assumption. assumption.
  assumption.
Qed.

(* --- Synthesis from Assume-Guarantee Contracts using Skolemized Proofs of Realizability --- *)

Definition skolem_0 (s:state) (i:inputs) : state := admit.
Definition skolem_1 (s:state) (i: inputs) (s': state) (i': inputs) : state := admit.

Inductive extendable_f : nat -> state -> assumption -> tguarantee -> Prop :=
|exnill : forall s (a:assumption) (gt:tguarantee), (forall i, a s i -> (gt s i (skolem_0 s i))) ->
extendable_f O s a gt
|exone : forall s i (a:assumption) (gt:tguarantee), a s i /\ gt s i (skolem_0 s i) /\
   (forall s' i', a s' i' -> gt s' i' (skolem_1 s i s' i')) -> extendable_f (S O) s a gt.

Theorem extf_zero_implies_ext_zero : forall (a:assumption) (gt:tguarantee) (s:state),
extendable_f O s a gt -> extendable O s a gt.
Proof.
  intros n a gt.
  intros. inversion H. simpl. intros. exists (skolem_0 s i).
  apply H0. apply H1.
Qed.

Theorem extf_one_implies_ext_one : forall (a:assumption) (gt:tguarantee) (s:state),
extendable_f 1 s a gt -> extendable 1 s a gt.
Proof.
  intros. simpl. intros. inversion H. inversion H3. inversion H8.
  assert (H11: gt s' i0 (skolem_1 s i1 s' i0)).
  apply H10. apply H2.  exists (skolem_1 s i1 s' i0).  apply H11.
Qed.

Definition Basecheck_simple_f (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable_f n s a gt.

Definition Extendcheck_f (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable_f n s a gt.

Theorem BCheck_f_imp_BCheck_zero : forall (a:assumption) (gi:iguarantee) (gt:tguarantee),
Basecheck_simple_f O a gi gt -> Basecheck_simple O a gi gt.
Proof.
  intros. unfold Basecheck_simple_f in H. unfold Basecheck_simple.
  intros. apply extf_zero_implies_ext_zero. apply H. apply H0.
Qed.

Theorem BCheck_f_imp_BCheck_one : forall (a:assumption) (gi:iguarantee) (gt:tguarantee),
Basecheck_simple_f 1 a gi gt -> Basecheck_simple 1 a gi gt.
Proof.
  intros. unfold Basecheck_simple_f in H. unfold Basecheck_simple.
  intros. apply H in H0. simpl. intros. inversion H0. inversion H4. inversion H9.
  assert (H12: gt s' i0 (skolem_1 s i1 s' i0)). apply H11. assumption.
  exists (skolem_1 s i1 s' i0). apply H12.
Qed.

Theorem ECheck_f_imp_ECheck_zero : forall (a:assumption) (gt:tguarantee) (s:state),
Extendcheck_f O a gt -> Extendcheck O a gt.
Proof.
  intros. unfold Extendcheck. unfold Extendcheck_f in H.
  intros. apply extf_zero_implies_ext_zero. apply H.
Qed.

Theorem ECheck_f_imp_ECheck_one : forall (a:assumption) (gt:tguarantee) (s:state),
Extendcheck_f 1 a gt -> Extendcheck 1 a gt.
Proof.
  intros. unfold Extendcheck. unfold Extendcheck_f in H.
  intros. apply extf_one_implies_ext_one. apply H.
Qed.

(*Random Notes Below --- Safe to ignore! *)

(*

Inductive extendable_f : nat -> assumption -> tguarantee -> Prop :=
|exnill : forall sl s (a:assumption) (gt:tguarantee), (sl = scons s snil) /\ (forall i, a s i -> (gt s i (skolem s i))) ->
extendable_f O sl a gt
|exone : forall sl s s' (a:assumption) (gt:tguarantee), extendable_f O sl a gt /\ (forall i, a s' i -> gt s i (skolem

Fixpoint extendable_f (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => forall i, a s i -> gt s i (skolem_0 s i)
  | S O => forall (i:inputs) s', a s i  /\ s' = skolem_0 s i -> gt s i (skolem s i) -> extendable_f n' s' a gt
  end.

Theorem extf_zero_implies_ext_zero : forall (a:assumption) (gt:tguarantee) (s:state),
extendable_f O s a gt -> extendable O s a gt.
Proof.
  intros n a gt.
  intros. inversion H. simpl. intros. exists (skolem_0 s i).
  apply H0. apply H1.
Qed.

Theorem extf_one_implies_ext_one : forall (a:assumption) (gt:tguarantee) (s:state),
extendable_f 1 s a gt -> extendable 1 s a gt.
Proof.
  intros. simpl. intros. simpl in H.

 simpl in H1. intros.
  apply H1 in H2. exists (skolem s i). apply H2.

  intros. simpl. inversion H. intros. apply IHn.
  split. apply H0. simpl in H1. apply H1 with (i:=i).
  split. apply H2. apply H0. assert (H4: s' = skolem s i).
  apply H0. rewrite H4 in H3. apply H3.
Qed.

Definition Basecheck_simple_f_zero (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable_f O s a gt.

Definition Basecheck_simple_f_one (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable_f 1 s a gt.

Definition Extendcheck_f_zero (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable_f O s a gt.

Definition Extendcheck_f_one (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable_f 1 s a gt.

Theorem BCheck_f_imp_BCheck : forall (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) (sl:statelist),
Basecheck_simple_f O a gi gt -> Basecheck_simple O a gi gt.
Proof.
  intros. unfold Basecheck_simple_f in H. unfold Basecheck_simple.
  intros. apply exs_imp_ex_one. apply sl. apply H. apply H0.
Qed.

Inductive statelist : Type :=
|snil : statelist
|scons : state -> statelist -> statelist.

Inductive extendable_f : nat -> statelist -> assumption -> tguarantee -> Prop :=

|exnill : forall sl s (a:assumption) (gt:tguarantee), (sl = scons s snil) /\ (forall i, a s i -> (gt s i (skolem s i))) ->
extendable_f O sl a gt
|exone : forall sl s s' (a:assumption) (gt:tguarantee), extendable_f O sl a gt /\ (forall i, a s' i -> gt s i (skolem
|exind : forall m sl a gt i s sl', ((sl = scons s sl') /\ a s i /\ gt s i (skolem s i) /\ extendable_f m sl a gt) -> extendable_f (S m) (scons (skolem s i) sl) a gt.

Inductive statelist : Type :=
|snil : statelist
|scons : state -> inputs -> statelist -> statelist.

Definition skolem (s:state) (i:inputs) : state := admit.

Fixpoint extendable_f (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => forall i, a s i -> gt s i (skolem s i)
  | S n' => forall (i:inputs) s', a s i  /\ s' = skolem s i -> gt s i (skolem s i) -> extendable_f n' s' a gt
  end.

Fixpoint finite_viable_f (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => True
  | S n' => forall i, a s i -> gt s i (skolem s i) /\ finite_viable_f n' (skolem s i) a gt
  end.

CoInductive viable_f (s:state) (a:assumption) (gi:iguarantee) (gt: tguarantee) : Prop :=
vblf : (forall (i:inputs), a s i -> gt s i (skolem s i) /\ viable_f (skolem s i) a gi gt) -> viable_f s a gi gt.

Theorem viable_f_implies_viable : forall s a gi gt,
(viable_f s a gi gt -> viable s a gi gt).
Proof. cofix.
  intros. inversion H. apply vbl. intros. apply H0 in H1.
  exists (skolem s i). inversion H1. split. apply H2. apply viable_f_implies_viable.
  apply H3.
Qed.

Definition Basecheck_simple_f (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable_f n s a gt.

Definition Extendcheck_f (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable_f n s a gt.

Theorem exs_imp_ex_one : forall (n:nat)  (a:assumption) (gt:tguarantee) (s:state),
(forall s' i' s'', s'' = skolem s' i') /\ extendable_f n s a gt -> extendable n s a gt.
Proof.
  intros n a gt. induction n.
  intros. inversion H. simpl. simpl in H1. intros.
  apply H1 in H2. exists (skolem s i). apply H2.

  intros. simpl. inversion H. intros. apply IHn.
  split. apply H0. simpl in H1. apply H1 with (i:=i).
  split. apply H2. apply H0. assert (H4: s' = skolem s i).
  apply H0. rewrite H4 in H3. apply H3.
Qed.

Lemma finite_viable_plus_one_f : forall n a gt (gi:iguarantee) (i:inputs) s,
(forall s' i' s'', s'' = skolem s' i') /\ extendable_f n s a gt /\ finite_viable_f n s a gt -> finite_viable_f (S n) s a gt.
Proof.
  intros n a gt gi i. induction n. intros.
  simpl. intros. inversion H. split. inversion H2. simpl in H3. apply H3.
  apply H0. auto.

  intros. inversion H. inversion H1. simpl in H2. simpl in H3.
  simpl. intros. assert (H5: a s i0). apply H4.
  assert (s':state). apply s. assert (H6: s' = skolem s i0).
  apply H0. split. apply conj with (A:=a s i0) in H6. apply H2 in H6.
  apply H3 in H4. inversion H4. apply H7.
  apply H3 in H4. inversion H4. apply H7.
  apply H4.
  intros. assert (s' = skolem s i0). apply H0.
  apply conj with (A:=a s i0) in H6. apply H2 in H6.
  rewrite H8 in H6. apply H3 in H4. inversion H4.
  assert (H11:finite_viable_f (S n) (skolem s i0) a gt).
  apply IHn. split. apply H0. split. apply H6. apply H10.
  admit. admit. assumption. Qed.

Theorem extendable_f_imp_viable_f : forall  (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) (s:state),
(forall i, a s i /\ finite_viable_f n s a gt /\ Extendcheck_f n a gt) -> viable_f s a gi gt.
Proof.
  cofix. intros n a gi gt. induction n.
  intros. apply vblf. intros. split. assert (H1: a s i /\ finite_viable_f 0 s a gt /\ Extendcheck_f 0 a gt).
  apply H. inversion H1. inversion H3. unfold Extendcheck_f in H5. assert (H6: extendable_f 0 s a gt).
  apply H5. simpl in H6. apply H6. apply H2. admit. admit.
Qed.

Inductive statelist : Type :=
|snil : statelist
|scons : state -> inputs -> statelist -> statelist.

Fixpoint skolem (s:state) (i:inputs) (sl:statelist) (a:assumption) (gt:tguarantee): Prop :=
  match sl with
  |snil => a s i /\ exists s':state, gt s i s'
  |scons s' i' sl' => a s' i' -> gt s' i' s -> a s i -> exists s'', gt s i s'' -> skolem s' i' sl' a gt
  end.

Fixpoint extendable_f (n:nat) (s:state) (a:assumption) (gt:tguarantee): Prop :=
  match n with
  | O => forall i sl, a s i -> skolem s i sl a gt
  | S n' => forall i sl s', skolem s i sl a gt -> gt s i s' -> extendable_f n' s' a gt
  end.

Fixpoint finite_viable_f (n:nat) (s:state) (a:assumption) (gt:tguarantee) : Prop :=
  match n with
  | O => True
  | S n' => forall i sl, a s i -> exists s', skolem s i sl a gt -> gt s i s' /\ finite_viable_f n' s' a gt
  end.

CoInductive viable_f (s:state) (a:assumption) (gi:iguarantee) (gt: tguarantee) : Prop :=
vblf : (forall (i:inputs) (sl:statelist) s', a s i -> skolem s i sl a gt /\ gt s i s' /\ viable_f s' a gi gt) -> viable_f s a gi gt.

Theorem viable_f_implies_viable : forall s a gi gt (sl:statelist),
(viable_f s a gi gt -> viable s a gi gt).
Proof. cofix.
  intros. inversion H. apply vbl. intros. assert (x:state). apply s.
  destruct H0 with (i:=i) (sl:=sl) (s':=x). apply H1. inversion H3. exists x.
  split. apply H4. apply viable_f_implies_viable. apply sl. apply H5.
Qed.

Definition Basecheck_simple_f (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee):=
forall s, (gi s) -> extendable_f n s a gt.

Definition Extendcheck_f (n:nat) (a:assumption) (gt:tguarantee) :=
forall s a gt, extendable_f n s a gt.

Theorem exs_imp_ex_one : forall (n:nat)  (a:assumption) (gt:tguarantee) (sl:statelist) (s:state),
extendable_f n s a gt -> extendable n s a gt.
Proof.
  intros n a gt sl. induction n. induction sl. intros.
  simpl. intros. simpl in H. apply H with (sl:=snil) in H0.
  simpl in H0. inversion H0. inversion H2. exists x. apply H3.
  intros. apply IHsl. apply H.

  induction sl. intros. simpl. intros. apply IHn. simpl in H. apply H with (i:=i) (sl:=snil).
  simpl. split. apply H0. exists s'. apply H1. apply H1.
  intros. apply IHsl. apply H.
Qed.

Theorem BCheck_f_imp_BCheck : forall (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) (sl:statelist),
Basecheck_simple_f n a gi gt -> Basecheck_simple n a gi gt.
Proof.
  intros. unfold Basecheck_simple_f in H. unfold Basecheck_simple.
  intros. apply exs_imp_ex_one. apply sl. apply H. apply H0.
Qed.

Theorem ECheck_f_imp_ECheck : forall (n:nat) (a:assumption) (gt:tguarantee) (sl:statelist) (s:state) (sl:statelist),
Extendcheck_f n a gt -> Extendcheck n a gt.
Proof.
  intros. unfold Extendcheck. unfold Extendcheck_f in H.
  intros. apply exs_imp_ex_one. apply sl. apply H.
Qed.

Theorem extendable_f_imp_viable_f : forall  (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) (s:state),
(forall i, a s i /\ finite_viable_f n s a gt /\ Extendcheck_f n a gt) -> viable_f s a gi gt.
Proof.
  cofix. intros. apply vblf. intros.
  destruct H with (i:=i). unfold Extendcheck_f in H2. inversion H2.
  assert (H4: extendable_f n s a gt). apply H3. induction n. simpl in H4.
  apply H4 with (sl:=sl) in H0. split. apply H0. split. induction sl.
  simpl in H0. inversion H0. apply H6.
 assert (H4: extendable_f 0 s a gt).
  apply H1. simpl in H4. split. apply H4. apply H4 in
 cofix. intros. apply vblf. induction n.
  intros. split.

 induction intros. inversion H. assert (H10: a s i). assumption. apply conj with (A:=finite_viable_f 0 s a gt) in H0.
 unfold Extendcheck_f in H2. assert (H3: extendable_f 0 s a gt). apply H2. apply conj with (A:= extendable_f 0 s a gt) in H0.
 apply extend_f_viable_f_shift in H0. inversion H3. apply H4 in H10. apply if_skolem_then_gt_holds in H10.
 inversion H10.  exists x. split.  inversion H5. assumption. split. inversion H5. assumption.
 apply extendable_f_imp_viable_f. split. apply fvnill. unfold Extendcheck_f.
 intros. apply H2. assumption. assumption. assumption. assumption.
Qed.

Lemma extend_f_viable_f_shift : forall (n:nat) (a:assumption) (gi:iguarantee) (gt:tguarantee) (s:state) (i:inputs),
(extendable_f n s a gt /\ finite_viable_f n s a gt /\ a s i) -> forall i' (sl:statelist), exists s', (skolem s' i' (scons s i sl) a gt) /\ finite_viable_f n s' a gt.
Proof.
  intros n a gi gt. induction n.
  intros. inversion H. simpl in H0.
  inversion H1. apply H0 with (sl:=sl) in H3.
  induction sl. simpl in H3. inversion H3. inversion H5.
  exists x. split. simpl. intros. assert (s'':state).
  apply s. exists s''. intros. split. apply H4. exists x. apply H6.
  simpl. auto.

  apply IHsl.
 simpl in H0. inversion H1.
  apply H0 with(sl:=snil) in H3. simpl in H3.
  inversion H3. inversion H5. exists x. intros.
  split. simpl. intros. assert (s'':state). apply s.
  exists s''. intros. apply H3. simpl. auto.

  intros. apply IHsl in H. inversion H. exists x. intros.
  simpl. intros. split. intros. assert (s'':state). apply s.
  exists s''. intros.
 split. simpl. intros. intros.
 split. inversion H. simpl in H0.(sl:statelist)
  simpl.
  induction sl. simpl.
  simpl. split. split. inversion H1. apply H3. split.
  assert (H2: skolem s i sl a gt). apply H0. inversion H1. apply H3.
  induction sl. simpl in H2.  inversion H2.
  simpl in H2. apply H0 with (sl:=(scons s i sl)). inversion H1. apply H3. simpl. auto.

  intros. split. simpl. split.
  inversion H. simpl in H0. inversion H1. simpl in H2. apply H2 with (s':=s') (sl:=sl) in H3.
  assert (H4: skolem s i (scons s' i' sl) a gt /\ finite_viable_f n s' a gt).
  apply H0.
  apply IHn. inversion H. simpl in H0.
  assert (H2: skolem s i sl a gt /\ gt s i s' /\ extendable_f n s a gt).
  apply H0.

 inversion H. inversion H1. exists s.
  inversion H0. apply H2. inversion H1. apply H8.
  apply IHn. split. inversion H. inversion H2. inversion H5.
  apply H10. split. inversion H1. inversion H2. apply H5.
  inversion H1. apply H3. inversion H0. inversion H3. apply H8.
  inversion H1. inversion H2. split. apply H5. apply H3.

  induction n. apply fvnill. apply fvv. apply IHn. inversion H0.
  inversion H3. split. apply H8. split. inversion H. inversion H11.
  inversion H12. apply H15. inversion H1. apply H11.
  inversion H0. inversion H3. apply H8. inversion H1.
  inversion H2. split. apply H5. apply H3.
  intros. inversion H0. inversion H4.
  assert (H12: compatible_f sl s i a gt /\ gt (extendable_f 0 (skolem (hds s sl) (hdi i sl) sl) sl a gt).
  inversion H4. apply H10. inversion H12. inversion H10. apply H11. inversion H9.
   inversion H11. destruct H10.

apply fvv.

 inversion H0. inversion H1. split.
  apply H2. apply H9. apply fvnill.
  split.
  split.  inversion H2. inversion H8. apply H10. inversion H1. apply H17.
apply H2 in H7. apply if_skolem_then_gt_holds in H7.
  inversion H7. exists x. inversion H8. split. assumption. apply fvv. assumption. assumption. assumption.
Qed.

Theorem extendable_f_imp_viable_f : forall (s:state) (a:assumption) (gi:iguarantee) (gt:tguarantee),
(finite_viable_f O s a gt /\ Extendcheck_f O a gt) -> viable_f s a gi gt.
Proof.
 cofix. intros. apply vblf. intros. inversion H. assert (H10: a s i). assumption. apply conj with (A:=finite_viable_f 0 s a gt) in H0.
 unfold Extendcheck_f in H2. assert (H3: extendable_f 0 s a gt). apply H2. apply conj with (A:= extendable_f 0 s a gt) in H0.
 apply extend_f_viable_f_shift in H0. inversion H3. apply H4 in H10. apply if_skolem_then_gt_holds in H10.
 inversion H10.  exists x. split.  inversion H5. assumption. split. inversion H5. assumption.
 apply extendable_f_imp_viable_f. split. apply fvnill. unfold Extendcheck_f.
 intros. apply H2. assumption. assumption. assumption. assumption.
Qed.
*)


Require Export XR_Rmult_comm.
Require Export XR_Rmult_lt_compat_l.

Local Open Scope R_scope.

Lemma Rmult_lt_compat_r : forall r r1 r2,
  R0 < r ->
  r1 < r2 ->
  r1 * r < r2 * r.
Proof.
  intros x y z.
  intros hx hyz.
  repeat rewrite (Rmult_comm _ x).
  apply Rmult_lt_compat_l.
  { exact hx. }
  { exact hyz. }
Qed.