(* ******************************************************************************* *)
(** * Bicategories
    Benedikt Ahrens, Marco Maggesi
    February 2018
 ********************************************************************************* *)

(* ============================================================================================= *)
(* Displayed transformation of contravariant functors.                                           *)
(* ============================================================================================= *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.ContravariantFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Arguments nat_trans_comp {C C' F G H} a b.

Section Cofunctormaps.

  Variable (K : univalent_category).

  Definition disp_presheaf : disp_bicat bicat_of_univ_cats
    := disp_presheaf_bicat K.

  Definition disp_two_presheaves : disp_bicat bicat_of_univ_cats
    := disp_dirprod_bicat disp_presheaf disp_presheaf.

  Definition disp_two_presheaves_is_univalent_2_1
    : disp_univalent_2_1 disp_two_presheaves.
  Proof.
    apply is_univalent_2_1_dirprod_bicat.
    - exact (disp_presheaves_is_univalent_2_1 K).
    - exact (disp_presheaves_is_univalent_2_1 K).
  Defined.

  Definition disp_two_presheaves_is_univalent_2_0
    : disp_univalent_2_0 disp_two_presheaves.
  Proof.
    apply is_univalent_2_0_dirprod_bicat.
    - exact univalent_cat_is_univalent_2_1.
    - exact (disp_presheaves_is_univalent_2 K).
    - exact (disp_presheaves_is_univalent_2 K).
  Defined.

  Definition disp_two_presheaves_is_univalent_2
    : disp_univalent_2 disp_two_presheaves.
  Proof.
    split.
    - exact disp_two_presheaves_is_univalent_2_0.
    - exact disp_two_presheaves_is_univalent_2_1.
  Defined.

  Definition disp_cofunctormaps_cat_ob_mor : disp_cat_ob_mor (total_bicat disp_two_presheaves).
  Proof.
    red.
    use tpair.
    - intros (C, (ty, tm)). cbn in *.
      exact (tm ⟹ ty).
    - intros (C, (ty, tm)) (C', (ty', tm')) p p' (f, (αty, αtm)).
      cbn in *.
      exact (nat_trans_comp p αty =
             nat_trans_comp αtm (pre_whisker _ p')).
  Defined.

  Definition disp_cofunctormaps_cat_id_comp
    : disp_cat_id_comp _ disp_cofunctormaps_cat_ob_mor.
  Proof.
    apply tpair.
    - intros (C, (ty, tm)) p.
      apply nat_trans_eq.
      + apply homset_property.
      + cbn. intros. etrans.
        * apply id_right.
        * apply pathsinv0. apply id_left.
    - intros (C, (ty, tm)).
      intros (C', (ty', tm')).
      intros (C'', (ty'', tm'')).
      cbn in *.
      intros (f, (αty,αtm)).
      intros (g, (βty,βtm)).
      cbn in *.
      intros p p' p''.
      cbn in *.
      intros eq1 eq2.
      apply nat_trans_eq.
      + apply homset_property.
      + cbn. intros x.
        set (h1 := nat_trans_eq_pointwise eq1 x).
        set (h2 := nat_trans_eq_pointwise eq2 (f x)).
        cbn in *.
        rewrite assoc.
        rewrite h1.
        rewrite <- assoc.
        rewrite <- assoc.
        apply maponpaths.
        apply h2.
  Defined.

  Definition disp_cofunctormaps_cat_data : disp_cat_data (total_bicat disp_two_presheaves)
    := (_ ,, disp_cofunctormaps_cat_id_comp).

  Definition disp_cofunctormaps_bicat
    : disp_bicat (total_bicat disp_two_presheaves)
    := disp_cell_unit_bicat disp_cofunctormaps_cat_data.

  Definition morphisms_of_presheaves_display : disp_bicat bicat_of_univ_cats.
  Proof.
    use sigma_bicat.
    - apply disp_two_presheaves.
    - exact disp_cofunctormaps_bicat.
  Defined.

  Definition morphisms_of_presheaves : bicat
    := total_bicat morphisms_of_presheaves_display.

  Definition disp_cofunctormaps_bicat_univalent_2_1
    : disp_univalent_2_1 disp_cofunctormaps_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intros F G η x y ; simpl in *.
    apply isaset_nat_trans.
    apply homset_property.
  Qed.

  Definition morphisms_of_presheaves_univalent_2_1
    : is_univalent_2_1 morphisms_of_presheaves.
  Proof.
    apply sigma_is_univalent_2_1.
    - exact univalent_cat_is_univalent_2_1.
    - exact disp_two_presheaves_is_univalent_2_1.
    - exact disp_cofunctormaps_bicat_univalent_2_1.
  Defined.

  Definition disp_cofunctormaps_bicat_univalent_2_0
    : disp_univalent_2_0 disp_cofunctormaps_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_0.
    + apply total_is_univalent_2_1.
      * exact univalent_cat_is_univalent_2_1.
      * exact disp_two_presheaves_is_univalent_2_1.
    + intros F G η x y ; simpl in *.
      apply isaset_nat_trans.
      apply homset_property.
    + intros a ; simpl.
      apply isaset_nat_trans.
      apply homset_property.
    + intros F α₁ α₂ X ; cbn in *.
      induction X as [X1 X2] ; cbn in *.
      apply nat_trans_eq.
      { apply homset_property. }
      intros x ; cbn in *.
      pose (nat_trans_eq_pointwise X1 x) as p1.
      cbn in *.
      rewrite id_left, id_right in p1.
      exact p1.
  Qed.

  Definition disp_cofunctormaps_bicat_univalent_2
    : disp_univalent_2 disp_cofunctormaps_bicat.
  Proof.
    split.
    - exact disp_cofunctormaps_bicat_univalent_2_0.
    - exact disp_cofunctormaps_bicat_univalent_2_1.
  Defined.

  Definition morphisms_of_presheaves_univalent_2_0
    : is_univalent_2_0 morphisms_of_presheaves.
  Proof.
    apply sigma_is_univalent_2_0.
    - exact univalent_cat_is_univalent_2.
    - exact disp_two_presheaves_is_univalent_2.
    - exact disp_cofunctormaps_bicat_univalent_2.
  Defined.

  Definition morphisms_of_presheaves_univalent_2
    : is_univalent_2 morphisms_of_presheaves.
  Proof.
    split.
    - exact morphisms_of_presheaves_univalent_2_0.
    - exact morphisms_of_presheaves_univalent_2_1.
  Defined.

  Definition disp_2cells_isaprop_cofunctormaps
    : disp_2cells_isaprop disp_cofunctormaps_bicat
    := disp_2cells_isaprop_cell_unit_bicat disp_cofunctormaps_cat_data.

  Definition disp_locally_groupoid_cofunctormaps
    : disp_locally_groupoid disp_cofunctormaps_bicat
    := disp_locally_groupoid_cell_unit_bicat disp_cofunctormaps_cat_data.

  Definition disp_2cells_isaprop_morphisms_of_presheaves_display
    : disp_2cells_isaprop morphisms_of_presheaves_display.
  Proof.
    apply disp_2cells_isaprop_sigma.
    - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf.
    - apply disp_2cells_isaprop_cofunctormaps.
  Qed.

  Definition disp_locally_groupoid_morphisms_of_presheaves_display
    : disp_locally_groupoid morphisms_of_presheaves_display.
  Proof.
    apply disp_locally_groupoid_sigma.
    - exact univalent_cat_is_univalent_2.
    - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf.
    - apply disp_2cells_isaprop_cofunctormaps.
    - apply disp_locally_groupoid_prod ; apply disp_locally_groupoid_presheaf.
    - exact disp_locally_groupoid_cofunctormaps.
  Qed.
End Cofunctormaps.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 lv0)).
Admitted.
QuickChick conj25eqsynthconj6.


Require Import Bedrock.StringSet.
Import StringSet.

Set Implicit Arguments.

Definition union_list ls := List.fold_right union empty ls.


(*
 * Necessary Imports
 *)
Require Import Init.Decimal.
Require Import Reals.
Require Import Floats.
Require Import List.
Require Import Coq.Strings.String.
From OracleFormalization Require Export Functions.

(*
 * Theorem 1: All actions on the oracle maintain the non-negativity of credit of all
 *            all consumers
 *)

(*
 * This function describes what it means for the credit for all the consumers to be
 * non negative. The input parameter 'allConsumers' is the list of consumer info obtained
 * from the Oracle.
 *)
Fixpoint credit_non_negative_all_consumers (allConsumers : AllConsumers) : Prop :=
    match allConsumers with
    | nil => True
    | (_, info) :: allConsumers' => 0 <=? info.(credit) = true /\
                                    credit_non_negative_all_consumers allConsumers'
    end.

(*
 * This states in terms of a proposition what it means for the credit of
 * a single consumer to be non-negative.
 *)
Definition credit_non_negative_single_consumer (info : ConsumerInfo) : Prop :=
    0 <=? info.(credit) = true.

(*
 * This proves that if the propoerty holds individually for the sublists l1 and l2
 *)
Theorem credit_non_negative_helper2 : forall (l1 : AllConsumers) (l2 : AllConsumers),
    credit_non_negative_all_consumers (l1 ++ l2) <->
    (credit_non_negative_all_consumers l1 /\ credit_non_negative_all_consumers l2).
Proof.
    intros. induction l1 as [ | (addr, info) l1' IHl1']. split.
    - simpl. intros. split. reflexivity. apply H.
    - simpl. intros. destruct H. apply H0.
    - split.
     + intros. split. simpl. simpl in H. split. destruct H.
        apply H. destruct H. apply IHl1' in H0. destruct H0. apply H0.
        simpl in H. destruct H. apply IHl1' in H0. destruct H0. apply H1.
     + intros. simpl. split.
        simpl in H. destruct H. destruct H.
            apply H.
        simpl in H. destruct H. destruct H. apply IHl1'. split.
        apply H1. apply H0.
Qed.

(*
 * This theorem proves that if the initial list of consumer info (allConsumers) satisfies the
 * credit non-negative property, then modifying one member of the list maintains the property
 * given that the new consumer info (elem) has non-negative credit. Since the function 'modify_list'
 * is tail_recursive we can assume that 'currModList' satisfies the credit non-negative property for
 * all the consumers
 *)
Theorem credit_non_negative_helper1 :
    forall (consumer : address) (elem : ConsumerInfo) (allConsumers : AllConsumers)
    (currModList : AllConsumers),
    credit_non_negative_single_consumer elem ->
    credit_non_negative_all_consumers allConsumers ->
    credit_non_negative_all_consumers currModList ->
    credit_non_negative_all_consumers (modify_list ConsumerInfo allConsumers consumer elem currModList).
Proof.
    intros consumer elem allConsumers. induction allConsumers as [ | (addr, info) l' IHl'].
    - intros. simpl. apply H1.
    - intros. simpl.
      case_eq (compare_address (addr) (consumer)).
       + intros. apply credit_non_negative_helper2. split.
        * apply H1.
        * simpl. split. unfold credit_non_negative_single_consumer in H. apply H.
          simpl in H0. destruct H0. apply H3.
       + intros. simpl in H0. destruct H0. apply IHl'.
         apply H.
         apply H3. apply credit_non_negative_helper2.
         split. apply H1. simpl. split. apply H0. reflexivity.
Qed.

(*
 * This is the main theorem. It proves that given an event and state of the oracle
 * if the credit of all the consumers is non negative then after the event the credit
 * still remains non negative for all the consumers
 *
 * The proof cases on the event
 *)
Theorem credit_non_negative : forall (event : Event) (state : State),
    credit_non_negative_all_consumers (get_consumers state) ->
    credit_non_negative_all_consumers (get_consumers (execute state event)).
Proof.
    intros. destruct state. destruct oracleState. destruct oracleParameters.
    destruct event. simpl in H.
    + simpl. unfold write_data. case_eq (compare_address owner caller).
        intros. simpl. rewrite -> H0. unfold get_consumers. simpl. unfold get_consumers in H. simpl in H. apply H.
        intros. simpl. rewrite -> H0. unfold get_consumers. simpl. unfold get_consumers in H. simpl in H. apply H.
    + simpl. unfold read_data. simpl.
      case_eq (credit (get_consumer_info allConsumers consumer) <?
      fee_of consumer
      (Datatypes.weight (get_consumer_info allConsumers consumer))
      allConsumers latestWrite baseFee).
        intros. simpl. simpl in H. apply H.
        intros. simpl. apply credit_non_negative_helper1.
            unfold credit_non_negative_single_consumer.
            simpl. reflexivity.
            simpl in H. apply H.
            simpl. reflexivity.
    + simpl. unfold schedule_weight_adjustment. simpl. case_eq (compare_address owner caller).
        intros. simpl. apply credit_non_negative_helper1.
            unfold credit_non_negative_single_consumer.
            simpl. reflexivity.
            simpl in H. apply H.
            simpl. reflexivity.
            intros. simpl. simpl in H. apply H.
    + simpl. unfold adjust_weight. simpl. case_eq (compare_address owner caller).
      case_eq (timeStamp <? weightTimeLock (get_consumer_info allConsumers consumer)).
        intros. simpl. simpl in H. apply H.
        intros. simpl. apply credit_non_negative_helper1.
            unfold credit_non_negative_single_consumer.
            simpl. reflexivity.
            simpl in H. apply H.
            simpl. reflexivity.
            intros. simpl. simpl in H. apply H.
    + simpl. unfold schedule_max_fee_adjustment. simpl. case_eq (compare_address owner caller).
        intros. simpl. simpl in H. apply H.
        intros. simpl. simpl in H. apply H.
    + simpl. unfold adjust_max_fee. simpl. case_eq (compare_address owner caller).
        intros. case_eq (timeStamp <? maxFeeTimeLock).
            intros. simpl. simpl in H. apply H.
            intros. simpl. simpl in H. apply H.
        intros. simpl. simpl in H. apply H.
    + simpl. unfold adjust_base_fee. simpl. case_eq (compare_address owner caller).
        intros. simpl. simpl in H. apply H.
        intros. simpl. simpl in H. apply H.
    + simpl. simpl in H. unfold deposit_credit. simpl. case_eq (weight (get_consumer_info allConsumers consumer) =? 0).
        intros. simpl. split.
            reflexivity.
            simpl in H. apply H.
        intros. apply credit_non_negative_helper1.
            simpl. unfold credit_non_negative_single_consumer. simpl. reflexivity.
            apply H.
            simpl. reflexivity.
    + simpl. unfold withdraw_credit. simpl. case_eq (credit (get_consumer_info allConsumers caller) <? amount).
        intros. simpl. simpl in H. apply H.
        intros. simpl. apply credit_non_negative_helper1.
            unfold credit_non_negative_single_consumer. simpl. reflexivity.
            simpl in H. apply H.
            simpl. reflexivity.
    + simpl. unfold withdraw. simpl. case_eq (compare_address owner caller).
        intros. case_eq (totalRevenue - totalCredit <? amount).
            simpl. intros. simpl in H. apply H.
            intros. simpl. simpl in H. apply H.
            intros. simpl. simpl in H. apply H.
    + simpl. unfold reset_cost_and_revenue. simpl. case_eq (totalRevenue <? totalCost).
        simpl. intros. simpl in H. apply H.
        simpl. intros. simpl in H. apply H.
Qed.

(*
 * Theorem 2:
 * Main Idea: Every consumer pays exactly once for every new data publish. Between any 2 data written
 * events in the trace is the consumer reads data more than once, he/she is to be charged only once
 *)

(*
 * This function looks at the trace and accumulates the events in the 'currList' until a 'DataWritten'
 * event is encountered or we reach the end of the trace. The function is tail recursive.
 * trace : The trace which is investigated
 * currState : The state of the oracle just before the event at the head of the trace
 * currList : The tail recursive list which accumulates the events
 *)

Fixpoint split_trace_helper (trace : Trace) (currState : State) (currList : list (State * Event)) : list (State * Event) :=
    match trace with
    | nil => currList
    | e :: trace' =>
        let newState := execute currState e
        in
            match e with
            | DataWritten _ _ _ => currList
            | _ => split_trace_helper trace' newState (currList ++ ((currState, e) :: nil))
            end
    end.

(*
 * This function looks at the trace and creates a lists of lists. The sublists are the record of events between two 'DataWritten'
 * events in the trace. The function returns a list of slices where each slice is a record of events between two 'DataWritten'
 * events
 * trace : The trace to be investigated
 * currState : This is the state of the Oracle before the event at the head of the trace
 * subLists : This list accumulates the slices as the function is tail recursive. This list is returned when we reach the end of the trace
 *)
Fixpoint split_trace (trace : Trace) (currState : State) (subLists : list (list (State * Event))) : list (list (State * Event)) :=
    match trace with
    | nil => subLists
    | e :: trace' =>
        let newState := execute currState e
        in
            match e with
            | DataWritten _ _ _ => split_trace trace' newState (subLists ++ ((split_trace_helper trace' newState nil) :: nil))
            | _ => split_trace trace' newState subLists
            end
    end.

Fixpoint split_trace_correct_prop (mergeSlice : list (State * Event)) (trace : list Event) : Prop :=
    match trace with
    | nil =>
        match mergeSlice with
        | nil => True
        | _ => False
        end
    | e :: trace' =>
        match e with
        | DataWritten _ _ _ => split_trace_correct_prop mergeSlice trace'
        | _ =>
            match mergeSlice with
            | nil => False
            | (_, event) :: mergeSlice' => event = e /\ split_trace_correct_prop mergeSlice' trace'
            end
        end
    end.

Fixpoint my_remove_event (trace : list Event) : list Event :=
    match trace with
    | nil => nil
    | e :: trace' =>
        match e with
        | DataWritten _ _ _ => my_remove_event trace'
        | _ => e :: (my_remove_event trace')
        end
    end.

Fixpoint my_remove_state (splitList : list (State * Event)) : list Event :=
    match splitList with
    | nil => nil
    | (state, event) :: splitList' => event :: (my_remove_state splitList')
    end.

Theorem my_remove_event_removes_datawritten :
    forall (trace1 : list Event) (trace2 : list Event),
    my_remove_event (trace1 ++ trace2) = my_remove_event trace1 ++ my_remove_event trace2.

Proof.
    intros. induction trace1 as [ | e l' IHl'].
    - simpl. reflexivity.
    - simpl. destruct e.
        (* First sub-goal *)
        apply IHl'.
        (* Remaining sug-goals *)
        all: (rewrite -> IHl'; reflexivity).
Qed.

(*
 * This function takes in a slice (record of events between 2 arbitrary DataWritten events) and
 * returns a Proposition. This proposition states what it means for every consumer to pay
 * exactly once between 2 DataWritten events. The function cases on the event in the tuple (state, event)
 * If the event is DataRead and the latestRead of the consumer is greater than the latestWrite then
 * the consumer has already paid before and should not pay. If not, then the consumer is reading the
 * data for the first time and should pay
 *)
Fixpoint all_consumers_pay_once_slice (slice : list (State * Event)) : Prop :=
    match slice with
    | nil => True
    | (state, event) :: slice' =>
        match event with
        | DataRead consumer Weight data =>
            let latestWrite := get_latest_write state in
            let consumerInfo := get_consumer_info (get_consumers state) consumer in
            let baseFee := get_base_fee state in
            let weightConsumer := consumerInfo.(weight) in
            let feeConsumer := weightConsumer * baseFee in
            let latestReadConsumer := consumerInfo.(latestRead) in
            let (totalRevenueBefore, totalRevenueAfter) :=
                (get_total_revenue state, get_total_revenue (execute state event)) in
                (  latestWrite <? latestReadConsumer = true ->
                   totalRevenueAfter = totalRevenueBefore /\ all_consumers_pay_once_slice slice'
                )
                /\
                (  latestWrite <? latestReadConsumer = false ->
                   (consumerInfo.(credit) <? feeConsumer = true -> totalRevenueAfter = totalRevenueBefore)
                   /\
                   (consumerInfo.(credit) <? feeConsumer = false -> totalRevenueAfter = totalRevenueBefore + feeConsumer)
                   /\
                   all_consumers_pay_once_slice slice'
                )
        | _ => all_consumers_pay_once_slice slice'
        end
    end.

(*
 * It makes sure that the above property holds for all the slices in the list
 * returned by 'split_trace' (splitList). It applied the 'rev' function on the slice
 * because initially every slice is ordered from least recent to most recent event
 * (least recent) at the head of the list. It makes more sense later in the inductive proof
 * to reason about the reversed list
 *)
Fixpoint all_consumers_pay_once (splitList : list (list (State * Event))) : Prop :=
    match splitList with
    | nil => True
    | slice :: splitList' => all_consumers_pay_once_slice (rev slice) /\ all_consumers_pay_once splitList'
    end.

(*
 * This function tells us what it means for there to be no DataWritten event
 * in an arbitrary slice. Since we are slicing at DataWritten events exclusive, there
 * should be no DataWritten events in a slice
 *)
Fixpoint no_data_written_in_slice (slice : list (State * Event)) : Prop :=
    match slice with
    | nil => True
    | (_, event) :: eventHistory' =>
        match event with
        | DataWritten _ _ _ => False
        | _ => no_data_written_in_slice eventHistory'
        end
    end.

(*
 * This function tells us what it means for there to be no DataWritten event
 * in the list of slices. From here, the list returned by 'split_trace' will be referred
 * as the list of slices.
 *)
Fixpoint no_data_written_subLists (subList : list (list (State * Event))) : Prop :=
    match subList with
    | nil => True
    | slice :: subList' => no_data_written_in_slice slice /\
                           no_data_written_subLists subList'
    end.

(*
 * This is part of the main proof. We prove that if we have no 'DataWritten' event in a slice
 * then all consumers pay exactly once in the slice.
 *
 * Proof Idea: We do induction on the slice. In the inducive case we do a case by case analysis of
 * the event in the tuple (state, event). The case for 'DataRead' is the hard one and requires elaborate proof.
 * The rest of the cases are easy and have exactly the same proof.
 *)
Theorem consumer_pays_once_slice : forall (slice : list (State * Event)),
    no_data_written_in_slice slice -> all_consumers_pay_once_slice slice.
Proof.
    intros. induction slice as [ | (s, e) l' IHl'].
    - auto.
    - destruct e ; try auto.
     + simpl. inversion H.
     + simpl. split.
      * intros. split.
            unfold read_data. unfold fee_of. simpl.
            case_eq (latestWrite (oracleState s) <?
            latestRead
            (get_consumer_info (allConsumers (oracleState s)) consumer)).
                intros. simpl. apply Nat.add_0_r.

                intros. unfold get_latest_write in H0. unfold get_consumers in H0.
                simpl in H0. rewrite -> H1 in H0. discriminate H0.

            apply IHl'. unfold no_data_written_in_slice in H.
            fold no_data_written_in_slice in H. apply H.
      * intros; repeat split.
                intros. unfold read_data. unfold fee_of. simpl.
                case_eq (latestWrite (oracleState s) <?
                latestRead
                (get_consumer_info (allConsumers (oracleState s)) consumer)).
                    intros. unfold get_consumers in H0. unfold get_latest_write in H0. rewrite -> H2 in H0.
                    discriminate.

                    intros.
                    case_eq (credit (get_consumer_info (allConsumers (oracleState s)) consumer) <?
                    Datatypes.weight (get_consumer_info (allConsumers (oracleState s)) consumer) *
                    baseFee (oracleState s)).
                        intros. reflexivity.

                        intros. unfold get_consumers in H1. unfold get_latest_write in H1.
                        unfold get_base_fee in H1.
                        rewrite -> H3 in H1. discriminate H1.

                intros. unfold read_data. unfold fee_of. simpl.
                case_eq (latestWrite (oracleState s) <?
                latestRead
                (get_consumer_info (allConsumers (oracleState s)) consumer)).
                    intros. unfold get_consumers in H0. unfold get_latest_write in H0.
                    rewrite -> H2 in H0. discriminate.

                intros.
                case_eq (credit (get_consumer_info (allConsumers (oracleState s)) consumer) <?
                Datatypes.weight (get_consumer_info (allConsumers (oracleState s)) consumer) *
                baseFee (oracleState s)).
                    intros. unfold get_consumers in H1. unfold get_latest_write in H1.
                    unfold get_base_fee in H1. rewrite -> H3 in H1. discriminate H1.

                     intros. unfold get_total_revenue. simpl. reflexivity.

            apply IHl'. unfold no_data_written_in_slice in H.
            fold no_data_written_in_slice in H. apply H.
Qed.

(*
 * This just proves that if a given property (no_data_written_in_slice) holds for two lists (l1, l2) appended
 * together than the given property also holds for the two lists individually
 *)
Theorem no_data_written_rev_split :
    forall (l1 : list (State * Event)) (l2 : list (State * Event)),
    no_data_written_in_slice (l1 ++ l2) -> no_data_written_in_slice l1 /\ no_data_written_in_slice l2.
Proof.
    intros. induction l1 as [ | (s, e) l' IHl'].
    - simpl in H. split.
        simpl. reflexivity.
        apply H.
    - destruct e.
        (* First sub-goal *)
        contradiction.
        (* Remaining sub-goals *)
        all: (simpl in H; simpl; apply IHl' in H; auto).
Qed.

(*
 * This just proves that if a given property (no_data_written_in_slice) holds for two lists (l1, l2) individually
 * together than the given property also holds for the two lists appended
 *)
Theorem no_data_written_in_slice_proof_helper1 :
    forall (l1 : list (State * Event)) (l2 : list (State * Event)),
    (no_data_written_in_slice l1 /\ no_data_written_in_slice l2) -> no_data_written_in_slice (l1 ++ l2).

Proof.
    intros. induction l1 as [ | e l1' IHl1'].
    - simpl. simpl in H. destruct H. apply H0.
    - destruct e. destruct e.
        (* First sub-goal *)
        simpl. simpl in H. destruct H. contradiction.
        (* Remaining sub-goals *)
        all: (simpl; simpl in H; destruct H; apply IHl1'; auto).
Qed.

(*
 * This states if there are no DataWritten events in rev (slice) then there are no
 * DataWritten events in the slice as well
 *)
Theorem no_data_written_rev :
    forall (slice : list (State * Event)),
    no_data_written_in_slice (rev slice) -> no_data_written_in_slice slice.
Proof.
    intros. induction slice as [ | (s, e) l' IHl'].
    - auto.
    - simpl. simpl in H. apply no_data_written_rev_split in H. destruct e.
        (* First sub-goal *)
        destruct H. simpl in H0. apply H0.
        (* Remaining sub-goals *)
        all: (apply IHl'; destruct H; apply H).
Qed.

(*
 * This states that if there are no DataWritten events in the list of slices (splitList) then
 * all consumers pay exactly once for all the slices
 *)
Theorem consumers_pay_once :
    forall (splitList : list (list (State * Event))),
    no_data_written_subLists splitList -> all_consumers_pay_once splitList.

Proof.
    intros. induction splitList as [ | x l' IHl'].
    - auto.
    - simpl. split.
      simpl in H. destruct H. apply consumer_pays_once_slice. apply no_data_written_rev. rewrite -> rev_involutive. apply H.
      apply IHl'. simpl in H. destruct H. apply H0.
Qed.

(*
 * This states that if the property no_data_written_subLists holds for two lists of slices (l1, l2) individually
 * then the property also holds for the two lists appended together.
 *)
Theorem no_data_written_when_list_split_helper1 :
    forall (l1 : list (list (State * Event))) (l2 : list (list (State * Event))),
    (no_data_written_subLists l1 /\ no_data_written_subLists l2) -> no_data_written_subLists (l1 ++ l2).

Proof.
    intros. induction l1 as [ | e l1' IHl1'].
    - simpl. simpl in H. destruct H. apply H0.
    - destruct e.
     + simpl. simpl in H. destruct H. split.
        reflexivity.
        apply IHl1'. split. destruct H. apply H1. apply H0.
     + destruct p. destruct e0.
       (* First sub-goal *)
       (simpl; simpl in H; destruct H; destruct H; contradiction).
       (* Remaining sub-goals *)
       all: (simpl;
             simpl in H;
             destruct H;
             destruct H; auto).
Qed.

(*
 * This proves that assuming we have no data written events in the slice given by 'sliceSoFar' then
 * we will have no data written events in the slice returned by split_trace_helper called on the trace, startState and the sliceSoFar
 *)
Theorem no_data_written_in_slice_proof :
    forall (trace : list (Event)) (startState : State) (sliceSoFar : list (State * Event)),
    no_data_written_in_slice sliceSoFar -> no_data_written_in_slice (split_trace_helper trace startState sliceSoFar).

Proof.
    intros trace. induction trace as [ | e l' IHl'].
    - simpl. intros. apply H.
    - intros. destruct e.
        (* First sub-goal *)
        (simpl; apply H).
        (* Remaining sub-goals *)
        all: (simpl;
              apply IHl';
              apply no_data_written_in_slice_proof_helper1;
              split; (apply H || simpl; reflexivity)).
Qed.

(*
 * This proves that assuming we have no data written events in the list of slices given by 'splitsSoFar', we will have no
 * data written events in the list of slices returned by split_trace called on trace, startState and splitsSoFar
 *)
Theorem no_data_written_when_list_split :
    forall (trace : list Event) (startState : State) (splitsSoFar : list (list (State * Event))),
    no_data_written_subLists splitsSoFar -> no_data_written_subLists (split_trace trace startState splitsSoFar).

Proof.
    intros trace. induction trace as [ | e l' IHl'].
    - simpl. intros. apply H.
    - intros. destruct e.
       (* First sub-goal *)
       simpl. apply IHl'. simpl. apply no_data_written_when_list_split_helper1. split. apply H. simpl. split.
       apply no_data_written_in_slice_proof. simpl. reflexivity. reflexivity.
       (* Remaining sub-goals *)
       all: (simpl; apply IHl'; apply H).
Qed.

(*
 * This theorem closes the proof. It says that given some state and baseFee (The baseFee is supposed to be the
 * starting baseFee when initialising the Oracle),
 * all consumers pay exactly once in the list of slices returned by split_trace called on the trace of the state given.
 * The split_trace function needs the state of the Oracle just before the event at the head of the trace. Since
 * we look at the full trace we need the initial state of the Oracle. To get that state we can call the constructor function
 * by getting the required parameters. However we also need the initial baseFee. There is no way to get the baseFee based on the
 * current implementation, therefore baseFee is provided as a parameter
 *)
Theorem all_consumers_pay_once_proof :
    forall (state : State) (baseFee : nat),
    all_consumers_pay_once (split_trace (get_trace state)
                                        (constructor (get_owner state)
                                                     (get_description state)
                                                     (get_locking_period state)
                                                     baseFee)
                                        nil).

Proof.
    intros. destruct state. destruct oracleParameters.
    simpl. apply consumers_pay_once. apply no_data_written_when_list_split. simpl. reflexivity.
Qed.


Load DOLCE_root.

Require Import Coq.Init.Tactics.
Require Import Relation_Definitions.
Require Import Coq.Program.Basics.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Structures.Equalities.
Require Import Relation_Definitions Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.ProofIrrelevance.

Arguments transitivity {A} {R} {_} [x] [y] [z] _ _.

Module Type Protothetic (dolce:DOLCE_root).
Import dolce.

(************************** Meta-rules of Protothetic in Coq ***************************)

Parameter eqP : Prop -> Prop -> Prop.

Notation "a ≡≡ b" := (eqP a b)  (at level 80).

Axiom A1 :forall p q r, (((p ≡≡ r) ≡≡ (q ≡≡ p)) ≡≡ (r ≡≡ q)).
Axiom A2 :forall p q r, ((p ≡≡ (q ≡≡ r)) ≡≡ ((p ≡≡ q) ≡≡ r)).

(* elimination rules for equivalence *)
Parameter detachL     : forall (p q:Prop), (p ≡≡ q) -> p -> q.
Parameter detachR     : forall (p q:Prop), (p ≡≡ q) -> q -> p.

(* substitution rules for equivalence -> use rewrite *)

Lemma T1 : forall (q r:Prop),(((q ≡≡ r) ≡≡ (r ≡≡ q)) ≡≡ (r ≡≡ r)).
Proof.
intros q r;apply (A1 q r).
Qed.

Lemma T2 : forall (q r:Prop),(((r ≡≡ (q ≡≡ r)) ≡≡ ((r ≡≡ q) ≡≡ r)) ≡≡ ((q ≡≡ r) ≡≡ (r ≡≡ q))).
Proof.
intros q r;apply (A1 r (r ≡≡ q) (q ≡≡ r)).
Qed.

Lemma T3 : forall (q r:Prop), ((r ≡≡ (q ≡≡ r)) ≡≡ ((r ≡≡ q) ≡≡ r)).
Proof.
intros q r;apply (A2 r).
Qed.

Lemma T4 : forall p q:Prop, ((p ≡≡ q) ≡≡ (q ≡≡ p)). (* symmetry in Proto *)
Proof.
intros q r.
assert (H1:(((r ≡≡ (q ≡≡ r)) ≡≡ ((r ≡≡ q) ≡≡ r)) ≡≡ ((q ≡≡ r) ≡≡ (r ≡≡ q)))).
apply T2.
assert (H2:((r ≡≡ (q ≡≡ r)) ≡≡ ((r ≡≡ q) ≡≡ r))).
apply T3.
apply (detachL (((r ≡≡ (q ≡≡ r)) ≡≡ ((r ≡≡ q) ≡≡ r))) ((q ≡≡ r) ≡≡ (r ≡≡ q))) in H2;assumption.
Qed.

Lemma ProtoReflex : forall r, r ≡≡ r. (* reflexivity in Proto and meta *)
Proof.
intro r.
assert (H1:forall q, ((q ≡≡ r) ≡≡ (r ≡≡ q))).
intro q;apply (T4 q r).
assert (H2:forall q,(((q ≡≡ r) ≡≡ (r ≡≡ q)) ≡≡ (r ≡≡ r))).
intro q;apply (T1 q r).
specialize (H1 r).
specialize (H2 r).
apply (detachL ((r ≡≡ r) ≡≡ (r ≡≡ r)) (r ≡≡ r));assumption.
Qed.

Lemma ProtoSymm : symmetric _ eqP. (* symmetry in meta *)
Proof.
intros p q H.
assert (H1:((p ≡≡ q) ≡≡ (q ≡≡ p))).
apply (T4 p q).
apply (detachL (p ≡≡ q) (q ≡≡ p));assumption.
Qed.

Lemma ProtoTrans : transitive _ eqP. (* transitivity in meta *)
Proof.
intros p q r H1 H2.
assert (H3:(((q ≡≡ r) ≡≡ (p ≡≡ q)) ≡≡ (r ≡≡ p))).
apply A1 with (p:=q)(q:=p).
assert (H4:( ((q ≡≡ r) ≡≡ ((p ≡≡ q) ≡≡ (r ≡≡ p))) ≡≡ (((q ≡≡ r) ≡≡ (p ≡≡ q)) ≡≡ (r ≡≡ p)))).
apply A2 with (p:=(q ≡≡ r))(q:=(p ≡≡ q))(r:=(r ≡≡ p)).
apply (detachR ((q ≡≡ r) ≡≡ ((p ≡≡ q) ≡≡ (r ≡≡ p))) (((q ≡≡ r) ≡≡ (p ≡≡ q)) ≡≡ (r ≡≡ p)) ) in H4;
[ apply (detachL (q ≡≡ r)((p ≡≡ q) ≡≡ (r ≡≡ p))) in H4;[ assert (H5:((r ≡≡ p) ≡≡ (p ≡≡ r)));
    [apply (T4 r p) |  apply (detachL (p ≡≡ q)(r ≡≡ p)) in H4;[
        apply (detachL (r ≡≡ p)(p ≡≡ r)) in H4;assumption  |
        assumption ] ] | assumption ] | assumption ].
Qed.

(* introduction of equivalence  *)

Lemma intro_eqP : forall (P Q:Prop), P -> Q -> (P ≡≡ Q).
Proof.
intros A B a b.
assert (H1:((A ≡≡ (B ≡≡ (A ≡≡ B))) ≡≡ ((A ≡≡ B) ≡≡ (A ≡≡ B)))).
apply A2 with (p:=A)(q:=B)(r:=(A ≡≡ B)).
assert (H2:((A ≡≡ (B ≡≡ (A ≡≡ B))) ≡≡ ((A ≡≡ B) ≡≡ (A ≡≡ B))) ≡≡ (((A ≡≡ B) ≡≡ (A ≡≡ B)) ≡≡ (A ≡≡ (B ≡≡ (A ≡≡ B))))).
apply T4 with (p:=(A ≡≡ (B ≡≡ (A ≡≡ B))))(q:=((A ≡≡ B) ≡≡ (A ≡≡ B))).
apply (detachL ((A ≡≡ (B ≡≡ (A ≡≡ B))) ≡≡ ((A ≡≡ B) ≡≡ (A ≡≡ B))) (((A ≡≡ B) ≡≡ (A ≡≡ B)) ≡≡ (A ≡≡ (B ≡≡ (A ≡≡ B))))) in H2;
  [ assert (H3:((A ≡≡ B) ≡≡ (A ≡≡ B)));[ apply ProtoReflex with (r:=(A ≡≡ B)) |
            apply (detachL ((A ≡≡ B) ≡≡ (A ≡≡ B))(A ≡≡ (B ≡≡ (A ≡≡ B)))) in H2;[
                apply (detachL A (B ≡≡ (A ≡≡ B))) in H2;[
                  apply (detachL B (A ≡≡ B)) in H2;assumption
                | assumption ]
          | assumption ]
    ] | assumption].
Qed.

Add Parametric Relation  : Prop (eqP)
 reflexivity proved by (ProtoReflex)
 symmetry proved by (ProtoSymm)
 transitivity proved by (ProtoTrans)
as eq_Prop.

Structure Morphism  : Type := {
  f       :> Prop -> Prop;
  compat  : forall (x1 x2: Prop), (x1 ≡≡ x2) -> ((f x1) ≡≡ (f x2))}.

Add Parametric Morphism  (M : Morphism) :
            (@f M) with signature (@eqP ==> @eqP) as extensional_prop.
Proof.
intros x y H0.
apply (compat M);assumption.
Qed.

Axiom A3 : forall (g:Morphism)(p:Prop), (forall f:Morphism, (g p ≡≡ (forall r:Prop, (f r ≡≡ g p) ≡≡ forall r:Prop,(f r ≡≡ g (p ≡≡ (forall q:Prop, q))))) ≡≡ forall q:Prop, g q).

(***************** Basic definitions ************************)

(* Affirmation of the consequent *)

Parameter  mu       : Prop -> Prop -> Prop.
Parameter  D1       : forall p q:Prop, mu p q ≡≡ (p ≡≡ (p ≡≡ q)).

(* binary tautology *)

Parameter  to       : Prop -> Prop -> Prop.
Parameter  D2       : forall p q:Prop, to p q ≡≡ ((p ≡≡ q) ≡≡ (p ≡≡ q)).

(* Affirmation of the antecedent *)

Parameter  alpha    : Prop -> Prop.
Parameter  D3       : forall p, alpha p ≡≡ (p ≡≡ (forall q, q ≡≡ q)).

(* negation *)

Parameter neg       : Morphism.
Notation "¬ a" := (neg a)  (at level 75).

Parameter not       : forall p:Prop, (¬p) ≡≡ (p ≡≡ forall q:Prop, q). (* D4 *)

(* exclusive OR *)

Parameter  omega    : Prop -> Prop -> Prop.
Parameter  D5       : forall p q:Prop, omega p q ≡≡ ¬(p ≡≡ q).

Parameter  phi       : Prop->Prop->Prop.
Parameter  D6       : forall p q:Prop, phi p q ≡≡ ((p ≡≡ q) ≡≡ (q ≡≡ p)).

(* True *)

Parameter T    : Prop.
Parameter Verum : T ≡≡ forall p:Prop, (p ≡≡ p).

(*False *)

Parameter F      : Prop.
Parameter Falsum : F ≡≡ forall p:Prop, p.

(* distrib des quantificateurs  ***)
(* si on a la these: forall x1 x2 ... xi ... xk ... xn, A ≡≡ B. alors:
  on obtient une nouvelle these:
        forall x1 x2 ... xi-1 ... xk+1 ... xn, forall xi ... xk, A ≡≡ forall xi ... xk, B. *)

Parameter dist_q : forall p:Prop, ((forall q : Prop, (p ≡≡ q)) ≡≡ (p ≡≡ forall q : Prop, q)).
Parameter dist_2 : (forall (p q:Prop), phi p q ≡≡ ((p ≡≡ q) ≡≡ (q ≡≡ p))) -> (forall (p q:Prop), phi p q) ≡≡ (forall (p q:Prop), ((p ≡≡ q) ≡≡ (q ≡≡ p))).

(************************ Logical operators  ******************)

Parameter Ass    : Morphism.
Parameter Assert : forall p:Prop, (Ass p ≡≡ p).

Parameter and    : Prop -> Prop -> Prop.
Notation "a ∧ b" := (and a b)  (at level 60).
Parameter DP14   : forall (p q:Prop)(f:Morphism), (p ∧ q) ≡≡ (p ≡≡ ((forall r, p ≡≡ f r) ≡≡ forall r, (q ≡≡ f r))).

(****** alternative definitions for p ∧ q assuming the law of extensionality  *********)

Parameter conj2  : forall (p q:Prop)(f:Morphism), (p ∧ q) ≡≡ (p ≡≡ (f p ≡≡ f q)).
Parameter conj3  : forall (p q:Prop)(r:Prop)(f : Prop->Prop->Prop), (p ∧ q) ≡≡ (f p r ≡≡ (f q r ≡≡ p)).

Parameter imply  : Prop -> Prop -> Prop.
Notation "a ⊃ b" := (imply a b)  (at level 90).
Parameter DP15   : forall (p q:Prop), (p ⊃ q) ≡≡ ¬(p ∧ (¬ q)).
Parameter DP15b   : forall (p q:Prop), (p ⊃ q) ≡≡ (p ≡≡ (p ∧ q)).

Parameter or     : Prop -> Prop -> Prop.
Notation "a ∨ b" := (or a b)  (at level 60).
Parameter DP16   : forall (p q:Prop), (p ∨ q) ≡≡ ¬((¬p) ∧ (¬q)).
Parameter DP16b   : forall (p q:Prop), (p ∨ q) ≡≡ ((¬p) ⊃ q).

Parameter dist_3 : forall (p q:Prop), (forall (r:Prop)(f : Prop->Prop->Prop), (p ∧ q) ≡≡ (f p r ≡≡ (f q r ≡≡ p))) -> ((p ∧ q) ≡≡ forall (r:Prop)(f : Prop->Prop->Prop), (f p r ≡≡ (f q r ≡≡ p))).

(************************ Theorems  and metatheorems *************************)

Parameter implication : forall (p q :Prop), (p -> q) ≡≡ (p ⊃ q).

Lemma contradict : forall p, ((¬p ≡≡ p) ≡≡ F).
Proof.
intro p.
assert (H:(F ≡≡ forall q:Prop, q)).
apply Falsum.
rewrite H.
assert (H':(¬p ≡≡ (p ≡≡ (forall q : Prop, q))) ≡≡ ((¬p ≡≡ p) ≡≡ (forall q : Prop, q))).
apply (A2 (¬p) p (forall q : Prop, q)).
apply (detachL (¬p ≡≡ (p ≡≡ (forall q : Prop, q)))((¬p ≡≡ p) ≡≡ (forall q : Prop, q)));[
   assumption | apply (not p) ].
Qed.

Lemma T5 : forall p, (¬p) ≡≡ (p ≡≡ F).
Proof.
intro p.
assert (H1:(¬p ≡≡ (p ≡≡ F)) ≡≡ ((¬p ≡≡ p) ≡≡ F)).
apply (A2 (¬p) p F).
apply (detachR (¬p ≡≡ (p ≡≡ F)) ((¬p ≡≡ p) ≡≡ F));[
    assumption |  apply (contradict p) ].
Qed.

Lemma T6 : forall p q, (p ≡≡ q) ≡≡ (¬p ≡≡ ¬q).
Proof.
intros p q.
assert (H1:(¬p ≡≡ ¬q) ≡≡ (¬q ≡≡ ¬p)).
apply (T4 (¬p)(¬q)).
rewrite H1.
assert (H2:((p ≡≡ q) ≡≡ ((¬q) ≡≡ ¬p)) ≡≡ (((p ≡≡ q) ≡≡ (¬q)) ≡≡ ¬p)).
apply (A2 (p ≡≡ q)(¬q)(¬p)).
apply (detachR ((p ≡≡ q) ≡≡ (¬q ≡≡ ¬p))(((p ≡≡ q) ≡≡ ¬q) ≡≡ ¬p)) in H2.
assumption.
assert (H3: (p ≡≡ (q ≡≡ ¬q)) ≡≡ ((p ≡≡ q) ≡≡ ¬q)).
apply (A2 p q (¬q)).
rewrite <- H3.
assert (H4:(q ≡≡ ¬q) ≡≡ ((¬q) ≡≡ q)).
apply (T4 q (¬q)).
assert (H5:((¬q ≡≡ q) ≡≡ F)).
apply (contradict q).
rewrite H5 in H4.
assert (H6: ((p ≡≡ (q ≡≡ ¬q)) ≡≡ (F ≡≡ p)) ≡≡ ((q ≡≡ ¬q) ≡≡ F)) .
apply (A1 p F (q ≡≡ ¬q)).
apply (detachR ((p ≡≡ (q ≡≡ ¬q)) ≡≡ (F ≡≡ p))((q ≡≡ ¬q) ≡≡ F)) in H6;[
    assert (H7:(F ≡≡ p) ≡≡ (p ≡≡ F)) ;[
          apply (T4 F p) |
          rewrite H7 in H6;assert (H8:(¬p) ≡≡ (p ≡≡ F)) ;[
                   apply (T5 p) |
                   rewrite <-H8 in H6;assumption ] ] |
    assumption ].
Qed.

Lemma T7 : forall p, ¬(¬p) ≡≡ p.
intro p.
assert (H:forall p:Prop, (¬p) ≡≡ (p ≡≡ F)).
apply T5.
specialize (H (¬p)).
assert (H1:((¬p ≡≡ p) ≡≡ F)).
apply (contradict p).
assert (H2:((¬p ≡≡ p) ≡≡ F) ≡≡ (F ≡≡ (¬p ≡≡ p))).
apply (T4 (¬p ≡≡ p) F).
apply (detachL ((¬p ≡≡ p) ≡≡ F)(F ≡≡ (¬p ≡≡ p))) in H2;[
  clear H1;assert (H1:(F ≡≡ (¬p ≡≡ p)) ≡≡ ((F ≡≡ ¬p) ≡≡ p));[
         apply (A2 F (¬p) p) |
         apply (detachL (F ≡≡ (¬p ≡≡ p))((F ≡≡ ¬p) ≡≡ p)) in H1;[
              clear H2;assert (H2:(F ≡≡ ¬p) ≡≡ ((¬p) ≡≡ F));[
                apply (T4 F (¬p)) |
                rewrite H2 in H1;clear H2;assert (H2:((¬p ≡≡ F) ≡≡ p) ≡≡ (¬(¬p) ≡≡ (¬p ≡≡ F)));[
                    apply (intro_eqP ((¬p ≡≡ F) ≡≡ p)(¬(¬p) ≡≡ (¬p ≡≡ F)) H1 H) |
                    assert (H3:(((¬p ≡≡ F) ≡≡ p) ≡≡ (¬(¬p) ≡≡ (¬p ≡≡ F))) ≡≡ (p ≡≡ ¬(¬p)));[
                      apply (A1 (¬p ≡≡ F)(¬(¬p)) p) |
                      apply (detachL (((¬p ≡≡ F) ≡≡ p) ≡≡ (¬(¬p) ≡≡ (¬p ≡≡ F)))(p ≡≡ ¬(¬p))) in H3;[
                         clear H2;assert (H2:(p ≡≡ ¬(¬p)) ≡≡ (¬(¬p) ≡≡ p));[
                            apply (T4 p (¬(¬p))) |
                            apply (detachL (p ≡≡ ¬(¬p))(¬(¬p) ≡≡ p)) in H2;assumption ] |
                         assumption ]]]] |
              assumption ]] |
  assumption ].
Qed.

Lemma T8 : F ≡≡ F.
Proof.
apply (ProtoReflex F).
Qed.

Lemma T9 : forall p : Prop, p -> ¬(forall q, (p ≡≡ q)).
Proof.
intros p p0.
assert (H1:forall p:Prop, (¬p) ≡≡ (p ≡≡ F)).
apply T5.
specialize (H1 (forall q : Prop, p ≡≡ q)).
apply (detachR (¬(forall q : Prop, p ≡≡ q))((forall q : Prop, p ≡≡ q) ≡≡ F)) in H1.
assumption.
assert (H2:((forall q : Prop, (p ≡≡ q)) ≡≡ (p ≡≡ forall q : Prop, q))).
apply (dist_q p).
rewrite H2.
assert (H3:(p ≡≡ ((forall q : Prop, q) ≡≡ F)) ≡≡ ((p ≡≡ (forall q : Prop, q)) ≡≡ F)).
apply (A2 p (forall q : Prop, q) F).
apply (detachL (p ≡≡ ((forall q : Prop, q) ≡≡ F))((p ≡≡ (forall q : Prop, q)) ≡≡ F)) in H3.
assumption.
assert (H4:F ≡≡ forall p:Prop, p).
apply Falsum.
assert (H5:(F ≡≡ (forall p : Prop, p)) ≡≡ ((forall p : Prop, p) ≡≡ F)).
apply (T4 F (forall p : Prop, p)).
apply (detachL (F ≡≡ (forall p : Prop, p))((forall p : Prop, p) ≡≡ F)) in H5;[
  apply (intro_eqP p ((forall p : Prop, p) ≡≡ F) p0 H5)   |
  assumption ].
Qed.

(* intro/elim rules for Falsum *)

Lemma elim_F     : forall p:Prop, F -> p.
Proof.
intros p Fl.
assert (H:F ≡≡ forall p:Prop, p).
apply Falsum.
apply (detachL F (forall p : Prop, p)) with (p:=p) in H;assumption.
Qed.

(* intro/elim rules for conjunction *)

Lemma intro_conj   : forall (p q:Prop),  p -> q -> (p ∧ q).
Proof.
intros p q p0 q0.
assert (H1:forall (p q:Prop)(f:Morphism), (p ∧ q) ≡≡ (p ≡≡ (f p ≡≡ f q))).
apply conj2.
specialize (H1 p q neg).
apply (detachR (p ∧ q)(p ≡≡ (¬p ≡≡ ¬q))) in H1;[
    assumption |
    assert (H2:(p ≡≡ (¬p ≡≡ ¬q)) ≡≡ ((p ≡≡ ¬p) ≡≡ ¬q));[
       apply (A2 p (¬p)(¬q)) |
       assert (H3:((p ≡≡ q) ≡≡ (¬p ≡≡ ¬q)));[
           apply (T6 p q) |
           rewrite <- H3;clear H2 H3;assert (H2:(p ≡≡ (p ≡≡ q)) ≡≡ ((p ≡≡ p) ≡≡ q));[
               apply (A2 p p q) |
               apply (detachR (p ≡≡ (p ≡≡ q))((p ≡≡ p) ≡≡ q)) in H2;[
                  assumption |
                  assert (H3:(p ≡≡ p));[
                     apply (ProtoReflex p) |
                     apply (intro_eqP (p ≡≡ p) q);assumption
]]]]]].
Qed.

Lemma elim_conjHL  : forall (p q:Prop), (p ∧ q) -> p.
Proof.
intros p q H.
assert (H1:forall (r:Prop)(f : Prop->Prop->Prop), (p ∧ q) ≡≡ (f p r ≡≡ (f q r ≡≡ p))).
apply (conj3 p q).
apply dist_3  in H1.
assert (H2:(forall p q:Prop, phi p q ≡≡ ((p ≡≡ q) ≡≡ (q ≡≡ p)))).
apply D6.
apply dist_2 in H2.
assert (H3:(forall p q:Prop, ((p ≡≡ q) ≡≡ (q ≡≡ p)))).
apply T4.
assert (H5:=H3).
apply (detachL (p ∧ q)(forall (r:Prop)(f :Prop->Prop->Prop), (f p r ≡≡ (f q r ≡≡ p)))) with (r:=p)(f:=phi) in H1;[
    apply (detachR (forall p q : Prop, phi p q)(forall p q : Prop, (p ≡≡ q) ≡≡ (q ≡≡ p))) with (p:=p)(q:=p) in H3;[
        apply (detachL (phi p p)(phi q p ≡≡ p)) in H1;[
           apply (detachR (forall p q : Prop, phi p q)(forall p q : Prop, (p ≡≡ q) ≡≡ (q ≡≡ p))) with (p:=q)(q:=p) in H2;[
                apply (detachL (phi q p) p) in H1;assumption |
                assumption ] |
           assumption ] |
        assumption ] |
    assumption ].
Qed.

Lemma elim_conjHR  : forall (p q:Prop), (p ∧ q) -> q.
Proof.
intros p q H.
assert (H1:forall (p q:Prop)(f:Morphism), (p ∧ q) ≡≡ (p ≡≡ (f p ≡≡ f q))).
apply conj2.
specialize (H1 p q neg).
apply (detachL (p ∧ q)(p ≡≡ (¬p ≡≡ ¬q))) in H1;[
   assert (H2:((p ≡≡ (¬p ≡≡ ¬q)) ≡≡ ((p ≡≡ ¬p) ≡≡ ¬q)));[
       apply (A2 p (¬p) (¬q)) |
       apply (detachL (p ≡≡ (¬p ≡≡ ¬q))((p ≡≡ ¬p) ≡≡ ¬q)) in H2;[
           clear H1;assert (H1:((¬p ≡≡ p) ≡≡ F));[
               apply (contradict p) |
               assert (H3:(p ≡≡ ¬p) ≡≡ (¬p ≡≡ p));[
                   apply (T4 p (¬p)) |
                   rewrite <- H3 in H1;rewrite H1 in H2;clear H3;assert (H3:(¬q) ≡≡ (q ≡≡ F));[
                        apply (T5 q) |
                        rewrite H3 in H2;clear H3;assert (H3:(F ≡≡ (q ≡≡ F)) ≡≡ ((q ≡≡ F) ≡≡ F));[
                                apply (T4 F (q ≡≡ F)) |
                                apply (detachL (F ≡≡ (q ≡≡ F))((q ≡≡ F) ≡≡ F)) in H3;[
                                      assert (H4:(q ≡≡ (F ≡≡ F)) ≡≡ ((q ≡≡ F) ≡≡ F));[
                                      apply (A2 q F F) |
                                      apply (detachR (q ≡≡ (F ≡≡ F))((q ≡≡ F) ≡≡ F)) in H4;[
                                          apply (detachR q (F ≡≡ F)) in H4;[
                                               assumption  | apply T8  ] |
                                          assumption ] ] |
                                    assumption ]]]]] |
           assumption ] ] |
   assumption ].
Qed.

(**** elimination of double negation *****)

Lemma elim_dneg   : forall (p:Prop), (¬¬p) -> p.
Proof.
intros p H1.
assert (H:(¬(¬p)) ≡≡ p).
apply (T7 p).
apply (detachL (¬(¬p)) p) in H;assumption.
Qed.

(* intro/elim rules for equivalence *)

Lemma elim_eqP   : forall p q:Prop,  (p ≡≡ q) -> ((p ⊃ q) -> (q ⊃ p)).
Proof.
intros p q H1 H2.
assert (H3:(p ⊃ q) ≡≡ (p ≡≡ (p ∧ q))).
apply (DP15b p q).
assert (H4:(q ⊃ p) ≡≡ (q ≡≡ (q ∧ p))).
apply (DP15b q p).
apply (detachL (p ⊃ q)(p ≡≡ p ∧ q)) in H3;[
    apply (detachR (q ⊃ p)(q ≡≡ q ∧ p)) in H4;[
       assumption |
       assert (H5:(q ∧ p) ≡≡ (q ≡≡ ((¬ q) ≡≡ ¬ p)));[
         apply (conj2 q p neg) |
        rewrite H5;assert (H6:(q ≡≡ (q ≡≡ (¬q ≡≡ ¬p))) ≡≡ ((q ≡≡ q) ≡≡ (¬q ≡≡ ¬p)));[
           apply (A2 q q (¬q ≡≡ ¬p)) |
           apply (detachR (q ≡≡ (q ≡≡ (¬q ≡≡ ¬p)))((q ≡≡ q) ≡≡ (¬q ≡≡ ¬p))) in H6;[
              assumption |
              assert (H7:q ≡≡ q);[
                apply (ProtoReflex q) |
                assert (H8:(p ≡≡ q) ≡≡ (q ≡≡ p));[
                  apply (T4 p q) |
                  apply (detachL (p ≡≡ q)(q ≡≡ p)) in H8;[
                      apply (intro_eqP (q ≡≡ q)(¬q ≡≡ ¬p));[
                           assumption |
                           assert (H9:(q ≡≡ p) ≡≡(¬q ≡≡ ¬p));[
                              apply (T6 q p) |
                              apply (detachL (q ≡≡ p)(¬q ≡≡ ¬p)) in H9;assumption ]]|
                      assumption ]]]]]]]|
    assumption ].
Qed.

Lemma def_eqP   : forall p q:Prop, (p ⊃ q) -> (q ⊃ p) -> p ≡≡ q.
Proof.
intros p q H1 H2.
assert (H3:(p ⊃ q) ≡≡ (p ≡≡ (p ∧ q))).
apply (DP15b p q).
assert (H4:(q ⊃ p) ≡≡ (q ≡≡ (q ∧ p))).
apply (DP15b q p).
apply (detachL (p ⊃ q)(p ≡≡ p ∧ q)) in H3;[
    apply (detachL (q ⊃ p)(q ≡≡ q ∧ p)) in H4;[
          assert (H5:(p ∧ q) ≡≡ (p ≡≡ ((¬ p) ≡≡ ¬ q)));[
               apply (conj2 p q neg) |
               rewrite <-H3 in H5;  assert (H7:(p ≡≡ (p ≡≡ (¬p ≡≡ ¬q))) ≡≡ ((p ≡≡ p) ≡≡ (¬p ≡≡ ¬q)));[
                        apply (A2 p p (¬p ≡≡ ¬q)) |
                        apply (detachL (p ≡≡ (p ≡≡ (¬p ≡≡ ¬q)))((p ≡≡ p) ≡≡ (¬p ≡≡ ¬q))) in H7;[
                           assert (H8:(p ≡≡ p));[
                                apply (ProtoReflex p) |
                                apply (detachL (p ≡≡ p)(¬p ≡≡ ¬q)) in H7;[
                                      assert (H9:(p ≡≡ q) ≡≡ (¬p ≡≡ ¬q));[
                                         apply (T6 p q) |
                                         apply (detachR (p ≡≡ q)(¬p ≡≡ ¬q)) in H9;assumption   ] |
                                      assumption  ] ] |
                           assumption ] ] ] |
          assumption ] |
    assumption ].
Qed.

(* intro/elim rules for implication *)

Lemma intro_impl  : forall (p q:Prop), (p->q) -> (p ⊃ q).
Proof.
intros p q H.
assert (H1: (p -> q) ≡≡ (p ⊃ q)).
apply (implication p q).
apply (detachL (p -> q)(p ⊃ q)) in H1;assumption.
Qed.

Lemma elim_impl : forall (p q:Prop),  (p ⊃ q) -> p -> q.
Proof.
intros p q H1 p0.
assert (H2:(p ⊃ q) ≡≡ (p ≡≡ (p ∧ q))).
apply (DP15b p q).
apply (detachL (p ⊃ q)(p ≡≡ p ∧ q)) in H2;[
    clear H1;apply (detachL p (p ∧ q)) in H2;[
            apply (elim_conjHR p q) in H2;assumption |
            assumption ] |
   assumption ].
Qed.

(* intro/elim rules for disjunction *)

Lemma intro_disjR       : forall (p q:Prop),  q -> (p ∨ q).
Proof.
intros p q q0.
assert (H1:forall (p q:Prop), (p ∨ q) ≡≡ ¬((¬p) ∧ (¬q))).
apply DP16.
specialize (H1 p q).
apply (detachR (p ∨ q)(¬((¬p) ∧ (¬q)))).
assumption.
assert (H2:forall p:Prop, (¬p) ≡≡ (p ≡≡ F)).
apply T5.
assert (H10:=H2).
specialize (H2 ((¬p) ∧ (¬q))).
apply (detachR (¬((¬p) ∧ (¬q)))(((¬p) ∧ (¬q) ≡≡ F))).
assumption.
assert (H3:forall (p q:Prop)(f:Morphism), (p ∧ q) ≡≡ (p ≡≡ (f p ≡≡ f q))).
apply conj2.
specialize (H3 (¬p)(¬q) neg).
rewrite H3.
assert (H4:(((¬p) ≡≡ (¬q)) ≡≡ (¬(¬p) ≡≡ ¬(¬q)))).
apply (T6 (¬p) (¬q)).
assert (H5:((¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q))) ≡≡ F) ≡≡ (F ≡≡ ((¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q)))))).
apply (T4 (¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q))) F).
apply (detachR ((¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q))) ≡≡ F)(F ≡≡ (¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q))))) in H5.
assumption.
assert (H6:(F ≡≡ (¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q)))) ≡≡ ((F ≡≡ ¬p) ≡≡ (¬(¬p) ≡≡ ¬(¬q)))).
apply (A2 F (¬p)(¬(¬p) ≡≡ ¬(¬q))).
apply (detachR (F ≡≡ (¬p ≡≡ (¬(¬p) ≡≡ ¬(¬q))))((F ≡≡ ¬p) ≡≡ (¬(¬p) ≡≡ ¬(¬q)))) in H6.
assumption.
rewrite <- H4.
assert (H7:((F ≡≡ ¬p) ≡≡ (¬p ≡≡ ¬q)) ≡≡ ((¬p ≡≡ ¬q) ≡≡ (F ≡≡ ¬p))).
apply (T4 (F ≡≡ ¬p)(¬p ≡≡ ¬q)).
apply (detachR ((F ≡≡ ¬p) ≡≡ (¬p ≡≡ ¬q)) ((¬p ≡≡ ¬q) ≡≡ (F ≡≡ ¬p))) in H7.
assumption.
assert (H8:((¬p ≡≡ ¬q) ≡≡ (F ≡≡ ¬p)) ≡≡ ((¬q) ≡≡ F)).
apply (A1 (¬p) F (¬q)).
apply (detachR ((¬p ≡≡ ¬q) ≡≡ (F ≡≡ ¬p))((¬q) ≡≡ F)) in H8.
assumption.
specialize (H10 q).
rewrite H10.
assert (H9:(q ≡≡ (F ≡≡ F)) ≡≡ ((q ≡≡ F) ≡≡ F)).
apply (A2 q F F).
apply (detachL (q ≡≡ (F ≡≡ F))((q ≡≡ F) ≡≡ F)) in H9.
assumption.
apply (intro_eqP q (F ≡≡ F));[ assumption | apply T8 ].
Qed.

Lemma intro_disjL       : forall (p q:Prop),  p -> (p ∨ q).
Proof.
intros p q p0.
assert (H1:(p ∨ q) ≡≡ ¬((¬p) ∧ (¬q))).
apply DP16.
apply (detachR (p ∨ q)(¬((¬p) ∧ (¬q)))).
assumption.
assert (H2:(¬((¬p) ∧ (¬q))) ≡≡ (((¬p) ∧ (¬q)) ≡≡ F)).
apply (T5 ((¬p) ∧ (¬q))).
apply (detachR (¬((¬p) ∧ (¬q)))(((¬p) ∧ (¬q) ≡≡ F))).
assumption.
assert (H3: forall (r:Prop)(f : Prop->Prop->Prop), ((¬p)  ∧ (¬q)) ≡≡  (f (¬p) r ≡≡ (f (¬q) r ≡≡ (¬p)))).
apply (conj3 (¬p)(¬q)).
specialize (H3 p phi).
assert (H4:(forall p q:Prop, phi p q ≡≡ ((p ≡≡ q) ≡≡ (q ≡≡ p)))).
apply D6.
apply dist_2 in H4.
assert (H5:(forall p q:Prop, ((p ≡≡ q) ≡≡ (q ≡≡ p)))).
apply T4.
assert (H6:=H4).
apply (detachR (forall p1 q0 : Prop, phi p1 q0)(forall p1 q0 : Prop, (p1 ≡≡ q0) ≡≡ (q0 ≡≡ p1))) with (p1:=(¬p))(q0:=p)  in H4;[
          apply (detachR (forall p1 q0 : Prop, phi p1 q0)(forall p1 q0 : Prop, (p1 ≡≡ q0) ≡≡ (q0 ≡≡ p1))) with (p1:=(¬q))(q0:=(p))  in H6;[
                 assert (H7: phi (¬p) p  ≡≡ phi (¬q) p);[
                          apply (intro_eqP);[  assumption  |  assumption ]  |
                          rewrite H3; assert (H8: (phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p)) ≡≡  ((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p));[
                               apply (A2  (phi (¬p) p)(phi (¬q) p) (¬p))  |
                               rewrite H8;assert (H9:((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ((¬p) ≡≡ F)) ≡≡ (((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p) ≡≡ F));[
                                  apply (A2 (phi (¬p) p ≡≡ phi (¬q) p)(¬p) F) |
                                  apply (detachL ((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ (¬p ≡≡ F))(((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p) ≡≡ F)) in H9;[
                                      assumption |
                                      assert (H10: (¬(¬p)) ≡≡ (¬p ≡≡ F));[
                                            apply (T5 (¬p)) |
                                            assert (H11: (¬(¬p)) ≡≡ p);[
                                                apply (T7 p) |
                                                rewrite H11 in H10;rewrite <- H10;apply intro_eqP;assumption  ] ] ] ] ] ]  |
         assumption ]  |
  assumption ].
Qed.

Lemma elim_disj         : forall (p q r:Prop), (p ∨ q) -> (p ⊃ r) -> (q ⊃ r) -> r.
Proof.
intros p q r H1 H2 H3.
assert (H4:forall (p q:Prop), (p ∨ q) ≡≡ ¬((¬p) ∧ (¬q))).
apply DP16.
specialize (H4 p q).
apply (detachL (p ∨ q)(¬((¬p) ∧ (¬q)))) in H4;[
  assert (H5:(¬((¬p) ∧ (¬q))) ≡≡ (((¬p) ∧ (¬q)) ≡≡ F));[
      apply (T5 ((¬p) ∧ (¬q)))  |
      apply (detachL (¬((¬p) ∧ (¬q)))(((¬p) ∧ (¬q) ≡≡ F))) in H5;[
           assert (H6: forall (r:Prop)(f : Prop->Prop->Prop), ((¬p)  ∧ (¬q)) ≡≡  (f (¬p) r ≡≡ (f (¬q) r ≡≡ (¬p))));[
                    apply (conj3 (¬p)(¬q)) |
                    specialize (H6 p phi);rewrite H5 in H6;clear H1 H4 H5;assert (H1:(forall p q:Prop, phi p q ≡≡ ((p ≡≡ q) ≡≡ (q ≡≡ p))));[
                          apply D6 |
                          apply dist_2 in H1; assert (H4:(forall p q:Prop, ((p ≡≡ q) ≡≡ (q ≡≡ p))));[
                              apply T4 |
                              assert (H5:=H1);apply (detachR (forall p0 q0 : Prop, phi p0 q0)(forall p0 q0 : Prop, (p0 ≡≡ q0) ≡≡ (q0 ≡≡ p0))) with (p0:=(¬p))(q0:=p) in H1;[
                                  apply (detachR (forall p0 q0 : Prop, phi p0 q0)(forall p0 q0 : Prop, (p0 ≡≡ q0) ≡≡ (q0 ≡≡ p0))) with (p0:=(¬q))(q0:=p) in H5;[
                                        assert (H7:(F ≡≡ (phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p))) ≡≡  ((phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p)) ≡≡ F ));[
                                            apply (T4 F (phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p))) |
                                            apply (detachL (F ≡≡ (phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p)))((phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p)) ≡≡ F)) in H7;[
                                                   assert (H8: phi (¬p) p  ≡≡ phi (¬q) p);[
                                                       apply (intro_eqP);[  assumption  |  assumption ]  |
                                                       clear H1 H6 H4 H5;assert (H1: (phi (¬p) p ≡≡ (phi (¬q) p ≡≡ ¬p)) ≡≡  ((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p));[
                                                            apply (A2  (phi (¬p) p)(phi (¬q) p) (¬p))  |
                                                            rewrite H1 in H7;assert (H4:((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ((¬p) ≡≡ F)) ≡≡ (((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p) ≡≡ F));[
                                                                     apply (A2 (phi (¬p) p ≡≡ phi (¬q) p)(¬p) F) |
                                                                     apply (detachR ((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ (¬p ≡≡ F))(((phi (¬p) p ≡≡ phi (¬q) p) ≡≡ ¬p) ≡≡ F)) in H4;[
                                                                           assert (H5: (¬(¬p)) ≡≡ (¬p ≡≡ F));[
                                                                                apply (T5 (¬p)) |
                                                                                assert (H6: (¬(¬p)) ≡≡ p);[
                                                                                apply (T7 p) |
                                                                                rewrite H6 in H5;rewrite <-H5 in H4;apply (detachL (phi (¬p) p ≡≡ phi (¬q) p) p) in H4;[
                                                                                apply (elim_impl p r) in H2;assumption  |
                                                                                assumption ] ] ] |
                                                                          assumption ] ] ] ] |
                                                 assumption ] ] |
                                        assumption ] |
                                  assumption ] ] ] ] |
           assumption ] ] |
   assumption ].
Qed.

(* intro/elim rules for negation *)

Lemma intro_neg : forall p, (p ≡≡ F) -> ¬p.
Proof.
intros p H1.
assert (H2:(¬p) ≡≡ (p ≡≡ F)).
apply (T5 p).
apply (detachR (¬p)(p ≡≡ F)) in H2;assumption.
Qed.

Lemma elim_neg : forall p, (¬p) -> (p ≡≡ F).
Proof.
intros p H1.
assert (H2:(¬p) ≡≡ (p ≡≡ F)).
apply (T5 p).
apply (detachL (¬p)(p ≡≡ F)) in H2;assumption.
Qed.

(* ========================================== *)

Lemma T10 : forall (p q:Prop)(F:Morphism), (p ≡≡ q) ⊃ (F p ≡≡ F q).
Proof.
intros P Q F.
apply intro_impl.
intro H.
rewrite H.
reflexivity.
Qed.

Lemma subst_law : forall (p q:Prop)(f:Morphism), ((p ≡≡ q) ∧ f p) ⊃  f q.
Proof.
intros p q F.
apply intro_impl.
intro H1.
assert (H2:=H1).
apply (elim_conjHR (p ≡≡ q)(F p)) in H1.
apply (elim_conjHL (p ≡≡ q)(F p)) in H2.
assert (H3:(p ≡≡ q) ⊃ (F p ≡≡ F q)).
apply (T10 p q F).
apply (elim_impl (p ≡≡ q)(F p ≡≡ F q)) in H3;[
   apply (detachL (F p)(F q)) in H3;assumption |
   assumption ].
Qed.

Lemma  excluded_middle : forall (p :Prop), p ∨ ¬p.
Proof.
intro p.
assert (H1:(p ∨ ¬p) ≡≡ ((¬p) ⊃ ¬p)).
apply (DP16b p (¬p)).
apply (detachR (p ∨ (¬p))((¬p) ⊃ ¬p)) in H1;[
   assumption |
   apply (intro_impl (¬p)(¬p));intro H2;assumption ].
Qed.

Lemma T11 : forall (p:Prop), p ≡≡ (p ≡≡ (forall q:Prop, (q ≡≡ q))).
Proof.
intros p.
apply (def_eqP p (p ≡≡ (forall q : Prop, q ≡≡ q)));[
    apply (intro_impl  p (p ≡≡ (forall q : Prop, q ≡≡ q)));intro p0;assert (H1:forall q :Prop, (q ≡≡ q));[
          apply ProtoReflex |
          apply intro_eqP;[ assumption | assumption ] ] |
    apply (intro_impl (p ≡≡ (forall q : Prop, q ≡≡ q)) p);intro H0;assert (H1:forall q :Prop, (q ≡≡ q));[
          apply ProtoReflex |
          apply (detachR p (forall q : Prop, (q ≡≡ q))) in H0;assumption ] ].
Qed.

Lemma T12 : forall (p:Prop)(f:Morphism), ((f (forall q :Prop, q)) ∧ (f (forall q :Prop, (q ≡≡ q))))  ⊃  f p.
Proof.
intros p F.
apply (intro_impl (F (forall q :Prop, q) ∧ F (forall q :Prop, (q ≡≡ q))) (F p)).
intro H1;assert (H2:=H1).
apply (elim_conjHL (F (forall q : Prop, q))(F (forall q : Prop, q ≡≡ q))) in H1.
apply (elim_conjHR (F (forall q : Prop, q))(F (forall q : Prop, q ≡≡ q))) in H2.
assert (H3: p ∨ ¬p).
apply (excluded_middle p).
apply (elim_disj p (¬p) (F p)) in H3;[
   assumption  |
   apply (intro_impl p (F p));intro p0;assert (H4:p ≡≡ (p ≡≡ (forall q:Prop, (q ≡≡ q))));[
          apply (T11 p) |
          apply (detachL p (p ≡≡ (forall q : Prop, q ≡≡ q))) in H4;[
              apply ProtoSymm in H4;assert (H5:forall (p q:Prop)(g:Morphism), (p ≡≡ q) ⊃ (g p ≡≡ g q));[
                   apply T10 |
                   specialize (H5 (forall q:Prop, (q ≡≡ q)) p F);apply (elim_impl  ((forall q : Prop, q ≡≡ q) ≡≡ p)(F (forall q : Prop, q ≡≡ q) ≡≡ F p)) in H5;[
                          apply (detachL (F (forall q : Prop, q ≡≡ q))(F p)) in H5;[ assumption | assumption ] |
                          assumption ] ] |
              assumption ] ] |
      apply (intro_impl (¬p) (F p));intro H0;assert (H4:(¬p) ≡≡ (p ≡≡ forall q:Prop, q));[
             apply (not p) |
             apply (detachL (¬p)(p ≡≡ (forall q : Prop, q)))  in H4;[
                   apply ProtoSymm in H4;assert (H5: ( ((forall q : Prop, q)  ≡≡ p) ∧ (F (forall q : Prop, q)) ⊃  F p));[
                          apply (subst_law (forall q : Prop, q) p F) |
                          apply (elim_impl (((forall q : Prop, q) ≡≡ p) ∧ F (forall q : Prop, q)) (F p)) in H5;[
                              assumption |
                              apply (intro_conj ((forall q : Prop, q) ≡≡ p)(F (forall q : Prop, q)));assumption ] ] |
                  assumption ] ] ].
Qed.

Lemma T13 : forall (p q:Prop)(f:Morphism), (f p ∧ f (¬p)) ⊃  f q.
Proof.
intros p q g.
apply (intro_impl (g p ∧ g (¬p))(g q)).
intro H1.
assert (H0:=H1).
assert (H2: p ∨ ¬p).
apply (excluded_middle p).
apply (elim_disj p (¬p) (g q)) in H2;[
    assumption |
    apply (intro_impl p (g q));intro p0;assert (H3:p ≡≡ (p ≡≡ (forall q:Prop, (q ≡≡ q))));[
         apply (T11 p) |
         apply (detachL p (p ≡≡ (forall q : Prop, q ≡≡ q))) in H3;[
             apply (elim_conjHL (g p)(g (¬p))) in H1;assert (H4:((p ≡≡ (forall q:Prop, (q ≡≡ q))) ∧ g p));[
                     apply (intro_conj (p ≡≡ (forall q:Prop, (q ≡≡ q)))(g p));[  assumption  |  assumption ] |
                     assert (H5:((p ≡≡ (forall q:Prop, (q ≡≡ q))) ∧ g p) ⊃ g (forall q:Prop, (q ≡≡ q)));[
                          apply (subst_law p (forall q:Prop, (q ≡≡ q))) |
                          apply (elim_impl ((p ≡≡ (forall q0 : Prop, q0 ≡≡ q0)) ∧ g p)(g (forall q0 : Prop, q0 ≡≡ q0))) in H5;[
                               assert (H6:(¬p) ≡≡ (p ≡≡ forall q:Prop, q));[
                                     apply (not p) |
                                     apply ProtoSymm in H6;assert (H7:(p ≡≡ ((forall q0 : Prop, q0) ≡≡ ¬p)) ≡≡ ((p ≡≡ (forall q0 : Prop, q0)) ≡≡ ¬p));[
                                         apply (A2 p (forall q0 : Prop, q0)(¬p)) |
                                         apply (detachR (p ≡≡ ((forall q0 : Prop, q0) ≡≡ ¬p))((p ≡≡ (forall q0 : Prop, q0)) ≡≡ ¬p)) in H7;[
                                               apply (detachL p ((forall q0 : Prop, q0) ≡≡ ¬p)) in H7;[
                                                      apply (elim_conjHR (g p)(g (¬p))) in H0;apply ProtoSymm in H7;assert (H8:((¬p) ≡≡ (forall q0 : Prop, q0)) ∧ g (¬p) ⊃ g  (forall q0 : Prop, q0));[
                                                          apply (subst_law (¬p)(forall q0 : Prop, q0) g) |
                                                          assert (H9:(((¬p) ≡≡ (forall q0:Prop, q0 )) ∧ g (¬p)));[
                                                               apply (intro_conj ((¬p) ≡≡ (forall q0 : Prop, q0))(g (¬p)));[  assumption  |  assumption ] |
                                                               apply (elim_impl ((¬p ≡≡ (forall q0 : Prop, q0)) ∧ g (¬p) ) (g (forall q0 : Prop, q0)) ) in H8;[
                                                                    assert (H10:(g (forall q0 : Prop, q0)) ∧ (g (forall q0 : Prop, q0 ≡≡ q0)));[
                                                                         apply (intro_conj (g (forall q0 : Prop, q0))(g (forall q0 : Prop, q0 ≡≡ q0)));[  assumption  |  assumption ]  |
                                                                         assert (H11:(g (forall q0 : Prop, q0) ∧ g (forall q0 : Prop, q0 ≡≡ q0)) ⊃ g q);[
                                                                               apply (T12 q g) |
                                                                               apply (elim_impl (g (forall q0 : Prop, q0) ∧ g (forall q0 : Prop, q0 ≡≡ q0))(g q)) in H11;[
                                                                                assumption  |  assumption ] ] ] |
                                                                    assumption ] ] ] |
                                                      assumption ] |
                                               assumption ] ] ] |
                               assumption ] ] ] |
            assumption ] ] |
  apply (intro_impl (¬p) (g q));intro H3;assert (H4:forall q0 : Prop, q0 ≡≡ q0);[
     apply ProtoReflex |
     assert (H5:(¬p) ≡≡ (forall q0 : Prop, q0 ≡≡ q0));[
        apply (intro_eqP (¬p)(forall q0 : Prop, q0 ≡≡ q0));[  assumption  |  assumption ]  |
        apply (elim_conjHR (g p)(g (¬p))) in H0;assert (H6: (((¬p) ≡≡ (forall q0 : Prop, q0 ≡≡ q0)) ∧ g (¬p)) ⊃  g (forall q0 : Prop, q0 ≡≡ q0));[
              apply (subst_law  (¬p)(forall q0 : Prop, q0 ≡≡ q0) g)  |
               apply (elim_impl ((¬p ≡≡ (forall q0 : Prop, q0 ≡≡ q0)) ∧ g (¬p))(g (forall q0 : Prop, q0 ≡≡ q0))) in H6;[
                   assert (H7:(¬p) ≡≡ (p ≡≡ (forall q0 : Prop, q0)));[
                         apply (not p) |
                         apply (detachL (¬p) (p ≡≡ (forall q0 : Prop, q0))) in H7;[
                                 apply (elim_conjHL (g p)(g (¬p))) in H1;assert (H8:((p ≡≡ (forall q0 : Prop, q0)) ∧ g p) ⊃ (g (forall q0 : Prop, q0)));[
                                         apply (subst_law p (forall q0 : Prop, q0) g) |
                                         apply (elim_impl ((p ≡≡ (forall q0 : Prop, q0)) ∧ g p) (g (forall q0 : Prop, q0)) ) in H8;[
                                              assert (H9:(g (forall q0 : Prop, q0) ∧ g (forall q0 : Prop, q0 ≡≡ q0)) ⊃ g q);[
                                                     apply (T12 q g) |
                                                     apply (elim_impl (g (forall q0 : Prop, q0) ∧ g (forall q0 : Prop, q0 ≡≡ q0))(g q)) in H9;[
                                                             assumption |
                                                             apply (intro_conj (g (forall q0 : Prop, q0)) (g (forall q0 : Prop, q0 ≡≡ q0)));assumption ] ] |
                                              apply (intro_conj (p ≡≡ (forall q0 : Prop, q0)) (g p));[  assumption  |  assumption ] ] ] |
                                 assumption ] ] |
                   apply (intro_conj (¬p ≡≡ (forall q0 : Prop, q0 ≡≡ q0))(g (¬p)));[  assumption  |  assumption ] ] ] ]
 ] ].
Qed.

Lemma T14 : forall (p :Prop)(f:Morphism), (f p ∧ f (¬p)) ≡≡  forall (q :Prop), f q.
Proof.
intros p g.
apply (def_eqP (g p ∧ g (¬p))(forall (q :Prop), g q));[
    apply (intro_impl (g p ∧ g (¬p))(forall (q :Prop), g q));intros H1 q;assert (H2:(g p ∧ g (¬p)) ⊃  g q);[
            apply (T13 p q g) |
            apply (elim_impl (g p ∧ g (¬p)) (g q)) in H2;assumption  ] |
    apply (intro_impl (forall (q :Prop), g q)(g p ∧ g (¬p)));intro H1;assert (H2:=H1);specialize (H1 p);specialize (H2 (¬p));
    apply (intro_conj (g p)(g (¬p)));assumption ].
Qed.

Lemma eqP_implies_impl : forall (p q:Prop), (p ≡≡ q) ⊃ (p ⊃ q).
Proof.
intros p q.
apply (intro_impl (p ≡≡ q)(p ⊃ q)).
intro H.
apply (intro_impl p q).
intro.
apply (detachL p q) in H;assumption.
Qed.

Lemma not_implies_F : forall (p:Prop), (p ≡≡ F) ⊃ (p ⊃ F).
Proof.
intros p;apply eqP_implies_impl.
Qed.

Lemma T16 : forall p, (p ≡≡ p).
Proof.
apply ProtoReflex.
Qed.

Lemma T17 : T.
Proof.
assert (H:(forall p, (p ≡≡ p))).
apply T16.
assert (H':(T ≡≡ forall p:Prop, (p ≡≡ p))).
apply Verum.
apply (detachR (T)(forall p : Prop, p ≡≡ p)) in H';assumption.
Qed.

Lemma T18 : (T ≡≡ (F ≡≡ F)) ≡≡ ((T ≡≡ F) ≡≡ F).
Proof.
apply (A2 T F F).
Qed.

Lemma T19 : ((T ≡≡ F) ≡≡ F) ≡≡ (T ≡≡ (F ≡≡ F)).
Proof.
assert (H:((((T ≡≡ F) ≡≡ F) ≡≡ (T ≡≡ (F ≡≡ F))) ≡≡ ((T ≡≡ (F ≡≡ F)) ≡≡ ((T ≡≡ F) ≡≡ F))));[
apply (T4 ((T ≡≡ F) ≡≡ F)(T ≡≡ (F ≡≡ F))) |
 assert (H':((T ≡≡ (F ≡≡ F)) ≡≡ ((T ≡≡ F) ≡≡ F)));[apply T18 |
   apply (detachR (((T ≡≡ F) ≡≡ F) ≡≡ (T ≡≡ (F ≡≡ F)))(((T ≡≡ (F ≡≡ F)) ≡≡ ((T ≡≡ F) ≡≡ F)))) in H;
   assumption ] ].
Qed.

Lemma T27 : T ≡≡ (F ≡≡ F).
Proof.
assert (H:T).
apply T17.
assert (H':(F ≡≡ F)).
apply T8.
apply (intro_eqP T (F ≡≡ F));assumption.
Qed.

Lemma T30 : T ≡≡ ¬F.
Proof.
assert (H:(T ≡≡ (F ≡≡ F))).
apply T27.
assert (H':(¬F ≡≡ (F ≡≡ F))).
apply (T5 F).
assert (H1:((¬F ≡≡ (F ≡≡ F)) ≡≡ ((F ≡≡ F) ≡≡ ¬F)));[
  apply (T4 (¬F)(F ≡≡ F)) | apply (detachL (¬F ≡≡ (F ≡≡ F))((F ≡≡ F) ≡≡ ¬F)) in H1;[
  apply transitivity with (x:=T)(y:=(F ≡≡ F))(z:=(¬F));assumption  |
 assumption ]].
Qed.

Lemma T32 : ¬T ≡≡ F.
Proof.
assert (H:(¬T ≡≡ (T ≡≡ F)));[apply (T5 T) |
    assert (H1:(((T ≡≡ F) ≡≡ F) ≡≡ (T ≡≡ (F ≡≡ F))));
    [ apply T19 | assert (H2:(T ≡≡ (F ≡≡ F)));[ apply T27 |
      apply (detachR ((T ≡≡ F) ≡≡ F)(T ≡≡ (F ≡≡ F))) in H1;
    [ apply transitivity with (x:=(¬T))(y:=(T ≡≡ F))(z:=F);assumption
  | assumption ]
  ]]].
Qed.

Lemma T50 : (F ≡≡ F) ≡≡ ¬F.
Proof.
apply transitivity with (x:=(F ≡≡ F))(y:=T)(z:=(¬F));[
  assert (H:((T ≡≡ (F ≡≡ F)) ≡≡ ((F ≡≡ F) ≡≡ T)));[
   apply (T4 T (F ≡≡ F)) | assert (H':(T ≡≡ (F ≡≡ F)));[ apply  T27 |
    apply (detachL (T ≡≡ (F ≡≡ F))((F ≡≡ F) ≡≡ T)) in H;assumption
  ] ] |
    apply T30 ].
Qed.

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

Ltac elimP :=
 match goal with
      | |- ?A ⊃ ?B =>  apply (intro_impl A B);intro
end.

Ltac elimP_in_hyp H :=
 match type of H with
      | ?A ⊃ ?B => apply (elim_impl A B) in H
end.

Ltac intro_lemma_in_hyp Lem :=
  let Tl := type of Lem in
  match Tl with
      | ?A => let H := fresh in assert (H:Tl); [apply Lem | idtac]
      | forall X, ?A => let H := fresh in assert (H:Tl); [apply Lem | idtac]
      | forall X, ?A ⊃ ?B => let H := fresh in assert (H:Tl);[apply Lem | idtac]
      | forall X Y, ?A ⊃ ?B => let H := fresh in assert (H:Tl);[apply Lem | idtac]
      | _ => idtac
end.

(* apply a lemma ?A ⊃ ?B to hypothese H : ?B => new hypothese A ***)

Ltac apply_Lem_in_hyp Lem H :=
  let Tm := type of Lem in
  match Tm with
      | ?A ⊃ ?B =>
        match type of H with A => apply (elim_impl A B) in H;[ idtac | apply Lem ]
        end
      | _ => idtac
end.

(* applied lemma has a forall with 1 arg in the right member *)

Ltac apply_Lem1_in_hyp Lem H X :=
  let Tm := type of Lem in
  match Tm with
      | ?A ⊃ ?B =>
        match type of H with
           | A =>
           match B with
             | forall X':N, _ => let H' := fresh in assert (H':Tm);[apply Lem | idtac];
                apply (elim_impl A B) with (X':=X) in H';[ idtac | assumption]
           end
        end
      | _ => idtac
end.

(* applied lemma has a forall with 2 args in the right member *)

Ltac apply_Lem2_in_hyp Lem H X Y :=
  let Tm := type of Lem in
  match Tm with
      | ?A ⊃ ?B =>
        match type of H with
           | A =>
           match B with
             | forall X' Y':N, _ => let H' := fresh in assert (H':Tm);[apply Lem | idtac];
                apply (elim_impl A B) with (X':=X)(Y':=Y) in H';[ idtac | assumption]
           end
        end
      | _ => idtac
end.

(* apply a lemma ?A ⊃ ?B to a goal ?B => new goal A ***)

Ltac apply_Lem_in_goal Lem :=
  let Tm := type of Lem in
   match Tm with
      | ?A ⊃ ?B =>
       let H := fresh in
            match goal with
              | |- B => apply (elim_impl A B);[apply Lem | idtac]
            end
      | _ => idtac
end.

Ltac decomposeL_and H :=
 match type of H with
      | ?A ∧ ?B =>  apply elim_conjHL in H
end.

Ltac decomposeR_and H :=
 match type of H with
      | ?A ∧ ?B =>  apply elim_conjHR in H
end.

Ltac decompose_and H :=
     match type of H with
      | ?A ∧ ?B => let H' := fresh in assert (H':=H); decomposeR_and H;
                             decomposeL_and H';decompose_and H'
      | _ => idtac
end.

(* elimination in goal *)

Ltac splitP :=
 match goal with
      | |- ?A ≡≡ ?B => apply (def_eqP A B)
      | |- ?A ∧ ?B =>  apply (intro_conj A B);[splitP | idtac]
      | _ => idtac
end.

(* using definition def for proving the definiendum having the definiens as hyp or vice-versa *)

Ltac apply_def_in_hyp def H :=
  let Td := type of def in
  match Td with
      | ?A ≡≡ ?B => match type of H with
           | A => let H' := fresh in assert (H':Td);[apply def | idtac];
                 apply (detachL A B) in H';[ idtac | assumption]
           | B => let H' := fresh in assert (H':Td);[apply def | idtac];
                 apply (detachR A B) in H';[ idtac |assumption]
    end
      | _ => idtac
end.

(* using definition def for the same thing when B has a forall X, ... *)

Ltac apply_def1_in_hyp Def H X :=
  let Tm := type of Def in
  match Tm with
      | ?A ≡≡ ?B =>
        match type of H with
           | A =>
           match B with
             | forall X':N, _ => let H' := fresh in assert (H':Tm);[apply Def | idtac];
                apply (detachL A B) with (X':=X) in H';[ idtac | assumption]
           end
        end
      | _ => idtac
end.

Ltac elim_def1_in_hyp D X :=
match goal with
      | [ H : ?A |- _ ] => let T := type of (D X) in
          match T with
            | A ≡≡ ?B => let H' := fresh in
                      specialize (D X);intro H';apply (detachL A B) in H';[ idtac | exact H]
          end
     | _ => idtac
end.

Ltac elim_def2_in_hyp D X Y :=
match goal with
      | [ H : ?A |- _ ] => let T := type of (D X Y) in
          match T with
            | A ≡≡ ?B => let H' := fresh in
                      specialize (D X Y);intro H';apply (detachL A B) in H';[ idtac | exact H]
          end
     | _ => idtac
end.

Ltac elim_def3_in_hyp D X Y Z H :=
let A := type of H in
        match type of (D X Y Z) with
            | A ≡≡ ?B => let H' := fresh in
                      specialize (D X Y Z);intro H';apply (detachL A B) in H';
                      [ idtac | exact H]
            | _ => idtac
end.

Ltac elim_def1 D X :=
match goal with
      | [ |- ?A ] => let T := type of (D X) in
          match T with
            | A ≡≡ ?B => apply (detachR A B);[ apply (D X) | idtac ]
          end
     | [ |- ?B ] => let T := type of (D X) in
          match T with
            | ?A ≡≡ B => apply (detachL A B);[ apply (D X) | idtac ]
          end
     | _ => idtac
end.

Ltac elim_def2 D X Y :=
match goal with
      | [  |- ?A ] => let T := type of (D X Y) in
          match T with
            | A ≡≡ ?B => apply (detachR A B);[ apply (D X Y) | idtac ]
          end
      | [ |- ?B ] => let T := type of (D X Y) in
          match T with
            | ?A ≡≡ B => apply (detachL A B);[ apply (D X Y) | idtac ]
          end
     | _ => idtac
end.

Ltac elim_def3 D X Y Z :=
match goal with
      | [ H : _ |- ?A ] => let T := type of (D X Y Z) in
          match T with
            | A ≡≡ ?B => apply (detachR A B);[ apply (D X Y Z) | idtac ]
          end
      | [ H : _ |- ?B ] => let T := type of (D X Y Z) in
          match T with
            | ?A ≡≡ B => apply (detachL A B);[ apply (D X Y Z) | idtac ]
          end
     | _ => idtac
end.

Ltac elim_or_in_hyp H :=
  match type of H with
       | ?A ∨ ?B =>
 match goal with
        |  |- ?G  => apply (elim_disj A B G) in H;[ assumption | elimP | elimP ]
   end
end.

Ltac assert_and_hyp H1 H2 :=
    let T1 := type of H1 in
    let T2 := type of H2 in
    match T1 with
        | ?A ∧ ?B => let H' := fresh in assert (H':(T1 ∧ T2));splitP;
                      [ assumption | assumption | assumption | idtac ]
        | _ => let H' := fresh in assert (H':(T1 ∧ T2));splitP;
                            [ assumption | assumption | idtac ]
 end.

Ltac elim_for_some H A :=
    match type of H with
       | exists X, _  => let H' := fresh in elim H;clear H;intros A H
       |  _ => idtac
 end.

Ltac elim_for_some2 H witness1 witness2 :=
let H1 := fresh in
    match type of H with
       | exists X Y, _  => elim H;intros witness1 H1;elim H1;
                           clear H H1;intros witness2 H1
 end.

End Protothetic.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals.
Require Import mathcomp.ssreflect.ssreflect.
Require Import List.

(** This file describes compactness results: finite covering of opens,
finite covering based on a gauge function, specific instances for 1D
and 2D spaces. *)

(* This enables a compatibility with Coq 8.4, which didn't have the right lemmas Rplus_lt_reg_l
   and Rplus_lt_reg_r.  So this Import should disappear in the future.  A better solution would
   be to have the fix in a specific compatibility file, rather than in Rcomplements.v. *)
Require Import Rcomplements.

Open Scope R_scope.

Lemma completeness_any :
  forall P : R -> Prop,
  ( forall x y, x <= y -> P y -> P x ) ->
  forall He : (exists x, P x),
  forall Hb : (bound P),
  forall x, x < proj1_sig (completeness _ Hb He) ->
  ~ ~ P x.
Proof.
intros P HP He Hb x.
case completeness => y [Hy1 Hy2] /= Hxy Px.
apply Rle_not_lt with (2 := Hxy).
apply Hy2 => t Pt.
apply Rnot_lt_le => Hxt.
apply Px.
apply: HP Pt.
now apply Rlt_le.
Qed.

Lemma false_not_not :
  forall P Q : Prop, (P -> ~Q) -> (~~P -> ~Q).
Proof.
intros P Q H HP HQ.
apply HP.
intros H'.
now apply H.
Qed.

Section Compactness.

Fixpoint Tn n T : Type :=
  match n with
  | O => unit
  | S n => (T * Tn n T)%type
  end.

Fixpoint bounded_n n : Tn n R -> Tn n R -> Tn n R -> Prop :=
  match n return Tn n R -> Tn n R -> Tn n R -> Prop with
  | O => fun a b x : Tn O R => True
  | S n => fun a b x : Tn (S n) R =>
    let '(a1,a2) := a in
    let '(b1,b2) := b in
    let '(x1,x2) := x in
    a1 <= x1 <= b1 /\ bounded_n n a2 b2 x2
  end.

Fixpoint close_n n d : Tn n R -> Tn n R -> Prop :=
  match n return Tn n R -> Tn n R -> Prop with
  | O => fun x t : Tn O R => True
  | S n => fun x t : Tn (S n) R =>
    let '(x1,x2) := x in
    let '(t1,t2) := t in
    Rabs (x1 - t1) < d /\ close_n n d x2 t2
  end.

(** * Compactness: there is a finite covering of opens *)

Lemma compactness_list :
  forall n a b (delta : Tn n R -> posreal),
  ~~ exists l, forall x, bounded_n n a b x -> exists t, In t l /\ bounded_n n a b t /\ close_n n (delta t) x t.
Proof.
induction n.
intros a b delta.
intros H.
apply H.
exists (tt :: nil).
intros x Hx.
exists tt.
repeat split.
now left.
simpl.
(* *)
intros (a,a') (b,b') delta.
destruct (Rlt_le_dec b a) as [Hab|Hab].
intros H.
apply H.
exists nil.
intros (x,x') (Hx,_).
elim (Rlt_irrefl a).
apply Rle_lt_trans with (2 := Hab).
now apply Rle_trans with x.
(* *)
set (P y := y <= b /\ ~~exists l, forall x, bounded_n (S n) (a,a') (y,b') x ->
  exists t, In t l /\ bounded_n (S n) (a,a') (b,b') t /\ close_n (S n) (delta t) x t).
(* . *)
assert (P1': P a).
split.
apply Hab.
simpl.
specialize (IHn a' b' (fun x' => delta (a,x'))).
contradict IHn.
contradict IHn.
destruct IHn as (l,Hl).
exists (fold_right (fun x' acc => (a,x')::acc) nil l).
intros (x,x') (Hx,Hx').
replace x with a by now apply Rle_antisym.
destruct (Hl x' Hx') as (t',(Ht1,Ht2)).
exists (a,t').
split.
clear -Ht1.
induction l.
easy.
simpl in Ht1 |- *.
destruct Ht1 as [Ht1|Ht1].
left.
now apply f_equal2.
right.
now apply IHl.
repeat split.
apply Rle_refl.
exact Hab.
apply Ht2.
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
apply Ht2.
(* . *)
assert (P2: bound P).
exists b => y Hy.
apply Hy.
(* . *)
assert (P3: forall x y, x <= y -> P y -> P x).
intros x y Hxy (Py1,Py2).
split.
now apply Rle_trans with y.
contradict Py2.
contradict Py2.
destruct Py2 as (l,Py2).
exists l => [[z z']] Hz.
apply Py2.
split.
split.
apply Hz.
now apply Rle_trans with (1 := proj2 (proj1 Hz)).
apply Hz.
assert (P1: exists x, P x).
now exists a.
(* . *)
set (y := proj1_sig (completeness _ P2 P1)).
assert (P4: ~~exists d : posreal, P (Rmin b (y + d))).
specialize (IHn a' b' (fun x' => delta (y,x'))).
contradict IHn.
contradict IHn.
destruct IHn as (l, Hl).
set (d := fold_right (fun t acc => mkposreal _ (Rmin_stable_in_posreal (delta (y,t)) acc)) (mkposreal _ Rlt_0_1) l).
assert (Hd: 0 < d/2).
apply Fourier_util.Rlt_mult_inv_pos.
apply cond_pos.
apply Rlt_R0_R2.
exists (mkposreal _ Hd).
split.
apply Rmin_l.
refine (_ (completeness_any _ P3 P1 P2 (y - d) _)).
intros Hy.
apply: false_not_not Hy => Hy.
destruct Hy as (Hy1,Hy2).
apply: false_not_not Hy2 => Hy2.
apply.
destruct Hy2 as (l',Hl').
exists (app (fold_right (fun x' acc => (y,x')::acc) nil l) l').
simpl.
intros (x,x') (Hx,Hx').
destruct (Rle_or_lt x (y - d)) as [Hxy|Hxy].
destruct (Hl' (x,x') (conj (conj (proj1 Hx) Hxy) Hx')) as (t,(Ht1,Ht2)).
exists t.
split.
apply in_or_app.
now right.
exact Ht2.
destruct (Hl x' Hx') as (t',(Ht1,Ht2)).
exists (y, t').
split.
apply in_or_app.
left.
clear -Ht1.
induction l.
easy.
simpl in Ht1 |- *.
destruct Ht1 as [Ht1|Ht1].
left.
now apply f_equal2.
right.
now apply IHl.
do 2 split.
unfold y.
case completeness => /= z [Hz1 Hz2].
split.
now apply Hz1.
apply Hz2.
intros w Hw.
apply Hw.
apply Ht2.
apply Rlt_le_trans with d.
apply Rabs_def1.
apply Rplus_lt_reg_r with y.
ring_simplify.
apply Rle_lt_trans with (y + d/2).
now apply Rle_trans with (2 := Rmin_r b _).
apply Rplus_lt_compat_l.
rewrite -(Rplus_0_r (d/2)).
rewrite {2}(double_var d).
now apply Rplus_lt_compat_l.
apply Rplus_lt_reg_l with y.
now ring_simplify (y + (x - y)).
clearbody y.
clear -Ht1.
induction l.
easy.
simpl in Ht1.
destruct Ht1 as [Ht1|Ht1].
rewrite -Ht1.
apply: Rmin_l.
unfold d.
simpl.
apply Rle_trans with (1 := Rmin_r _ _).
now apply IHl.
apply Ht2.
fold y.
rewrite -{2}(Rplus_0_r y) -Ropp_0.
apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
apply cond_pos.
(* . *)
apply: false_not_not P4 => P4.
destruct P4 as (d,P4).
destruct (Rle_or_lt b y) as [Hby|Hby].
rewrite Rmin_left in P4.
apply P4.
rewrite -(Rplus_0_r b).
apply Rplus_le_compat with (1 := Hby).
apply Rlt_le.
apply cond_pos.
elimtype False.
unfold y in *.
clear y.
revert P4 Hby.
case completeness => /= y [Hy1 Hy2] P4 Hby.
apply Rle_not_lt with (1 := Hy1 (Rmin b (y + d)) P4).
apply Rmin_case.
exact Hby.
rewrite -{1}(Rplus_0_r y).
apply Rplus_lt_compat_l.
apply cond_pos.
Qed.

(** * Compactness: there is a covering based on a gauge function *)

Lemma compactness_value :
  forall n a b (delta : Tn n R -> posreal),
  { d : posreal | forall x, bounded_n n a b x -> ~~ exists t, bounded_n n a b t /\ close_n n (delta t) x t /\ d <= delta t }.
Proof.
intros n a b delta.
set (P d := d <= 1 /\ forall x, bounded_n n a b x -> exists t, bounded_n n a b t /\ close_n n (delta t) x t /\ d <= delta t).
assert (P1 : exists d, P d).
exists 0.
split.
apply Rle_0_1.
intros x Hx.
exists x.
split.
exact Hx.
split.
clear.
induction n.
easy.
destruct x as (x,x').
split.
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
apply (IHn (fun x' => delta (x,x'))).
apply Rlt_le.
apply cond_pos.
assert (P2 : bound P).
exists 1.
now intros d (Hd,_).
set (d := completeness P P2 P1).
(* *)
assert (P3 : 0 < proj1_sig d).
revert d.
case completeness.
intros d (Hd1,Hd2).
simpl.
apply Rnot_le_lt.
intros Hd3.
apply (compactness_list n a b delta).
intros (l,Hl).
set (v := fold_right (fun t acc => mkposreal _ (Rmin_stable_in_posreal (delta t) acc)) (mkposreal _ Rlt_0_1) l).
apply (Rlt_not_le _ _ (cond_pos v)).
apply Rle_trans with (2 := Hd3).
apply Hd1.
split.
unfold v.
clear.
induction l.
apply Rle_refl.
simpl.
apply Rle_trans with (2 := IHl).
apply Rmin_r.
intros x Hx.
destruct (Hl x Hx) as (t,(Ht1,Ht2)).
exists t.
split.
apply Ht2.
split.
apply Ht2.
clear -Ht1.
induction l.
easy.
simpl in Ht1.
destruct Ht1 as [Ht1|Ht1].
simpl.
rewrite Ht1.
apply Rmin_l.
simpl.
eapply Rle_trans with (1 := Rmin_r _ _).
now apply IHl.
(* *)
exists (mkposreal _ (Fourier_util.Rlt_mult_inv_pos _ _ P3 Rlt_R0_R2)).
intros x Hx.
simpl.
refine (_ (completeness_any P _ P1 P2 (proj1_sig d / 2) _)).
intros HP.
contradict HP.
contradict HP.
destruct HP as (_,HP).
now apply HP.
intros u v Huv (Pv1,Pv2).
split.
now apply Rle_trans with v.
intros z Hz.
destruct (Pv2 z Hz) as (t,Ht).
exists t.
split.
apply Ht.
split.
apply Ht.
apply Rle_trans with (1 := Huv).
apply Ht.
fold d.
rewrite -(Rplus_0_r (proj1_sig d / 2)).
rewrite {2}(double_var (proj1_sig d)).
apply Rplus_lt_compat_l.
apply Fourier_util.Rlt_mult_inv_pos.
exact P3.
apply Rlt_R0_R2.
Qed.

End Compactness.

(** * Specific instances of compactness for 1D and 2D spaces *)

Lemma compactness_value_1d :
  forall a b (delta : R -> posreal),
  { d : posreal | forall x, a <= x <= b -> ~~ exists t, a <= t <= b /\ Rabs (x - t) < delta t /\ d <= delta t }.
Proof.
intros a b delta.
destruct (compactness_value 1 (a,tt) (b,tt) (fun t => let '(t,_) := t in delta t)) as (d, Hd).
exists d.
intros x Hx.
specialize (Hd (x,tt) (conj Hx I)).
do 2 contradict Hd.
destruct Hd as ((t,t'),Ht).
exists t.
repeat split ; apply Ht.
Qed.

Lemma compactness_value_2d :
  forall a b a' b' (delta : R -> R -> posreal),
  { d : posreal | forall x y, a <= x <= b -> a' <= y <= b' ->
    ~~ exists u, exists v, a <= u <= b /\ a' <= v <= b' /\ Rabs (x - u) < delta u v /\ Rabs (y - v) < delta u v /\ d <= delta u v }.
Proof.
intros a b a' b' delta.
destruct (compactness_value 2 (a,(a',tt)) (b,(b',tt)) (fun t => let '(u,(v,_)) := t in delta u v)) as (d, Hd).
exists d.
intros x y Hx Hy.
specialize (Hd (x,(y,tt)) (conj Hx (conj Hy I))).
do 2 contradict Hd.
destruct Hd as ((u,(v,w)),Ht).
exists u.
exists v.
simpl in Ht.
repeat split ; apply Ht.
Qed.


From cgraphs.locks.lambdalockpp Require Import invariant.

(* The theorems are given in a slightly different order because some of the
   proofs of the earlier theorems depend on the later theorems. *)

(* Paper theorem 7 part 1 *)
Lemma fully_reachable_iff_deadlock_free ρ :
  fully_reachable ρ <-> deadlock_free ρ.
Proof.
  split.
  - intros Hfr s [] i si.
    destruct (Hfr i); eauto.
    exfalso. induction H; naive_solver.
  - intros Hdf i. classical_left.
    eapply (Hdf (λ i, ¬ reachable ρ i));
    first constructor; eauto using reachable.
Qed.

(* Paper theorem 10 part 1 *)
Lemma fully_reachable_type_safety ρ :
  fully_reachable ρ -> type_safety ρ.
Proof.
  intros Hfr i. destruct (Hfr i) as [|[]]; eauto.
Qed.

(* Paper theorem 10 part 2 *)
Lemma fully_reachable_global_progress ρ :
  fully_reachable ρ -> global_progress ρ.
Proof.
  intros Hfr.
  destruct (classic (∃ i, ¬ inactive ρ i)).
  - destruct H as [i Hi]. destruct (Hfr i); first naive_solver.
    clear Hi. right. induction H; eauto.
  - left. intros i. apply NNPP. eauto.
Qed.

(* Paper theorem 11 *)
Lemma typed_full_reachability e ρ :
  typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> fully_reachable ρ.
Proof.
  intros Ht Hsteps.
  assert (ginv {[ 0 := Thread e ]}) as Hinv.
  { eapply initialization. done. }
  induction Hsteps.
  - eapply full_reachability. done.
  - eapply IHHsteps. destruct H. eapply preservation; eauto.
Qed.

(* Paper theorem 1 *)
Lemma typed_global_progress e ρ :
  typed ∅ e UnitT -> steps {[ 0 := Thread e ]} ρ -> global_progress ρ.
Proof.
  intros. eapply fully_reachable_global_progress, typed_full_reachability; done.
Qed.


From iris.algebra Require Import
  agree.
From iris.proofmode Require Import
  proofmode.

From caml5 Require Import
  prelude.
From caml5 Require Export
  base.

Class AgreeG Σ A := {
  agree_G_inG : inG Σ (agreeR A) ;
}.
#[local] Existing Instance agree_G_inG.

Definition agree_Σ A := #[
  GFunctor (agreeR A)
].
#[global] Instance subG_agree_Σ A Σ :
  subG (agree_Σ A) Σ →
  AgreeG Σ A.
Proof.
  solve_inG.
Qed.

Section agree_G.
  Context `{!AgreeG Σ A}.

  Definition agree_on γ a :=
    own γ (to_agree a).

  #[global] Instance agree_on_timeless γ a :
    Discrete a →
    Timeless (agree_on γ a).
  Proof.
    apply _.
  Qed.
  #[global] Instance agree_on_persistent γ a :
    Persistent (agree_on γ a).
  Proof.
    apply _.
  Qed.

  Lemma agree_alloc a :
    ⊢ |==> ∃ γ,
      agree_on γ a.
  Proof.
    apply own_alloc. done.
  Qed.

  Section cmra_discrete.
    Context `{!OfeDiscrete A}.

    Lemma agree_on_agree γ a1 a2 :
      agree_on γ a1 -∗
      agree_on γ a2 -∗
      ⌜a1 ≡ a2⌝.
    Proof.
      iIntros "H1 H2".
      iDestruct (own_valid_2 with "H1 H2") as %?%to_agree_op_valid. done.
    Qed.
    Lemma agree_on_agree_L `{!LeibnizEquiv A} γ a1 a2 :
      agree_on γ a1 -∗
      agree_on γ a2 -∗
      ⌜a1 = a2⌝.
    Proof.
      iIntros "H1 H2".
      iDestruct (agree_on_agree with "H1 H2") as %?%leibniz_equiv. done.
    Qed.
  End cmra_discrete.
End agree_G.

#[global] Opaque agree_on.


Require Import isla.isla.
Require Import isla.riscv64.riscv64.
Require Export isla.instructions.binary_search_riscv64.a18.

Lemma a18_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a18) -∗
  instr_body pc (sd_spec pc "x20" "x2" (16)).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a18_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a18_spec pc).
Global Existing Instance a18_spec_inst.