Require Import FM.

(* Gensym avec la monade libre *)
Module gensym.
  Export FreeMonad.

  Inductive Fresh {ident} : Type -> Type :=
  | Gensym : Fresh ident.

  Definition gensym {ident} : mon Fresh ident := syntax_effect Gensym.

End gensym.

Module gensym_run.
  Export gensym.

  Definition ident := nat.

  Definition Fresh := @Fresh ident.

  Definition initial_state := 0.

  Fixpoint run {X} (m : mon Fresh X) : ident -> ident * X :=
    match m with
    | ret v => fun n => (n, v)
    | op Gensym f =>
      fun n => run (f n) (S n)
    end.

End gensym_run.

Require Import SepList.

(* Raisonnement pour gensym avec la SL sur liste minimaliste *)
Module weakestpre_gensym.
  Export SepList.
  Export weakestpre.
  Export gensym_run.

  Definition iProp := @iPropGen (@hpropList ident) biInd.

  Definition op_spec X (m : Fresh X) : iProp * (X -> iProp) :=
    match m with
    | Gensym => (emp, IsFresh)
    end.

  Definition wp {X} (m : mon Fresh X) (Q : X -> iProp) : iProp :=
    @wp_gen _ _ _ op_spec _ m Q.

  Notation "'{{' P } } e {{ v ; Q } }" := (@triple _ _ _ op_spec _ P e (fun v => Q))
      (at level 20, format "'[hv' {{  P  } }  '/  ' e  '/'  {{  v ;  Q  } } ']'").
  (** triple rules *)

  Lemma gensym_spec :
  ⊢{{ emp }} gensym {{ l; IsFresh l }}.
  Proof. unfold triple. simpl. auto. Qed.

End weakestpre_gensym.

(* Adequacy pour gensym avec la SL minimaliste *)
Module adequacy_gensym.
  Export weakestpre_gensym.

  Definition inject n := seq 0 n.

  Lemma inject_last : forall n, inject (S n) = inject n ++ [n].
  Proof. intros. unfold inject. rewrite seq_S. reflexivity. Qed.

  Lemma next_disjoint : forall n, list_disjoint (inject n) [n].
  Proof.
    intros n x y P0 P1 eq. subst. inversion P1. subst. apply in_seq in P0.
    destruct P0. lia. inversion H.
  Qed.

  Lemma adequacy {X} : forall (e : mon Fresh X) (Q : X -> iProp) n n' v,
      (heap_ctx (inject n) ⊢ wp e Q ) ->
      run e n = (n', v) ->
      (Q v) () (inject n').
  Proof.
    fix e 1.
    destruct e0; intros.
    - inversion H0; subst. apply soundness2. iApply H.
    - simpl in *. destruct f. eapply e.
      2 : apply H0.
      + iIntros "HA". rewrite inject_last.
        iDestruct (heap_ctx_split with "HA") as "[HA HB]". apply next_disjoint.
        iDestruct (H with "HA") as "[_ HA]".
        iApply ("HA" with "HB").
  Qed.

  Lemma adequacy_init {X} : forall (e : mon Fresh X) (Q : X -> iProp) (s' : nat) v ,
      (⊢ wp e Q) ->
      run e initial_state = (s', v) ->
      (Q v) () (inject s').
  Proof. intros. eapply adequacy; eauto. iIntros "_". auto. Qed.

  Lemma adequacy_triple {X} : forall (e : mon Fresh X) (Q : X -> iProp) n v n' H,
      (heap_ctx (inject n) ⊢ H) -> (⊢ {{ H }} e {{ v; Q v }}) ->
      run e n = (n', v) ->
      (Q v) () (inject n').
  Proof.
    intros. eapply adequacy; eauto. iIntros "HA". iDestruct (H0 with "HA") as "HA".
    iApply (H1 with "HA").
  Qed.

  Lemma adequacy_triple_init {X} : forall (e : mon Fresh X) (Q : X -> iProp) v n' H,
      (⊢ H) -> (⊢ {{ H }} e {{ v; Q v }}) ->
      run e initial_state = (n', v) ->
      (Q v) () (inject n').
  Proof.
    intros. eapply adequacy_init; eauto. iApply H1; eauto.
  Qed.

  Lemma use_adequacy {X} : forall (e : mon Fresh X) (Q : X -> iProp) v n' H,
      (⊢ H) -> (⊢ {{ H }} e {{ v; Q v }}) ->
      run e initial_state = (n', v) ->
      ∃ s, (Q v) () s.
  Proof.
    intros. exists (inject n'). apply (adequacy_triple_init _ _ _ _ _ H0 H1 H2).
  Qed.

  Lemma adequacy_wp_pure {X} : forall (e : mon Fresh X) (Q : X -> Prop) n v n',
      (heap_ctx (inject n) ⊢ wp e (fun v =>  ⌜Q v⌝)) ->
      run e n = (n', v) ->
      Q v.
  Proof.
    intros. apply (soundness1 (inject n')). iApply soundness3.
    eapply (adequacy _ _ _ _ _ H H0).
  Qed.

  Lemma adequacy_pure {X} : forall (e : mon Fresh X) (Q : X -> Prop) n v n' H,
      (heap_ctx (inject n) ⊢ H) -> (⊢ {{ H }} e {{ v; ⌜ Q v ⌝}}) ->
      run e n = (n', v) ->
      Q v.
  Proof.
    intros. eapply adequacy_wp_pure; eauto. iIntros "HA". iDestruct (H0 with "HA") as "HA".
    iApply (H1 with "HA").
  Qed.

  Lemma adequacy_pure_init {X} : forall (e : mon Fresh X) (Q : X -> Prop) v s' H,
      (⊢ H) -> (⊢ {{ H }} e {{ v; ⌜ Q v ⌝}}) ->
      run e initial_state = (s', v) ->
      Q v.
  Proof.
    intros. eapply adequacy_pure; eauto.
    iIntros "_". iApply H1; auto.
  Qed.

End adequacy_gensym.


(** * Definition of a functor *)

From Coq Require Import
     Setoid
     Morphisms.

From ITree Require Import
     CategoryOps.

Import CatNotations.
Local Open Scope cat_scope.

Section Functor.

Context
  {obj1 obj2 : Type}
  {C1 : obj1 -> obj1 -> Type}
  {C2 : obj2 -> obj2 -> Type}
  {F : obj1 -> obj2} {fmap : forall a b, C1 a b -> C2 (F a) (F b)}
  `{Eq2 _ C1} `{Id_ _ C1} `{Cat _ C1}
  `{Eq2 _ C2} `{Id_ _ C2} `{Cat _ C2}.

Arguments fmap {a b}.

Class Functor : Prop :=
  { fmap_id : forall a, fmap (id_ a) ⩯ id_ (F a)
  ; fmap_cat : forall a b c (f : C1 a b) (g : C1 b c), fmap (cat f g) ⩯ cat (fmap f) (fmap g)
  ; fmap_proper : forall a b, Proper (eq2 ==> eq2) (@fmap a b)
  }.

End Functor.

Arguments Functor : clear implicits.
Arguments Functor {_ _} C1 C2 F fmap {_ _ _ _ _ _}.

Section FunctorId.

Context
  {obj : Type} {C1 C2 : obj -> obj -> Type}
  {fmap : forall a b, C1 a b -> C2 a b}
  `{Eq2 _ C1} `{Id_ _ C1} `{Cat _ C1}
  `{Eq2 _ C2} `{Id_ _ C2} `{Cat _ C2}
  {Functor_id : Functor C1 C2 (fun x => x) fmap}.

Lemma fmap_id0 : forall a, fmap _ _ (id_ a) ⩯ id_ a.
Proof. apply fmap_id. Qed.

Lemma fmap_cat0 : forall a b c (f : C1 a b) (g : C1 b c),
    fmap _ _ (f >>> g) ⩯ fmap _ _ f >>> fmap _ _ g.
Proof. apply fmap_cat. Qed.

End FunctorId.


From iris.proofmode Require Export base intro_patterns spec_patterns
     sel_patterns coq_tactics reduction
     coq_tactics ltac_tactics.
Require Import FunctionalExtensionality.
From iris Require Export bi.bi proofmode.tactics proofmode.monpred proofmode.reduction.
Global Set Warnings "-convert_concl_no_check -notation-overridden".

(* Monade libre *)
Module FreeMonad.

  Inductive mon (E : Type -> Type) (X : Type) : Type :=
  | ret : X -> mon E X
  | op : forall Y, E Y -> (Y -> mon E X) -> mon E X.

  Arguments ret {_ _} x.
  Arguments op {_ _ _}.

  Fixpoint bind {E X Y} (m : mon E X) (f : X -> mon E Y)
    : mon E Y :=
    match m with
    | ret x => f x
    | op e c => op e (fun x => bind (c x) f)
    end.

  Definition syntax_effect {E X} (e : E X) := op e ret.
-
  Notation "'let!' x ':=' e1 'in' e2" :=
    (bind e1 (fun x => e2)) (x name, at level 50).

  Notation "'ret!' v" := (ret v) (v name, at level 50).

  Lemma lid : forall E X Y (a : X) (f : X -> mon E Y), let! v := ret! a in f v = f a.
  Proof. auto. Qed.

  Lemma rid : forall E X (m : mon E X), let! v := m in ret v = m.
  Proof.
    fix m 3.
    destruct m0.
    * reflexivity.
    * simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

  Lemma ass_bind : forall E X Y Z (m : mon E X) f (g : Y -> mon E Z),
      let! v :=
         let! v' := m in
         f v'
      in
      g v =
      let! v := m in
      let! v' := f v in
      g v'.
  Proof.
    fix m 5.
    destruct m0; intros.
    * reflexivity.
    * simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

End FreeMonad.

(* Pour le moment, juste une tactique fait maison *)
Module SepBasicCore.

  Local Ltac Fresh :=
    let x := iFresh in
    match x with
    | IAnon ?x =>
      let x := eval compute in (ascii_of_pos (x + 64)) in
          let x := eval compute in (append "H" (string_of_list_ascii [x])) in
              let env := iGetCtx in
              let P := reduction.pm_eval (envs_lookup x env) in
              match P with
              | None => x
              | Some _ => Fresh
              end
    | _ => fail "iFresh returns " x " sometimes."
    end.

  (*h should be in the environment *)
  Local Ltac norm h :=
    let env := iGetCtx in
    let P := reduction.pm_eval (envs_lookup h env) in
    match P with
    | None => fail "assert false"
    | Some (false, ?P) =>
      match P with
      | bi_exist ?Q => let x := fresh "x" in (iDestruct h as (x) h; norm h)
      | bi_sep ?Q ?W =>
        let x := Fresh in
        let y := Fresh in
        eapply tac_and_destruct with h _ x y _ _ _;
        [ pm_reflexivity | pm_reduce; iSolveTC | pm_reduce; norm x; norm y]
      | bi_pure (and ?P ?Q) =>
        let x := Fresh in
        eapply tac_and_destruct with h _ h x _ _ _;
        [pm_reflexivity
        |pm_reduce; iSolveTC
        |pm_reduce; norm h; norm x]
      | bi_pure _ => iPure h as ?
      | bi_wand _ _ => iDestruct (h with "[]") as h; [progress auto | norm h]
      | bi_absorbingly _ =>
        let name := Fresh in
        let name_mod := eval compute in (append ">" name) in
            iPoseProof h as name; iDestruct name as name_mod; norm name
      | _ =>
        match h with
        | IAnon _ =>
          let x := Fresh in
          iPoseProof h as x
        | _ => idtac
        end
      end
    | Some (true,?P) => idtac
    end.

    (* (List.fold norm) in Ltac *)
  Local Ltac norm_list l :=
    match l with
    | [] => idtac
    | ?h :: ?t => norm h ; norm_list t
    end.

  Ltac norm_all :=
    iStartProof;
    let env := iGetCtx in
    let list_ident := eval compute in (rev (envs_dom env)) in
        norm_list list_ident; auto.

  Tactic Notation "iNorm" := norm_all.

End SepBasicCore.

(* Règles structurelles commune aux logiques de ressources et effets *)
Module weakestpre.
  Export SepBasicCore.
  Import FreeMonad.

  Section structural_rules.
    Context {PROP : bi}.
    Context {biInd : biIndex}.

    Definition iPropGen  := monPred biInd PROP.

    Context {E : Type -> Type}.
    Context {E_SPEC : forall {X}, E X -> iPropGen * (X -> iPropGen)}.

    Fixpoint wp_gen {X} (e1 : mon E X) (Q : X -> iPropGen) : iPropGen :=
      match e1 with
      | ret v => Q v
      | op e f =>
        let (pre,post) := E_SPEC _ e in
        bi_sep pre (∀ l, post l -∗ (wp_gen (f l) Q))
      end.

    Lemma wp_bind {X Y} (e : mon E X) (f :  X → mon E Y) (Q : Y -> iPropGen) (Q' : X -> iPropGen) :
      wp_gen e Q' ⊢
      (∀ v,  Q' v -∗ wp_gen (f v) Q ) -∗
      wp_gen (let! v := e in f v) Q %I.
    Proof.
      iIntros "HA HB". revert e. fix e 1.
      destruct e0.
      - iApply "HB". iApply "HA".
      - simpl. destruct (E_SPEC Y0 e0). iNorm. iFrame. iIntros (l) "HC".
        iDestruct ("HD" with "HC") as "HA".
        iPoseProof "HB" as "HB". apply e.
    Qed.

    Lemma wp_consequence {X} (P Q : X -> iPropGen) (f : mon E X) :
      ⊢ wp_gen f P -∗
        (∀ x, P x -∗ Q x) -∗
        wp_gen f Q.
    Proof.
      induction f; simpl; intros; auto.
      - iIntros "HA HB". iApply ("HB" with "HA").
      - iIntros. iNorm. destruct (E_SPEC Y e). iNorm. iFrame. iIntros (l) "HA".
        iApply (H with "[HA HH] HE"). iApply ("HH" with "HA").
    Qed.

    Definition triple {X} (P : iPropGen) (e : mon E X) Q : iPropGen :=
      bi_wand P (wp_gen e Q).

    Notation "'{{' P } } e {{ v ; Q } } " := (triple P e (fun v => Q))
                                               (at level 20, format "'[hv' {{  P  } }  '/  ' e  '/'  {{  v ;  Q  } } ']'").

    Lemma ret_spec {X} (v : X) H (Q : X -> iPropGen) :
      (H ⊢ Q v) -> ⊢{{ H }} (ret! v : mon E X) {{ v'; Q v' }}.
    Proof. simpl; iIntros. iApply H0; auto. Qed.

    Lemma bind_spec {X Y} (e : mon E X) (f : X -> mon E Y) Q Q' (H : iPropGen) :
      (⊢{{ H }} e {{ v; Q' v }}) ->
      (∀ v, ⊢{{ Q' v }} f v {{ v'; Q v' }}) ->
      ⊢ {{ H }} let! v := e in f v {{ v; Q v}}.
    Proof.
      intros. iIntros "HA".
      iApply (wp_bind e f _ Q' with "[HA]").
      - iApply (H0 with "[HA]"); auto.
      - iIntros (v) "HC". iApply (H1 with "[HC]"); auto.
    Qed.

    Lemma consequence {X} H H' (Q : X -> iPropGen) (Q' : X -> iPropGen) (e : mon E X) :
      (⊢{{ H' }} e {{ v; Q' v }}) ->
      (forall v, Q' v ⊢ Q v) ->
      (H ⊢ H') ->
      ⊢{{ H }} e {{ v; Q v }}.
    Proof.
      intros. iIntros "HA". iDestruct (H2 with "HA") as "HA".
      iDestruct (H0 with "HA") as "HA". iApply (wp_consequence with "HA").
      iIntros "*". iApply H1.
    Qed.

    Lemma frame_bind : forall (P : iPropGen), ⊢ P -∗ emp ∗ P.
    Proof. iIntros "* $". Qed.

    Lemma frame {X} (H : iPropGen) R Q (e : mon E X) :
      (⊢{{ H }} e {{ v; Q v }}) ->
      ⊢{{ H ∗ R }} e {{ v; Q v ∗ R }}.
    Proof.
      intro P. iIntros "[HA HC]". iApply (wp_consequence with "[HA]").
      iApply P; auto. iIntros; iFrame.
    Qed.

    Lemma intro_true_r {X} (H : iPropGen) Q (e : mon E X) :
      (⊢{{ emp ∗ H }} e {{ v; Q v }}) ->
      ⊢{{ H }} e {{ v; Q v }}.
    Proof.
      intro P. iIntros "HA". iApply (P with "[HA]"). iFrame.
    Qed.

    Lemma effect_spec {X} (e : E X) :
      ⊢({{ fst (E_SPEC _ e) }} syntax_effect e {{ l; snd (E_SPEC _ e) l }}: iPropGen).
    Proof. unfold triple. simpl. destruct (E_SPEC _ e). iIntros "$ * $". Qed.

  End structural_rules.

  Ltac Frame := eapply intro_true_r; eapply frame.
  Ltac iRet := eapply ret_spec; auto.
  Ltac iBind := eapply bind_spec; [idtac | intro; idtac].

End weakestpre.


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

(*i $Id: SeqSeries.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Max.
Require Export Rseries.
Require Export SeqProp.
Require Export Rcomplete.
Require Export PartSum.
Require Export AltSeries.
Require Export Binomial.
Require Export Rsigma.
Require Export Rprod.
Require Export Cauchy_prod.
Require Export Alembert.
Open Local Scope R_scope.

(**********)
Lemma sum_maj1 :
  forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R)
    (N:nat),
    Un_cv (fun n:nat => SP fn n x) l1 ->
    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
    (forall n:nat, Rabs (fn n x) <= An n) ->
    Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N.
Proof.
  intros;
    cut { l:R | Un_cv (fun n => sum_f_R0 (fun l => fn (S N + l)%nat x) n) l }.
  intro X;
    cut { l:R | Un_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l }.
  intro X0; elim X; intros l1N H2.
  elim X0; intros l2N H3.
  cut (l1 - SP fn N x = l1N).
  intro; cut (l2 - sum_f_R0 An N = l2N).
  intro; rewrite H4; rewrite H5.
  apply sum_cv_maj with
    (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x.
  unfold SP in |- *; apply H2.
  apply H3.
  intros; apply H1.
  symmetry  in |- *; eapply UL_sequence.
  apply H3.
  unfold Un_cv in H0; unfold Un_cv in |- *; intros; elim (H0 eps H5);
    intros N0 H6.
  unfold R_dist in H6; exists N0; intros.
  unfold R_dist in |- *;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
      [ idtac | ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
  (sum_f_R0 An (S (N + n))).
  apply H6; unfold ge in |- *; apply le_trans with n.
  apply H7.
  apply le_trans with (N + n)%nat.
  apply le_plus_r.
  apply le_n_Sn.
  cut (0 <= N)%nat.
  cut (N < S (N + n))%nat.
  intros; assert (H10 := sigma_split An H9 H8).
  unfold sigma in H10.
  do 2 rewrite <- minus_n_O in H10.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  cut ((S (N + n) - S N)%nat = n).
  intro; rewrite H11 in H10.
  apply H10.
  apply INR_eq; rewrite minus_INR.
  do 2 rewrite S_INR; rewrite plus_INR; ring.
  apply le_n_S; apply le_plus_l.
  apply sum_eq; intros.
  reflexivity.
  apply sum_eq; intros.
  reflexivity.
  apply le_lt_n_Sm; apply le_plus_l.
  apply le_O_n.
  symmetry  in |- *; eapply UL_sequence.
  apply H2.
  unfold Un_cv in H; unfold Un_cv in |- *; intros.
  elim (H eps H4); intros N0 H5.
  unfold R_dist in H5; exists N0; intros.
  unfold R_dist, SP in |- *;
    replace
    (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
      (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
    (sum_f_R0 (fun k:nat => fn k x) N +
      sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1);
    [ idtac | ring ].
  replace
  (sum_f_R0 (fun k:nat => fn k x) N +
    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
  (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
  unfold SP in H5; apply H5; unfold ge in |- *; apply le_trans with n.
  apply H6.
  apply le_trans with (N + n)%nat.
  apply le_plus_r.
  apply le_n_Sn.
  cut (0 <= N)%nat.
  cut (N < S (N + n))%nat.
  intros; assert (H9 := sigma_split (fun k:nat => fn k x) H8 H7).
  unfold sigma in H9.
  do 2 rewrite <- minus_n_O in H9.
  replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
  replace (sum_f_R0 (fun k:nat => fn k x) N) with
  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
  cut ((S (N + n) - S N)%nat = n).
  intro; rewrite H10 in H9.
  apply H9.
  apply INR_eq; rewrite minus_INR.
  do 2 rewrite S_INR; rewrite plus_INR; ring.
  apply le_n_S; apply le_plus_l.
  apply sum_eq; intros.
  reflexivity.
  apply sum_eq; intros.
  reflexivity.
  apply le_lt_n_Sm.
  apply le_plus_l.
  apply le_O_n.
  exists (l2 - sum_f_R0 An N).
  unfold Un_cv in H0; unfold Un_cv in |- *; intros.
  elim (H0 eps H2); intros N0 H3.
  unfold R_dist in H3; exists N0; intros.
  unfold R_dist in |- *;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
      [ idtac | ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
  (sum_f_R0 An (S (N + n))).
  apply H3; unfold ge in |- *; apply le_trans with n.
  apply H4.
  apply le_trans with (N + n)%nat.
  apply le_plus_r.
  apply le_n_Sn.
  cut (0 <= N)%nat.
  cut (N < S (N + n))%nat.
  intros; assert (H7 := sigma_split An H6 H5).
  unfold sigma in H7.
  do 2 rewrite <- minus_n_O in H7.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  cut ((S (N + n) - S N)%nat = n).
  intro; rewrite H8 in H7.
  apply H7.
  apply INR_eq; rewrite minus_INR.
  do 2 rewrite S_INR; rewrite plus_INR; ring.
  apply le_n_S; apply le_plus_l.
  apply sum_eq; intros.
  reflexivity.
  apply sum_eq; intros.
  reflexivity.
  apply le_lt_n_Sm.
  apply le_plus_l.
  apply le_O_n.
  exists (l1 - SP fn N x).
  unfold Un_cv in H; unfold Un_cv in |- *; intros.
  elim (H eps H2); intros N0 H3.
  unfold R_dist in H3; exists N0; intros.
  unfold R_dist, SP in |- *.
  replace
  (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
    (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
  (sum_f_R0 (fun k:nat => fn k x) N +
    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1);
  [ idtac | ring ].
  replace
  (sum_f_R0 (fun k:nat => fn k x) N +
    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
  (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
  unfold SP in H3; apply H3.
  unfold ge in |- *; apply le_trans with n.
  apply H4.
  apply le_trans with (N + n)%nat.
  apply le_plus_r.
  apply le_n_Sn.
  cut (0 <= N)%nat.
  cut (N < S (N + n))%nat.
  intros; assert (H7 := sigma_split (fun k:nat => fn k x) H6 H5).
  unfold sigma in H7.
  do 2 rewrite <- minus_n_O in H7.
  replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
  replace (sum_f_R0 (fun k:nat => fn k x) N) with
  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
  cut ((S (N + n) - S N)%nat = n).
  intro; rewrite H8 in H7.
  apply H7.
  apply INR_eq; rewrite minus_INR.
  do 2 rewrite S_INR; rewrite plus_INR; ring.
  apply le_n_S; apply le_plus_l.
  apply sum_eq; intros.
  reflexivity.
  apply sum_eq; intros.
  reflexivity.
  apply le_lt_n_Sm.
  apply le_plus_l.
  apply le_O_n.
Qed.

(** Comparaison of convergence for series *)
Lemma Rseries_CV_comp :
  forall An Bn:nat -> R,
    (forall n:nat, 0 <= An n <= Bn n) ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 Bn N) l } ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros An Bn H X; apply cv_cauchy_2.
  assert (H0 := cv_cauchy_1 _ X).
  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
  intros; elim (H0 eps H1); intros.
  exists x; intros.
  cut
    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
      R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
  intro; apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
  assumption.
  apply H2; assumption.
  assert (H5 := lt_eq_lt_dec n m).
  elim H5; intro.
  elim a; intro.
  rewrite (tech2 An n m); [ idtac | assumption ].
  rewrite (tech2 Bn n m); [ idtac | assumption ].
  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Ropp_plus_distr;
    do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
      do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
  apply sum_Rle; intros.
  elim (H (S n + n0)%nat); intros.
  apply H8.
  apply Rle_ge; apply cond_pos_sum; intro.
  elim (H (S n + n0)%nat); intros.
  apply Rle_trans with (An (S n + n0)%nat); assumption.
  apply Rle_ge; apply cond_pos_sum; intro.
  elim (H (S n + n0)%nat); intros; assumption.
  rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
    do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right;
      reflexivity.
  rewrite (tech2 An m n); [ idtac | assumption ].
  rewrite (tech2 Bn m n); [ idtac | assumption ].
  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
    rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
      do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l;
        do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
  apply sum_Rle; intros.
  elim (H (S m + n0)%nat); intros; apply H8.
  apply Rle_ge; apply cond_pos_sum; intro.
  elim (H (S m + n0)%nat); intros.
  apply Rle_trans with (An (S m + n0)%nat); assumption.
  apply Rle_ge.
  apply cond_pos_sum; intro.
  elim (H (S m + n0)%nat); intros; assumption.
Qed.

(** Cesaro's theorem *)
Lemma Cesaro :
  forall (An Bn:nat -> R) (l:R),
    Un_cv Bn l ->
    (forall n:nat, 0 < An n) ->
    cv_infty (fun n:nat => sum_f_R0 An n) ->
    Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n)
    l.
Proof with trivial.
  unfold Un_cv in |- *; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
  intro; apply tech1...
  assert (H4 : forall n:nat, sum_f_R0 An n <> 0)...
  intro; red in |- *; intro; assert (H5 := H3 n); rewrite H4 in H5;
    elim (Rlt_irrefl _ H5)...
  assert (H5 := cv_infty_cv_R0 _ H4 H1); assert (H6 : 0 < eps / 2)...
  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
  apply Rinv_0_lt_compat; prove_sup...
  elim (H _ H6); clear H; intros N1 H;
    set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1));
      assert
        (H7 :
          exists N : nat,
            (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2))...
  case (Req_dec C 0); intro...
  exists 0%nat; intros...
  rewrite H7; unfold Rdiv in |- *; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
  apply Rinv_0_lt_compat; prove_sup...
  assert (H8 : 0 < eps / (2 * Rabs C))...
  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat...
  prove_sup...
  apply Rabs_pos_lt...
  elim (H5 _ H8); intros; exists x; intros; assert (H11 := H9 _ H10);
    unfold R_dist in H11; unfold Rminus in H11; rewrite Ropp_0 in H11;
      rewrite Rplus_0_r in H11...
  apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n))...
  apply RRle_abs...
  unfold Rdiv in |- *; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
  apply Rinv_0_lt_compat; apply Rabs_pos_lt...
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C))...
  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
  ring...
  discrR...
  apply Rabs_no_R0...
  apply Rabs_no_R0...
  elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros;
    unfold R_dist in |- *;
      replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with
      (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n)...
  assert (H9 : (N1 < n)%nat)...
  apply lt_le_trans with (S N)...
  apply le_lt_n_Sm; unfold N in |- *; apply le_max_l...
  rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv in |- *;
    rewrite Rmult_plus_distr_r;
      apply Rle_lt_trans with
        (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) +
          Rabs
          (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
            (n - S N1) / sum_f_R0 An n))...
  apply Rabs_triang...
  rewrite (double_var eps); apply Rplus_lt_compat...
  unfold Rdiv in |- *; rewrite Rabs_mult; fold C in |- *; rewrite Rabs_right...
  apply (H7 n); apply le_trans with (S N)...
  apply le_trans with N; [ unfold N in |- *; apply le_max_r | apply le_n_Sn ]...
  apply Rle_ge; left; apply Rinv_0_lt_compat...

  unfold R_dist in H; unfold Rdiv in |- *; rewrite Rabs_mult;
    rewrite (Rabs_right (/ sum_f_R0 An n))...
  apply Rle_lt_trans with
    (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)))
      (n - S N1) * / sum_f_R0 An n)...
  do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
  left; apply Rinv_0_lt_compat...
  apply
    (Rsum_abs (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
      (n - S N1))...
  apply Rle_lt_trans with
    (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (eps / 2)) (n - S N1) *
      / sum_f_R0 An n)...
  do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
  left; apply Rinv_0_lt_compat...
  apply sum_Rle; intros; rewrite Rabs_mult;
    pattern (An (S N1 + n0)%nat) at 2 in |- *;
      rewrite <- (Rabs_right (An (S N1 + n0)%nat))...
  apply Rmult_le_compat_l...
  apply Rabs_pos...
  left; apply H; unfold ge in |- *; apply le_trans with (S N1);
    [ apply le_n_Sn | apply le_plus_l ]...
  apply Rle_ge; left...
  rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2));
    unfold Rdiv in |- *; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
  pattern (/ 2) at 2 in |- *; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
  apply Rinv_0_lt_compat; prove_sup...
  rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n)...
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
  rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n)...
  rewrite Rplus_comm;
    pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1 in |- *;
      rewrite <- Rplus_0_r; apply Rplus_lt_compat_l...
  apply Rle_ge; left; apply Rinv_0_lt_compat...
  replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
  (sum_f_R0 (fun k:nat => An k * Bn k) n +
    sum_f_R0 (fun k:nat => An k * - l) n)...
  rewrite <- (scal_sum An n (- l)); field...
  rewrite <- plus_sum; apply sum_eq; intros; ring...
Qed.

Lemma Cesaro_1 :
  forall (An:nat -> R) (l:R),
    Un_cv An l -> Un_cv (fun n:nat => sum_f_R0 An (pred n) / INR n) l.
Proof with trivial.
  intros Bn l H; set (An := fun _:nat => 1)...
  assert (H0 : forall n:nat, 0 < An n)...
  intro; unfold An in |- *; apply Rlt_0_1...
  assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
  intro; apply tech1...
  assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
  unfold cv_infty in |- *; intro; case (Rle_dec M 0); intro...
  exists 0%nat; intros; apply Rle_lt_trans with 0...
  assert (H2 : 0 < M)...
  auto with real...
  clear n; set (m := up M); elim (archimed M); intros;
    assert (H5 : (0 <= m)%Z)...
  apply le_IZR; unfold m in |- *; simpl in |- *; left; apply Rlt_trans with M...
  elim (IZN _ H5); intros; exists x; intros; unfold An in |- *; rewrite sum_cte;
    rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M))...
  apply Rle_lt_trans with (INR x)...
  rewrite INR_IZR_INZ; fold m in |- *; rewrite <- H6; right...
  apply lt_INR; apply le_lt_n_Sm...
  assert (H3 := Cesaro _ _ _ H H0 H2)...
  unfold Un_cv in |- *; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
    exists (S x); intros; unfold R_dist in |- *; unfold R_dist in H5;
      apply Rle_lt_trans with
        (Rabs
          (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l))...
  right;
    replace (sum_f_R0 Bn (pred n) / INR n - l) with
    (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)...
  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
    apply Rplus_eq_compat_l...
  unfold An in |- *;
    replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with
    (sum_f_R0 Bn (pred n))...
  rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n...
  apply S_pred with 0%nat; apply lt_le_trans with (S x)...
  apply lt_O_Sn...
  apply sum_eq; intros; ring...
  apply H5; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n...
  apply S_pred with 0%nat; apply lt_le_trans with (S x)...
  apply lt_O_Sn...
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^212 - 29
Base: 42.4
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 42 + 2/5;
    bitwidth := 64;
    s := 2^212;
    c := [(1, 29)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^213 - 3
Base: 26.625
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 26 + 5/8;
    bitwidth := 32;
    s := 2^213;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(******************************************************************************)
(** * Definition of correspondence between IMM labels and Promise's transition labels*)
(******************************************************************************)
Require Import List.
From imm Require Import Events.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import Event.

Set Implicit Arguments.

Definition rmod (mod : mode) : Ordering.t :=
  match mod with
  | Opln => Ordering.plain
  | Orel
  | Orlx => Ordering.relaxed
  | Oacq
  | Oacqrel
  | Osc => Ordering.acqrel
  end.

Definition wmod (mod : mode) : Ordering.t :=
  match mod with
  | Opln => Ordering.plain
  | Oacq
  | Orlx => Ordering.relaxed
  | Orel
  | Oacqrel
  | Osc => Ordering.acqrel
  end.

Definition fmod (mod : mode) (ordr ordw : Ordering.t) :=
  match mod with
  | Opln | Orlx => ordr = Ordering.relaxed /\ ordw = Ordering.relaxed
  | Oacq => ordr = Ordering.acqrel /\ ordw = Ordering.relaxed
  | Orel => ordr = Ordering.relaxed /\ ordw = Ordering.acqrel
  | Oacqrel => ordr = Ordering.acqrel /\ ordw = Ordering.acqrel
  | Osc => ordr = Ordering.seqcst /\ ordw = Ordering.seqcst
  end.

Definition lab_imm_promise (lbls : list label) (ev : ProgramEvent.t) :=
  match lbls, ev with
  | nil, ProgramEvent.silent => True
  | Aload _ o l v :: nil, ProgramEvent.read l' v' o' =>
    ⟪ SAME_LOC : l = l' ⟫ /\
    ⟪ SAME_VAL : v = v' ⟫ /\
    ⟪ SAME_MOD : o' = rmod o ⟫
  | Astore x o l v :: nil, ProgramEvent.write l' v' o' =>
    ⟪ SAME_LOC : l = l' ⟫ /\
    ⟪ SAME_VAL : v = v' ⟫ /\
    ⟪ SAME_MOD : o' = wmod o ⟫

  | Astore x o l v :: Aload _ o' l' v' :: nil,
    ProgramEvent.update l'' valr valw ordr ordw =>
    ⟪ SAME_LOC : l = l' /\ l' = l'' ⟫ /\
    ⟪ SAME_VAL : v = valw /\ v' = valr ⟫ /\
    ⟪ SAME_MOD : ordw = wmod o /\
                  ordr = rmod o' ⟫

  | Afence o :: nil, ProgramEvent.fence ordr ordw =>
    ⟪ SAME_MOD : fmod o ordr ordw ⟫
  | _, _ => False
  end.

Definition same_g_events (lab : actid -> label) (l : list actid) := lab_imm_promise (map lab l).


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 conj5synthconj1 : forall  (lv0 : natural), (@eq natural (plus lv0 Zero) (plus lv0 Zero)).
Admitted.
QuickChick conj5synthconj1.


Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export featuremodelsemantics_int.
Require Export featuremodelsemantics_def.
Require Export formulatheory_int.
Require Export formulatheory_def.
Require Export formulatheory_inst.
Require Export formulatheory_proofs.
Require Export assettheory_int.
Require Export assettheory_def.
Require Export maps_def.
Require Export maps_int.
Require Export maps_inst.
Import FormulaTheory.
Import FeatureModelSemantics.
Import AssetTheory.
Import Maps.

 Program Instance AssetTheory_Int : AssetTheory AssetName Asset map_ :=
{
  wfProduct:= wfProduct_ind;
  assetRef:= assetRef_func;

}. Next Obligation.
{ (*ANdec_eq*)
  apply ANdec_eq_axiom.

} Qed.
  Next Obligation.
 { (*Asset_dec*)
  apply Asset_dec_axiom.
} Qed.
  Next Obligation.
{ (*assetRefinement*)
 assert (H3: assetRef_func x x /\ assetRef_func x y).
 split.
 + apply H.
 + apply H1.
 + generalize H3, H0.
   apply assetRefinement_axiom.
} Qed.
  Next Obligation.
{ (*asRefCompositional_axiom*)
    assert (H3: assetRef_func S1 S2 /\ wfProduct_ind (union_t_func S1 aSet)).
  split.
  + apply H.
  + apply H0.
  + apply asRefCompositional_axiom. apply H3.
} Qed.


(* Narjes Jomaa and David Nowak,
   Pip code refactored by Mohamed Sami Cherif *)
Require Import Lib Pip_state Pip_stateLib List.
Require Import  Omega List Coq.Logic.ProofIrrelevance.
Import List.ListNotations.

(** THE VERTICAL SHARING PROPERTY:
    All child used pages (configuration tables and mapped pages) are mapped into
    the parent partition  *)
Definition verticalSharing s : Prop :=

forall parent child : page ,

  In parent (getPartitions multiplexer s) ->

  In child (getChildren parent s) ->

  incl (getUsedPages child s) (getMappedPages parent s).

(** THE ISOLATION PROPERTY BETWEEN PARTITIONS,
    If we take two different children of a given parent,
    so all their used pages are different  *)
Definition partitionsIsolation  s : Prop :=

forall parent child1 child2 : page ,

  In parent (getPartitions multiplexer s)->

  In child1 (getChildren parent s) ->

  In child2 (getChildren parent s) ->

  child1 <> child2 ->

  disjoint (getUsedPages child1 s)(getUsedPages child2 s).

(** THE ISOLATION PROPERTY BETWEEN THE KERNEL DATA AND PARTITIONS
    kernel data is the configuration pages of partitions.
    All configuration tables of a given partition are inaccessible by all
    partitions *)
Definition kernelDataIsolation s : Prop :=

forall partition1 partition2,

  In partition1 (getPartitions multiplexer s) ->

  In partition2 (getPartitions multiplexer s) ->

  disjoint (getAccessibleMappedPages partition1 s) (getConfigPages partition2 s).

(** ** The [dataStructurePdSh1Sh2asRoot] property defines the type of different values
stored into the page directory structure, the first shadow structure and
the second shadow structure.
Configuation tables of the last level must contain :
 - Physical entries (the type [PEntry] is already definded in [Model.ADT]) for the page directory
  data structure
 - Virtual entries (the type [VEntry] is already definded in [Model.ADT] ) for the first shadow
   data structure
 - Virtual addresses (the type [vaddr] is already definded in [Model.ADT]) for the second shadow
  data structure
The other tables contain Physical entries
    [idxroot] should be PDidx, sh1idx or sh2idx.
 (1)
*)
Definition dataStructurePdSh1Sh2asRoot (idxroot : index) (s : state) :=
forall (partition : page),
In partition (getPartitions multiplexer s) ->
forall entry, nextEntryIsPP partition idxroot entry s ->
forall va : vaddr,
True -> forall level stop , Some level = getNbLevel ->
forall indirection idx, getIndirection entry va level stop s = Some indirection ->
( indirection = defaultPage \/
(( ( stop < level /\ isPE indirection idx s )\/
   ( stop >= level /\ ( (isVE indirection idx s /\ idxroot = sh1idx) \/
                       (isVA indirection idx s /\ idxroot = sh2idx) \/
                       (isPE indirection idx s /\ idxroot = PDidx) ) ))
                       /\
  indirection <> defaultPage)) .

Definition wellFormedFstShadow (s : state) :=
forall partition,
In partition (getPartitions multiplexer s) ->
forall va pg pd sh1,
getPd partition (memory s) = Some pd ->
getFstShadow partition (memory s) = Some sh1 ->
getMappedPage pd s va= Some pg ->
exists vainparent, getVirtualAddressSh1 sh1 s va = Some vainparent.

Definition wellFormedSndShadow (s : state) :=
forall partition,
In partition (getPartitions multiplexer s) ->
partition <> multiplexer ->
forall va pg pd sh2,
getPd partition (memory s) = Some pd ->
getSndShadow partition (memory s) = Some sh2 ->
getMappedPage pd s va= Some pg ->
exists vainparent, getVirtualAddressSh2 sh2 s va = Some vainparent /\
beqVAddr defaultVAddr vainparent = false .

Definition wellFormedShadows (idxroot : index) (s : state) :=
forall (partition : page),
In partition (getPartitions multiplexer s) ->
forall pdroot ,
getPd partition (memory s) = Some pdroot ->
forall structroot, nextEntryIsPP partition idxroot structroot s ->
forall nbL stop , Some nbL = getNbLevel ->
forall indirection1  va,
getIndirection pdroot va nbL stop s = Some indirection1 ->
(defaultPage =? indirection1) = false ->
(exists indirection2,
getIndirection structroot va nbL stop s = Some indirection2 /\
(defaultPage =? indirection2) = false).

(* Definition fstShadowWellFormed (s : state) :=
forall (partition : page),
In partition (getPartitions multiplexer s) ->
forall pdroot sh1Root,
StateLib.getPd partition (memory s) = Some pdRoot ->
StateLib.getFstShadow partition (memory s) = Some sh1Root ->
forall level stop , Some level = getNbLevel ->
forall indirection1 indirection2 va,
getIndirection pdRoot va level stop s = Some defaultPage ->
getIndirection sh1Root va level stop s = Some defaultPage.  *)

(** ** The [currentPartitionInPartitionsList] property specifies that the
    current partition must be into the list of partitions retrieved from the
    first created partition (multiplexer)
    (2) *)
Definition currentPartitionInPartitionsList (s : state) :=
 In (currentPartition s) (getPartitions multiplexer s).

(** ** The [currentPartitionIsNotDefaultPage t] property specifies that the
    current partition is not a default physical page
    (2) *)
Definition currentPartitionIsNotDefaultPage (s : state) :=
 (currentPartition s) <> defaultPage.

(** ** The [parentInPartitionList] property specifies that the parent of a given
partition should be into the list of partitions retrieved from the
    first created partition (multiplexer)
    (3) *)
Definition parentInPartitionList (s : state) :=
forall partition, In partition (getPartitions multiplexer s) ->
forall parent, nextEntryIsPP partition PPRidx parent s ->
In parent (getPartitions multiplexer s).

(** ** The [partitionDescriptorEntry] defines some properties of the partition descriptor.
    - A partition descriptor is a table containing virtual addresses and physical pages.
    - Indecie PDidx, sh1idx, sh2idx, PPRidx and PRidx should be less than ("tableSize" - 1) and
      contain virtual addresses.
    - The successors of these indices contain physical pages which should not be
      equal to "defaultPage".
    (4) *)
Definition partitionDescriptorEntry s :=
forall (partition : page),
In partition (getPartitions multiplexer s) ->
forall (idxroot : index), (idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx \/
idxroot = sh3idx \/
idxroot = PPRidx  \/ idxroot = PRidx ) ->
idxroot < tableSize - 1  /\
isVA partition idxroot  s /\
exists entry, nextEntryIsPP partition idxroot entry s  /\
entry <> defaultPage.

(** ** The [multiplexerWithoutParent] specifies that the multiplexer is the root of
the partition tree *)
Definition multiplexerWithoutParent s :=
getParent multiplexer (memory s) = None.

(** ** The [noDupMappedPagesList] requires that mapped pages of a single partition
    are different
    (5) *)
Definition noDupMappedPagesList s :=
forall (partition : page),
In partition (getPartitions multiplexer s) ->
 NoDup (getMappedPages partition s).

(** ** The [noDupConfigPagesList] requires that configuation tables of
    a single partition are different
    (6) *)
Definition noDupConfigPagesList s :=
forall idxroot, (idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx) ->
forall (partition : page),
In partition (getPartitions multiplexer s) ->
forall root, nextEntryIsPP partition idxroot root s->
 NoDup (getIndirections root s).

(** ** The [accessibleVAIsNotPartitionDescriptor] requires that accessible virtual
    addresses are not marked as partition descriptor into the first shadow configuation
    structure
    (7) *)
Definition accessibleVAIsNotPartitionDescriptor s :=
forall partition va pd sh1 page,
  In partition (getPartitions multiplexer s) ->
  getPd partition (memory s) = Some pd ->
  getFstShadow partition (memory s) = Some sh1 ->
  getAccessibleMappedPage pd s va = Some page ->
  getPDFlag sh1 va s = false.

(** ** The [accessibleChildPageIsAccessibleIntoParent] requires that all accessible physical
      pages into a given partition should be accessible into its parent
    (8) *)
Definition  accessibleChildPageIsAccessibleIntoParent s :=
forall partition va pd  accessiblePage,
  In partition (getPartitions multiplexer s) ->
  getPd partition (memory s) = Some pd ->
  getAccessibleMappedPage pd s va = Some accessiblePage ->
  isAccessibleMappedPageInParent partition va accessiblePage s = true.

(** ** The [noCycleInPartitionTree] requires that a partition and
        its ancestors are different
    (9) **)
Definition noCycleInPartitionTree s :=
forall ancestor partition,
In partition (getPartitions multiplexer s) ->
In ancestor (getAncestors partition s) ->
ancestor <> partition.

(** ** The [configTablesAreDifferent] requires that configuation tables of different
        partitions are disjoint
      (10) **)
Definition configTablesAreDifferent s :=
forall partition1 partition2,
In partition1 (getPartitions multiplexer s) ->
In partition2 (getPartitions multiplexer s) ->
partition1 <> partition2 ->
disjoint (getConfigPages partition1 s) (getConfigPages partition2 s).

(** ** The [isChild] specifies that a given partition should be a child of the
        physical page stored as parent into the associated partition descriptor
    (11) **)
Definition isChild  s :=
forall partition parent : page,
In partition (getPartitions multiplexer s) ->
getParent partition (memory s) = Some parent ->
In partition (getChildren parent s).

(** ** The [isParent] specifies that if we take any child into the children list of any
partition into the partition list so this partition should be the parent of this child
 (..) **)
Definition isParent  s :=
forall partition parent : page,
In parent (getPartitions multiplexer s) ->
In partition (getChildren parent s) ->
getParent partition (memory s) = Some parent.

(** ** The [isPresentNotDefaultIff] specifies that if the present flag of a physical
    entry is equal to false so the associated physical page must be equal to the default
    value
    (12) **)
Definition isPresentNotDefaultIff s:=
forall table idx ,
 readPresent table idx (memory s) = Some false <->
 readPhyEntry table idx (memory s) = Some defaultPage .

(** ** The [physicalPageNotDerived] specifies that if a given physical
    page is marked as not derived in a parent so it is not mapped in any child
    (13)
**)
Definition physicalPageNotDerived s :=
forall parent va pdParent pageParent,
In parent (getPartitions multiplexer s) ->
getPd parent (memory s) = Some pdParent ->
~ isDerived parent va s ->
getMappedPage pdParent s va = Some pageParent ->
forall child pdChild vaInChild pageChild ,
In child (getChildren parent s) ->
getPd child (memory s) = Some pdChild ->
getMappedPage pdChild s vaInChild = Some  pageChild ->
pageParent <> pageChild.

Definition noDupPartitionTree s :=
NoDup (getPartitions multiplexer s) .

(** ** Conjunction of all consistency properties *)
Definition consistency s :=
 partitionDescriptorEntry s /\
 dataStructurePdSh1Sh2asRoot PDidx s /\
 dataStructurePdSh1Sh2asRoot sh1idx s /\
 dataStructurePdSh1Sh2asRoot sh2idx s /\
 currentPartitionInPartitionsList s /\
 noDupMappedPagesList s /\
 noDupConfigPagesList s  /\
 parentInPartitionList s /\
 accessibleVAIsNotPartitionDescriptor s /\
 accessibleChildPageIsAccessibleIntoParent s /\
 noCycleInPartitionTree s /\
 configTablesAreDifferent s /\
 isChild s /\
 isPresentNotDefaultIff s /\
 physicalPageNotDerived s /\
 multiplexerWithoutParent s /\
 isParent s /\
 noDupPartitionTree s /\
 wellFormedFstShadow s /\
 wellFormedSndShadow s /\
 wellFormedShadows sh1idx s /\
 wellFormedShadows sh2idx s /\
 currentPartitionIsNotDefaultPage s .

Definition propagatedProperties  accessibleChild accessibleSh1 accessibleSh2 accessibleList
pdChild currentPart currentPD level ptRefChild descChild idxRefChild presentRefChild
 ptPDChild idxPDChild presentPDChild  ptSh1Child shadow1 idxSh1
presentSh1  ptSh2Child shadow2 idxSh2 presentSh2  ptConfigPagesList
idxConfigPagesList presentConfigPagesList
currentShadow1 ptRefChildFromSh1 derivedRefChild ptPDChildSh1 derivedPDChild
ptSh1ChildFromSh1 derivedSh1Child childSh2
derivedSh2Child childListSh1 derivedRefChildListSh1 list phyPDChild phySh1Child
phySh2Child phyConfigPagesList phyDescChild s : Prop :=
partitionsIsolation s /\
kernelDataIsolation s /\
verticalSharing s /\
consistency s /\
Some level = getNbLevel /\
false = checkVAddrsEqualityWOOffset nbLevel descChild pdChild level /\
false = checkVAddrsEqualityWOOffset nbLevel descChild shadow1 level /\
false = checkVAddrsEqualityWOOffset nbLevel descChild shadow2 level /\
false = checkVAddrsEqualityWOOffset nbLevel descChild list level /\
false = checkVAddrsEqualityWOOffset nbLevel pdChild shadow1 level /\
false = checkVAddrsEqualityWOOffset nbLevel pdChild shadow2 level /\
false = checkVAddrsEqualityWOOffset nbLevel pdChild list level /\
false = checkVAddrsEqualityWOOffset nbLevel shadow1 shadow2 level /\
false = checkVAddrsEqualityWOOffset nbLevel shadow1 list level /\
false = checkVAddrsEqualityWOOffset nbLevel shadow2 list level /\
(Kidx =? nth (length descChild - (nbLevel - 1 + 2)) descChild defaultIndex) = false /\
(Kidx =? nth (length pdChild - (nbLevel - 1 + 2)) pdChild defaultIndex) = false /\
(Kidx =? nth (length shadow1 - (nbLevel - 1 + 2)) shadow1 defaultIndex) = false /\
(Kidx =? nth (length shadow2 - (nbLevel - 1 + 2)) shadow2 defaultIndex) = false /\
(Kidx =? nth (length list - (nbLevel - 1 + 2)) list defaultIndex) = false /\
beqVAddr defaultVAddr pdChild = false /\
beqVAddr defaultVAddr shadow1 = false /\
beqVAddr defaultVAddr shadow2 = false /\
beqVAddr defaultVAddr list = false /\
currentPart = currentPartition s /\
nextEntryIsPP currentPart PDidx currentPD s /\
(forall idx : index,
getIndexOfAddr descChild fstLevel = idx ->
isPE ptRefChild idx s /\ getTableAddrRoot ptRefChild PDidx currentPart descChild s) /\
(defaultPage =? ptRefChild) = false /\
getIndexOfAddr descChild fstLevel = idxRefChild /\
entryPresentFlag ptRefChild idxRefChild presentRefChild s /\
entryUserFlag ptRefChild idxRefChild accessibleChild s /\
(forall idx : index,
getIndexOfAddr pdChild fstLevel = idx ->
isPE ptPDChild idx s /\ getTableAddrRoot ptPDChild PDidx currentPart pdChild s) /\
(defaultPage =? ptPDChild) = false /\
getIndexOfAddr pdChild fstLevel = idxPDChild /\
entryPresentFlag ptPDChild idxPDChild presentPDChild s /\
entryUserFlag ptPDChild idxPDChild false s /\
(forall idx : index,
getIndexOfAddr shadow1 fstLevel = idx ->
isPE ptSh1Child idx s /\ getTableAddrRoot ptSh1Child PDidx currentPart shadow1 s) /\
(defaultPage =? ptSh1Child) = false /\
getIndexOfAddr shadow1 fstLevel = idxSh1 /\
entryPresentFlag ptSh1Child idxSh1 presentSh1 s /\
entryUserFlag ptSh1Child idxSh1 accessibleSh1 s /\
(forall idx : index,
getIndexOfAddr shadow2 fstLevel = idx ->
isPE ptSh2Child idx s /\ getTableAddrRoot ptSh2Child PDidx currentPart shadow2 s) /\
(defaultPage =? ptSh2Child) = false /\
getIndexOfAddr shadow2 fstLevel = idxSh2 /\
entryPresentFlag ptSh2Child idxSh2 presentSh2 s /\
entryUserFlag ptSh2Child idxSh2 accessibleSh2 s /\
(forall idx : index,
getIndexOfAddr list fstLevel = idx ->
isPE ptConfigPagesList idx s /\ getTableAddrRoot ptConfigPagesList PDidx currentPart list s) /\
(defaultPage =? ptConfigPagesList) = false /\
getIndexOfAddr list fstLevel = idxConfigPagesList /\
entryPresentFlag ptConfigPagesList idxConfigPagesList presentConfigPagesList s /\
entryUserFlag ptConfigPagesList idxConfigPagesList accessibleList s /\
nextEntryIsPP currentPart sh1idx currentShadow1 s /\
(forall idx : index,
getIndexOfAddr descChild fstLevel = idx ->
isVE ptRefChildFromSh1 idx s /\
getTableAddrRoot ptRefChildFromSh1 sh1idx currentPart descChild s) /\
(defaultPage =? ptRefChildFromSh1) = false /\
(exists va : vaddr,
isEntryVA ptRefChildFromSh1 idxRefChild va s /\ beqVAddr defaultVAddr va = derivedRefChild) /\
(forall idx : index,
getIndexOfAddr pdChild fstLevel = idx ->
isVE ptPDChildSh1 idx s /\ getTableAddrRoot ptPDChildSh1 sh1idx currentPart pdChild s) /\
(defaultPage =? ptPDChildSh1) = false /\
(exists va : vaddr,
isEntryVA ptPDChildSh1 idxPDChild va s /\ beqVAddr defaultVAddr va = derivedPDChild) /\
(forall idx : index,
getIndexOfAddr shadow1 fstLevel = idx ->
isVE ptSh1ChildFromSh1 idx s /\
getTableAddrRoot ptSh1ChildFromSh1 sh1idx currentPart shadow1 s) /\
(defaultPage =? ptSh1ChildFromSh1) = false /\
(exists va : vaddr,
isEntryVA ptSh1ChildFromSh1 idxSh1 va s /\ beqVAddr defaultVAddr va = derivedSh1Child) /\
(forall idx : index,
getIndexOfAddr shadow2 fstLevel = idx ->
isVE childSh2 idx s /\ getTableAddrRoot childSh2 sh1idx currentPart shadow2 s) /\
(defaultPage =? childSh2) = false /\
(exists va : vaddr,
isEntryVA childSh2 idxSh2 va s /\ beqVAddr defaultVAddr va = derivedSh2Child) /\
(forall idx : index,
getIndexOfAddr list fstLevel = idx ->
isVE childListSh1 idx s /\ getTableAddrRoot childListSh1 sh1idx currentPart list s) /\
(defaultPage =? childListSh1) = false /\
(exists va : vaddr,
isEntryVA childListSh1 idxConfigPagesList va s /\
beqVAddr defaultVAddr va = derivedRefChildListSh1) /\
isEntryPage ptPDChild idxPDChild phyPDChild s /\
(defaultPage =? phyPDChild) = false /\
(forall partition : page,
In partition (getPartitions multiplexer s) ->
~ (partition = phyPDChild \/ In phyPDChild (getConfigPagesAux partition s))) /\
isEntryPage ptSh1Child idxSh1 phySh1Child s /\
(defaultPage =? phySh1Child) = false /\
(forall partition : page,
In partition (getPartitions multiplexer s) ->
~ (partition = phySh1Child \/ In phySh1Child (getConfigPagesAux partition s))) /\
isEntryPage ptSh2Child idxSh2 phySh2Child s /\
(defaultPage =? phySh2Child) = false /\
(forall partition : page,
In partition (getPartitions multiplexer s) ->
~ (partition = phySh2Child \/ In phySh2Child (getConfigPagesAux partition s))) /\
isEntryPage ptConfigPagesList idxConfigPagesList phyConfigPagesList s /\
(defaultPage =? phyConfigPagesList) = false /\
(forall partition : page,
In partition (getPartitions multiplexer s) ->
~ (partition = phyConfigPagesList \/ In phyConfigPagesList (getConfigPagesAux partition s))) /\
isEntryPage ptRefChild idxRefChild phyDescChild s /\ (defaultPage =? phyDescChild) = false /\
(forall partition : page,
In partition (getPartitions multiplexer s) -> ~ In phyDescChild (getConfigPages partition s)) /\
isPartitionFalse ptSh1ChildFromSh1 idxSh1 s /\
isPartitionFalse childSh2 idxSh2 s /\
isPartitionFalse childListSh1 idxConfigPagesList s /\
isPartitionFalse ptRefChildFromSh1 idxRefChild s /\
isPartitionFalse ptPDChildSh1 idxPDChild s .

Definition propagatedPropertiesAddVaddr s (vaInCurrentPartition vaChild: vaddr)  currentPart
currentShadow descChild idxDescChild ptDescChild ptVaInCurPart idxvaInCurPart
vainve isnotderiv currentPD ptVaInCurPartpd accessiblesrc presentmap ptDescChildpd idxDescChild1
presentDescPhy phyDescChild pdChildphy ptVaChildpd idxvaChild presentvaChild phyVaChild
sh2Childphy ptVaChildsh2 level
:=
(partitionsIsolation s /\
kernelDataIsolation s /\
verticalSharing s /\
consistency s /\
(Kidx =? nth (length vaInCurrentPartition - (nbLevel - 1 + 2)) vaInCurrentPartition defaultIndex) = false /\
(Kidx =? nth (length vaChild - (nbLevel - 1 + 2)) vaChild defaultIndex) = false /\
currentPart = currentPartition s /\
Some level = getNbLevel /\
nextEntryIsPP currentPart sh1idx currentShadow s /\
getIndexOfAddr descChild fstLevel = idxDescChild /\
isVE ptDescChild (getIndexOfAddr descChild fstLevel) s /\
getTableAddrRoot ptDescChild sh1idx currentPart descChild s /\ (defaultPage =? ptDescChild) = false /\
entryPDFlag ptDescChild idxDescChild true s /\
isVE ptVaInCurPart (getIndexOfAddr vaInCurrentPartition fstLevel) s /\
getTableAddrRoot ptVaInCurPart sh1idx currentPart vaInCurrentPartition s /\
(defaultPage =? ptVaInCurPart) = false /\
getIndexOfAddr vaInCurrentPartition fstLevel = idxvaInCurPart /\
isEntryVA ptVaInCurPart idxvaInCurPart vainve s /\
beqVAddr defaultVAddr vainve = isnotderiv /\
nextEntryIsPP currentPart PDidx currentPD s /\
isPE ptVaInCurPartpd (getIndexOfAddr vaInCurrentPartition fstLevel) s /\
getTableAddrRoot ptVaInCurPartpd PDidx currentPart vaInCurrentPartition s /\
(defaultPage =? ptVaInCurPartpd) = false /\
entryUserFlag ptVaInCurPartpd idxvaInCurPart accessiblesrc s /\
entryPresentFlag ptVaInCurPartpd idxvaInCurPart presentmap s /\
isPE ptDescChildpd (getIndexOfAddr descChild fstLevel) s /\
getTableAddrRoot ptDescChildpd PDidx currentPart descChild s /\
(defaultPage =? ptDescChildpd) = false /\
getIndexOfAddr descChild fstLevel = idxDescChild1 /\
entryPresentFlag ptDescChildpd idxDescChild1 presentDescPhy s /\
isEntryPage ptDescChildpd idxDescChild1 phyDescChild s /\
In phyDescChild (getChildren (currentPartition s) s) /\
nextEntryIsPP phyDescChild PDidx pdChildphy s /\
isPE ptVaChildpd (getIndexOfAddr vaChild fstLevel) s /\
getTableAddrRoot ptVaChildpd PDidx phyDescChild vaChild s /\
(defaultPage =? ptVaChildpd) = false /\
getIndexOfAddr vaChild fstLevel = idxvaChild /\
entryPresentFlag ptVaChildpd idxvaChild presentvaChild s /\
isEntryPage ptVaInCurPartpd idxvaInCurPart phyVaChild s /\
nextEntryIsPP phyDescChild sh2idx sh2Childphy s) /\
isVA ptVaChildsh2 (getIndexOfAddr vaChild fstLevel) s /\
getTableAddrRoot ptVaChildsh2 sh2idx phyDescChild vaChild s /\
(defaultPage =? ptVaChildsh2) = false.


Require Import Classical.

Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_GHC.
Require Import K_logics.
Require Import K_extens_interactions.
Require Import K_wKH_meta_interactions.
Require Import K_sKH_meta_interactions.
Require Import K_Kripke_sem.
Require Import wKH_Lindenbaum_lem.

Definition is_mcs (Γ: Ensemble MPropF) : Prop :=
  ((forall B, (Γ B) \/ (Γ (B --> Bot))) /\ (wKH_prv (Γ, Bot) -> False)).

Lemma clos_deriv : forall Γ, is_mcs Γ ->
                                (forall A, wKH_prv (Γ, A) -> (In _ Γ A)).
Proof.
intros. destruct H. pose (H A). destruct o ; auto.
exfalso. apply H1.
apply MP with  (ps:=[(Γ, A --> Bot);(Γ, A)]).
2: apply MPRule_I. intros. inversion H3 ; subst.
apply Id. apply IdRule_I ; auto. inversion H4. 2: inversion H5.
subst. auto.
Qed.

Definition Canon_worlds : Type := {x : Ensemble MPropF | is_mcs x}.

Definition Canon_rel (P0 P1 : Canon_worlds) : Prop :=
  forall A, (In _ (proj1_sig P0) (Box A)) -> (In _ (proj1_sig P1) A).

Definition Canon_val (P : Canon_worlds) (q : V) : Prop :=
  In _ (proj1_sig P) (# q).

Instance CM : kmodel :=
      {|
        nodes := Canon_worlds ;
        reachable := Canon_rel ;
        val := Canon_val
      |}.

Lemma existence_lemma : forall A (cw : Canon_worlds),
  (forall cw0, Canon_rel cw cw0 -> In _ (proj1_sig cw0) A) -> (In _ (proj1_sig cw) (Box A)).
Proof.
intros. destruct cw.
pose (@exist (Ensemble MPropF) is_mcs x i).
inversion i. simpl. pose (H0 (Box A)) ; destruct o ; auto.
assert (J0: wKH_prv (fun y : MPropF => (exists B : MPropF, In MPropF x (Box B) /\ y = B) \/ y = (A --> Bot), Bot) -> False).
{ intro. assert ((fun y : MPropF => (exists B : MPropF, In MPropF x (Box B) /\ y = B) \/ y = A --> Bot) =
  (Union _ (fun y : MPropF => (exists B : MPropF, In MPropF x (Box B) /\ y = B)) (Singleton _ (A --> Bot)))).
  apply Extensionality_Ensembles. split ; intro ; intros. inversion H4. destruct H5.
  destruct H5. subst. apply Union_introl ; auto. unfold In. exists x1 ; auto. subst.
  apply Union_intror. apply In_singleton. inversion H4. subst. inversion H5.
  destruct H6. subst. unfold In. left. exists x1 ; auto. subst. inversion H5.
  subst. unfold In ; auto.
  rewrite H4 in H3. clear H4.
  assert (J0: Union MPropF
     (fun y : MPropF => exists B : MPropF, In MPropF x (Box B) /\ y = B)
     (Singleton MPropF (A --> Bot)) =
   Union MPropF
     (fun y : MPropF => exists B : MPropF, In MPropF x (Box B) /\ y = B)
     (Singleton MPropF (A --> Bot)) ). auto.
  assert (J1: Bot = Bot). auto.
  pose (wKH_Deduction_Theorem _ H3 (A --> Bot) Bot
  (fun y : MPropF => exists B : MPropF, In MPropF x (Box B) /\ y = B) J0 J1).
  apply NegNeg_elim in w. clear J0. clear J1.
  apply K_rule in w. apply H1.
  apply MP with (ps:=[(x, Box A --> Bot);(x, Box A)]). 2: apply MPRule_I.
  intros. inversion H4. subst. apply Id. apply IdRule_I. auto. inversion H5.
  2: inversion H6. subst.
  pose (wKH_monot _ w). apply w0 ; simpl. clear w0.
  intro. intros. destruct H6. inversion H6. subst.
  inversion H7. destruct H8. subst. auto. }
pose (Lindenbaum_lemma (fun y => (exists B, (In _ x (Box B)) /\ y = B) \/ y = (A --> Bot)) Bot J0).
destruct e. destruct H3. destruct H4.
assert (J1: is_mcs x0). unfold is_mcs. auto.
pose (@exist (Ensemble MPropF) is_mcs x0 J1).
assert (J2: Canon_rel (exist (fun x : Ensemble MPropF => is_mcs x) x i) s0).
intro. intros. simpl. apply H3. simpl in H6. unfold In. left. exists A0 ; auto.
pose (H s0 J2). simpl in i0.
exfalso. apply H5.
apply MP with (ps:=[(x0, A --> Bot);(x0, A)]). 2 : apply MPRule_I.
intros. inversion H6 ; subst. apply Id. apply IdRule_I. apply H3.
unfold In. auto. inversion H7. subst. apply Id. apply IdRule_I. auto.
inversion H8.
Qed.

Lemma truth_lemma : forall A (cw : Canon_worlds),
  (wforces CM cw A) <-> (In _ (proj1_sig cw) A).
Proof.
induction A ; intro ; split ; intros ; destruct cw ; simpl ; try simpl in H ; auto.
(* Bot V *)
- inversion H.
- unfold is_mcs in i. destruct i. apply H1. apply Id. apply IdRule_I. auto.
(* Imp A1 A2 *)
- assert (J0: is_mcs x). auto.
  pose (@exist (Ensemble MPropF) is_mcs x i).
  unfold is_mcs in J0. destruct J0.
  pose (H0 A1). destruct o. pose (IHA1 s). simpl in i0. apply i0 in H2.
  clear i0. apply H in H2. apply IHA2 in H2. simpl in H2.
  apply clos_deriv ; auto.
  apply MP with (ps:=[(x, A2 --> A1 --> A2);(x, A2)]). 2: apply MPRule_I.
  intros. inversion H3 ; subst. apply Ax. apply AxRule_I. apply MA2_I.
  exists A2 ; exists A1 ; auto. inversion H4 ; subst. 2: inversion H5.
  apply Id. apply IdRule_I. auto.
  apply clos_deriv ; auto.
  apply wKH_Deduction_Theorem with (s:=(Union _ x (Singleton _ A1), A2)) ; auto.
  apply MP with (ps:=[(Union MPropF x (Singleton MPropF A1), Bot --> A2);
  (Union MPropF x (Singleton MPropF A1), Bot)]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply MA4_I. exists A2 ; auto. inversion H4. 2: inversion H5. subst.
  apply MP with (ps:=[(Union MPropF x (Singleton MPropF A1), A1 --> Bot);
  (Union MPropF x (Singleton MPropF A1), A1)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Id. apply IdRule_I. apply Union_introl ; auto.
  inversion H6. subst. apply Id. apply IdRule_I. apply Union_intror. apply In_singleton.
  inversion H7.
- intros. apply IHA1 in H0. simpl in H0. apply IHA2. simpl.
  apply clos_deriv ; auto.
  apply MP with (ps:=[(x, A1 --> A2);(x, A1)]). 2: apply MPRule_I.
  intros. inversion H1. subst. apply Id. apply IdRule_I ; auto.
  inversion H2 ; subst. 2: inversion H3. apply Id. apply IdRule_I ; auto.
(* Box A1 *)
- pose (@exist (Ensemble MPropF) is_mcs x i).
  pose (existence_lemma A s). apply i0. intros. apply IHA. auto.
- intros. apply IHA. auto.
Qed.

Theorem wCounterCompleteness : forall Γ A,
    (wKH_prv (Γ, A) -> False) -> ((loc_conseq Γ A) -> False).
Proof.
intros Γ A WD.
apply Lindenbaum_lemma in WD. destruct WD. destruct H. destruct H0.
intro. unfold loc_conseq in H2.
assert (J1: is_mcs x). unfold is_mcs. split ; auto. intro. apply H1.
apply MP with (ps:=[(x, Bot --> A);(x, Bot)]). 2: apply MPRule_I.
intros. inversion H4. subst. apply Ax. apply AxRule_I. apply MA4_I.
exists A ; auto. inversion H5 ; subst. 2: inversion H6. auto.
pose (@exist (Ensemble MPropF) is_mcs x J1).
pose (H2 CM s).
assert (forall B : MPropF, In MPropF Γ B -> wforces CM s B). intros. apply truth_lemma. auto.
apply w in H3. apply truth_lemma in H3. simpl in H3.
apply H1. apply Id. apply IdRule_I ; auto.
Qed.

Theorem wCompleteness : forall Γ A,
    (loc_conseq Γ A) -> wKH_prv (Γ, A).
Proof.
intros Γ A LC. pose (wCounterCompleteness Γ A).
pose (classic (wKH_prv (Γ, A))). destruct o. auto. exfalso.
apply f ; assumption.
Qed.


Require Import squiggle5.
Require Import ReflParam.unusedVar.
Require Import JMeq.
Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import ReflParam.indProp.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.Trecord.
Require Import ReflParam.unusedVar.

(** https://github.com/aa755/ReduceAwayVar *)
Require Import ReduceAwayVar.ReduceAwayVar.
(** the above plugin only tries to eliminate one variable at a time.
So, we invoke it twice: once to eliminate the OneToOne hypothesis for BTmᵣ,
then for Tmᵣ*)

Section Test.
Variables
(Tm Tm₂ : Set)
(Tmᵣ : Tm -> Tm₂ -> Prop)
(TmᵣTot : TotalHeteroRel Tmᵣ)
(TmᵣOne : oneToOne Tmᵣ)
(BTm BTm₂ : Set)
(BTmᵣ : BTm -> BTm₂ -> Prop)
(BTmᵣTot : TotalHeteroRel BTmᵣ)
.

(* The plugin takes a lambda term and tries to eliminate the first argument.
(The result is declared as [sthm].)
In the
process, it may be able to eliminate other variables too. In this case, it
successfully eliminates even the variable [BTmᵣTot] declared above *)
Time ReduceAwayLamVar sthm := (
fun (BTmᵣOne : oneToOne BTmᵣ) (* plugin's goal is to eliminate this*) =>
(* for now, we manually eta expand the pair type with the relation and its 2 proofs *)
let A_R := (@Build_GoodRel allProps _ _ Tmᵣ TmᵣTot TmᵣOne) in
let B_R := (@Build_GoodRel allProps _ _ BTmᵣ BTmᵣTot BTmᵣOne) in
Top_squiggle5_obseq_pmtcty_RR _ _ A_R _ _ B_R (* the result of weak isorel translation *)
).

(** As expected, [sthm], which is the output of the [ReduceAwayLamVar] plugin,
is definitionally equal to the input, because the [reflexivity] proof works.*)
Lemma testDefn (BTmᵣOne : oneToOne BTmᵣ):
let A_R := (@Build_GoodRel allProps _ _ Tmᵣ TmᵣTot TmᵣOne) in
let B_R := (@Build_GoodRel allProps _ _ BTmᵣ BTmᵣTot BTmᵣOne) in
JMeq
  (Top_squiggle5_obseq_pmtcty_RR _ _ A_R _ _ B_R)
  sthm.
Proof using.
  reflexivity.
Qed.

End Test.
Notation π₁ := BestR.
Notation IsoRel := BestRel.
Check sthm.

(*
forall (Tm Tm₂ : Set) (Tmᵣ : Tm -> Tm₂ -> Prop)
         (TmᵣTot : TotalHeteroRel Tmᵣ) (TmᵣOne : oneToOne Tmᵣ)
         (BTm BTm₂ : Set)
         (BTmᵣ : BTm -> BTm₂ -> Prop)
         (* The plugin managed to eliminate not only the [OneToOne] hypothesis for BTmᵣ, but also the [Total] hypothesis *)
         (applyBtm : BTm -> Tm -> Tm) (applyBtm₂ : BTm₂ -> Tm₂ -> Tm₂),
       (forall (a1 : BTm) (a2 : BTm₂),
        BTmᵣ a1 a2 ->
        π₁
          (PiGoodSet Tm Tm₂ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |}
             (fun _ : Tm => Tm) (fun _ : Tm₂ => Tm₂)
             (fun (H : Tm) (H0 : Tm₂)
                (_ : π₁ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |} H H0)
              => {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |}))
          (applyBtm a1) (applyBtm₂ a2)) ->
       forall (tmKind : Tm -> TmKind Tm BTm)
         (tmKind₂ : Tm₂ -> TmKind Tm₂ BTm₂),
       (forall (a1 : Tm) (a2 : Tm₂),
        π₁ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |} a1 a2 ->
        Top_squiggle5_TmKind_pmtcty_RR0 Tm Tm₂
          (π₁ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |}) BTm BTm₂ BTmᵣ
          (tmKind a1) (tmKind₂ a2)) ->
       forall (tl : Tm) (tl₂ : Tm₂),
       π₁ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |} tl tl₂ ->
       forall (tr : Tm) (tr₂ : Tm₂),
       π₁ {| R := Tmᵣ; Rtot := TmᵣTot; Rone := TmᵣOne |} tr tr₂ ->
       IsoRel (forall a : nat, obsEq Tm BTm applyBtm tmKind a tl tr)
         (forall a : nat, obsEq Tm₂ BTm₂ applyBtm₂ tmKind₂ a tl₂ tr₂)
*)

(* Now, we do the same for Tmᵣ: eliminate the hypothesis requiring it to be OneToOne.*)
Section Test2.
Variables
(Tm Tm₂ : Set)
(Tmᵣ : Tm -> Tm₂ -> Prop)
(TmᵣTot : TotalHeteroRel Tmᵣ)
(BTm BTm₂ : Set)
(BTmᵣ : BTm -> BTm₂ -> Prop).

Time  ReduceAwayLamVar obseqStrongIso :=
(
fun (poa : oneToOne Tmᵣ) =>
@sthm _ _ Tmᵣ TmᵣTot poa _ _ BTmᵣ (* [sthm] was produced by the first invocation (above) *)
).

(*
Finished transaction in 1.547 secs (1.259u,0.s) (successful)
*)

End Test2.

Check obseqStrongIso.

(*
obseqStrongIso
     : forall (Tm Tm₂ : Set) (Tmᵣ : Tm -> Tm₂ -> Prop),
       TotalHeteroRel Tmᵣ ->
       (* the OneToOne hypothesis was eliminated for Tmᵣ *)
       forall (BTm BTm₂ : Set)
       (BTmᵣ : BTm -> BTm₂ -> Prop)
         (applyBtm : BTm -> Tm -> Tm) (applyBtm₂ : BTm₂ -> Tm₂ -> Tm₂),
       (forall (a1 : BTm) (a2 : BTm₂),
        BTmᵣ a1 a2 ->
        forall (a3 : Tm) (a4 : Tm₂),
        Tmᵣ a3 a4 -> Tmᵣ (applyBtm a1 a3) (applyBtm₂ a2 a4)) ->
       forall (tmKind : Tm -> TmKind Tm BTm)
         (tmKind₂ : Tm₂ -> TmKind Tm₂ BTm₂),
       (forall (a1 : Tm) (a2 : Tm₂),
        Tmᵣ a1 a2 ->
        Top_squiggle5_TmKind_pmtcty_RR0 Tm Tm₂ Tmᵣ BTm BTm₂ BTmᵣ (tmKind a1)
          (tmKind₂ a2)) ->
       forall (tl : Tm) (tl₂ : Tm₂),
       Tmᵣ tl tl₂ ->
       forall (tr : Tm) (tr₂ : Tm₂),
       Tmᵣ tr tr₂ ->
       BestRel (forall a : nat, obsEq Tm BTm applyBtm tmKind a tl tr)
         (forall a : nat, obsEq Tm₂ BTm₂ applyBtm₂ tmKind₂ a tl₂ tr₂)

*)

(* folding definitions and alpha renaming in above for readability *)
Definition obseqStrongIsoType :=
forall
  (Tm Tm₂ : Set) (Tmᵣ : Tm -> Tm₂ -> Prop)
  (Tmᵣtot: TotalHeteroRel Tmᵣ)
  (BTm BTm₂ : Set) (BTmᵣ : BTm -> BTm₂ -> Prop)
  (applyBtm : BTm -> Tm -> Tm) (applyBtm₂ : BTm₂ -> Tm₂ -> Tm₂)
  (applyBtmᵣ : forall (b : BTm) (b₂ : BTm₂) (bᵣ: BTmᵣ b b₂)
    (a : Tm) (a₂ : Tm₂) (aᵣ : Tmᵣ a a₂), Tmᵣ (applyBtm b a) (applyBtm₂ b₂ a₂))
  (tmKind : Tm -> TmKind Tm BTm)
  (tmKind₂ : Tm₂ -> TmKind Tm₂ BTm₂)
  (tmKindᵣ : forall (a : Tm) (a₂ : Tm₂)
        (aᵣ: Tmᵣ a a₂),
        Top_squiggle5_TmKind_pmtcty_RR0 Tm Tm₂ Tmᵣ BTm BTm₂ BTmᵣ (tmKind a)
          (tmKind₂ a₂))
  (tl : Tm) (tl₂ : Tm₂)
  (tlᵣ: Tmᵣ tl tl₂)
  (tr : Tm) (tr₂ : Tm₂)
  (trᵣ: Tmᵣ tr tr₂),
     IsoRel (obseq Tm BTm applyBtm tmKind tl tr)
             (obseq Tm₂ BTm₂ applyBtm₂ tmKind₂ tl₂ tr₂).

(** confirming that our readability improvement did not change the meaning *)
Goal JMeq obseqStrongIsoType ltac:(let T:=type of obseqStrongIso in exact T).
reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal19.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_2  := ( Cons (Succ Zero)         (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))))).
Definition lfind_example_3  := ( Cons Zero         (Cons (Succ (Succ (Succ Zero)))            (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_5  := ( Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_6  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_7  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_8  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_9  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons (Succ Zero) Nil))).
Definition lfind_example_10  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_11  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_12  := ( Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_13  := ( Cons (Succ Zero)         (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))).
Definition lfind_example_14  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_15  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_16  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal19_lem2_33_lem/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 .


Require Export Db.Spec.
Require Export Db.Lemmas.

Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.
Require Export RecTypes.ValidTy.

Require Import Coq.Bool.Bool.
Require Import Coq.micromega.Lia.

Lemma closed_implies_not_var {i} :
  ⟨ 0 ⊢ (tvar i) ⟩ → False.
Proof.
  intros.
  inversion H.
  inversion H1.
Qed.
#[export]
Hint Resolve closed_implies_not_var : cty.

Lemma closed_implies_not_var_eq {τ} :
  ⟨ 0 ⊢ τ ⟩ → ∀ i : Ix, τ <> tvar i.
Proof.
  intros.
  intros contra.
  rewrite contra in H.
  exact (closed_implies_not_var H).
Qed.

Lemma closed_arr_implies_closed_argty {τ τ'} :
  ⟨ 0 ⊢ (tarr τ τ') ⟩ → ⟨ 0 ⊢ τ ⟩.
Proof.
  inversion 1; assumption.
Qed.
#[export]
Hint Resolve closed_arr_implies_closed_argty : cty.

Lemma closed_arr_implies_closed_retty {τ τ'} :
  ⟨ 0 ⊢ (tarr τ τ') ⟩ → ⟨ 0 ⊢ τ' ⟩.
Proof.
  inversion 1; assumption.
Qed.
#[export]
Hint Resolve closed_arr_implies_closed_retty : cty.

Lemma closed_arr_implies_closed_argty_eq {τ τ1 τ2} :
  ⟨ 0 ⊢ τ ⟩ →
  τ = tarr τ1 τ2 →
  ⟨ 0 ⊢ τ1 ⟩.
Proof.
  intros.
  rewrite H0 in H.
  exact (closed_arr_implies_closed_argty H).
Qed.

Lemma closed_arr_implies_closed_retty_eq {τ τ1 τ2} :
  ⟨ 0 ⊢ τ ⟩ →
  τ = tarr τ1 τ2 →
  ⟨ 0 ⊢ τ2 ⟩.
Proof.
  intros.
  rewrite H0 in H.
  exact (closed_arr_implies_closed_retty H).
Qed.

Lemma closed_sum_implies_closed_lhs {τ τ'} :
 ⟨ 0 ⊢ (tsum τ τ') ⟩ → ⟨ 0 ⊢ τ ⟩.
Proof.
  inversion 1; assumption.
Qed.
#[export]
Hint Resolve closed_sum_implies_closed_lhs : cty.

Lemma closed_sum_implies_closed_rhs {τ τ'} :
 ⟨ 0 ⊢ (tsum τ τ') ⟩ → ⟨ 0 ⊢ τ' ⟩.
Proof.
  inversion 1; assumption.
Qed.
#[export]
Hint Resolve closed_sum_implies_closed_rhs : cty.

Lemma closed_sum_implies_closed_lhs_eq {τ τ1 τ2} :
 ⟨ 0 ⊢ τ ⟩ →
  τ = tsum τ1 τ2 →
 ⟨ 0 ⊢ τ1 ⟩.
Proof.
  intros.
  rewrite H0 in H.
  exact (closed_sum_implies_closed_lhs H).
Qed.

Lemma closed_sum_implies_closed_rhs_eq {τ τ1 τ2} :
 ⟨ 0 ⊢ τ ⟩ →
  τ = tsum τ1 τ2 →
 ⟨ 0 ⊢ τ2 ⟩.
Proof.
  intros.
  rewrite H0 in H.
  exact (closed_sum_implies_closed_rhs H).
Qed.

(* Lemma closed_rec_implies_closed_unfold {τ} : *)
(*  ClosedTy (trec τ) →ClosedTy τ[beta1 (trec τ)]. *)
(* Proof. *)
(*   intros. *)
(*   inversion H. *)
(*   induction τ. *)
(*   inversion H1. *)
(*   assert (H6 :ClosedTy (trec τ1)). *)
(*   constructor. *)
(*   assumption. *)
(*   assert (H7 :ClosedTy (trec τ2)). *)
(*   constructor. *)
(*   assumption. *)
(*   assert (H8 :ClosedTy τ1[beta1 (trec τ1)]). *)
(*   apply IHτ1. *)
(*   assumption. *)
(*   assert (H9 :ClosedTy τ2[beta1 (trec τ2)]). *)
(*   apply IHτ2. *)
(*   assumption. *)
(* Admitted. *)

(* Lemma closed_rec_implies_closed_unfold_eq {τ τ'} : *)
(*  ClosedTy τ → *)
(*   τ = trec τ' → *)
(*  ClosedTy τ'[beta1 (trec τ')]. *)
(* Proof. *)
(*   intros. *)
(*   rewrite H0 in H. *)
(*   exact (closed_rec_implies_closed_unfold H). *)
(* Qed. *)

Lemma Closed_SimpleRec_SimpleContr {τ} : ⟨ 0 ⊢ τ ⟩ -> SimpleRec τ -> SimpleContr τ.
Proof.
  intros cty rty.
  destruct rty; [|assumption].
  exfalso; eauto with cty.
Qed.

Lemma Closed_SimpleRec_Valid {τ} : ⟨ 0 ⊢ τ ⟩ -> SimpleRec τ -> ValidTy τ.
Proof.
  split; eauto using Closed_SimpleRec_SimpleContr.
Qed.

Lemma ValidTy_arr {τ1 τ2} : ValidTy τ1 -> ValidTy τ2 -> ValidTy (tarr τ1 τ2).
Proof.
  intros [τ1_cl τ1_contr] [τ2_cl τ2_contr].
  split; eauto with simple_contr_rec.
  now constructor.
Qed.
#[export]
Hint Resolve ValidTy_arr : tyvalid.

Lemma ValidTy_invert_arr {τ1 τ2} : ValidTy (tarr τ1 τ2) -> ValidTy τ1 /\ ValidTy τ2.
Proof.
  intros [τ_cl τ_contr].
  inversion τ_cl; subst.
  inversion τ_contr; subst.
  eauto using Closed_SimpleRec_Valid.
Qed.

Lemma ValidTy_prod {τ1 τ2} : ValidTy τ1 -> ValidTy τ2 -> ValidTy (tprod τ1 τ2).
Proof.
  intros [τ1_cl τ1_contr] [τ2_cl τ2_contr].
  split; eauto with simple_contr_rec.
  now constructor.
Qed.
#[export]
Hint Resolve ValidTy_prod : tyvalid.

Lemma ValidTy_invert_prod {τ1 τ2} : ValidTy (tprod τ1 τ2) -> ValidTy τ1 /\ ValidTy τ2.
Proof.
  intros [τ_cl τ_contr].
  inversion τ_cl; subst.
  inversion τ_contr; subst.
  eauto using Closed_SimpleRec_Valid.
Qed.

Lemma ValidTy_sum {τ1 τ2} : ValidTy τ1 -> ValidTy τ2 -> ValidTy (tsum τ1 τ2).
Proof.
  intros [τ1_cl τ1_contr] [τ2_cl τ2_contr].
  split; eauto with simple_contr_rec.
  now constructor.
Qed.
#[export]
Hint Resolve ValidTy_sum : tyvalid.

Lemma ValidTy_invert_sum {τ1 τ2} : ValidTy (tsum τ1 τ2) -> ValidTy τ1 /\ ValidTy τ2.
Proof.
  intros [τ_cl τ_contr].
  inversion τ_cl; subst.
  inversion τ_contr; subst.
  eauto using Closed_SimpleRec_Valid.
Qed.

Lemma ValidTy_unit : ValidTy tunit.
Proof.
  split; now constructor.
Qed.
#[export]
Hint Resolve ValidTy_unit : tyvalid.

Lemma ValidTy_bool : ValidTy tbool.
Proof.
  split; now constructor.
Qed.
#[export]
Hint Resolve ValidTy_bool : tyvalid.

Lemma ValidTy_rec {τ} : ⟨ 1 ⊢ τ ⟩ -> SimpleContr τ -> ValidTy (trec τ).
Proof.
  intros τ_cl τ_contr.
  split; eauto with simple_contr_rec.
  now constructor.
Qed.
#[export]
Hint Resolve ValidTy_rec : tyvalid.

Lemma ValidTy_unfold_trec {τ} : ValidTy (trec τ) -> ValidTy (τ[beta1 (trec τ)]).
Proof.
  intros (clτ & crτ).
  inversion clτ; subst.
  inversion crτ; subst.
  split.
  - eauto using wsAp, wsSub_sub_beta1.
  - eauto using unfold_preserves_contr.
Qed.

Lemma unfold_trec_prerves_ws {i τ} : ⟨ i ⊢ trec τ ⟩ → ⟨ i ⊢ τ[beta1 (trec τ)] ⟩.
Proof.
  intros.
  pose proof wsSub_sub_beta1.
  eapply wsAp; eauto. inversion H; subst; assumption.
Qed.

Lemma ValidTy_unfoldOnce {τ} : ValidTy τ -> ValidTy (unfoldOnce τ).
Proof.
  destruct τ; cbn; eauto using ValidTy_unfold_trec.
Qed.
#[export]
Hint Resolve ValidTy_unfoldOnce : tyvalid.

Lemma ValidTy_unfoldn {n τ} : ValidTy τ -> ValidTy (unfoldn n τ).
Proof.
  revert τ;
  induction n; cbn; eauto using ValidTy_unfoldOnce.
Qed.

Lemma unfoldOnce_preserves_ws {i τ} : ⟨ i ⊢ τ ⟩ → ⟨ i ⊢ unfoldOnce τ ⟩.
Proof.
  destruct τ; cbn; eauto using unfold_trec_prerves_ws.
Qed.

Lemma unfoldn_preserves_ws {i n τ} : ⟨ i ⊢ τ ⟩ → ⟨ i ⊢ unfoldn n τ ⟩.
Proof.
  revert τ;
  induction n; cbn; eauto using unfoldOnce_preserves_ws.
Qed.

Lemma ValidTy_invert_rec {τ} : ValidTy (trec τ) -> ⟨ 1 ⊢ τ ⟩ /\ SimpleContr τ.
Proof.
  intros [clτ cτ].
  inversion clτ.
  now inversion cτ.
Qed.

Definition decideValidTy τ := decideClosed τ && checkContractive τ.
Arguments decideValidTy /τ.

Lemma decideValidTy_sound τ : Is_true (decideValidTy τ) -> ValidTy τ.
Proof.
  intros (clres & ctres)%andb_prop_elim.
  split; eauto using decideClosed_sound, checkContractive_sound.
Qed.

Lemma ValidEnv_invert_cons {Γ τ} : ValidEnv (Γ r▻ τ) -> ValidEnv Γ /\ ValidTy τ.
Proof.
  intros (cΓτ & crΓτ).
  inversion cΓτ; subst.
  inversion crΓτ; subst.
  split; split; assumption.
Qed.

Ltac crushValidTyMatch2 :=
  try assumption;
  match goal with
  | |- ValidTy (?τ [ beta1 (trec ?τ)]) => refine (ValidTy_unfoldOnce (τ := trec τ) _)
  | H: ⟨ _ ⊢ ?τ ⟩ |- ⟨ _ ⊢ ?τ ⟩ => refine (WsTy_mono _ H)
  | H : ValidTy ?τ |- SimpleContr ?τ => exact (proj2 H)
  | H : ValidTy ?τ |- SimpleRec ?τ => eapply SimpleRecContr
  | H : ValidTy ?τ |- ⟨ 0 ⊢ ?τ ⟩ => exact (proj1 H)
  | H : ValidTy ?τ |- ⟨ _ ⊢ ?τ ⟩ => refine (WsTy_mono _ (proj1 H))
  | H: ValidTy (_ r⇒ _) |- _ => eapply ValidTy_invert_arr in H; destruct H as (? & ?)
  | H: ValidTy (_ r× _) |- _ => eapply ValidTy_invert_prod in H; destruct H as (? & ?)
  | H: ValidTy (_ r⊎ _) |- _ => eapply ValidTy_invert_sum in H; destruct H as (? & ?)
  | H: ValidTy (trec _) |- _ => eapply ValidTy_invert_rec in H; destruct H as (? & ?)
  | H: ValidTy (tvar _) |- _ => now eapply proj1, closed_implies_not_var in H
  | |- ValidTy (_ r× _) => eapply ValidTy_prod
  | |- ValidTy (unfoldOnce _) => eapply ValidTy_unfoldOnce
  | |- ValidTy (_ r⇒ _) => eapply ValidTy_arr
  | |- ValidTy (_ r⊎ _) => eapply ValidTy_sum
  | |- ValidTy tunit => eapply ValidTy_unit
  | |- ValidTy tbool => eapply ValidTy_bool
  | |- SimpleContr (trec _) => constructor
  | |- SimpleContr (_ r× _) => constructor
  | |- SimpleContr (_ r⇒ _) => constructor
  | |- SimpleContr (_ r⊎ _) => constructor
  | |- SimpleContr tunit => constructor
  | |- SimpleContr tbool => constructor
  | |- SimpleContr (tvar _) => constructor
  | |- SimpleContr (?τ [beta1 (trec ?τ)]) => refine (unfold_preserves_contr _)
  | |- SimpleRec (trec _) => constructor
  | |- SimpleRec (_ r× _) => constructor
  | |- SimpleRec (_ r⇒ _) => constructor
  | |- SimpleRec (_ r⊎ _) => constructor
  | |- SimpleRec tunit => constructor
  | |- SimpleRec tbool => constructor
  | |- SimpleRec (tvar _) => constructor
  | |- ValidEnv empty => eapply ValidEnv_nil
  | |- ValidEnv (_ r▻ _) => eapply ValidEnv_cons
  | |- ⟨ _ ⊢ trec _ ⟩ => constructor
  | |- ⟨ _ ⊢ _ r× _ ⟩ => constructor
  | |- ⟨ _ ⊢ _ r⊎ _ ⟩ => constructor
  | |- ⟨ _ ⊢ _ r⇒ _ ⟩ => constructor
  | |- ⟨ _ ⊢ tunit ⟩ => constructor
  | |- ⟨ _ ⊢ tbool ⟩ => constructor
  | |- ⟨ _ ⊢ tvar _ ⟩ => constructor
  | |- ⟨ _ ⊢ ?τ [beta1 (trec ?τ)] ⟩ => refine (unfold_trec_prerves_ws _)
  | |- wsTy ?n ?τ => change (⟨ n ⊢ τ ⟩)
  | H: ⟨ 0 ⊢ ?τ ⟩ |- context [ ?τ [ ?σ ] ] => rewrite (wsClosed_invariant (x := τ))
  | H: SimpleContr ?τ |- SimpleRec ?τ => eapply SimpleRecContr
(* , H2: ⟨ 0 ⊢ ?τ ⟩  *)
  end.
Ltac crushValidTyMatch :=
  crushValidTyMatch2 +
    match goal with
    | |- ValidTy _ => split
    end.

Ltac crushValidTy :=
  repeat crushValidTyMatch; try lia; eauto with ws wsi.

#[export]
Hint Extern 20 (ValidTy _) =>
  crushValidTy : tyvalid2.

#[export]
Hint Extern 20 (Closed_SimpleRec_SimpleContr _) =>
  crushValidTy : tyvalid2.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.
Require Import Coq.Program.Equality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.All.
Require Import FinProof.CommonInstances.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import UMLang.All.

Require Import UrsusStdLib.Solidity.All.

Require Import UrsusTVM.Solidity.All.

(* Require Import Blank.ClassTypesNotations. *)

(* Set Typeclasses Depth 100. *)

Import UrsusNotations.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.
Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Local Open Scope xlist_scope.

(*

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.
 *)
Require Import Logic.FunctionalExtensionality.
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import CommonQCEnvironment.
Require Import INT.Props.
Require Import CommonForProps.

Require Import  SetcodeMultisig.

Definition INT_1_propb
       (owners : listArray uint256)
       (reqConfirms :  uint8)
       (lifetime :  uint32)
       (mpk: uint256)
       (acc: bool)
       (pk: uint256)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_1 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_1_propb.

Definition INT_2_propb
       (owners : listArray uint256)
       (reqConfirms :  uint8)
       (lifetime :  uint32)
       (mpk: uint256)
       (acc: bool)
       (pk: uint256)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_2 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_2_propb.

Definition INT_3_1_propb l
       (updateId :  uint64)
       (mpk: uint256)
       (acc: bool)
       (bal: N)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

INT_3_1 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       updateId  ? .

(* OK *)
QuickCheck INT_3_1_propb.

Definition INT_3_2_propb l
       (codeHash : optional uint256)
       (owners : optional (listArray uint256))
       (reqConfirms : optional uint8)
       (lifetime : optional uint32)
       (mpk: uint256)
       (acc: bool)
       (bal: N)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

INT_3_2 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       codeHash owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_3_2_propb.

Definition INT_3_3_propb l
       (transactionId :  uint64)
       (mpk: uint256)
       (acc: bool)
       (bal: N)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

INT_3_3 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       transactionId  ? .

(* OK *)
QuickCheck INT_3_3_propb.

Definition INT_3_4_propb l
       (dest :  address)
       (value :  uint128)
       (bounce :  boolean)
       (allBalance :  boolean)
       (payload :  cell_)
       (stateInit :  optional TvmCell)
       (mpk: uint256)
       (acc: bool)
       (bal: N)
       timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

INT_3_4 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       dest value bounce allBalance payload stateInit ? .

(* OK *)
QuickCheck INT_3_4_propb.

Definition INT_3_5_propb l
       (dest :  address)
       (value :  uint128)
       (bounce :  boolean)
       (flags :  uint8)
       (payload :  cell_)
       (mpk: uint256)
       (acc: bool)
       (bal: N)
       timestamp
       now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

INT_3_5 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       dest value bounce flags payload  ? .

(* OK *)
QuickCheck INT_3_5_propb.

Definition INT_6_propb
       (owners : listArray uint256)
       (reqConfirms :  uint8)
       (lifetime :  uint32)
       (mpk: uint256)
       (acc: bool)
       (pk: uint256)
       timestamp
       now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_6 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_6_propb.

Definition INT_7_propb
       (owners : listArray uint256)
       (reqConfirms :  uint8)
       (lifetime :  uint32)
       (acc: bool)
       (pk: uint256)
       timestamp
       now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := pk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_msg_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_7 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_7_propb.

Definition INT_8_1_propb
       (owners : listArray uint256)
       (reqConfirms :  uint8)
       (lifetime :  uint32)
       (acc: bool)
       (pk: uint256)
       timestamp
       now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := pk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_8_1 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_8_1_propb.

Definition INT_8_2_propb
            (owners : listArray uint256)
            (reqConfirms :  uint8)
            (lifetime :  uint32)
            (acc: bool)
            (pk: uint256)
            timestamp
            (now:N): bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := pk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_pubkey := pk $$} in
let v3 := {$$ v2 with VMState_ι_now := Build_XUBInteger (4000 + now) $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

INT_8_2 {$$ LedgerDefault with Ledger_VMState := v4 $$}
       owners reqConfirms lifetime ? .

(* OK *)
QuickCheck INT_8_2_propb.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal31.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq lst (append (qreva x Nil) (Cons n y))
  (append (append (qreva x Nil) (Cons n Nil)) y).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal31_qreva_nil_50_append_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


Require Import Bedrock.IL Bedrock.Memory Coq.Strings.String.
Require Import Platform.Cito.SyntaxExpr.

Set Implicit Arguments.

Fixpoint eval vs expr :=
  match expr with
    | Var str => vs str
    | Const w => w
    | Binop op a b => evalBinop op (eval vs a) (eval vs b)
    | TestE op a b =>  if evalTest op (eval vs a) (eval vs b) then $1 else $0
  end.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Term Weakening

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Term_Weakening_Proof_Admitted.
Require Export Cyclone_Fset_Lemmas.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma A_3_Heap_Weakening_1:
  forall u g u' g',
    LVPE.extends u u' ->
    extends g g' ->
    WFC empty u' g' ->
    forall h g'',
      htyp u g h g'' ->
      htyp u' g' h g''.
Proof.
  introv Euu' Egg' WFCd H.
  induction H; auto.
  specialize (IHhtyp Euu' Egg').
  constructor; try assumption.
  lets* T: A_2_Term_Weakening_3.
Qed.

Lemma A_3_Heap_Weakening_2:
  forall h u,
    refp h u ->
    forall h',
      extends h h' ->
      refp h' u.
Proof.
  introv R.
  induction R; intros; auto.
  apply refp_pack with (tau:=tau) (k:=k)(v:=v)(v':=v'); auto.
Qed.

Lemma fv_subst:
  forall tau alpha tau',
    T.fv tau' = \{} ->
    T.subst tau alpha tau' = tau'.
Proof.
  intros.
  induction tau'; auto;
    try solve[simpl in H; simpl; fequals*].
  simpl in H.
  apply singleton_empty in H.
  inversion H.

  simpl in H.
  simpl.
  assert(T.fv tau'1 = \{}). admit.
  assert(T.fv tau'2 = \{}). admit.
  fequals*.

  simpl in H.
  simpl.
  assert(T.fv tau'1 = \{}). admit.
  assert(T.fv tau'2 = \{}). admit.
  fequals*.
Qed.


From Coq.Unicode Require Import Utf8.
From stdpp Require Import base list.
From trillium.prelude Require Import classical.
From Coq.ssr Require Import ssreflect.

Lemma sig_eq {A} (P : A → Prop) (x y : sig P) :
  proj1_sig x = proj1_sig y → x = y.
Proof.
  destruct x as [x Px]; simpl.
  destruct y as [y Py]; simpl.
  intros ->.
  rewrite (ProofIrrelevance _ Px Py); trivial.
Qed.

Definition sig_prod_and {A B P Q} (a : {x : A | P x}) (b : {x : B | Q x}) :
    {x : A * B | P (fst x) ∧ Q (snd x)} :=
  (proj1_sig a, proj1_sig b) ↾ (conj (proj2_sig a) (proj2_sig b)).

Definition sig_prod_or_l {A P Q} (a : {x : A | P x}) :
  {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_introl (proj2_sig a)).

Definition sig_prod_or_r {A P Q} (a : {x : A | Q x}) :
    {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_intror (proj2_sig a)).

Definition sig_and {A} {P Q : A -> Prop} (a : {x : A | P x}) (HQ: Q (proj1_sig a)) :
    { x : A | P x ∧ Q x } := (proj1_sig a) ↾ (conj (proj2_sig a) (HQ)).

Fixpoint sig_and_list {A} (P Q : A → Prop) `{!∀ x, Decision (Q x)}
             (enum : list { x | P x }) : list { x | P x ∧ Q x } :=
    match enum with
    | [] => []
    | x :: xs => match (decide (Q $ proj1_sig x)) with
                 | left HQ => (sig_and x HQ) :: sig_and_list P Q xs
                 | _ => sig_and_list P Q xs
                 end
    end.

Lemma sig_and_list_le {A} (P Q : A → Prop)
      `{!EqDecision A} `{!∀ x, Decision (Q x)}
      `{!∀ x, ProofIrrel (P x)} `{!∀ x, ProofIrrel (Q x)}
      (enum : list { x | P x }) :
  ∀ x HQ, sig_and x HQ ∈ (sig_and_list P Q enum) → x ∈ enum.
Proof.
  intros x y Hin.
  induction enum; [by apply elem_of_nil in Hin|].
  apply elem_of_cons.
  destruct (decide (x = a)) as [Heq|Hneq]; simplify_eq /=; [left;done|right].
  destruct (decide (Q (`a))); [|by apply IHenum].
  apply elem_of_cons in Hin as [Hin|Hin]; [|by apply IHenum].
  inversion Hin as [Heq]. by apply proj1_sig_inj in Heq.
Qed.