Require Import Program.
Require Import List.

Require Import Misc.
Require Level.
Require Stack.

Module S := Stack.

Inductive t (A : Set) : Type :=
  | SingleLevel :
    forall B, forall s : Stack.t A B, Stack.well_formed s true -> t A
  | SeveralLvls :
    forall B, forall s : Stack.t A B, Stack.well_formed s false -> t B -> t A.

Arguments SingleLevel [A B] _ _.
Arguments SeveralLvls [A B] _ _ _.

Notation "<< X >>" := (SingleLevel X _).
Notation "x ++ y" := (SeveralLvls x _ y).

Notation "[]" := (@Stack.Nil _) (at level 40).
Notation "a ::: b" := (@Stack.Cons _ _ a b) (at level 55, right associativity).

Definition color {A} (d : t A) :=
  match d with
  | << stack >> => Stack.color stack true
  | stack ++ _ => Stack.color stack false
  end.

Definition is_empty {A} (d : t A) :=
  match d with
  | << (lvl ::: []) >> => Level.is_empty lvl
  | _ => False
  end.

Definition dec_is_empty {A} (d : t A) : { is_empty d } + { ~ is_empty d }.
Proof.
  destruct d ; [ .. | (right ; simpl ; auto) ].
  destruct s ; [ (exfalso ; assumption) | .. ].
  dependent destruction s ; simpl ; [ .. | (right ; auto) ].
  apply Level.dec_is_empty.
Defined.

Fixpoint green_between_reds {A} (d : t A) : Prop :=
  match d with
  | << stack >> => Stack.color stack true <> Yellow
  | top ++ rest =>
    let g_before_r :=
      match Stack.color top false with
      | Red => color rest = Green
      | Green => True
      | Yellow => False
      end
    in
    g_before_r /\ green_between_reds rest
  end.

Definition semi_regular {A} (d : t A) : Prop :=
  match d with
  | << _ >> => True
  | top ++ rest =>
    match color d with
    | Yellow => green_between_reds rest
    | _ => green_between_reds d
    end
  end.

Definition regular {A} (d : t A) : Prop :=
  match d with
  | << s >> =>
    match Stack.color s true with
    | Red => Stack.is_empty s
    | _   => True
    end
  | top ++ rest =>
    match Stack.color top false with
    | Red    => False
    | Green  => green_between_reds rest
    | Yellow => color rest = Green /\ green_between_reds rest
    end
  end.

Program Definition empty A : { d : t A | regular d } := << Stack.empty A >>.
Next Obligation.
Proof. compute ; tauto. Qed.

Inductive regularisation_cases (A : Set) : t A -> Type :=
  | one_level :
    forall lvl : Level.t A,
    forall p_wf : Stack.well_formed (lvl ::: []) true,
    regularisation_cases A (SingleLevel (lvl ::: []) p_wf)
  | general_case1a :
    forall B lvli lvlSi,
    forall yellows : Stack.t ((A * A) * (A * A)) B,
    forall p_wf : Stack.well_formed (lvli ::: lvlSi ::: yellows) true,
    regularisation_cases A (SingleLevel (lvli ::: lvlSi ::: yellows) p_wf)
  | general_case1b :
    forall B lvli lvlSi,
    forall yellows : Stack.t ((A * A) * (A * A)) B,
    forall p_wf1 : Stack.well_formed (lvli ::: []) false,
    forall p_wf2 : Stack.well_formed (lvlSi ::: yellows) true,
    regularisation_cases A
      (SeveralLvls (lvli ::: []) p_wf1
        (SingleLevel (lvlSi ::: yellows) p_wf2))
  | general_case2a :
    forall B lvli lvlSi,
    forall yellows : Stack.t ((A * A) * (A * A)) B,
    forall p_wf : Stack.well_formed (lvli ::: lvlSi ::: yellows) false,
    forall rest : t B,
    regularisation_cases A (SeveralLvls (lvli ::: lvlSi ::: yellows) p_wf rest)
  | general_case2b :
    forall B lvli lvlSi,
    forall yellows : Stack.t ((A * A) * (A * A)) B,
    forall p_wf1 : Stack.well_formed (lvli ::: []) false,
    forall p_wf2 : Stack.well_formed (lvlSi ::: yellows) false,
    forall rest : t B,
    regularisation_cases A
      (SeveralLvls (lvli ::: []) p_wf1
        (SeveralLvls (lvlSi ::: yellows) p_wf2 rest)).

Definition dispatch (A : Set) (d : t A) (p : semi_regular d) :
  regularisation_cases A d.
Proof.
  destruct d ; (destruct s ; [ (exfalso ; apply w) | .. ]) ;
  dependent destruction s ; try constructor.
  destruct d ; dependent destruction s ; try (exfalso ; assumption) ;
  constructor.
Defined.

Lemma color_preservation :
  forall {A}, forall lvl:Level.t A,
    Level.color lvl false <> Red -> Level.color lvl true = Level.color lvl false.
Proof.
  intros.
  destruct lvl ; destruct prefix, suffix ; compute in H |- * ;
  reflexivity || (exfalso ; apply H ; reflexivity).
Qed.

Ltac is_color x :=
  match x with
  | Red => idtac
  | Green => idtac
  | Yellow => idtac
  | _ => fail
  end.

Ltac simpl_colors :=
  simpl in * ;
  repeat match goal with
  | [ H : ?Color = color ?deque |- _ ] =>
    is_color Color ; rewrite <- H in *
  | [ H : ?Color = Stack.color ?stack ?bool |- _ ] =>
    is_color Color ; rewrite <- H in *
  | [ H : ?Color = Level.color ?lvl ?is_last |- _ ] =>
    is_color Color ; rewrite <- H in *
  | [ H : Level.color ?lvl ?is_last = ?Color |- _ ] =>
    is_color Color ; rewrite H in *
  | [ Hcol : Level.color ?lvli false = Green
    |- context[Level.color ?lvli true = Green] ] =>
    rewrite color_preservation ; rewrite Hcol ; auto || discriminate
  end ; try split ; trivial || auto.

Local Obligation Tactic := (program_simpl ; try simpl_colors).

Program Definition do_regularize {A} (d : t A) (Hsr : semi_regular d)
  (Color : color d = Red) (Hempty : ~ is_empty d)
: { d : t A | regular d /\ color d = Green }
:=
  match dispatch A d Hsr with
  | one_level lvli _ =>
    if Level.dec_is_empty lvli then ! else
    let lvlSi := Level.empty (A * A) in
    let pair :
      {l : Level.t A | Level.color l false = Green } * Level.t (A * A)
    :=
      (* Why not [Level.equilibrate]? *)
      Level.one_buffer_case lvli lvlSi true true _ _ _ _ _ _
    in
    let (lvli, lvlSi) := pair in
    let (lvli, Hcol) := lvli in
    match Level.color lvlSi true with
    | Yellow => << lvli ::: lvlSi ::: [] >>
    | _ =>
      if Level.dec_is_empty lvlSi
        then << lvli ::: [] >>
        else lvli ::: [] ++ << lvlSi ::: [] >>
    end
  | general_case1a _ lvli lvlSi yellows _
  | general_case1b _ lvli lvlSi yellows _ _ =>
    let is_lastSi :=
      match yellows with
      | [] => true
      | _ ::: _  => false
      end
    in
    match Level.equilibrate lvli lvlSi false is_lastSi _ _ _ _ _ with
    | inl p =>
      let (lvli', lvlSi'_sig) := p in
      let (lvlSi', HlvlSi') := lvlSi'_sig in
      match Level.color lvlSi' is_lastSi with
      | Yellow => << lvli' ::: lvlSi' ::: yellows >>
      | _ =>
        match Level.dec_is_empty lvlSi', is_lastSi with
        | left HeSi, true =>
          << lvli' ::: [] >>
        | _, _ => lvli' ::: [] ++ << lvlSi' ::: yellows >>
        end
      end
    | inr lvl_sig =>
      let (lvl, Hlvl) := lvl_sig in
      << lvl ::: [] >>
    end
  | general_case2a _ lvli lvlSi yellows _ rest
  | general_case2b _ lvli lvlSi yellows _ _ rest =>
    match Level.equilibrate lvli lvlSi false false _ _ _ _ _ with
    | inl p =>
      let (lvli', lvlSi'_sig) := p in
      let (lvlSi', HlvlSi') := lvlSi'_sig in
      match Level.color lvlSi' false with
      | Yellow => lvli' ::: lvlSi' ::: yellows ++ rest
      | _ => lvli' ::: [] ++ lvlSi' ::: yellows ++ rest
      end
    | inr lvl_sig => !
    end
  end.

(* one_level case *)
Next Obligation.
Proof. right ; compute ; tauto. Qed.

Next Obligation.
Proof.
  destruct lvli ; destruct prefix, suffix ; solve [
    (simpl ; omega) |
    (compute in Color ; discriminate Color) |
    (compute in H ; exfalso ; apply H ; tauto) |
    (simpl in wildcard'0 ; discriminate wildcard'0)
  ].
Qed.

(* general_case1a *)
Next Obligation.
Proof.
  left; dependent destruction yellows; [ .. | destruct wildcard'0 ]; congruence.
Qed.

Next Obligation.
Proof.
  destruct lvlSi ; destruct prefix, suffix ; compute in H ;
  destruct H as [ Hp Hs ]; try (exfalso ; assumption) ;
  dependent destruction yellows.
  - discriminate wildcard'0.
  - dependent destruction wildcard'0.
    discriminate e.
Qed.

Next Obligation.
Proof.
  intuition.
  destruct lvlSi ; destruct prefix, suffix ; compute in H1 ;
  destruct H1 as [ Hp Hs ] ; try (exfalso ; assumption) ;
  dependent destruction yellows.
  - discriminate wildcard'0.
  - dependent destruction wildcard'0.
    discriminate e.
Qed.

Next Obligation.
Proof.
  dependent destruction yellows.
  - congruence.
  - split ; [ congruence | .. ].
    destruct wildcard'0.
    assumption.
Qed.

Next Obligation.
Proof.
  dependent destruction yellows ; [ .. | destruct wildcard'0 ] ; auto.
Qed.

Next Obligation.
Proof.
  dependent destruction yellows ; auto.
Qed.

(* general_case1b *)
Next Obligation.
Proof.
  clear Heq_anonymous.
  left; dependent destruction yellows; simpl_colors; destruct Hsr; congruence.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous.
  rewrite Color in Hsr.
  dependent destruction yellows ; destruct Hsr as [ Hcol _ ] ;
  destruct lvlSi ; destruct prefix, suffix ; compute in H, Hcol ;
  firstorder ; discriminate Hcol.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous.
  intuition ; simpl_colors.
  dependent destruction yellows ; destruct Hsr as [ Hcol _ ] ;
  destruct lvlSi ; destruct prefix, suffix ; compute in H1, Hcol ;
  firstorder ; discriminate Hcol.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  dependent destruction yellows.
  - congruence.
  - split ; [ congruence | assumption ].
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous H0 H1 H3 HlvlSi'.
  dependent destruction yellows ; auto.
Qed.

(* general_case2a *)
Next Obligation.
Proof.
  left; dependent destruction yellows; [ .. | destruct wildcard'0 ]; congruence.
Qed.

Next Obligation.
Proof.
  destruct lvlSi ; destruct prefix, suffix ; compute in H ; firstorder.
  compute in wildcard'0 ;
  dependent destruction yellows ; [ .. | destruct wildcard'0 ] ; congruence.
Qed.

Next Obligation.
Proof.
  intuition.
  destruct lvlSi ; destruct prefix, suffix ; compute in H1 ; firstorder.
  compute in wildcard'0 ;
  dependent destruction yellows ; [ .. | destruct wildcard'0 ] ; congruence.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  dependent destruction yellows ; [ .. | split ] ; auto.
  destruct wildcard'0 ; assumption.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  simpl_colors ; destruct Hsr ; assumption.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  dependent destruction yellows.
  - simpl ; trivial.
  - destruct wildcard'0 ; assumption.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  split.
  - dependent destruction yellows ;
    destruct (Level.color lvlSi' false) ; solve [
      trivial | (apply H ; reflexivity) | (simpl_colors ; firstorder)
    ].
  - simpl_colors ; destruct Hsr ; assumption.
Qed.

(* general_case2b *)
Next Obligation.
Proof.
  clear Heq_anonymous.
  left; dependent destruction yellows ;
    simpl_colors ; destruct Hsr ; congruence.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous.
  simpl_colors ; dependent destruction yellows ; destruct Hsr as [ Hcol _ ] ;
  destruct lvlSi ; destruct prefix, suffix ; compute in H, Hcol ;
  firstorder ; discriminate Hcol.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous ; intuition ; simpl_colors.
  dependent destruction yellows ; destruct Hsr as [ Hcol _ ] ;
  destruct lvlSi ; destruct prefix, suffix ; compute in H1, Hcol ;
  firstorder ; discriminate Hcol.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  dependent destruction yellows ; auto.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  simpl_colors ; do 2 destruct Hsr  as [ _ Hsr ]; assumption.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous0 Heq_anonymous.
  split.
  - dependent destruction yellows ;
    destruct (Level.color lvlSi' false) ; solve [
      trivial | (apply H ; reflexivity) | (simpl_colors ; firstorder)
    ].
  - simpl_colors ; do 2 destruct Hsr as [ _ Hsr ] ; assumption.
Qed.

Program Definition regularize {A : Set} (d : t A) (Hsr : semi_regular d) :
  { d : t A | regular d }
:=
  match color d with
  | Green => d
  | Yellow =>
    match d with
    | << _ >> => d
    | top ++ stacks =>
      match color stacks with
      | Green => d
      | Yellow => !
      | Red =>
        match dec_is_empty stacks with
        | left _ => << top >>
        | right NotEmpty =>
          let stacks' := do_regularize stacks _ _ NotEmpty in
          top ++ stacks'
        end
      end
    end
  | Red =>
    match dec_is_empty d with
    | left _ => d
    | right NotEmpty => do_regularize d _ _ NotEmpty
    end
  end.

Next Obligation.
Proof. destruct d ; simpl_colors ; tauto. Qed.

Next Obligation.
Proof.
  destruct stacks ; simpl in *.
  - congruence.
  - destruct Hsr as [ Hsr _ ].
    simpl_colors.
Qed.

Next Obligation.
Proof.
  clear Heq_anonymous Heq_anonymous0 Heq_anonymous1 Hsr wildcard'1 stacks.
  destruct top ; trivial.
  simpl in *.
  induction top ; trivial.
  simpl in *.
  destruct top.
  - rewrite color_preservation ; congruence.
  - destruct wildcard'0 as [ H1 H2 ] ; split.
    + assumption.
    + apply IHtop ; assumption.
Qed. (* well that was laborious *)

Next Obligation.
Proof.
  destruct top.
  - exfalso ; assumption.
  - simpl_colors.
    dependent destruction top ; [ rewrite color_preservation | .. ] ;
    simpl_colors ; discriminate.
Qed.

Next Obligation.
Proof.
  destruct stacks.
  - simpl ; trivial.
  - simpl in *.
    destruct (Stack.color s false) ; try assumption.
    destruct Hsr ; exfalso ; assumption.
Qed.

Next Obligation.
Proof.
  dependent rewrite <- Heq_anonymous.
  remember (do_regularize stacks _ _ _) as s ; clear Heqs.
  split.
  - exact (proj2 (proj2_sig s)).
  - destruct s ; simpl.
    destruct a, x.
    + simpl in H0 |- * ; congruence.
    + simpl in *.
      rewrite H0 in H |- *.
      auto.
Qed.

Next Obligation.
Proof.
  destruct d.
  - simpl in Heq_anonymous |- *.
    rewrite <- Heq_anonymous.
    destruct s ; simpl in *.
    + exfalso ; exact wildcard'.
    + assumption.
  - exfalso ; exact wildcard'.
Qed.

Next Obligation.
Proof.
  remember (do_regularize d _ _ _) as d' ; clear Heqd'.
  exact (proj1 (proj2_sig d')).
Qed.

Ltac trivial_cases :=
  match goal with
  | [ H : Stack.well_formed ?top ?bool, jmeq : [] ~= ?top |- False ] =>
    apply JMeq_eq in jmeq ; subst ; assumption
  | [ H : Stack.well_formed ?top ?bool, jmeq : ?lvl ::: ?yellows ~= ?top
      |- Stack.all_yellows ?yellows ?bool
    ] => apply JMeq_eq in jmeq ; subst ; assumption
  end.

Ltac clean_jmeq :=
  match goal with
  | [ H : ?Pattern ~= ?ident |- _ ] =>
      remember H as H' eqn:Heq ; clear Heq ;
      apply JMeq_eq in H ; subst
  end.

Ltac destruct_lvl_color :=
  match goal with
  | [ |- Level.color ?lvl ?bool <> Red \/ Level.is_empty ?lvl ] =>
    destruct (Level.color lvl bool) eqn:Hcol
  end.

Ltac destruct_yellows :=
  match goal with
  | [ H : Stack.well_formed (?lvl ::: ?Y) ?b
      |- Level.color ?lvl ?bool <> Red \/ Level.is_empty ?lvl
    ] =>
      let yellows := fresh in rename Y into yellows;
      dependent destruction yellows ; simpl in * ;
      destruct_lvl_color ; try solve [
        (left ; discriminate) | (right ; auto) | (exfalso ; assumption)
      ]
  end.

Ltac deduce_next_green :=
  match goal with
  | [ Hreg : regular (?lvl ::: ?yellows ++ ?stacks) ,
      Hcol : Level.color ?lvl ?is_last <> Green
      |- color ?stacks = Green
    ] =>
      simpl in Hreg ; destruct (Level.color lvl is_last) ; [
        (exfalso ; apply Hcol ; trivial) |
        (destruct Hreg ; assumption) |
        (exfalso ; assumption)
      ]
  end.

Local Obligation Tactic := (
  program_simpl ; try clean_jmeq ; try (assumption || destruct_yellows)
).

Inductive front_or_back : Set := Front | Back.

Definition push_helper {A : Set} (elt : A) (pos : front_or_back)
  (lvl : Level.t A) (is_last : bool) p
:=
  match pos with
  | Front => Level.push elt lvl is_last p
  | Back  => Level.inject elt lvl is_last p
  end.

Program Definition push {A : Set} (elt : A) (pos : front_or_back) (d : t A) (p : regular d) :
  { d : t A | regular d }
:=
  match d with
  | << top >> =>
    match top with
    | [] => !
    | Stack.Cons X Y lvl yellows =>
      let elt := eq_rect A (fun T => T) elt X eq_refl in
      let is_last :=
        match yellows with
        | [] => true
        | _ ::: _ => false
        end
      in
      let p := _ in
      let lvl := push_helper elt pos lvl is_last p in
      let d := << lvl ::: yellows >> in
      regularize d _
    end
  | @SeveralLvls B top _ stacks =>
    match top with
    | [] => !
    | Stack.Cons X Y lvl yellows =>
      let elt := eq_rect A (fun T => T) elt X eq_refl in
      let p := _ in
      let lvl := push_helper elt pos lvl false p in
      let stacks := eq_rect B t stacks Y eq_refl in
      let d := lvl ::: yellows ++ stacks in
      regularize d _
    end
  end.

Next Obligation.
Proof.
  remember (push_helper _ pos lvl false _) as lvl' ; simpl.
  assert (Hgbr : green_between_reds stacks) by
    (simpl in p ; clear Heqlvl' lvl';
    dependent destruction yellows ; destruct (Level.color lvl false) ;
    simpl in p ; firstorder).
  destruct pos ;
  dependent destruction yellows; destruct (Level.color lvl' false) eqn:Hcol ;
  try solve [ trivial | (split ; trivial) ] ; (split ; [ .. | trivial ]);
  subst lvl' ; (
    apply Level.red_push_iff_yellow in Hcol ||
    apply Level.red_inject_iff_not_green in Hcol
  ) ; deduce_next_green.
Qed.

Definition pop_helper {A : Set} (pos : front_or_back) (lvl : Level.t A) p :=
  match pos with
  | Front => Level.pop lvl p
  | Back  => Level.eject lvl p
  end.

Program Definition pop {A : Set} pos (d : t A) (p : regular d) :
  option (A * { d : t A | regular d })
:=
  match d with
  | << top >> =>
    match top with
    | [] => !
    | Stack.Cons X Y lvl yellows =>
      match Level.dec_is_empty lvl with
      | left _ => None
      | right NotEmpty  =>
        let (elt, lvl) := pop_helper pos lvl NotEmpty in
        let d := << lvl ::: yellows >> in
        Some (elt, regularize d _)
      end
    end
  | @SeveralLvls B top _ stacks =>
    match top with
    | [] => !
    | Stack.Cons X Y lvl yellows =>
      match Level.dec_is_empty lvl with
      | left _ => None
      | right NotEmpty  =>
        let pair := pop_helper pos lvl NotEmpty in
        let stacks := eq_rect B t stacks Y eq_refl in
        let d := (snd pair) ::: yellows ++ stacks in
        Some (fst pair, regularize d _)
      end
    end
  end.

Next Obligation.
Proof.
  remember (snd (pop_helper pos lvl NotEmpty)) as lvl0 ; simpl.
  assert (Hgbr : green_between_reds stacks) by
    (simpl in p ;
    dependent destruction yellows ; destruct (Level.color lvl false) ;
    simpl in p ; firstorder).
  destruct pos;
  dependent destruction yellows ; destruct (Level.color lvl0 false) eqn:Hcol;
  try solve [ trivial | (split ; trivial) ] ; (split ; [ .. | trivial ]) ;
  subst lvl0 ; (
    apply Level.red_pop_iff_not_green in Hcol ||
    apply Level.red_eject_iff_not_green in Hcol
  ) ; deduce_next_green.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 B1 A2 B2 X : Universe, ((wd_ A1 B1 /\ (wd_ A2 B2 /\ (col_ X A1 B1 /\ (col_ X A2 B2 /\ (col_ A2 A1 B1 /\ col_ B2 A1 B1))))) -> col_ A1 A2 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Implicit Arguments.
Require Import FCF.FCF.

Local Open Scope list_scope.

Section Signature.

  Variable Message : Set.
  Variable Signature : Set.
  Variable PrivateKey : Set.
  Variable PublicKey : Set.

  Hypothesis Message_EqDec : EqDec Message.
  Hypothesis Signature_EqDec : EqDec Signature.

  Variable KeyGen : Comp (PrivateKey * PublicKey).
  Variable Sign : PrivateKey -> Message -> Comp Signature.
  Variable Verify : PublicKey -> Message -> Signature -> bool.

  Section UF_CMA.

    Definition SignOracle k state m :=
      sig <-$ Sign k m;
      ret (sig, m :: state).

    Variable A : PublicKey -> OracleComp Message Signature (Message * Signature).

    Definition UF_CMA_G :=
      [pri, pub] <-$2 KeyGen;
      [m, s, ls] <-$3 A pub _ _ (SignOracle pri) nil;
      ret (if (in_dec (EqDec_dec _) m ls) then false else
      (Verify pub m s)).

    Definition UF_CMA_Advantage :=
      Pr[UF_CMA_G].

  End UF_CMA.

End Signature.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 B1 A2 B2 X : Universe, ((wd_ A1 B1 /\ (wd_ A2 B2 /\ (col_ X A1 B1 /\ (col_ X A2 B2 /\ (col_ A2 A1 B1 /\ col_ B2 A1 B1))))) -> col_ B1 A2 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Lia Primitives Layer.

Record CoreRefinement {O_imp} (L_imp: Layer O_imp) (O_abs: Core) :=
  {
    compile_core : forall T, O_abs.(Core.operation) T -> L_imp.(prog) T;
    refines_core: L_imp.(state) -> O_abs.(Core.state) -> Prop;
    refines_reboot_core: L_imp.(state) -> O_abs.(Core.state) -> Prop;
    token_refines: forall T, user -> L_imp.(state) -> O_abs.(Core.operation) T ->
      (L_imp.(state) -> L_imp.(state)) -> L_imp.(oracle) -> O_abs.(Core.token) -> Prop;
    exec_compiled_preserves_refinement_finished_core :
      forall T (p2: O_abs.(Core.operation) T) o1 s1 s1' r u,
        (exists s2, refines_core s1 s2) ->
        L_imp.(exec) u o1 s1 (compile_core T p2) (Finished s1' r) ->
        (exists s2', refines_core s1' s2');
  }.

Record Refinement {O_imp O_abs} (L_imp: Layer O_imp) (L_abs: Layer O_abs) :=
  {
    compile : forall T, L_abs.(prog) T -> L_imp.(prog) T;
    refines: L_imp.(state) -> L_abs.(state) -> Prop;
    refines_reboot: L_imp.(state) -> O_abs.(Core.state) -> Prop;
    oracle_refines: forall T, user -> L_imp.(state) -> L_abs.(prog) T -> (L_imp.(state) -> L_imp.(state)) -> L_imp.(oracle) -> L_abs.(oracle) -> Prop;
    exec_compiled_preserves_refinement_finished :
      forall T (p2: L_abs.(prog) T) o1 s1 s1' r u,
        (exists s2, refines s1 s2) ->
        L_imp.(exec) u o1 s1 (compile T p2) (Finished s1' r) ->
        (exists s2', refines s1' s2');
  }.

Arguments Build_CoreRefinement {_ _ _}.
Arguments compile_core {_ _ _} _ {_}.
Arguments refines_core {_ _ _}.
Arguments refines_reboot_core {_ _ _}.
Arguments token_refines {_ _ _} _ {_}.
Arguments exec_compiled_preserves_refinement_finished_core {_ _ _}.

Arguments Build_Refinement {_ _ _ _}.
Arguments compile {_ _ _ _} _ {_}.
Arguments refines {_ _ _ _}.
Arguments refines_reboot {_ _ _ _}.
Arguments oracle_refines {_ _ _ _} _ {_}.
Arguments exec_compiled_preserves_refinement_finished {_ _ _ _}.

Section Relations.
  Variable O_imp O_abs: Core.
  Variable L_imp: Layer O_imp.
  Variable L_abs: Layer O_abs.
  Variable R : Refinement L_imp L_abs.

  Fixpoint recovery_oracles_refine {T}
           (u: user) (s: L_imp.(state)) (p_abs: L_abs.(prog) T) (rec_abs: L_abs.(prog) unit)
           (l_get_reboot_state_imp: list (L_imp.(state) -> L_imp.(state)))
           (lo_imp: list L_imp.(oracle)) (lo_abs: list L_abs.(oracle)) {struct lo_imp} :=
    match lo_imp, lo_abs with
    | o_imp :: loi, o_abs :: loa =>
      length lo_imp = length lo_abs /\
      ((exists s' t,
         L_imp.(exec) u o_imp s (R.(compile) p_abs) (Finished s' t) /\
         (forall grs_imp, R.(oracle_refines) u s p_abs grs_imp o_imp o_abs) /\
         loi = [] /\ loa = []) \/
      (exists s',
         L_imp.(exec) u o_imp s (R.(compile) p_abs) (Crashed s') /\
         match l_get_reboot_state_imp with
         | get_reboot_state_imp :: lgrsi =>
           R.(oracle_refines) u s p_abs get_reboot_state_imp o_imp o_abs /\
           recovery_oracles_refine u (get_reboot_state_imp s') rec_abs rec_abs lgrsi loi loa
         | _ => False
         end))
    | _, _ => False
    end.

Definition abstract_oracles_exist_wrt Rel (u: user) {T} (p_abs: L_abs.(prog) T) rec_abs l_get_reboot_state :=
  forall l_oi si si',
    (exists sa: L_abs.(state), Rel si sa) ->
    L_imp.(exec_with_recovery) u l_oi si l_get_reboot_state (R.(compile) p_abs) (R.(compile) rec_abs) si' ->
    exists l_oa, recovery_oracles_refine u si p_abs rec_abs l_get_reboot_state l_oi l_oa.

Definition abstract_oracles_exist_wrt_explicit Rel (u: user) {T} (p_abs: L_abs.(prog) T) rec_abs l_get_reboot_state l_oi si si' :=
    (exists sa: L_abs.(state), Rel si sa) ->
    L_imp.(exec_with_recovery) u l_oi si l_get_reboot_state (R.(compile) p_abs) (R.(compile) rec_abs) si' ->
    exists l_oa, recovery_oracles_refine u si p_abs rec_abs l_get_reboot_state l_oi l_oa.

(**
A relation that takes
   - two input states (si1 and si2),
   - a refinement realiton (refines), and
   - a relation (related_abs)
and asserts that
    - there are two other abstract states (sa1 and sa2) such that,
    - si1 (si2) refines to sa1 (sa2) via refines relation, and
    - sa1 and sa2 are related via related_abs
**)
  Definition refines_related
             (related_abs:  L_abs.(state) -> L_abs.(state) -> Prop)
             (si1 si2: L_imp.(state))
    : Prop :=
    exists (sa1 sa2: L_abs.(state)),
      R.(refines) si1 sa1 /\
      R.(refines) si2 sa2 /\
      related_abs sa1 sa2.

Definition refines_related_reboot
(related_abs:  L_abs.(state) -> L_abs.(state) -> Prop)
(si1 si2: L_imp.(state))
: Prop :=
exists (sa1 sa2: L_abs.(state)),
R.(refines_reboot) si1 sa1 /\
R.(refines_reboot) si2 sa2 /\
related_abs sa1 sa2.

Definition refines_valid
           (valid_state_abs: L_abs.(state) -> Prop)
           (si: L_imp.(state))
  : Prop :=
  forall (sa: L_abs.(state)),
    R.(refines) si sa ->
    valid_state_abs sa.

Definition exec_compiled_preserves_validity  {T} (u: user)(p_abs: L_abs.(prog) T) rec_abs l_get_reboot_state (valid_state: L_imp.(state) -> Prop) :=
    forall l_oi s ret,
      valid_state s ->
      L_imp.(exec_with_recovery) u l_oi s l_get_reboot_state (R.(compile) p_abs) (R.(compile) rec_abs) ret ->
      valid_state (extract_state_r ret).

Definition oracle_refines_same_from_related
            (u: user) {T} (p1_abs p2_abs: L_abs.(prog) T)
            rec_abs
            l_get_reboot_state_imp
           (related_states_abs: L_abs.(state) -> L_abs.(state) -> Prop) :=
  forall l_o_imp l_o_abs l_o_abs' s1_imp s2_imp,
    refines_related related_states_abs s1_imp s2_imp ->
    recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' ->
l_o_abs = l_o_abs'.

Definition oracle_refines_same_from_related_explicit
            (u: user) {T} (p1_abs p2_abs: L_abs.(prog) T)
            rec_abs
            l_get_reboot_state_imp
           (related_states_abs: L_abs.(state) -> L_abs.(state) -> Prop)
l_o_imp l_o_abs l_o_abs' s1_imp s2_imp :=
    refines_related related_states_abs s1_imp s2_imp ->
    recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' ->
l_o_abs = l_o_abs'.

Definition oracle_refines_same_from_related_reboot
            (u: user) {T} (p1_abs p2_abs: L_abs.(prog) T)
            rec_abs
            l_get_reboot_state_imp
           (related_states_abs: L_abs.(state) -> L_abs.(state) -> Prop) :=
  forall l_o_imp l_o_abs l_o_abs' s1_imp s2_imp,
    refines_related_reboot related_states_abs s1_imp s2_imp ->
    recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' ->
l_o_abs = l_o_abs'.

Definition oracle_refines_same_from_related_test
            (u: user) {T} (p1_abs p2_abs: L_abs.(prog) T)
            rec_abs
            l_get_reboot_state_imp
            l_get_reboot_state_abs
           (related_states_abs: L_abs.(state) -> L_abs.(state) -> Prop) :=
  forall l_o_imp l_o_abs l_o_abs' s1_imp s2_imp,
    refines_related related_states_abs s1_imp s2_imp ->
    recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' ->
(forall s1_abs ret1,
refines R s1_imp s1_abs ->
L_abs.(exec_with_recovery) u l_o_abs s1_abs l_get_reboot_state_abs p1_abs rec_abs ret1 ->
L_abs.(exec_with_recovery) u l_o_abs' s1_abs l_get_reboot_state_abs p1_abs rec_abs ret1).

Definition oracle_refines_same_from_related_test2
            (u: user) {T} (p1_abs p2_abs: L_abs.(prog) T)
            rec_abs
            l_get_reboot_state_imp
           (related_states_abs: L_abs.(state) -> L_abs.(state) -> Prop) :=
  forall l_o_imp l_o_abs l_o_abs' s1_imp s2_imp,
    refines_related related_states_abs s1_imp s2_imp ->
    recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' ->
    (recovery_oracles_refine u s1_imp p1_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs' \/
    recovery_oracles_refine u s2_imp p2_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs) .

    (** RDNI **)
(**
  valid_state: This predicate restrict the statement to "well-formed" states.
  valid_op: This predicate restrict programs to valid ones
  R: This is the actual simulation relation
**)

Definition RDNI (u: user) {T} (p1 p2: L_abs.(prog) T)
       (rec: L_abs.(prog) unit)
       (valid_state: L_abs.(state) -> Prop)
       (R: L_abs.(state) -> L_abs.(state) -> Prop)
       (cond: user -> Prop)
       l_get_reboot_state :=
  forall lo s1 s1',
    L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
    valid_state s1 ->
    forall s2,
    valid_state s2 ->
    R s1 s2 ->
    exists s2',
      L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2' /\
      R (extract_state_r s1') (extract_state_r s2') /\
      (cond u -> extract_ret_r s1' = extract_ret_r s2') /\
      valid_state (extract_state_r s1') /\
      valid_state (extract_state_r s2').

Definition Termination_Sensitive u {T} (p1 p2: L_abs.(prog) T)
           (rec: L_abs.(prog) unit)
           (valid_state: L_abs.(state) -> Prop)
           (R: L_abs.(state) -> L_abs.(state) -> Prop)
           l_get_reboot_state :=
  forall s1 s1' s2 lo,
    valid_state s1 ->
    valid_state s2 ->
    L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
    R s1 s2 ->
    exists s2',
      L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2'.

Definition RDNI_Weak u {T} (p1 p2: L_abs.(prog) T)
           (rec: L_abs.(prog) unit)
           (valid_state: L_abs.(state) -> Prop)
           (REL: L_abs.(state) -> L_abs.(state) -> Prop)
           (cond: user -> Prop)
           l_get_reboot_state :=
  forall lo s1 s1' s2 s2',
    L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
    L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2' ->
    valid_state s1 ->
    valid_state s2 ->
    REL s1 s2 ->
    REL (extract_state_r s1') (extract_state_r s2') /\
    (cond u -> extract_ret_r s1' = extract_ret_r s2') /\
    valid_state (extract_state_r s1') /\
    valid_state (extract_state_r s2').

Lemma RDNI_Weak_to_RDNI:
  forall u T (p1 p2: L_abs.(prog) T) R
    valid_state rec cond l_get_reboot_state,

    Termination_Sensitive u p1 p2 rec valid_state R l_get_reboot_state ->
    RDNI_Weak u p1 p2 rec valid_state R cond l_get_reboot_state ->

    RDNI u p1 p2 rec valid_state R cond l_get_reboot_state.
Proof.
  unfold Termination_Sensitive, RDNI_Weak, RDNI; intros.
  edestruct H.
  3: eauto.
  all: eauto.
Qed.

Theorem RDNI_to_RDNIW:
forall u R V T (p1 p2: L_abs.(prog) T) rec cond l_grs,
 RDNI u p1 p2 rec V R cond l_grs ->
 RDNI_Weak u p1 p2 rec V R cond l_grs.
 Proof.
   unfold RDNI_Weak; intros.
   edestruct H; eauto.
   destruct H5.
   eapply exec_with_recovery_deterministic_wrt_reboot_state in H1; eauto.
   subst; eauto.
Qed.

Definition RDNI_explicit (u: user) lo s1 s2 {T} (p1 p2: L_abs.(prog) T)
       (rec: L_abs.(prog) unit)
       (valid_state: L_abs.(state) -> Prop)
       (R: L_abs.(state) -> L_abs.(state) -> Prop)
       (cond: user -> Prop)
       l_get_reboot_state :=
  forall s1',
    L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
    valid_state s1 ->
    valid_state s2 ->
    R s1 s2 ->
    exists s2',
      L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2' /\
      R (extract_state_r s1') (extract_state_r s2') /\
      (cond u -> extract_ret_r s1' = extract_ret_r s2') /\
      valid_state (extract_state_r s1') /\
      valid_state (extract_state_r s2').

Definition Termination_Sensitive_explicit u lo s1 s2 {T} (p1 p2: L_abs.(prog) T)
      (rec: L_abs.(prog) unit)
      (valid_state: L_abs.(state) -> Prop)
      (R: L_abs.(state) -> L_abs.(state) -> Prop)
      l_get_reboot_state :=
forall s1',
valid_state s1 ->
valid_state s2 ->
L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
R s1 s2 ->
exists s2',
 L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2'.

 Definition RDNI_Weak_explicit u lo s1 s2 {T} (p1 p2: L_abs.(prog) T)
           (rec: L_abs.(prog) unit)
           (valid_state: L_abs.(state) -> Prop)
           (R: L_abs.(state) -> L_abs.(state) -> Prop)
           (cond: user -> Prop)
           l_get_reboot_state :=
  forall s1' s2',
    L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state p1 rec s1' ->
    L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state p2 rec s2' ->
    valid_state s1 ->
    valid_state s2 ->
    R s1 s2 ->
    R (extract_state_r s1') (extract_state_r s2') /\
    (cond u -> extract_ret_r s1' = extract_ret_r s2') /\
    valid_state (extract_state_r s1') /\
    valid_state (extract_state_r s2').

Lemma RDNI_explicit_state_iff_RDNI:
  forall u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_abs
      (equivalent_states_abs : state L_abs -> state L_abs -> Prop)
      valid_state_abs
      cond,

    (forall lo s1 s2,
    equivalent_states_abs s1 s2 ->
    RDNI_explicit
      u lo s1 s2
      p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs) <->

    RDNI
      u
      p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs.
Proof.
  unfold RDNI, RDNI_explicit; intros.
  intuition; try eapply H; eauto.
Qed.

Lemma RDNI_Weak_explicit_to_RDNI_explicit:
  forall u T (p1 p2: L_abs.(prog) T) R
    valid_state rec cond l_get_reboot_state lo s1 s2,

    Termination_Sensitive_explicit u lo s1 s2 p1 p2 rec valid_state R l_get_reboot_state ->
    RDNI_Weak_explicit u lo s1 s2 p1 p2 rec valid_state R cond l_get_reboot_state ->

    RDNI_explicit u lo s1 s2 p1 p2 rec valid_state R cond l_get_reboot_state.
Proof.
  unfold Termination_Sensitive_explicit, RDNI_Weak_explicit, RDNI_explicit; intros.
  edestruct H.
  3: eauto.
  all: eauto.
Qed.

(** Simulation **)
Definition SimulationForProgramGeneral
           u T (p_abs: L_abs.(prog) T) (rec_abs : L_abs.(prog) unit)
           l_get_reboot_state_imp
           l_get_reboot_state_abs
           R_begin R_end :=
  forall l_o_imp l_o_abs s_imp s_abs,
    recovery_oracles_refine u s_imp p_abs rec_abs l_get_reboot_state_imp l_o_imp l_o_abs ->
    R_begin s_imp s_abs ->

    (forall s_imp',
       L_imp.(exec_with_recovery) u l_o_imp s_imp
        l_get_reboot_state_imp (R.(compile) p_abs)
        (R.(compile) rec_abs) s_imp' ->
       exists s_abs',
         L_abs.(exec_with_recovery) u l_o_abs s_abs l_get_reboot_state_abs p_abs rec_abs s_abs' /\
         R_end (extract_state_r s_imp') (extract_state_r s_abs') /\
         extract_ret_r s_imp' = extract_ret_r s_abs'
    ).

 Definition SimulationForProgram u T (p_abs: L_abs.(prog) T) (rec_abs : L_abs.(prog) unit)
           l_get_reboot_state_imp
           l_get_reboot_state_abs :=
    SimulationForProgramGeneral u T p_abs rec_abs l_get_reboot_state_imp l_get_reboot_state_abs R.(refines) R.(refines).

Definition Simulation rec_abs l_get_reboot_state_imp l_get_reboot_state_abs
    := forall u T (p_abs: L_abs.(prog) T),
         SimulationForProgram u T p_abs rec_abs l_get_reboot_state_imp l_get_reboot_state_abs.

Lemma RDNI_explicit_state_and_inject:
         forall u T (p1_abs p2_abs: L_abs.(prog) T)
             rec_abs
             l_get_reboot_state_abs
             (equivalent_states_abs1
             equivalent_states_abs2 : state L_abs -> state L_abs -> Prop)
             valid_state_abs
             cond lo s1 s2,

          ( equivalent_states_abs2 s1 s2 ->
           RDNI_explicit
             u lo s1 s2
             p1_abs p2_abs
             rec_abs
             valid_state_abs
             (fun s1 s2 => equivalent_states_abs1 s1 s2)
             cond
             l_get_reboot_state_abs) ->

            (forall lo s1' s2',
            equivalent_states_abs2 s1 s2 ->
            L_abs.(exec_with_recovery) u lo s1 l_get_reboot_state_abs p1_abs rec_abs s1' ->
            L_abs.(exec_with_recovery) u lo s2 l_get_reboot_state_abs p2_abs rec_abs s2' ->
            equivalent_states_abs2 (extract_state_r s1') (extract_state_r s2')) ->

           RDNI_explicit
             u lo s1 s2
             p1_abs p2_abs
             rec_abs
             valid_state_abs
             (fun s1 s2 => equivalent_states_abs1 s1 s2 /\ equivalent_states_abs2 s1 s2)
             cond
             l_get_reboot_state_abs.
       Proof.
         unfold RDNI_explicit; intros.
         cleanup; edestruct H; eauto.
         cleanup.
         eexists; intuition eauto.
    Qed.

    Lemma RDNI_explicit_state_and_extract:
    forall u T (p1_abs p2_abs: L_abs.(prog) T)
        rec_abs
        l_get_reboot_state_abs
        (equivalent_states_abs1
        equivalent_states_abs2 : state L_abs -> state L_abs -> Prop)
        valid_state_abs
        cond lo s1 s2,

        RDNI_explicit
        u lo s1 s2
        p1_abs p2_abs
        rec_abs
        valid_state_abs
        (fun s1 s2 => equivalent_states_abs1 s1 s2 /\ equivalent_states_abs2 s1 s2)
        cond
        l_get_reboot_state_abs ->

        equivalent_states_abs2 s1 s2 ->

      RDNI_explicit
        u lo s1 s2
        p1_abs p2_abs
        rec_abs
        valid_state_abs
        (fun s1 s2 => equivalent_states_abs1 s1 s2)
        cond
        l_get_reboot_state_abs.
  Proof.
    unfold RDNI_explicit; intros.
    cleanup; edestruct H; eauto.
    cleanup.
    eexists; intuition eauto.
Qed.

End Relations.

Arguments recovery_oracles_refine {_ _ _ _} _ {_}.
Arguments refines_related {_ _ _ _}.
Arguments refines_valid {_ _ _ _}.
Arguments exec_compiled_preserves_validity {_ _ _ _} _ {_}.
Arguments abstract_oracles_exist_wrt {_ _ _ _} _ _ _ {_}.
Arguments abstract_oracles_exist_wrt_explicit {_ _ _ _} _ _ _ {_}.
Arguments oracle_refines_same_from_related {_ _ _ _} _ _ {_}.
Arguments RDNI {_ _} _ {_}.
Arguments RDNI_Weak {_ _} _ {_}.
Arguments Termination_Sensitive {_ _} _ {_}.

Arguments RDNI_explicit {_ _} _ _ _ _ {_}.
Arguments RDNI_Weak_explicit {_ _} _ _ _ _ {_}.
Arguments Termination_Sensitive_explicit {_ _} _ _ _ _ {_}.

Arguments Simulation {_ _ _ _}.
Arguments SimulationForProgram {_ _ _ _} _ _ {_}.

Arguments oracle_refines_same_from_related_explicit {_ _ _ _} _ _ {_}.
Arguments oracle_refines_same_from_related_test2 {_ _ _ _} _ _ {_}.

(*
Lemma ORS_prefix_explicit_to_ORS_explicit:
forall O_imp O_abs (L_imp: Layer O_imp)
(L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
u T (p1_abs p2_abs: L_abs.(prog) T)
  rec_abs
  l_get_reboot_state_imp
  l_get_reboot_state_abs
equivalent_states_abs
  l_o_imp
  l_o_abs1 l_o_abs2
  s1_imp s2_imp
  s1_abs s2_abs
  s1_abs' s2_abs',

(forall l_o_imp1 l_o_imp2,
oracle_refines_same_from_related_prefix_explicit R u
p1_abs
p2_abs
rec_abs
l_get_reboot_state_imp
equivalent_states_abs
l_o_imp1 l_o_imp2
l_o_abs1 l_o_abs2
s1_imp s2_imp) ->

(forall l_o_abs1 l_o_abs2 s1_abs s2_abs s1_abs' s2_abs',
(equivalent_states_abs s1_abs s2_abs ->
L_abs.(exec_with_recovery) u l_o_abs1 s1_abs l_get_reboot_state_abs p1_abs rec_abs s1_abs' ->
L_abs.(exec_with_recovery) u l_o_abs2 s2_abs l_get_reboot_state_abs p2_abs rec_abs s2_abs' ->
results_match_r s1_abs' s2_abs' ->
Forall2 (fun o_abs1 o_abs2 => exists oa1 oa2, o_abs1 ++ oa1 = o_abs2 ++ oa2) l_o_abs1 l_o_abs2->
l_o_abs1 = l_o_abs2)) ->

R.(refines) s1_imp s1_abs ->
R.(refines) s2_imp s2_abs ->
equivalent_states_abs s1_abs s2_abs ->
L_abs.(exec_with_recovery) u l_o_abs1 s1_abs l_get_reboot_state_abs p1_abs rec_abs s1_abs' ->
L_abs.(exec_with_recovery) u l_o_abs2 s2_abs l_get_reboot_state_abs p2_abs rec_abs s2_abs' ->
results_match_r s1_abs' s2_abs' ->

oracle_refines_same_from_related_explicit R u
p1_abs
p2_abs
rec_abs
l_get_reboot_state_imp
equivalent_states_abs
l_o_imp
  l_o_abs1 l_o_abs2
  s1_imp s2_imp.
Proof.
  unfold oracle_refines_same_from_related_explicit,
  oracle_refines_same_from_related_prefix_explicit; intros.
  eapply_fresh H in H8; eauto.
  eapply forall_forall2; eauto.
  eapply Forall_forall; intros.
  apply in_combine_same in H10; cleanup; eauto.
  Unshelve.
  constructor.
Qed.
*)

Lemma RDNI_transfer_test2:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond,

    RDNI
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    abstract_oracles_exist_wrt R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp ->
    abstract_oracles_exist_wrt R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp ->

    oracle_refines_same_from_related_test2 R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    Termination_Sensitive u (compile R p1_abs)
    (compile R p2_abs) (compile R rec_abs)
    (refines_valid R valid_state_abs)
    (refines_related R equivalent_states_abs)
    l_get_reboot_state_imp ->

    RDNI
      u (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.
  intros.
  (** Convert to weak self_simulation **)
  eapply RDNI_Weak_to_RDNI; eauto.
  unfold RDNI_Weak; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt _ _ _ ?p1 _ _,
     H2: abstract_oracles_exist_wrt _ _ _ ?p2 _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: oracle_refines_same_from_related_test2 _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.
  split_ors.
  {
    match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  (** Use self_simulation to generate second abs execution from s2 **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p1_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ _ _ _,
     H1: RDNI _ _ _ _ _ _ _ _,
     H2: equivalent_states_abs _ _ |- _ ] =>
    eapply_fresh H1 in H;
    specialize Hx with (3:= H2); edestruct Hx;
    eauto; cleanup
  end.

  (** Show two executions are the same **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p2_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ p2_abs _ _ |- _ ] =>
    eapply exec_with_recovery_deterministic_wrt_reboot_state in H;
    eauto; cleanup
  end.

  repeat (split; eauto).
  }
  {
  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  (** Use self_simulation to generate second abs execution from s2 **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p1_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ _ _ _,
     H1: RDNI _ _ _ _ _ _ _ _,
     H2: equivalent_states_abs _ _ |- _ ] =>
    eapply_fresh H1 in H;
    specialize Hx with (3:= H2); edestruct Hx;
    eauto; cleanup
  end.

  (** Show two executions are the same **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p2_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ p2_abs _ _ |- _ ] =>
    eapply exec_with_recovery_deterministic_wrt_reboot_state in H;
    eauto; cleanup
  end.

  repeat (split; eauto).
  }
Qed.

(*
Lemma ORS_to_ORST:
forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
u T (p1_abs p2_abs: L_abs.(prog) T)
  rec_abs
  l_get_reboot_state_imp
  l_get_reboot_state_abs
  equivalent_states_abs,
oracle_refines_same_from_related R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->
oracle_refines_same_from_related_test R u p1_abs p2_abs rec_abs l_get_reboot_state_imp l_get_reboot_state_abs equivalent_states_abs.
Proof.
  unfold oracle_refines_same_from_related, oracle_refines_same_from_related_test; intros.
  eapply H in H0; eauto.
  subst; eauto.
Qed.
*)

Lemma RDNI_transfer:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond,

    RDNI
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    abstract_oracles_exist_wrt R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp ->
    abstract_oracles_exist_wrt R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp ->

    oracle_refines_same_from_related R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    Termination_Sensitive u (compile R p1_abs)
    (compile R p2_abs) (compile R rec_abs)
    (refines_valid R valid_state_abs)
    (refines_related R equivalent_states_abs)
    l_get_reboot_state_imp ->

    RDNI
      u (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.
  intros.
  (** Convert to weak self_simulation **)
  eapply RDNI_Weak_to_RDNI; eauto.
  unfold RDNI_Weak; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt _ _ _ ?p1 _ _,
     H2: abstract_oracles_exist_wrt _ _ _ ?p2 _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: oracle_refines_same_from_related _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  (** Use self_simulation to generate second abs execution from s2 **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p1_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ _ _ _,
     H1: RDNI _ _ _ _ _ _ _ _,
     H2: equivalent_states_abs _ _ |- _ ] =>
    eapply_fresh H1 in H;
    specialize Hx with (3:= H2); edestruct Hx;
    eauto; cleanup
  end.

  (** Show two executions are the same **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p2_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ p2_abs _ _ |- _ ] =>
    eapply exec_with_recovery_deterministic_wrt_reboot_state in H;
    eauto; cleanup
  end.

  repeat (split; eauto).
Qed.

Lemma RDNI_compositional:
  forall O (L: Layer O) u
  T (p1 p2: L.(prog) T) T' (p3 p4: T -> L.(prog) T')
      rec
      l_get_reboot_state3
      equivalent_states valid_state
      cond1 cond2,

    (forall l_get_reboot_state1,
    RDNI
      u p1 p2
      rec
      valid_state
      equivalent_states
      cond1
      l_get_reboot_state1) ->

    (forall l_get_reboot_state2 t t',
    RDNI
      u (p3 t) (p4 t')
      rec
      valid_state
      equivalent_states
      cond2
      l_get_reboot_state2) ->

      RDNI
      u (Bind p1 p3) (Bind p2 p4)
      rec
      valid_state
      equivalent_states
      (fun u => cond1 u /\ cond2 u)
      l_get_reboot_state3.
Proof.

  unfold RDNI;
  intros; simpl in *.
  repeat invert_exec.
  {
    invert_exec'' H13.

    edestruct H.
    4: eauto.
    repeat econstructor; eauto.
    all: eauto.
    cleanup.
    simpl in *.
    invert_exec; simpl in *.

    edestruct H0.
    4: eauto.
    eapply ExecFinished; eauto.
    all: eauto.
    cleanup.
    simpl in *.

    repeat invert_exec.
    exists (RFinished
    d'1 t1).
    intuition eauto.
    simpl in *.
    repeat econstructor; eauto.
  }
  {
    invert_exec'' H12.
    {
        edestruct H.
        4: eauto.
        repeat econstructor; eauto.
        all: eauto.
        cleanup.
        simpl in *.
        invert_exec; simpl in *.

        edestruct H0.
        4: eauto.
        eapply ExecRecovered; eauto.
        all: eauto.
        cleanup; simpl in *.

        repeat invert_exec.
        exists (Recovered (extract_state_r ret0)).
        intuition eauto.
        simpl in *.
        repeat econstructor; eauto.
    }
    {
      edestruct H.
      4: eauto.
      eapply ExecRecovered; eauto.
      all: eauto.
      cleanup.
      simpl in *.
      repeat invert_exec.
        exists (Recovered (extract_state_r ret0)).
        intuition eauto.
        simpl in *.
        econstructor; eauto.
        eapply ExecBindCrash; eauto.
    }
  }
Qed.

Lemma RDNI_explicit_transfer:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond l_o s1_imp s2_imp,

    RDNI
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp l_o s1_imp s_abs)->
    (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp l_o s2_imp s_abs)->

    oracle_refines_same_from_related R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    Termination_Sensitive_explicit u l_o s1_imp s2_imp
    (compile R p1_abs)
    (compile R p2_abs) (compile R rec_abs)
    (refines_valid R valid_state_abs)
    (refines_related R equivalent_states_abs)
    l_get_reboot_state_imp ->

    RDNI_explicit
      u l_o s1_imp s2_imp
      (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  eapply RDNI_Weak_explicit_to_RDNI_explicit; eauto.
  unfold RDNI_Weak_explicit; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  specialize (H2 s1').
  specialize (H3 s2').
  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt_explicit _ _ _ ?p1 _ _ _ _ _,
     H2: abstract_oracles_exist_wrt_explicit _ _ _ ?p2 _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: oracle_refines_same_from_related _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  (** Use self_simulation to generate second abs execution from s2 **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p1_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ _ _ _,
     H1: RDNI _ _ _ _ _ _ _ _,
     H2: equivalent_states_abs _ _ |- _ ] =>
    eapply_fresh H1 in H;
    specialize Hx with (3:= H2); edestruct Hx;
    eauto; cleanup
  end.

  (** Show two executions are the same **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p2_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ p2_abs _ _ |- _ ] =>
    eapply exec_with_recovery_deterministic_wrt_reboot_state in H;
    eauto; cleanup
  end.

  repeat (split; eauto).
Qed.

Lemma RDNI_explicit_transfer_2:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond l_o s1_imp s2_imp,

    RDNI
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp l_o s1_imp s_abs)->
    (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp l_o s2_imp s_abs)->

    (forall l_o_abs1 l_o_abs2, oracle_refines_same_from_related_explicit R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs l_o l_o_abs1 l_o_abs2 s1_imp s2_imp) ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    Termination_Sensitive_explicit u l_o s1_imp s2_imp
    (compile R p1_abs)
    (compile R p2_abs) (compile R rec_abs)
    (refines_valid R valid_state_abs)
    (refines_related R equivalent_states_abs)
    l_get_reboot_state_imp ->

    RDNI_explicit
      u l_o s1_imp s2_imp
      (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  eapply RDNI_Weak_explicit_to_RDNI_explicit; eauto.
  unfold RDNI_Weak_explicit; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  specialize (H2 s1').
  specialize (H3 s2').
  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt_explicit _ _ _ ?p1 _ _ _ _ _,
     H2: abstract_oracles_exist_wrt_explicit _ _ _ ?p2 _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: forall _ _, oracle_refines_same_from_related_explicit _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  (** Use self_simulation to generate second abs execution from s2 **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p1_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ _ _ _,
     H1: RDNI _ _ _ _ _ _ _ _,
     H2: equivalent_states_abs _ _ |- _ ] =>
    eapply_fresh H1 in H;
    specialize Hx with (3:= H2); edestruct Hx;
    eauto; cleanup
  end.

  (** Show two executions are the same **)
  match goal with
  | [H: exec_with_recovery L_abs _ _ _ _ p2_abs _ _,
     H0: exec_with_recovery L_abs _ _ _ _ p2_abs _ _ |- _ ] =>
    eapply exec_with_recovery_deterministic_wrt_reboot_state in H;
    eauto; cleanup
  end.

  repeat (split; eauto).
Qed.

(** If you don't care about termination, then you don't need Termination_Sensitive **)
Lemma RDNIW_transfer:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond,

    RDNI_Weak
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    abstract_oracles_exist_wrt R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp ->
    abstract_oracles_exist_wrt R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp ->

    oracle_refines_same_from_related R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    RDNI_Weak
      u (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  unfold RDNI_Weak; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt _ _ _ ?p1 _ _,
     H2: abstract_oracles_exist_wrt _ _ _ ?p2 _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: oracle_refines_same_from_related _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  edestruct H; eauto.
  do 2 eexists; intuition eauto.
Qed.

Lemma RDNIW_transfer_test2:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond,

    RDNI_Weak
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    abstract_oracles_exist_wrt R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp ->
    abstract_oracles_exist_wrt R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp ->

    oracle_refines_same_from_related_test2 R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    RDNI_Weak
      u (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  unfold RDNI_Weak; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: abstract_oracles_exist_wrt _ _ _ ?p1 _ _,
     H2: abstract_oracles_exist_wrt _ _ _ ?p2 _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: oracle_refines_same_from_related_test2 _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.
  split_ors.
  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  edestruct H; eauto.
  do 2 eexists; intuition eauto.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  edestruct H; eauto.
  do 2 eexists; intuition eauto.
Qed.

Lemma RDNIW_explicit_transfer:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      valid_state_abs
      cond lo s1 s2,

    RDNI_Weak
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

      (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp lo s1 s_abs)->
      (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp lo s2 s_abs)->

      (forall l_o_abs1 l_o_abs2, oracle_refines_same_from_related_explicit R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs lo l_o_abs1 l_o_abs2 s1 s2) ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    RDNI_Weak_explicit
      u lo s1 s2
      (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (refines_related R equivalent_states_abs)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  unfold RDNI_Weak_explicit; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: forall _, abstract_oracles_exist_wrt_explicit _ _ _ ?p1 _ _ _ _ _,
     H2: forall _, abstract_oracles_exist_wrt_explicit _ _ _ ?p2 _ _ _ _ _|- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: forall _ _, oracle_refines_same_from_related_explicit _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  edestruct H; eauto.
  do 2 eexists; intuition eauto.
Qed.

Lemma RDNIW_explicit_transfer_2:
  forall O_imp O_abs (L_imp: Layer O_imp) (L_abs: Layer O_abs) (R: Refinement L_imp L_abs)
    u T (p1_abs p2_abs: L_abs.(prog) T)
      rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs
      equivalent_states_abs
      (P: _ -> _ -> Prop)
      valid_state_abs
      cond lo s1 s2,

    RDNI_Weak
      u p1_abs p2_abs
      rec_abs
      valid_state_abs
      equivalent_states_abs
      cond
      l_get_reboot_state_abs ->

    SimulationForProgram R u p1_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

    SimulationForProgram R u p2_abs rec_abs
      l_get_reboot_state_imp
      l_get_reboot_state_abs ->

      (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p1_abs rec_abs l_get_reboot_state_imp lo s1 s_abs)->
      (forall s_abs, abstract_oracles_exist_wrt_explicit R R.(refines) u p2_abs rec_abs l_get_reboot_state_imp lo s2 s_abs)->

      (forall l_o_abs1 l_o_abs2, oracle_refines_same_from_related_explicit R u p1_abs p2_abs rec_abs l_get_reboot_state_imp equivalent_states_abs lo l_o_abs1 l_o_abs2 s1 s2) ->

    exec_compiled_preserves_validity R
    u p1_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    exec_compiled_preserves_validity R
    u p2_abs rec_abs l_get_reboot_state_imp
    (refines_valid R valid_state_abs) ->

    (forall s1' s2',
    refines_related R equivalent_states_abs s1 s2 ->
    P s1 s2 ->
    exec_with_recovery L_imp u lo s1 l_get_reboot_state_imp
       (compile R p1_abs) (compile R rec_abs) s1' ->
    exec_with_recovery L_imp u lo s2 l_get_reboot_state_imp
       (compile R p2_abs) (compile R rec_abs) s2' ->
    P (extract_state_r s1') (extract_state_r s2')) ->

    RDNI_Weak_explicit
      u lo s1 s2
      (R.(compile) p1_abs)
      (R.(compile) p2_abs)
      (R.(compile) rec_abs)
      (refines_valid R valid_state_abs)
      (fun s1 s2 => refines_related R equivalent_states_abs s1 s2 /\ P s1 s2)
      cond
      l_get_reboot_state_imp.
Proof.

  intros.
  (** Convert to weak self_simulation **)
  unfold RDNI_Weak_explicit; simpl; intros.

  (** Construct abs oracles **)
  (* unfold refines_valid, refines_related in *; cleanup. *)

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: forall _, abstract_oracles_exist_wrt_explicit _ _ _ ?p1 _ _ _ _ _,
     H2: forall _, abstract_oracles_exist_wrt_explicit _ _ _ ?p2 _ _ _ _ _|- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup;
    try solve [ unfold refines_valid, refines_related in *; cleanup; eauto]
  end.

  match goal with
  | [H: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H0: recovery_oracles_refine _ _ _ _ _ _ _ _,
     H1: forall _ _, oracle_refines_same_from_related_explicit _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] =>
    eapply_fresh H1 in H0; eauto; cleanup
  end.

  (** Construct abs executions **)
  unfold refines_related in *; cleanup.

  match goal with
  | [H: exec_with_recovery _ _ _ _ _ (compile _ ?p1) _ _,
     H0: exec_with_recovery _ _ _ _ _ (compile _ ?p2) _ _,
     H1: SimulationForProgram _ _ ?p1 _ _ _,
     H2: SimulationForProgram _ _ ?p2 _ _ _ |- _ ] =>
    eapply_fresh H1 in H; eauto; cleanup;
    eapply_fresh H2 in H0; eauto; cleanup
  end.
  simpl in *; cleanup.

  edestruct H; eauto.
  do 2 eexists; intuition eauto.
  eapply H7; eauto.
Qed.


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

Require Export NBase.

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

(** For theorems about [add] that are both valid for [N] and [Z], see [NZAdd] *)
(** Now comes theorems valid for natural numbers but not for Z *)

Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0.
Proof.
intros n m; induct n.
nzsimpl; intuition.
intros n IH. nzsimpl.
setoid_replace (S (n + m) == 0) with False by
 (apply neg_false; apply neq_succ_0).
setoid_replace (S n == 0) with False by
 (apply neg_false; apply neq_succ_0). tauto.
Qed.

Theorem eq_add_succ :
  forall n m, (exists p, n + m == S p) <->
              (exists n', n == S n') \/ (exists m', m == S m').
Proof.
intros n m; cases n.
split; intro H.
destruct H as [p H]. rewrite add_0_l in H; right; now exists p.
destruct H as [[n' H] | [m' H]].
symmetry in H; false_hyp H neq_succ_0.
exists m'; now rewrite add_0_l.
intro n; split; intro H.
left; now exists n.
exists (n + m); now rewrite add_succ_l.
Qed.

Theorem eq_add_1 : forall n m,
  n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1.
Proof.
intros n m. rewrite one_succ. intro H.
assert (H1 : exists p, n + m == S p) by now exists 0.
apply eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]].
left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H.
apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split.
right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H.
apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split.
Qed.

Theorem succ_add_discr : forall n m, m ~= S (n + m).
Proof.
intro n; induct m.
apply neq_sym. apply neq_succ_0.
intros m IH H. apply succ_inj in H. rewrite add_succ_r in H.
unfold not in IH; now apply IH.
Qed.

Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m).
Proof.
intros n m; cases n.
intro H; now elim H.
intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ.
Qed.

Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m).
Proof.
intros n m H; rewrite (add_comm n (P m));
rewrite (add_comm n m); now apply add_pred_l.
Qed.

End NAddProp.


Require Export ProjectiveGeometry.Dev.desargues_2D_lemmasV3.
Require Export ProjectiveGeometry.Dev.desargues_3D_special.

(*****************************************************************************)
(** Proof of Desargues in 2D **)

Section s_desargues2D.

Context `{RPSOH : RankProjectiveSpaceOrHigher}.
Context `{EP : EqDecidability Point}.

Variables A' B' C' : Point.
Variables A B C : Point.

Variables O : Point.

Variable rABC : rk(triple A B C)=3.
Variable rA'B'C' : rk(triple A' B' C')=3.
Variable rABCA'B'C'O : rk(union (triple A B C) (union (triple A' B' C') (singleton O)))=3.

Variable rABO : rk(triple A B O)=3.
Variable rACO :rk(triple A C O)=3.
Variable rBCO : rk (triple B C O)=3.

Variable rAA'O : rk(triple A A' O)=2.
Variable rBB'O : rk(triple B B' O)=2.
Variable rCC'O : rk(triple C C' O)=2.

Variable rA'O : rk(couple A' O)=2.
Variable rB'O : rk(couple B' O)=2.
Variable rC'O : rk(couple C' O)=2.

Lemma rA'B'O' : rk(triple A' B' O)=3.
Proof.
eapply (l1_scheme A' B' A B O); try assumption.
Qed.

Lemma rA'C'O' :rk(triple A' C' O)=3.
Proof.
eapply (l1_scheme A' C' A C O); try assumption.
Qed.

Lemma rB'C'O' : rk (triple B' C' O)=3.
Proof.
eapply (l1_scheme B' C' B C O); try assumption.
Qed.

Hint Resolve rA'B'O' rA'C'O' rB'C'O' : rk.

(* all points are distinct, especially ABC A'B'C and O *)
(* If needed, for any 2 points, rk(X,Y)=2 *)
(* triangles are truely perspective in the plane *)

Variable rAA' : rk(couple A A')=2.
Variable rBB' : rk(couple B B')=2.
Variable rCC' : rk(couple C C')=2.

Variables alpha beta gamma : Point.

Variable rABgamma : rk(triple A B gamma)=2.
Variable rA'B'gamma : rk(triple A' B' gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable rA'C'beta : rk(triple A' C' beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rB'C'alpha : rk(triple B' C' alpha) =2.

Lemma Desargues_plane : rk (triple alpha beta gamma) <= 2.
Proof.
elim (l2rABOP A' B' C' A B C O); try assumption.
intros P (rABOP, rOP).
elim (ex_o O P).
intros o (rOPo,(rOo, rPo)).
setoid_replace (triple O P o) with (triple o O P) in rOPo by (clear_all;fsetdecide).
assert (T:exists a : Point, rk (triple o A a) = 2 /\ rk (triple P A' a) = 2).
eapply (ra A' B' C' A B C O);solve [eauto with rk].
elim T;intros a (Ha2,Ha2');clear T.
assert (Tb:exists b : Point, rk (triple o B b) = 2 /\ rk (triple P B' b) = 2).
eapply (rb A' B' C' A B C O);solve [eauto with rk].
elim Tb;intros b (Hb2,Hb2');clear Tb.
assert (Tc:exists c : Point, rk (triple o C c) = 2 /\ rk (triple P C' c) = 2).
eapply rc;solve [eauto with rk].
elim Tc;intros c (Hc2,Hc2');clear Tc.
(* we prove r(a,b,c)=3 in advance, so we can reuse it in subsequent sections of the proof *)
assert (rabc3:rk(triple a b c)=3).
apply le_antisym.
apply rk_triple_le.
assert (rk (union (triple a b c) (couple o A))>=4).
generalize (matroid3 (union (triple a b c) (couple o A)) (triple o B b)).
setoid_replace (union (union (triple a b c) (couple o A)) (triple o B b)) with
(union (triple a b c) (triple o A B)) by (unfold Equal; split; (clear_all;fsetdecide)).
assert (rk(union (triple a b c) (triple o A B))>=4).
generalize (matroid3 (union (triple a b c) (triple o A B)) (triple o C c)).
assert (rk (union (union (triple a b c) (triple o A B)) (triple o C c)) >=4).
assert (rk (add c (triple A B C)) >=4).
generalize (rABOc A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O' rA'C'O'
            rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o); intro Hr.
assert (rk (add c (triple A B C)) >= 4).
setoid_replace (triple A B C) with (triple C B A) by (clear_all;fsetdecide).
apply (rk3_4 O B A C c).
apply le_antisym.
assert (rk (union (triple A B C) (union (triple A' B' C') (singleton O))) >= rk (add C (triple O B A))).
apply matroid2; (clear_all;fsetdecide).
omega.
assert (rk(triple A B C)<=rk(add C (triple O B A))).
apply matroid2; (clear_all;fsetdecide).
omega.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide).
assumption.
setoid_replace (triple O B A) with (triple A B O) by (clear_all;fsetdecide).
eapply Hr; try eassumption.
omega.
assert (rk (union (union (triple a b c) (triple o A B)) (triple o C c)) >=rk (add c (triple A B C))).
apply matroid2; (clear_all;fsetdecide).
omega.
assert (rk (inter (union (triple a b c) (triple o A B)) (triple o C c)) >=
rk (couple o c)).
apply matroid2;(clear_all;fsetdecide).
assert (rk (couple o c)>=2).
setoid_replace (couple o c) with (couple c o) by (clear_all;fsetdecide).
generalize (rco A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O'
            rA'C'O' rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o rOPo rOo rPo c Hc2 Hc2'); omega.
omega.
assert (rk(inter (union (triple a b c) (couple o A)) (triple o B b))>=rk(couple o b)).
apply matroid2; (clear_all;fsetdecide).
assert (rk(couple o b)>=2).
setoid_replace (couple o b) with (couple b o) by (clear_all;fsetdecide).
generalize (rbo A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O' rA'C'O' rB'C'O'
            rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o rOPo rOo rPo b Hb2 Hb2') ; omega.
omega.
generalize (matroid3 (triple a b c) (triple o A a)).
setoid_replace (union (triple a b c) (triple o A a))
with (union (triple a b c) (couple o A)) by (unfold Equal; split; (clear_all;fsetdecide)).
assert (rk(inter (triple a b c) (triple o A a))>=rk(singleton a)).
apply matroid2; (clear_all;fsetdecide).
rewrite rk_singleton in H1.
omega.
(* end of the proof of r(a,b,c)=3 *)
eapply (Desargues A B C a b c alpha beta gamma o).
setoid_replace (triple A a o) with (triple o A a) by (clear_all;fsetdecide);assumption.
setoid_replace (triple B b o) with (triple o B b) by (clear_all;fsetdecide);assumption.
setoid_replace (triple C c o) with (triple o C c) by (clear_all;fsetdecide);assumption.
assumption.
assumption.

(* r(a,b,c,A,B,C)>=4 *)
assert (rk(add b (triple A B C))<= rk (union (triple a b c) (triple A B C))).
apply matroid2; (clear_all;fsetdecide).
assert (rk(add b (triple A B C)) >= 4).
generalize (rABOb A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO
            rA'B'O' rA'C'O' rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP
            rOP o rOPo rOo  rPo b Hb2 Hb2'); intros HrABOb.
generalize (matroid3 (add b (triple A B C)) (add O (triple A B C))).
setoid_replace (union (add b (triple A B C)) (add O (triple A B C)))
with (union (triple A B C) (couple O b)) by (unfold Equal; split; (clear_all;fsetdecide)).
assert (rk(inter (add b (triple A B C)) (add O (triple A B C)))>=rk(triple A B C)).
apply matroid2; (clear_all;fsetdecide).
assert (rk(add b (triple A B C))<=rk(union (triple A B C) (couple O b))).
apply matroid2; (clear_all;fsetdecide).
assert (rk (add b (triple A B C))>=4).
setoid_replace (triple A B C) with (triple C A B) by (clear_all;fsetdecide).
apply (rk3_4 O A B C b).
apply le_antisym.
assert (rk(add C (triple O A B))<=rk
                (union (triple A B C) (union (triple A' B' C') (singleton O))) ).
apply matroid2; (clear_all;fsetdecide).
omega.
assert (rk(add C (triple O A B)) >=rk(triple A B C)).
apply matroid2; (clear_all;fsetdecide).
omega.
assumption.
setoid_replace (triple O A B) with (triple A B O) by (clear_all;fsetdecide).
assumption.
omega.
assert (rk(add C (triple O A B))<=rk
                (union (triple A B C) (union (triple A' B' C') (singleton O)))).
apply matroid2; (clear_all;fsetdecide).
omega.

(* gamma *)
apply (beta_ok' A' C' B' A C B O) with (P0:=P) (o0:=o) (alpha0:=alpha) (gamma0:=beta) (b0:=c); try eassumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A' C' B') with (triple A' B' C') by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple A' C' B') with (triple A' B' C') by (clear_all;fsetdecide); assumption.
setoid_replace (triple C B O) with (triple B C O) by (clear_all;fsetdecide);assumption.
eauto with rk.
eauto with rk.
setoid_replace (triple C' B' O) with (triple B' C' O) by (clear_all;fsetdecide); eauto with rk.
apply (rACOP A' B' C' A B C O); try assumption.
eauto with rk.
eauto with rk.
eauto with rk.
setoid_replace (triple C B alpha) with (triple B C alpha) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C' B' alpha) with (triple B' C' alpha) by (clear_all;fsetdecide); assumption.
setoid_replace (triple a c b) with (triple a b c) by (clear_all;fsetdecide); assumption.

assumption.
(* beta *)
apply (beta_ok' A' B' C' A B C O) with (P0:=P) (o0:=o) (alpha0:=alpha) (gamma0:=gamma) (b0:=b); try eassumption.
eauto with rk.
eauto with rk.
eauto with rk.
assumption.
(* alpha *)
apply (beta_ok' B' A' C' B A C O) with (P0:=P) (o0:=o) (alpha0:=beta) (gamma0:=gamma) (b0:=a); try eassumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide) ; assumption.
setoid_replace (triple B' A' C') with (triple A' B' C') by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple B' A' C') with (triple A' B' C') by (clear_all;fsetdecide).
assumption.
setoid_replace (triple B A O) with (triple A B O) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B' A' O) with (triple A' B' O) by (clear_all;fsetdecide); eauto with rk.
eauto with rk.
eauto with rk.
setoid_replace (triple B A O) with (triple A B O) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B' A' gamma) with (triple A' B' gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a c) with (triple a b c) by (clear_all;fsetdecide); assumption.

assumption.
eauto with rk.
eauto with rk.
eauto with rk.
Qed.

End s_desargues2D.


From Cofq.SystemK Require Import
     SystemKDefinitions
     SystemKUtils
     SystemKShow. (* Need show for errors in evaluation *)

From Cofq.Utils Require Import Utils.
From Cofq.Show Require Import ShowUtils.

From Coq Require Import
     Lia
     List.

From ExtLib Require Import
     Structures.Monads
     Structures.Functor
     Eqv.

Import MonadNotation.
Local Open Scope monad_scope.

From ITree Require Import
     Basics
     ITree
     Interp.Recursion
     Events.Exception.

From Vellvm.Utils Require Import Util.

Section Substitution.
  Definition nat_to_n (n : nat) : N. Admitted.

  (* Lift by 2 because fixpoint has a argument in addition to referring to itself *)
  Fixpoint kvalue_lift {I} `{FInt I} (n : N) (lift_by : N) (value : KValue) : KValue :=
    match value with
    | KAnnotated type raw_value => KAnnotated type (kraw_value_lift n lift_by raw_value)
    end
  with kraw_value_lift {I} `{FInt I} (n : N) (lift_by : N) (value : KRawValue) : KRawValue :=
    match value with
    | KNum num => KNum num
    | KVar index =>
      if N.ltb index n
      then KVar index
      else KVar (index + lift_by)
    | KFix type_param_count value_params body =>
      KFix type_param_count
           value_params
           (kterm_lift (n + (nat_to_n (length value_params)) + 1) lift_by body)
    | KTuple values => KTuple (map (kvalue_lift n lift_by) values)
    end
    with kterm_lift {I} `{FInt I} (n : N) (lift_by : N) (term : KTerm) : KTerm :=
    match term with
    | KLet declaration body =>
      KLet (kdeclaration_lift n lift_by declaration) (kterm_lift (n + 1) lift_by body)
    | KApp f type_params value_params =>
      KApp (kvalue_lift n lift_by f) type_params (map (kvalue_lift n lift_by) value_params)
    | KIf0 value then_term else_term =>
      KIf0 (kvalue_lift n lift_by value) (kterm_lift n lift_by then_term) (kterm_lift n lift_by else_term)
    | KHalt type value => KHalt type (kvalue_lift n lift_by value)
    end
    with kdeclaration_lift {I} `{FInt I} (n : N) (lift_by : N) (declaration : KDeclaration) : KDeclaration :=
    match declaration with
    | KVal value => KVal (kvalue_lift n lift_by value)
    | KProjN i value => KProjN i (kvalue_lift n lift_by value)
    | KOp op value_a value_b => KOp op (kvalue_lift n lift_by value_a) (kvalue_lift n lift_by value_b)
    end.

  Fixpoint ktype_lift (n lift_by : N) (τ : KType) : KType :=
    match τ with
    | KProd types => KProd (map (ktype_lift n lift_by) types)
    | KTForall type_param_count term_params =>
      KTForall type_param_count (map (ktype_lift (n + type_param_count) lift_by) term_params)
    | KTVar index =>
      if N.ltb index n
      then KTVar index
      else KTVar (index + lift_by)
    | KIntType => KIntType
    end.

  Fixpoint kvalue_subst {I} `{FInt I} (v : VarInd) (body : KValue) (arg : KRawValue) : KValue :=
    match body with
    | KAnnotated type raw_value => KAnnotated type (kraw_value_subst v raw_value arg)
    end
  with kraw_value_subst {I} `{FInt I} (v : VarInd) (body : KRawValue) (arg : KRawValue) : KRawValue :=
    match body with
    | KNum num => KNum num
    | KVar index =>
      if N.eqb index v
      then arg
      else KVar index
    | KFix type_param_count value_params fbody =>
      KFix type_param_count
          value_params
          (kterm_subst
            (v + (nat_to_n (length value_params)) + 1)
            fbody
            (kraw_value_lift 0 ((nat_to_n (length value_params)) + 1) arg)
          )
    | KTuple tuple_bodies => KTuple (map (fun tuple_body => kvalue_subst v tuple_body arg) tuple_bodies)
    end
    with kterm_subst {I} `{FInt I} (v : VarInd) (body : KTerm) (arg : KRawValue) : KTerm :=
      match body with
      | KLet declaration lbody =>
        KLet
          (kdeclaration_subst v declaration arg)
          (kterm_subst
            (v + 1)
            lbody
            (kraw_value_lift 0 1 arg)
          )
      | KApp f type_params value_params =>
        KApp
          (kvalue_subst v f arg)
          type_params
          (map (fun value_param => kvalue_subst v value_param arg) value_params)
      | KIf0 value then_term else_term =>
        KIf0
          (kvalue_subst v value arg)
          (kterm_subst v then_term arg)
          (kterm_subst v else_term arg)
      | KHalt type value =>
        KHalt type (kvalue_subst v value arg)
      end
    with kdeclaration_subst {I} `{FInt I} (v : VarInd) (body : KDeclaration) (arg : KRawValue) : KDeclaration :=
      match body with
      | KVal value =>
        KVal (kvalue_subst v value arg)
      | KProjN i value =>
        KProjN i (kvalue_subst v value arg)
      | KOp op value_a value_b =>
        KOp op
          (kvalue_subst v value_a arg)
          (kvalue_subst v value_b arg)
      end
    .

  (*
  Lemma type_lift_type_size:
    forall τ n,
      type_size (ktype_lift n τ) = type_size τ.
  Proof.
    induction τ; intros sz; cbn;
      repeat match goal with
               H: _ |- _ =>
               rewrite H
             end; eauto.

    destruct (x <? sz)%N; auto.

    rewrite map_map.
    erewrite map_ext_in; eauto.
  Qed.
  *)

  Obligation Tactic := try Tactics.program_simpl; try solve [cbn; try lia | repeat split; try solve [intros; discriminate]].
  Program Fixpoint ktype_subst_in_type (v : TypeInd) (τ : KType) (arg : KType) {measure (ktype_size τ)} : KType :=
    match τ with
    | KProd τs =>
      KProd (map_In τs (fun τ HIn => ktype_subst_in_type v τ arg))
    | KTForall type_param_count term_params =>
      KTForall type_param_count
               (map_In term_params
                       (fun τ' HIn => ktype_subst_in_type (v + type_param_count) τ' (ktype_lift 0 type_param_count arg)))
    | KTVar x =>
      if N.eqb x v
      then arg
      else if N.ltb v x
          then KTVar (x-1)
          else KTVar x
    | KIntType => KIntType
    end.
  Next Obligation.
    cbn.
    pose proof (list_sum_map ktype_size τ τs HIn).
    lia.
  Qed.
  Next Obligation.
    cbn.
    pose proof (list_sum_map ktype_size τ' term_params HIn).
    lia.
  Qed.

  Fixpoint ktype_subst_value {I} `{FInt I} (v : TypeInd) (e : KValue) (arg_type : KType) : KValue :=
    match e with
    | KAnnotated type raw_value =>
      KAnnotated
        (ktype_subst_in_type v type arg_type)
        (ktype_subst_raw_value v raw_value arg_type)
    end
  with ktype_subst_raw_value {I} `{FInt I} (v : TypeInd) (e : KRawValue) (arg_type : KType) : KRawValue :=
    match e with
    | KNum num => KNum num
    | KVar index => KVar index
    | KFix type_param_count value_params fbody =>
      KFix type_param_count
        (map (fun value_param => ktype_subst_in_type (v + type_param_count) value_param arg_type) value_params)
        (ktype_subst_term (v + type_param_count) fbody arg_type)
    | KTuple tuple_bodies =>
      KTuple (map (fun tuple_body => ktype_subst_value v tuple_body arg_type) tuple_bodies)
    end
  with ktype_subst_term {I} `{FInt I} (v : TypeInd) (e : KTerm) (arg_type : KType) : KTerm :=
    match e with
    | KLet declaration lbody =>
      KLet
        (ktype_subst_declaration v declaration arg_type)
        (ktype_subst_term v lbody arg_type)
    | KApp f type_params value_params =>
      KApp
        (ktype_subst_value v f arg_type)
        (map (fun type => ktype_subst_in_type v type arg_type) type_params)
        (map (fun value => ktype_subst_value v value arg_type) value_params)
    | KIf0 value then_term else_term =>
      KIf0
        (ktype_subst_value v value arg_type)
        (ktype_subst_term v then_term arg_type)
        (ktype_subst_term v else_term arg_type)
    | KHalt type value =>
      KHalt
        (ktype_subst_in_type v type arg_type)
        (ktype_subst_value v value arg_type)
    end
  with ktype_subst_declaration {I} `{FInt I} (v : TypeInd) (e : KDeclaration) (arg_type : KType) : KDeclaration :=
    match e with
    | KVal value => KVal (ktype_subst_value v value arg_type)
    | KProjN i value => KProjN i (ktype_subst_value v value arg_type)
    | KOp op value_a value_b =>
      KOp op
        (ktype_subst_value v value_a arg_type)
        (ktype_subst_value v value_b arg_type)
    end
  .
End Substitution.

(*
(** Single-step semantics for SystemF, useful for testing. *)
Section SingleStep.
  Obligation Tactic := try Tactics.program_simpl; try solve [cbn; try lia | repeat split; try solve [intros; discriminate]].
  Program Fixpoint step {I} `{FInt I} (e : KTerm) {measure (kterm_size e)} : (unit + KTerm) :=
    match e with
    | Ann e t => step e
    | Fix fix_type arg_type body => inl tt
    | App (Fix fix_type arg_type body) arg =>
      inr (app_fix fix_type arg_type body arg)
    | App e1 e2 =>
      e1v <- step e1;;
      inr (App e1v e2)
    | Op op (Num xn) (Num yn) =>
      inr (Num (eval_op op xn yn))
    | Op op (Num xn) y =>
      yv <- step y ;;
      inr (Op op (Num xn) yv)
    | Op op x y =>
      xv <- step x ;;
      inr (Op op xv y)
    | TApp (TAbs e) arg_type =>
      inr (type_subst 0 e arg_type)
    | TApp e t =>
      e' <- step e;;
      inr (TApp e' t)
    | ProjN i (Tuple es) =>
      match nth_error es (N.to_nat i) with
      | Some e => step e
      | None => inl tt
      end
    | ProjN i e =>
      ev <- step e;;
      inr (ProjN i ev)
    | If0 (Num x) e1 e2 =>
      if eq x zero
      then inr e1
      else inr e2
    | If0 c e1 e2 =>
      cv <- step c;;
      inr (If0 cv e1 e2)
    | _ => inl tt
    end.
  Next Obligation.
    cbn.
    symmetry in Heq_anonymous.
    apply nth_error_In in Heq_anonymous.
    pose proof (list_sum_map term_size e es Heq_anonymous).
    lia.
  Qed.

  Definition step' {I} `{FInt I} (v : unit + Term) : (unit + Term)
    := match v with
       | inl tt => inl tt
       | inr t => step t
       end.

  Fixpoint multistep {I} `{FInt I} (n : nat) (v : Term) : Term
    := match n with
       | O => v
       | S n =>
         match step v with
         | inl tt => v
         | inr t => multistep n t
         end
       end.

  (* Returns a term only if it's fully evaluated *)
  Fixpoint multistep' {I} `{FInt I} (n : nat) (v : Term) : option Term
    := match n with
       | O => None
       | S n =>
         match step v with
         | inl tt => Some v
         | inr t => multistep' n t
         end
       end.
End SingleStep.

(** Denotation of SystemF in terms of itrees. *)
Section Denotation.
  Definition Failure := exceptE string.

  Definition eval_body {I} `{FInt I} `{Show I} (e : Term) : itree (callE Term Term +' Failure) Term :=
    match e with
    | Ann e t => call e
    | App e1 e2 =>
      e1v <- call e1;;
      e2v <- call e2;;
      match e1v with
      | Fix fix_type arg_type body =>
        call (app_fix fix_type arg_type body e2v)
      | _ => throw ("ill-typed application: " ++ show e)
      end
    | TApp e t =>
      e' <- call e;;
      match e' with
      | TAbs body =>
        call (type_subst 0 body t)
      | _ => throw ("ill-typed type application: " ++ show (TApp e' t))
      end
    | ProjN i es =>
      es' <- call es;;
      match es' with
      | Tuple xs =>
        match nth_error xs (N.to_nat i) with
        | Some e => call e
        | None => throw ("tuple projection out of bounds: " ++ show e)
        end
      | _ => throw ("ill-typed tuple projection: " ++ show e)
      end
    | If0 c e1 e2 =>
      cv <- call c;;
      match cv with
      | Num x =>
        if eq x zero
        then call e1
        else call e2
      | _ => throw ("ill-typed if0: " ++ show e)
      end
    | Op op e1 e2 =>
      e1v <- call e1;;
      e2v <- call e2;;
      match e1v, e2v with
      | Num x, Num y =>
        ret (Num (eval_op op x y))
      | _, _ => throw ("ill-typed operation: " ++ show e)
      end
    | Num x => ret e
    | TAbs x => ret e
    | Tuple xs =>
      xs' <- map_monad call xs;;
      ret (Tuple xs')
    | Fix fix_type arg_type body => ret e
    | Var x => ret e
    end.

  Definition eval {I} `{FInt I} `{Show I} : Term -> itree Failure Term :=
    rec eval_body.
End Denotation.
*)