Require Import RamifyCoq.CertiGC.gc_spec.

Ltac hif_tac H :=
  match type of H with context [if ?a then _ else _] => destruct a eqn: ?H end.

Lemma body_Is_block: semax_body Vprog Gprog f_Is_block Is_block_spec.
Proof.
  start_function.
  assert (eqb_type
            (Tpointer Tvoid {| attr_volatile := false; attr_alignas := Some 2%N |})
            int_or_ptr_type = true) by
      (rewrite eqb_type_spec; unfold int_or_ptr_type; f_equal). forward_call x.
  forward. hif_tac H1. 2: inversion H0. destruct x; simpl in *; entailer!.
Qed.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

Require Import Equations.Prop.Equations.

From Coq Require Import String Ensembles Setoid Btauto.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.Classical_Prop.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Coq.Classes Require Import Morphisms_Prop.
From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.

From stdpp Require Import base fin_sets sets propset proof_irrel option list coGset finite infinite gmap.

From MatchingLogic Require Import
  Logic
  DerivedOperators_Syntax
  ProofMode.MLPM
.
From MatchingLogic.Theories Require Import Definedness_Syntax Definedness_ProofSystem.
From MatchingLogic.Utils Require Import stdpp_ext.
Import extralibrary.

Import MatchingLogic.Logic.Notations.
Import MatchingLogic.DerivedOperators_Syntax.Notations.
Import MatchingLogic.Syntax.BoundVarSugar.

Set Default Proof Mode "Classic".

Import Notations.

Open Scope ml_scope.
Open Scope string_scope.
Open Scope list_scope.

(* TODO: These 3 lemmas are used only here as is, but maybe it should be somewhere else? *)
Local Lemma impl_ctx_impl {Σ : Signature} Γ ctx ϕ ψ i :
  well_formed ϕ ->
  well_formed ψ ->
  well_formed (pcPattern ctx) ->
  ProofInfoLe AnyReasoning i ->
  Γ ⊢i ϕ ---> ψ using i ->
  (is_positive_context ctx ->
  Γ ⊢i (emplace ctx ϕ) ---> (emplace ctx ψ) using i)
  *
  (is_negative_context ctx ->
  Γ ⊢i (emplace ctx ψ) ---> (emplace ctx ϕ) using i).
Proof.
  intros wfϕ wfψ wfc pile H.

  remember (size' (pcPattern ctx)) as sz.
  assert (Hsz: size' (pcPattern ctx) <= sz) by lia.
  clear Heqsz.

  unfold emplace.

  destruct ctx as [cvar cpatt].
  simpl in *.

  generalize dependent cpatt.

  induction sz.
  {
    destruct cpatt; simpl in *; lia.
  }

  intros cpatt wfc Hsz.

  split.
  {
    intro Hp.
    destruct cpatt; simpl in *.

    (* trivial cases *)
    2,5,7: aapply A_impl_A;[eapply pile_trans;[|apply pile];try_solve_pile;try_solve_pile|wf_auto2].
    (* not well formed cases*)
    2,3: cbv in wfc; discriminate wfc.

    + destruct decide.
      { assumption. }
      { gapply A_impl_A. eapply pile_trans;[|apply pile]; try_solve_pile. wf_auto2. }

    + pose proof (IH1 := IHsz cpatt1).
      feed specialize IH1.
      { wf_auto2. }
      { lia. }
      destruct IH1 as [IH1 _]. feed specialize IH1.
      {
        clear -Hp. unfold is_positive_context in *. simpl in *.
        unfold evar_has_negative_occurrence in Hp.
        simpl in Hp. fold evar_has_negative_occurrence in Hp.
        rewrite negb_or in Hp. destruct_and! Hp.
        assumption.
      }
      pose proof (IH2 := IHsz cpatt2).
      feed specialize IH2.
      { wf_auto2. }
      { lia. }
      destruct IH2 as [IH2 _]. feed specialize IH2.
      {
        clear -Hp. unfold is_positive_context in *. simpl in *.
        unfold evar_has_negative_occurrence in Hp.
        simpl in Hp. fold evar_has_negative_occurrence in Hp.
        rewrite negb_or in Hp. destruct_and! Hp.
        assumption.
      }

      eapply syllogism_meta.
      4: {
        unshelve(eapply Framing_left;[| |apply IH1]).
        { wf_auto2. }
        { try_solve_pile. }
      }
      { wf_auto2. }
      { wf_auto2. }
      { wf_auto2. }

      unshelve(eapply Framing_right).
      { wf_auto2. }
      { eapply pile_trans;[|apply pile]. apply pile_any. }
      apply IH2.

    + unfold is_positive_context in Hp. simpl in Hp.
      unfold evar_has_negative_occurrence in Hp. simpl in Hp.
      fold evar_has_positive_occurrence evar_has_negative_occurrence in Hp.
      rewrite negb_orb in Hp.
      destruct_and! Hp.

      pose proof (IH := IHsz (cpatt2)).
      feed specialize IH.
      { wf_auto2. }
      { lia. }
      destruct IH as [IH _]. feed specialize IH.
      {
        unfold is_positive_context. simpl. assumption.
      }

      toMLGoal.
      { wf_auto2. }
      mlAdd IH as "IH". clear IH.
      mlIntro "H".
      mlIntro "Hc".
      mlApply "IH". mlClear "IH".
      mlApply "H". mlClear "H".
      fromMLGoal.

      pose proof (IH := IHsz cpatt1).
      feed specialize IH.
      { wf_auto2. }
      { lia. }
      destruct IH as [_ IH]. feed specialize IH.
      { unfold is_negative_context. simpl. assumption. }
      assumption.

    + remember (evar_fresh_s ({[cvar]} ∪ free_evars cpatt ∪ free_evars ψ ∪ free_evars ϕ)) as x.
      pose proof (IH := IHsz (evar_open x 0 cpatt)).
      feed specialize IH.
      { wf_auto2. }
      { rewrite evar_open_size'. lia. }
      destruct IH as [IH _]. feed specialize IH.
      {
        clear -Hp Heqx. unfold is_positive_context in *. simpl in *.
        unfold evar_has_negative_occurrence in Hp.
        simpl in Hp. fold evar_has_negative_occurrence in Hp.
        rewrite <- neg_occurrence_bevar_subst.
        + assumption.
        + subst. solve_fresh_neq.
      }
      rewrite <- evar_quantify_evar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ϕ]]) (x := x).
      rewrite <- evar_quantify_evar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ψ]]) (x := x).
      apply ex_quan_monotone.
      { eapply pile_trans;[|apply pile]. try_solve_pile. }
      unfold evar_open.
      unfold evar_open in IH.

      rewrite free_evar_subst_free_evar_subst.
      { wf_auto2. }
      { subst x. simpl.
        rewrite not_elem_of_singleton.
        solve_fresh_neq.
      }

      rewrite free_evar_subst_free_evar_subst.
      { wf_auto2. }
      {
        rewrite not_elem_of_singleton.
        solve_fresh_neq.
      }

      assumption.

      {
        subst x; clear.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        pose proof (Hfree := free_evars_free_evar_subst cpatt ψ cvar).
        set_solver.
      }
      { wf_auto2. }
      {
        subst x.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        pose proof (Hfree := free_evars_free_evar_subst cpatt ϕ cvar).
        clear -Hfree.
        set_solver.
      }
      { wf_auto2. }

    + remember (svar_fresh_s (free_svars cpatt ∪ free_svars ψ ∪ free_svars ϕ ∪ free_svars cpatt^[[evar:cvar↦ϕ]] ∪ free_svars cpatt^[[evar:cvar↦ψ]])) as X.
      pose proof (IH := IHsz (svar_open X 0 cpatt)).
      feed specialize IH.
      { wf_auto2. }
      { rewrite svar_open_size'. lia. }
      destruct IH as [IH _]. feed specialize IH.
      {
        clear -Hp. unfold is_positive_context in *. simpl in *.
        cbn in Hp.
        rewrite <- neg_occurrence_bsvar_subst.
        assumption.
      }
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ϕ]]) (X := X).
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ψ]]) (X := X).
      apply mu_monotone.
      { eapply pile_trans;[|apply pile]. try_solve_pile. }
      {
        unfold is_positive_context in Hp. simpl in Hp.
        unfold well_formed in wfc. simpl in wfc.
        destruct_and! wfc.
        pose proof (Hneg := free_evar_subst_preserves_no_negative_occurrence cvar cpatt ϕ 0).
        feed specialize Hneg.
        { wf_auto2. }
        { assumption. }
        cbn in Hp.
        apply positive_negative_occurrence_db_named.
        { assumption. }
        apply fresh_svar_no_neg.
        subst.
        clear.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        set_solver.
      }
      {
        unfold is_positive_context in Hp. simpl in Hp.
        unfold well_formed in wfc. simpl in wfc.
        destruct_and! wfc.
        pose proof (Hneg := free_evar_subst_preserves_no_negative_occurrence cvar cpatt ψ 0).
        feed specialize Hneg.
        { wf_auto2. }
        { assumption. }
        cbn in Hp.
        apply positive_negative_occurrence_db_named.
        { assumption. }
        apply fresh_svar_no_neg.
        subst.
        clear.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        set_solver.
      }
      unfold svar_open.
      unfold svar_open in IH.
      rewrite <- free_evar_subst_bsvar_subst.
      rewrite <- free_evar_subst_bsvar_subst.
      apply IH.
      { wf_auto2. }
      { unfold evar_is_fresh_in. set_solver. }
      { wf_auto2. }
      { unfold evar_is_fresh_in. set_solver. }
      {
        clear -HeqX.
        intro Hcontra.
        pose proof (Hfree := free_svars_free_evar_subst cpatt cvar ψ).
        assert (X ∉ free_svars cpatt /\ X ∉ free_svars ψ).
        {
          subst.
          split.
          {
            eapply svar_is_fresh_in_richer'.
            2: apply set_svar_fresh_is_fresh'.
            clear.
            set_solver.
          }
          {
            eapply svar_is_fresh_in_richer'.
            2: apply set_svar_fresh_is_fresh'.
            clear.
            set_solver.
          }
        }
        set_solver.
      }
      { wf_auto2. }
      {
        subst X.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        clear.
        set_solver.
      }
      { wf_auto2. }
  }
  {
    intro Hp.
    destruct cpatt; simpl in *.

    (* trivial cases *)
    2,5,7: aapply A_impl_A;[eapply pile_trans;[|apply pile];try_solve_pile;try_solve_pile|wf_auto2].
    (* not well formed cases*)
    2,3: cbv in wfc; discriminate wfc.

    + destruct decide.
      {
        subst.
        unfold is_negative_context in Hp. cbn in Hp.
        destruct decide in Hp; simpl in Hp; congruence.
      }
      { gapply A_impl_A. eapply pile_trans;[|apply pile]; try_solve_pile. wf_auto2. }

    + pose proof (IH1 := IHsz cpatt1).
      feed specialize IH1.
      { wf_auto2. }
      { lia. }
      destruct IH1 as [_ IH1]. feed specialize IH1.
      {
        clear -Hp. unfold is_negative_context in *. simpl in *.
        cbn in Hp.
        rewrite negb_or in Hp. destruct_and! Hp.
        assumption.
      }
      pose proof (IH2 := IHsz cpatt2).
      feed specialize IH2.
      { wf_auto2. }
      { lia. }
      destruct IH2 as [_ IH2]. feed specialize IH2.
      {
        clear -Hp. unfold is_negative_context in *. simpl in *.
        cbn in Hp.
        rewrite negb_or in Hp. destruct_and! Hp.
        assumption.
      }

      eapply syllogism_meta.
      4: {
        unshelve(eapply Framing_left;[| |apply IH1]).
        { wf_auto2. }
        { eapply pile_trans;[|apply pile]. apply pile_any. }
      }
      { wf_auto2. }
      { wf_auto2. }
      { wf_auto2. }

      unshelve(eapply Framing_right).
      { wf_auto2. }
      { eapply pile_trans;[|apply pile]. apply pile_any. }
      apply IH2.

    + unfold is_negative_context in Hp. simpl in Hp.
      unfold evar_has_positive_occurrence in Hp. simpl in Hp.
      fold evar_has_positive_occurrence evar_has_negative_occurrence in Hp.
      rewrite negb_orb in Hp.
      destruct_and! Hp.

      pose proof (IH := IHsz (cpatt2)).
      feed specialize IH.
      { wf_auto2. }
      { lia. }
      destruct IH as [_ IH]. feed specialize IH.
      {
        unfold is_negative_context. simpl. assumption.
      }

      toMLGoal.
      { wf_auto2. }
      mlAdd IH as "IH". clear IH.
      mlIntro "H".
      mlIntro "Hc".
      mlApply "IH". mlClear "IH".
      mlApply "H". mlClear "H".
      fromMLGoal.

      pose proof (IH := IHsz cpatt1).
      feed specialize IH.
      { wf_auto2. }
      { lia. }
      destruct IH as [IH _]. feed specialize IH.
      { unfold is_positive_context. simpl. assumption. }
      assumption.

    + remember (evar_fresh_s ({[cvar]} ∪ free_evars cpatt ∪ free_evars ψ ∪ free_evars ϕ)) as x.
      pose proof (IH := IHsz (evar_open x 0 cpatt)).
      feed specialize IH.
      { wf_auto2. }
      { rewrite evar_open_size'. lia. }
      destruct IH as [_ IH]. feed specialize IH.
      {
        clear -Hp Heqx. unfold is_negative_context in *. simpl in *.
        cbn in Hp.
        rewrite <- pos_occurrence_bevar_subst.
        + assumption.
        + subst. solve_fresh_neq.
      }
      rewrite <- evar_quantify_evar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ϕ]]) (x := x).
      rewrite <- evar_quantify_evar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ψ]]) (x := x).
      apply ex_quan_monotone.
      { eapply pile_trans;[|apply pile]. try_solve_pile. }
      unfold evar_open.
      unfold evar_open in IH.

      rewrite free_evar_subst_free_evar_subst.
      { wf_auto2. }
      {
        rewrite not_elem_of_singleton.
        solve_fresh_neq.
      }

      rewrite free_evar_subst_free_evar_subst.
      { wf_auto2. }
      {
        rewrite not_elem_of_singleton.
        solve_fresh_neq.
      }

      assumption.

      {
        subst x; clear.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        pose proof (Hfree := free_evars_free_evar_subst cpatt ψ cvar).
        set_solver.
      }
      { wf_auto2. }
      {
        subst x.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        pose proof (Hfree := free_evars_free_evar_subst cpatt ϕ cvar).
        clear -Hfree.
        set_solver.
      }
      { wf_auto2. }

    + remember (svar_fresh_s (free_svars cpatt ∪ free_svars ψ ∪ free_svars ϕ ∪ free_svars cpatt^[[evar:cvar↦ϕ]] ∪ free_svars cpatt^[[evar:cvar↦ψ]])) as X.
      pose proof (IH := IHsz (svar_open X 0 cpatt)).
      feed specialize IH.
      { wf_auto2. }
      { rewrite svar_open_size'. lia. }
      destruct IH as [_ IH]. feed specialize IH.
      {
        clear -Hp. unfold is_negative_context in *. simpl in *.
        cbn in Hp.
        rewrite <- pos_occurrence_bsvar_subst.
        assumption.
      }
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ϕ]]) (X := X).
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := cpatt^[[evar:cvar↦ψ]]) (X := X).
      apply mu_monotone.
      { eapply pile_trans;[|apply pile]. try_solve_pile. }
      {
        unfold is_negative_context in Hp. simpl in Hp.
        unfold well_formed in wfc. simpl in wfc.
        destruct_and! wfc.
        pose proof (Hneg := free_evar_subst_preserves_no_negative_occurrence cvar cpatt ψ 0).
        feed specialize Hneg.
        { wf_auto2. }
        { assumption. }
        cbn in Hp.
        apply positive_negative_occurrence_db_named.
        { assumption. }
        apply fresh_svar_no_neg.
        subst.
        clear.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        set_solver.
      }
      {
        unfold is_negative_context in Hp. simpl in Hp.
        unfold well_formed in wfc. simpl in wfc.
        destruct_and! wfc.
        pose proof (Hneg := free_evar_subst_preserves_no_negative_occurrence cvar cpatt ϕ 0).
        feed specialize Hneg.
        { wf_auto2. }
        { assumption. }
        cbn in Hp.
        apply positive_negative_occurrence_db_named.
        { assumption. }
        apply fresh_svar_no_neg.
        subst.
        clear.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        set_solver.
      }
      unfold svar_open.
      unfold svar_open in IH.
      rewrite <- free_evar_subst_bsvar_subst.
      rewrite <- free_evar_subst_bsvar_subst.
      apply IH.
      { wf_auto2. }
      { unfold evar_is_fresh_in. set_solver. }
      { wf_auto2. }
      { unfold evar_is_fresh_in. set_solver. }
      {
        clear -HeqX.
        intro Hcontra.
        pose proof (Hfree := free_svars_free_evar_subst cpatt cvar ψ).
        assert (X ∉ free_svars cpatt /\ X ∉ free_svars ψ).
        {
          subst.
          split.
          {
            eapply svar_is_fresh_in_richer'.
            2: apply set_svar_fresh_is_fresh'.
            clear.
            set_solver.
          }
          {
            eapply svar_is_fresh_in_richer'.
            2: apply set_svar_fresh_is_fresh'.
            clear.
            set_solver.
          }
        }
        set_solver.
      }
      { wf_auto2. }
      {
        subst X.
        eapply svar_is_fresh_in_richer'.
        2: apply set_svar_fresh_is_fresh'.
        clear.
        set_solver.
      }
      { wf_auto2. }
  }
Defined.

Lemma impl_ctx_impl_pos {Σ : Signature} Γ ctx ϕ ψ i :
  well_formed ϕ ->
  well_formed ψ ->
  well_formed (pcPattern ctx) ->
  is_positive_context ctx ->
  ProofInfoLe AnyReasoning i ->
  Γ ⊢i ϕ ---> ψ using i ->
  Γ ⊢i (emplace ctx ϕ) ---> (emplace ctx ψ) using i.
Proof.
  intros wfϕ wfψ wfc Hp pile H.
  pose proof (impl := impl_ctx_impl Γ ctx ϕ ψ i wfϕ wfψ wfc pile H).
  destruct impl as [impl _].
  apply impl in Hp.
  assumption.
Defined.

Lemma impl_ctx_impl_neg {Σ : Signature} Γ ctx ϕ ψ i :
  well_formed ϕ ->
  well_formed ψ ->
  well_formed (pcPattern ctx) ->
  is_negative_context ctx ->
  ProofInfoLe AnyReasoning i ->
  Γ ⊢i ϕ ---> ψ using i ->
  Γ ⊢i (emplace ctx ψ) ---> (emplace ctx ϕ) using i.
Proof.
  intros wfϕ wfψ wfc Hn pile H.
  pose proof (impl := impl_ctx_impl Γ ctx ϕ ψ i wfϕ wfψ wfc pile H).
  destruct impl as [_ impl].
  apply impl in Hn.
  assumption.
Defined.

(* Lemma 88 in in the matching mu logic paper.*)
Lemma pred_and_ctx_and {Σ : Signature} {syntax : Syntax} Γ ctx ϕ ψ:
  Definedness_Syntax.theory ⊆ Γ ->
  well_formed ϕ ->
  well_formed ψ ->
  well_formed (pcPattern ctx) ->
  mu_in_evar_path (pcEvar ctx) (pcPattern ctx) 0 = false ->
  Γ ⊢ is_predicate_pattern ψ ->
  Γ ⊢ ψ and (emplace ctx ϕ) <---> ψ and (emplace ctx (ψ and ϕ)).
Proof.
  intros HΓ wfm wfψ wfc Hmf Hp.

  remember (size' (pcPattern ctx)) as sz.
  assert (Hsz: size' (pcPattern ctx) <= sz) by lia.
  clear Heqsz.

  unfold emplace.

  destruct ctx as [cvar cpatt].
  simpl in *.

  generalize dependent cpatt.

  induction sz.
  {
    destruct cpatt; simpl in *; lia.
  }

  intros cpatt wfc Hmf Hsz.
  destruct cpatt. all: simpl in *.

  (* trivial cases *)
  2,5,7: useBasicReasoning; apply pf_iff_equiv_refl; wf_auto2.
  (* not well formed cases*)
  2,3: cbv in wfc; discriminate wfc.

  + destruct decide.
    {
      apply pf_iff_split; wf_auto2.
      toMLGoal. wf_auto2. mlIntro. mlDestructAnd "0". mlSplitAnd.
      { mlExact "1". }
      {
        mlSplitAnd.
        * mlExact "1".
        * mlExact "2".
      }
      toMLGoal. wf_auto2. mlIntro. mlDestructAnd "0". mlDestructAnd "2". mlSplitAnd.
      * mlExact "1".
      * mlExact "3".
    }
    { apply pf_iff_split;[wf_auto2|wf_auto2|aapply A_impl_A|aapply A_impl_A];wf_auto2; set_solver. }
  + pose proof (IH1 := IHsz cpatt1).
    feed specialize IH1.
    { wf_auto2. }
    {
      unfold mu_in_evar_path in *.
      simpl in Hmf.
      case_match.
      2: { lia. }
      rewrite negb_false_iff.
      eapply (introT (Nat.eqb_spec 0 _)).
      lia.
    }
    {
      lia.
    }
    pose proof (IH2 := IHsz cpatt2).
    feed specialize IH2.
    { wf_auto2. }
    {
      unfold mu_in_evar_path in *.
      simpl in Hmf.
      case_match.
      2: { lia. }
      rewrite negb_false_iff.
      eapply (introT (Nat.eqb_spec 0 _)).
      lia.
    }
    { lia. }

    toMLGoal.
    { wf_auto2. }
    pose proof (Htmp := predicate_propagate_right_2 Γ
      (cpatt2^[[evar:cvar↦ϕ]])
      ψ
      (cpatt1^[[evar:cvar↦ϕ]])
      HΓ
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      Hp
    ).
    mlRewrite Htmp at 1.
    clear Htmp.
    mlRewrite IH2 at 1.
    pose proof (Htmp := predicate_propagate_right_2 Γ
      (cpatt2^[[evar:cvar↦ψ and ϕ]])
      ψ
      (cpatt1^[[evar:cvar↦ϕ]])
      HΓ
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      Hp
    ).
    mlRewrite <- Htmp at 1.
    clear Htmp.
    pose proof (Htmp := predicate_propagate_left_2 Γ
      (cpatt2^[[evar:cvar↦ψ and ϕ]])
      ψ
      (cpatt1^[[evar:cvar↦ϕ]])
      HΓ
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      Hp
    ).
    mlRewrite Htmp at 1.
    clear Htmp.
    mlRewrite IH1 at 1.
    pose proof (Htmp := predicate_propagate_left_2 Γ
      (cpatt2^[[evar:cvar↦ψ and ϕ]])
      ψ
      (cpatt1^[[evar:cvar↦ψ and ϕ]])
      HΓ
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      ltac:(wf_auto2)
      Hp
    ).
    mlRewrite <- Htmp at 1.
    fromMLGoal.
    useBasicReasoning.
    apply pf_iff_equiv_refl.
    wf_auto2.
  + pose proof (IH1 := IHsz cpatt1).
    feed specialize IH1.
    { wf_auto2. }
    {
      unfold mu_in_evar_path in *.
      simpl in Hmf.
      case_match.
      2: { lia. }
      rewrite negb_false_iff.
      eapply (introT (Nat.eqb_spec 0 _)).
      lia.
    }
    { lia. }
    pose proof (IH2 := IHsz cpatt2).
    feed specialize IH2.
    { wf_auto2. }
    {
      unfold mu_in_evar_path in *.
      simpl in Hmf.
      case_match.
      2: { lia. }
      rewrite negb_false_iff.
      eapply (introT (Nat.eqb_spec 0 _)).
      lia.
    }
    { lia. }
    toMLGoal.
    { wf_auto2. }
    mlSplitAnd.
    {
      mlIntro "H1".
      mlDestructAnd "H1" as "Hψ" "Himp".
      mlSplitAnd.
      { mlExact "Hψ". }
      mlAdd IH2 as "IH2".
      mlDestructAnd "IH2" as "IH21" "IH22".
      mlIntro "H".
      mlAssert ("Htmp": ((ψ and cpatt2^[[evar:cvar↦ψ and ϕ]]) ---> cpatt2^[[evar:cvar↦ψ and ϕ]])).
      { wf_auto2. }
      {
        mlIntro "H0".
        mlDestructAnd "H0" as "H00" "H01".
        mlExact "H01".
      }
      mlApply "Htmp".
      mlClear "Htmp".
      mlAdd IH1 as "IH1".
      mlDestructAnd "IH1" as "IH11" "IH12".
      mlApply "IH21".
      mlSplitAnd. mlExact "Hψ".
      mlApply "Himp".
      mlClear "Himp".
      mlAssert ("Htmp": ((ψ and cpatt1^[[evar:cvar↦ϕ]]) ---> cpatt1^[[evar:cvar↦ϕ]])).
      { wf_auto2. }
      {
        mlIntro "H0".
        mlDestructAnd "H0" as "H00" "H01".
        mlExact "H01".
      }
      mlApply "Htmp".
      mlClear "Htmp".
      mlApply "IH12".
      mlSplitAnd.
      { mlExact "Hψ". }
      { mlExact "H". }
    }
    {
      mlAdd IH1 as "IH1".
      mlAdd IH2 as "IH2".
      mlDestructAnd "IH1" as "IH11" "IH12".
      mlDestructAnd "IH2" as "IH21" "IH22".
      mlIntro "H1".
      mlDestructAnd "H1" as "Hψ" "H2".
      mlSplitAnd. mlExact "Hψ".
      mlIntro "H3".
      mlAssert ("IH11'": (ψ and cpatt1^[[evar:cvar↦ψ and ϕ]])).
      { wf_auto2. }
      {
        mlApply "IH11".
        mlSplitAnd.
        { mlExact "Hψ". }
        { mlExact "H3". }
      }
      mlClear "IH11".
      mlAssert ("H4": (ψ and cpatt2^[[evar:cvar↦ψ and ϕ]])).
      { wf_auto2. }
      {
        mlDestructAnd "IH11'" as "IH11'1" "IH11'2".
        mlSplitAnd. mlExact "Hψ".
        mlApply "H2".
        mlExact "IH11'2".
      }
      mlAssert ("IH22'": (ψ and cpatt2^[[evar:cvar↦ϕ]])).
      { wf_auto2. }
      {
        mlApply "IH22".
        mlExact "H4".
      }
      mlClear "IH22".
      mlDestructAnd "IH22'" as "IH22'1" "IH22'2".
      mlExact "IH22'2".
    }
  +
    toMLGoal.
    { wf_auto2. }
    mlApplyMeta extract_common_from_equivalence_1.
    mlIntro "Hψ".
    remember (evar_fresh_s (free_evars (cpatt ---> ϕ ---> ψ) ∪ {[cvar]})) as x0.
    specialize (IHsz (cpatt^{evar:0↦x0})).
    feed specialize IHsz.
    {
      wf_auto2.
    }
    {
      unfold mu_in_evar_path in *.
      simpl in Hmf.
      case_match.
      2: { lia. }
      rewrite negb_false_iff.
      eapply (introT (Nat.eqb_spec 0 _)).
      rewrite evar_open_mu_depth.
      { solve_fresh_neq. }
      symmetry in H.
      exact H.
    }
    {
      rewrite evar_open_size'. lia.
    }
    mlSplitAnd; mlIntro "H".
    {
      mlDestructEx "H" as x0.
      {
        cbn. rewrite union_empty_r_L.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn. set_solver.
      }
      {
        cbn.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn.
        eapply transitivity. apply free_evars_free_evar_subst.
        set_solver.
      }
      {
        cbn.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn.
        eapply transitivity. apply free_evars_free_evar_subst.
        set_solver.
      }
      mlExists x0. mlSimpl.
      rewrite evar_open_free_evar_subst_swap.
      { solve_fresh_neq. }
      { wf_auto2. }
      rewrite evar_open_free_evar_subst_swap.
      { solve_fresh_neq. }
      { wf_auto2. }

      mlAssert ("Hand": (ψ and (cpatt^{evar:0↦x0}^[[evar:cvar↦ϕ]]))).
      { wf_auto2. }
      { mlSplitAnd; mlAssumption. }
      mlClear "Hψ". mlClear "H".
      mlRevertLast.
      mlRewrite IHsz at 1.
      mlIntro "H".
      mlDestructAnd "H" as "H1" "H2".
      mlExact "H2".
    }
    {
      mlDestructEx "H" as x0.
      {
        cbn. rewrite union_empty_r_L.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn. set_solver.
      }
      {
        cbn.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn.
        eapply transitivity. apply free_evars_free_evar_subst.
        set_solver.
      }
      {
        cbn.
        eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        clear. cbn.
        eapply transitivity. apply free_evars_free_evar_subst.
        set_solver.
      }
      mlExists x0. mlSimpl.
      rewrite evar_open_free_evar_subst_swap.
      { solve_fresh_neq. }
      { wf_auto2. }
      rewrite evar_open_free_evar_subst_swap.
      { solve_fresh_neq. }
      { wf_auto2. }

      mlAssert ("Hand": (ψ and (cpatt^{evar:0↦x0}^[[evar:cvar↦ψ and ϕ]]))).
      { wf_auto2. }
      { mlSplitAnd; mlAssumption. }
      mlClear "Hψ". mlClear "H".
      mlRevertLast.
      mlRewrite <- IHsz at 1.
      mlIntro "H".
      mlDestructAnd "H" as "H1" "H2".
      mlExact "H2".
    }

  +
    destruct (decide (cvar ∈ free_evars cpatt)).
    {
      unfold mu_in_evar_path in Hmf.
      cbn in Hmf.
      case_match.
      2: { lia. }
      rewrite maximal_mu_depth_to_S in H.
      assumption.
      inversion H.
    }
    {
      rewrite free_evar_subst_no_occurrence.
      { assumption. }
      rewrite free_evar_subst_no_occurrence.
      { assumption. }
      useBasicReasoning.
      apply pf_iff_equiv_refl.
      wf_auto2.
    }
Defined.

(* Lemma 89 *)
Lemma mu_and_predicate_propagation {Σ : Signature} {syntax : Syntax} Γ ϕ ψ X :
  Definedness_Syntax.theory ⊆ Γ ->
  well_formed (mu, ϕ) ->
  well_formed ψ ->
  (* "Let X be a set variable that does not occur under any µ-binder in ϕ" *)
  (forall x, evar_is_fresh_in x ϕ ->
    mu_in_evar_path x ϕ^[svar:0↦patt_free_evar x] 0 = false
  ) ->
  svar_is_fresh_in X ϕ ->
  svar_is_fresh_in X ψ ->
  Γ ⊢ is_predicate_pattern ψ ->
  Γ ⊢ (mu, (ψ and ϕ)) <---> (ψ and (mu, ϕ)).
Proof.
  intros HΓ wfm wfψ Hϕnomu fϕ fψ Hp.

  assert (well_formed (mu , ψ and ϕ)).
  {
    clear -wfm wfψ.
    unfold well_formed,well_formed_closed in *.
    cbn in *. fold no_negative_occurrence_db_b.
    destruct_and!.
    split_and!; try reflexivity; try assumption.
    {
      apply wfc_impl_no_neg_occ.
      assumption.
    }
    {
      wf_auto2.
    }
  }

  assert (svar_has_negative_occurrence X ψ^{svar:0↦X} = false).
  {
    clear -wfm wfψ fψ.
    unfold well_formed,well_formed_closed in *.
    cbn in *. fold no_negative_occurrence_db_b svar_has_negative_occurrence.
    repeat rewrite orb_false_iff.
    destruct_and!.
    apply positive_negative_occurrence_db_named.
    { apply wfc_impl_no_neg_occ. assumption. }
    apply fresh_svar_no_neg.
    apply fψ.
  }

  assert (svar_has_negative_occurrence X ψ^[svar:0↦patt_free_svar X] = false).
  {
    clear -wfm wfψ fψ.
    unfold well_formed,well_formed_closed in *.
    cbn in *. fold no_negative_occurrence_db_b svar_has_negative_occurrence.
    destruct_and!.
    apply svar_hno_bsvar_subst.
    3: { apply fresh_svar_no_neg. exact fψ. }
    {
      cbn. congruence.
    }
    {
      cbn. rewrite decide_eq_same. intros _.
      apply wfc_impl_no_neg_occ. assumption.
    }
  }

  assert (svar_has_negative_occurrence X ϕ^{svar:0↦X} = false).
  {
    wf_auto2.
  }

  apply pf_iff_split.
  { assumption. }
  { wf_auto2. }

  (* Makes set_solver work later in the proof. *)
  unfold svar_is_fresh_in in fϕ, fψ.
  {
    toMLGoal.
    {
      wf_auto2.
    }
    mlIntro "H".
    mlSplitAnd; fromMLGoal.
    {
      apply Knaster_tarski.
      { try_solve_pile. }
      { wf_auto2. }
      unfold instantiate.
      mlSimpl.
      rewrite -> well_formed_bsvar_subst with (k := 0).
      toMLGoal.
      { wf_auto2. }
      mlIntro.
      mlDestructAnd "0".
      mlExact "1".
      { lia. }
      { wf_auto2. }
    }
    {
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := (ψ and ϕ)) (X := X).
      rewrite <- svar_quantify_svar_open with (n := 0) (phi := ϕ) (X := X) at 2.
      apply mu_monotone.
      { try_solve_pile. }
      {
        unfold well_formed,well_formed_closed in *.
        cbn in *. fold no_negative_occurrence_db_b svar_has_negative_occurrence.
        repeat rewrite orb_false_iff.
        repeat split; try reflexivity; try assumption.
      }
      { wf_auto2. }
      {
        unfold svar_open.
        mlSimpl.
        gapply pf_conj_elim_r.
        { try_solve_pile. }
        { wf_auto2. }
        { wf_auto2. }
      }
      { assumption. }
      { wf_auto2. }
      { set_solver. }
      { wf_auto2. }
    }
  }

  {
    toMLGoal.
    { wf_auto2. }
    mlRewrite (useBasicReasoning AnyReasoning (@patt_and_comm Σ Γ ψ (mu , ϕ) wfψ wfm)) at 1.
    fromMLGoal.
    apply lhs_from_and.
    { wf_auto2. }
    { wf_auto2. }
    { wf_auto2. }

    apply Knaster_tarski.
    { try_solve_pile. }
    { wf_auto2. }

    apply lhs_to_and.
    { wf_auto2.
      fold no_negative_occurrence_db_b.
      apply wfc_impl_no_neg_occ. wf_auto2.
    }
    { wf_auto2. }
    { wf_auto2. }

    toMLGoal.
    { wf_auto2. fold no_negative_occurrence_db_b. apply wfc_impl_no_neg_occ. wf_auto2. }
    assert (Htmp : is_true (well_formed (mu , ϕ) ^ [ψ ---> (mu , ψ and ϕ)])).
    {
      wf_auto2. fold no_negative_occurrence_db_b. apply wfc_impl_no_neg_occ. wf_auto2.
    }
    mlRewrite (useBasicReasoning AnyReasoning (@patt_and_comm Σ Γ ((mu , ϕ) ^ [ψ ---> (mu , ψ and ϕ)]) ψ Htmp wfψ)) at 1.

    mlIntro "H".
    mlApplyMeta Pre_fixp.
    unfold instantiate.
    mlSimpl.
    fromMLGoal.
    rewrite -> well_formed_bsvar_subst with (φ := ψ) (k := 0).
    2: auto.
    2: wf_auto2.

    remember (evar_fresh_s (free_evars ϕ)) as x.
    pose proof (HH := pred_and_ctx_and Γ
      {|
        pcEvar := x;
        pcPattern := ϕ^[svar:0↦patt_free_evar x];
      |}
      (ψ ---> (mu , ψ and ϕ)) ψ HΓ).
    unfold emplace in HH. simpl in HH.
    feed specialize HH.
    { wf_auto2. }
    { wf_auto2. }
    { wf_auto2. }
    {
      apply Hϕnomu.
      subst x. clear.
      apply set_evar_fresh_is_fresh.
    }
    { assumption. }

    assert (no_negative_occurrence_db_b 0 ψ = true).
    {
      apply wfc_impl_no_neg_occ. wf_auto2.
    }

    toMLGoal.
    { wf_auto2. }
    rewrite subst_svar_evar_svar in HH.
    { subst x. solve_fresh. }
    rewrite subst_svar_evar_svar in HH.
    { subst x. solve_fresh. }
    clear Htmp.
    unshelve(epose proof (Htmp := @liftProofInfoLe _ _ _ _ AnyReasoning _ HH)).
    { try_solve_pile. }
    mlRewrite Htmp at 1.

    clear Heqx x H Htmp.

    remember (evar_fresh_s (free_evars ϕ)) as x.
    pose proof (HH' := impl_ctx_impl_pos Γ
      {|
        pcEvar := x;
        pcPattern := ϕ^[svar:0↦patt_free_evar x];
      |}
      (ψ and (ψ ---> (mu , ψ and ϕ)))
      (mu , ψ and ϕ)
      AnyReasoning
      ).
    unfold emplace in HH'. simpl in HH'.
    feed specialize HH'.
    { wf_auto2. }
    { wf_auto2. }
    { wf_auto2. }
    { unfold is_positive_context. cbn.
      unfold well_formed in wfm.
      cbn in wfm.
      destruct_and! wfm.
      apply no_neg_svar_subst.
      {  clear -H2 Heqx. subst. eapply evar_is_fresh_in_richer'. 2: apply set_evar_fresh_is_fresh. set_solver. }
      { assumption. }
    }
    { try_solve_pile. }
    toMLGoal.
    { wf_auto2. }
    { mlIntro "H". mlDestructAnd "H". mlApply "1". mlExact "0". }

    rewrite subst_svar_evar_svar in HH'.
    {
      subst x. solve_fresh.
    }

    rewrite subst_svar_evar_svar in HH'.
    {
      subst x. solve_fresh.
    }

    mlIntro "H".
    mlDestructAnd "H" as "H0" "H1".
    mlSplitAnd.
    + mlExact "H0".
    + mlApplyMeta HH'. mlExact "H1".
  }
Defined.

Lemma fresh_impl_no_mu_in_evar_path {Σ : Signature} x phi k:
  evar_is_fresh_in x phi ->
  mu_in_evar_path x phi k = false.
Proof.
  move: k x.
  induction phi; intros k x' Hx'; unfold mu_in_evar_path in *;
    cbn in *; try reflexivity.
  {
    destruct (decide (x = x')); try reflexivity.
    unfold evar_is_fresh_in in Hx'. cbn in Hx'.
    exfalso. set_solver.
  }
  {
    unfold evar_is_fresh_in in *.
    cbn in Hx'.
    specialize (IHphi1 k x' ltac:(set_solver)).
    specialize (IHphi2 k x' ltac:(set_solver)).
    repeat case_match; try reflexivity; cbn in *; lia.
  }
  {
    unfold evar_is_fresh_in in *.
    cbn in Hx'.
    specialize (IHphi1 k x' ltac:(set_solver)).
    specialize (IHphi2 k x' ltac:(set_solver)).
    repeat case_match; try reflexivity; cbn in *; lia.
  }
  {
    unfold evar_is_fresh_in in *.
    cbn in Hx'.
    specialize (IHphi k x' ltac:(set_solver)).
    exact IHphi.
  }
  {
    unfold evar_is_fresh_in in *.
    cbn in Hx'.
    specialize (IHphi (S k) x' ltac:(set_solver)).
    exact IHphi.
  }
Qed.

Lemma hbvum_impl_mmdt0 {Σ : Signature} phi dbi x y k:
  evar_is_fresh_in x phi ->
  evar_is_fresh_in y phi ->
  well_formed_closed_mu_aux phi (S dbi) ->
  maximal_mu_depth_to k y phi^[svar:dbi↦patt_free_evar y] = 0 ->
  maximal_mu_depth_to k x phi^[svar:dbi↦patt_free_evar x] = 0
.
Proof.
  move: x y dbi k.
  induction phi; intros x' y dbi k Hfrx' Hfry Hwf H; cbn in *; try reflexivity.
  {
    unfold evar_is_fresh_in in *. cbn in *.
    repeat case_match; subst; try reflexivity.
    set_solver.
  }
  {
    repeat case_match; cbn in *; try reflexivity;
    rewrite decide_eq_same; try reflexivity; subst;
    case_match; subst; cbn in *; try reflexivity; contradiction.
  }
  {
    unfold evar_is_fresh_in in *. cbn in *.
    rewrite -> IHphi1 with (y := y).
    5: lia.
    4: wf_auto2.
    3: set_solver.
    2: set_solver.
    cbn. apply IHphi2 with (y := y).
    { set_solver. }
    { set_solver. }
    { wf_auto2. }
    { lia. }
  }
  {
    unfold evar_is_fresh_in in *. cbn in *.
    rewrite -> IHphi1 with (y := y).
    5: lia.
    4: wf_auto2.
    3: set_solver.
    2: set_solver.
    cbn. apply IHphi2 with (y := y).
    { set_solver. }
    { set_solver. }
    { wf_auto2. }
    { lia. }
  }
  {
    eauto with nocore.
  }
  {
    eauto with nocore.
  }
Qed.

Theorem deduction_theorem {Σ : Signature} {syntax : Syntax} Γ ϕ ψ
  (gpi : ProofInfo)
  (pf : Γ ∪ {[ ψ ]} ⊢i ϕ using gpi) :
  well_formed ϕ ->
  well_formed ψ ->
  theory ⊆ Γ ->
  pi_generalized_evars gpi ## (gset_to_coGset (free_evars ψ)) ->
  pi_substituted_svars gpi ## (gset_to_coGset (free_svars ψ)) ->
  pi_uses_advanced_kt gpi = false ->
  Γ ⊢i ⌊ ψ ⌋ ---> ϕ
  using AnyReasoning.
Proof.
  intros wfϕ wfψ HΓ HnoExGen HnoSvarSubst Hnoakt.
  destruct pf as [pf Hpf]. simpl.
  induction pf.
  - (* hypothesis *)
    rename axiom into axiom0.
    (* We could use [apply elem_of_union in e; destruct e], but that would be analyzing Prop
        when building Set, which is prohibited. *)
    destruct (decide (axiom0 = ψ)).
    + subst.
      eapply useGenericReasoning.
      2: {
        apply total_phi_impl_phi; try assumption.
        instantiate (1 := fresh_evar ψ). solve_fresh.
      }
      {
        try_solve_pile.
      }

    + assert (axiom0 ∈ Γ).
      { clear -e n. set_solver. }
      toMLGoal.
      { wf_auto2. }
      mlIntro. mlClear "0". fromMLGoal.
      eapply useGenericReasoning.
      2: apply (BasicProofSystemLemmas.hypothesis Γ axiom0 i H).
      try_solve_pile.
  - (* P1 *)
    toMLGoal.
    { wf_auto2. }
    do 3 mlIntro. mlExactn 1.
  - (* P2 *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    useBasicReasoning.
    apply P2; assumption.
  - (* P3 *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    useBasicReasoning.
    apply P3; assumption.
  - (* Modus Ponens *)
    assert (well_formed phi2).
    { unfold well_formed, well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto.
    }
    assert (well_formed phi1).
    {
      clear -pf1. apply proved_impl_wf in pf1. exact pf1.
    }

    remember_constraint as i'.

    destruct Hpf as [Hpf2 Hpf3 Hpf4].
    simpl in Hpf2, Hpf3, Hpf4.
    feed specialize IHpf1.
    {
      constructor; simpl.
      { set_solver. }
      { set_solver. }
      { unfold implb in *.
        destruct (uses_kt pf1) eqn:Hktpf1;[|reflexivity]. simpl in *.
        exact Hpf4.
      }
      {
        cbn in *.
        unfold is_true.
        rewrite implb_true_iff.
        intro Hakt1.
        rewrite Hakt1 in pwi_pf_kta. simpl in pwi_pf_kta.
        unfold is_true in pwi_pf_kta.
        rewrite andb_true_iff in pwi_pf_kta.
        destruct pwi_pf_kta as [HH1 HH2].
        rewrite HH1.
        simpl.
        apply kt_unreasonably_implies_somehow.
        exact Hakt1.
      }
    }
    { assumption. }
    feed specialize IHpf2.
    {
      constructor; simpl.
      { set_solver. }
      { set_solver. }
      { unfold implb in *.
        destruct (uses_kt pf2) eqn:Hktpf2;[|reflexivity].
        rewrite orb_comm in Hpf4. simpl in *.
        exact Hpf4.
      }
      {
        cbn in *.
        unfold is_true.
        rewrite implb_true_iff.
        intro Hakt1.
        rewrite Hakt1 in pwi_pf_kta. rewrite orb_true_r in pwi_pf_kta.
        simpl in pwi_pf_kta.
        unfold is_true in pwi_pf_kta.
        rewrite andb_true_iff in pwi_pf_kta.
        destruct pwi_pf_kta as [HH1 HH2].
        rewrite HH1.
        simpl.
        apply kt_unreasonably_implies_somehow.
        exact Hakt1.
      }
    }
    { wf_auto2. }

    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlAdd IHpf2.
    mlAssert ((phi1 ---> phi2)).
    { wf_auto2. }
    { mlApply "1". mlExactn 1. }
    mlApply "2".
    mlAdd IHpf1.
    mlApply "3".
    mlExactn 2.
  - (* Existential Quantifier *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    useBasicReasoning.
    apply Ex_quan. wf_auto2.
  - (* Existential Generalization *)
    destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
    simpl in Hpf2, Hpf3, Hpf4.
    (*
    simpl in HnoExGen.
    case_match;[congruence|]. *)
    feed specialize IHpf.
    {
      constructor; simpl.
      { clear -Hpf2. set_solver. }
      { clear -Hpf3. set_solver. }
      { apply Hpf4. }
      { apply Hpf5. }
    }
    { clear Hpf5; wf_auto2. }

    apply reorder_meta in IHpf.
    2-4:  clear Hpf5; wf_auto2.
    apply Ex_gen with (x := x) in IHpf.
    3: { simpl. set_solver. }
    2: { try_solve_pile. }
    apply reorder_meta in IHpf.
    2-4: clear Hpf5; wf_auto2.
    exact IHpf.

  - (* Propagation of ⊥, left *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    useBasicReasoning.
    apply Prop_bott_left; assumption.
  - (* Propagation of ⊥, right *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0"; auto. fromMLGoal.
    useBasicReasoning.
    apply Prop_bott_right; assumption.
  - (* Propagation of 'or', left *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0"; auto. fromMLGoal.
    useBasicReasoning.
    apply Prop_disj_left; assumption.
  - (* Propagation of 'or', right *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0"; auto. fromMLGoal.
    useBasicReasoning.
    apply Prop_disj_right; assumption.
  - (* Propagation of 'exists', left *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0"; auto. fromMLGoal.
    useBasicReasoning.
    apply Prop_ex_left; assumption.
  - (* Propagation of 'exists', right *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0"; auto. fromMLGoal.
    useBasicReasoning.
    apply Prop_ex_right; assumption.
  - (* Framing left *)
    assert (well_formed (phi1)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (phi2)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (psi)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (phi1 ---> phi2)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }
    destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
    simpl in Hpf2,Hpf3,Hpf4.
    feed specialize IHpf.
    {
      constructor; simpl.
      { set_solver. }
      { set_solver. }
      { apply Hpf4. }
      { apply Hpf5. }
    }
    { wf_auto2. }
    clear Hpf5.
    remember_constraint as i'.

    (*
    apply useGenericReasoning with (i0 := i') in IHpf.
    2: {
      subst i'.
      apply pile_evs_svs_kt.
      { clear. set_solver. }
      { apply reflexivity. }
      { reflexivity. }
    }
    *)
    assert (S2: Γ ⊢i phi1 ---> (phi2 or ⌈ ! ψ ⌉) using i').
    { toMLGoal.
      {  wf_auto2. }
      mlAdd IHpf. mlIntro.
      mlAdd (useBasicReasoning i' (A_or_notA Γ (⌈ ! ψ ⌉) ltac:(wf_auto2))).
      mlDestructOr "0".
      - mlRight. mlExact "3".
      - mlLeft.
        mlApply "4". mlExact "1".
    }

    assert (S3: Γ ⊢i (⌈ ! ψ ⌉ $ psi) ---> ⌈ ! ψ ⌉ using i').
    {
      replace (⌈ ! ψ ⌉ $ psi)
        with (subst_ctx (ctx_app_l AC_patt_defined psi ltac:(assumption)) (! ψ))
        by reflexivity.
      subst i'.
      gapply in_context_impl_defined; auto.
      instantiate (1 := fresh_evar (ψ ---> psi)).
      try_solve_pile.
      solve_fresh.
    }

    assert (S4: Γ ⊢i (phi1 $ psi) ---> ((phi2 or ⌈ ! ψ ⌉) $ psi) using i').
    {
      unshelve (eapply Framing_left).
      { wf_auto2. } 2: exact S2.
      subst i'. clear. try_solve_pile.
    }

    assert (S5: Γ ⊢i (phi1 $ psi) ---> ((phi2 $ psi) or (⌈ ! ψ ⌉ $ psi)) using i').
    {
      pose proof (Htmp := prf_prop_or_iff Γ (ctx_app_l box psi ltac:(assumption)) phi2 (⌈! ψ ⌉)).
      feed specialize Htmp.
      { wf_auto2. }
      { wf_auto2. }
      simpl in Htmp.
      apply pf_iff_proj1 in Htmp.
      3: wf_auto2.
      2: wf_auto2.
      subst i'.
      eapply syllogism_meta.
      5: {
        gapply Htmp.
        clear. try_solve_pile.
      }
      4: assumption.
      all: wf_auto2.
    }

    assert (S6: Γ ⊢i ((phi2 $ psi) or (⌈ ! ψ ⌉ $ psi)) ---> ((phi2 $ psi) or (⌈ ! ψ ⌉)) using i').
    {
      toMLGoal.
      { wf_auto2. }
      mlIntro. mlAdd S3.
      (* TODO we need a tactic for adding  something with stronger constraint. *)
      mlAdd (useBasicReasoning i' (A_or_notA Γ (phi2 $ psi) ltac:(auto))).
      mlDestructOr "2".
      - mlLeft. mlExact "3".
      - mlRight. mlApply "1". mlApply "0". mlExactn 0.
    }

    assert (S7: Γ ⊢i (phi1 $ psi) ---> ((phi2 $ psi)  or ⌈ ! ψ ⌉) using i').
    {
      toMLGoal.
      { wf_auto2. }
      mlAdd S5. mlAdd S6. mlIntro.
      mlAssert (((phi2 $ psi) or (⌈ ! ψ ⌉ $ psi))).
      { wf_auto2. }
      { mlApply "0". mlExactn 2. }
      mlDestructOr "3".
      - mlLeft. mlExactn 3.
      - mlApply "1". mlRight. mlExactn 3.
    }

    toMLGoal.
    { wf_auto2. }
    do 2 mlIntro. mlAdd S7.
    mlAssert ((phi2 $ psi or ⌈ ! ψ ⌉)).
    { wf_auto2. }
    { mlApply "2". mlExactn 2. }
    mlDestructOr "3".
    + mlExactn 3.
    + mlAssert ((phi2 $ psi or ⌈ ! ψ ⌉)).
      { wf_auto2. }
      { mlApply "2". mlExactn 2. }
      mlAdd (useBasicReasoning i' (A_or_notA Γ (phi2 $ psi) ltac:(auto))).
      mlDestructOr "4".
      * mlExactn 0.
      * mlAdd (useBasicReasoning i' (bot_elim Γ (phi2 $ psi) ltac:(auto))).
        mlApply "4".
        mlApply "0".
        mlExactn 5.
  - (* Framing right *)
    assert (well_formed (phi1)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (phi2)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (psi)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }

    assert (well_formed (phi1 ---> phi2)).
    { unfold well_formed,well_formed_closed in *. simpl in *.
      destruct_and!. split_and!; auto. }
    simpl in HnoExGen. simpl in HnoSvarSubst.

    destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
    simpl in Hpf2,Hpf3,Hpf4.
    feed specialize IHpf.
    {
      constructor; simpl.
      { set_solver. }
      { set_solver. }
      { apply Hpf4. }
      { apply Hpf5. }
    }
    { clear Hpf5; wf_auto2. }

    clear Hpf5.

    remember_constraint as i'.

    (*
    apply useGenericReasoning with (i := i') in IHpf.
    2: {
      subst i'.
      apply pile_evs_svs_kt.
      { clear. set_solver. }
      { apply reflexivity. }
      { reflexivity. }
    }
    *)
    assert (S2: Γ ⊢i phi1 ---> (phi2 or ⌈ ! ψ ⌉) using i').
    { toMLGoal.
      { wf_auto2. }
      mlAdd IHpf. mlIntro.
      mlAdd (useBasicReasoning i' (A_or_notA Γ (⌈ ! ψ ⌉) ltac:(wf_auto2))).
      mlDestructOr "2".
      - mlRight. mlExactn 0.
      - mlLeft.
        mlAssert((phi1 ---> phi2)).
        { wf_auto2. }
        { mlApply "0". mlExactn 0. }
        mlApply "2". mlExactn 2.
    }

    assert (S3: Γ ⊢i (psi $ ⌈ ! ψ ⌉) ---> ⌈ ! ψ ⌉ using i').
    {
      replace (psi $ ⌈ ! ψ ⌉)
        with (subst_ctx (ctx_app_r psi AC_patt_defined ltac:(assumption)) (! ψ))
        by reflexivity.
        subst i'.
        gapply in_context_impl_defined; auto.
        instantiate (1 := fresh_evar (ψ ---> psi)).
        try_solve_pile. solve_fresh.
    }

    assert (S4: Γ ⊢i (psi $ phi1) ---> (psi $ (phi2 or ⌈ ! ψ ⌉)) using i').
    {
      (* TODO: have a variant of apply which automatically solves all wf constraints.
        Like: unshelve (eapply H); try_wfauto
      *)
      unshelve (eapply Framing_right).
      { wf_auto2. }
      2: exact S2.
      subst i'. try_solve_pile.
    }

    assert (S5: Γ ⊢i (psi $ phi1) ---> ((psi $ phi2) or (psi $ ⌈ ! ψ ⌉)) using i').
    {
      pose proof (Htmp := prf_prop_or_iff Γ (ctx_app_r psi box ltac:(assumption)) phi2 (⌈! ψ ⌉)).
      feed specialize Htmp.
      { wf_auto2. }
      { wf_auto2. }
      simpl in Htmp.
      apply pf_iff_proj1 in Htmp.
      2,3: wf_auto2.
      subst i'.
      eapply syllogism_meta.
      5: gapply Htmp; try_solve_pile.
      4: assumption.
      all: wf_auto2.
    }

    assert (S6: Γ ⊢i ((psi $ phi2) or (psi $ ⌈ ! ψ ⌉)) ---> ((psi $ phi2) or (⌈ ! ψ ⌉)) using i').
    {
      toMLGoal.
      { wf_auto2. }
      mlIntro. mlAdd S3.
      mlAdd (useBasicReasoning i' (A_or_notA Γ (psi $ phi2) ltac:(auto))).
      mlDestructOr "2".
      - mlLeft. mlExactn 0.
      - mlRight. mlApply "1". mlApply "0". mlExactn 0.
    }

    assert (S7: Γ ⊢i (psi $ phi1) ---> ((psi $ phi2)  or ⌈ ! ψ ⌉) using i').
    {
      toMLGoal.
      { wf_auto2. }
      mlAdd S5. mlAdd S6. mlIntro.
      mlAssert (((psi $ phi2) or (psi $ ⌈ ! ψ ⌉))).
      { wf_auto2. }
      { mlApply "0". mlExactn 2. }
      mlDestructOr "3".
      - mlLeft. mlExactn 3.
      - mlApply "1". mlRight. mlExactn 3.
    }

    toMLGoal.
    { wf_auto2. }
    do 2 mlIntro. mlAdd S7.
    mlAssert ((psi $ phi2 or ⌈ ! ψ ⌉)).
    { wf_auto2. }
    { mlApply "2". mlExactn 2. }
    mlDestructOr "3".
    + mlExactn 3.
    + mlAssert ((psi $ phi2 or ⌈ ! ψ ⌉)).
      { wf_auto2. }
      { mlApply "2". mlExactn 2. }
      mlAdd (useBasicReasoning i' (A_or_notA Γ (psi $ phi2) ltac:(auto))).
      mlDestructOr "4".
      * mlExactn 0.
      * mlAdd (useBasicReasoning i' (bot_elim Γ (psi $ phi2) ltac:(auto))).
        mlApply "4".
        mlApply "0".
        mlExactn 5.
  - (* Set variable substitution *)
    simpl in HnoExGen. simpl in HnoSvarSubst. simpl in IHpf.
    destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
    simpl in Hpf2, Hpf3, Hpf4.
    feed specialize IHpf.
    {
      constructor; simpl.
      { exact Hpf2. }
      { clear -Hpf3. set_solver. }
      { exact Hpf4. }
      { exact Hpf5. }
    }
    {
      wf_auto2.
    }
    clear Hpf5.
    remember_constraint as i'.

    replace (⌊ ψ ⌋ ---> phi^[[svar: X ↦ psi]])
      with ((⌊ ψ ⌋ ---> phi)^[[svar: X ↦ psi]]).
    2: {  simpl.
        rewrite [ψ^[[svar: X ↦ psi]]]free_svar_subst_fresh.
        {
          clear -HnoSvarSubst Hpf3. unfold svar_is_fresh_in. set_solver.
        }
        reflexivity.
    }
    apply Svar_subst.
    3: {
      apply IHpf.
    }
    {
      subst i'. try_solve_pile.
    }
    { wf_auto2. }

  - (* Prefixpoint *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    apply useBasicReasoning.
    apply Pre_fixp. wf_auto2.
  - (* Knaster-Tarski *)
    destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
    apply lhs_to_and.
    1-3: clear Hpf2 Hpf3 Hpf4 Hpf5; wf_auto2.
    remember_constraint as pi.
    feed specialize IHpf.
    {
      cbn. constructor; try assumption.
      {
        clear -Hpf4.
        destruct (uses_kt pf) eqn:H; rewrite H; simpl.
        2: reflexivity.
        simpl in Hpf4.
        assumption.
      }
      {
        unfold is_true.
        rewrite implb_true_iff. intros HH.
        cbn in *.
        unfold is_true in Hpf5.
        rewrite HH in Hpf5. rewrite orb_true_r in Hpf5. simpl in Hpf5.
        rewrite Hnoakt in Hpf5. inversion Hpf5.
      }
    }
    { clear Hpf2 Hpf3 Hpf4 Hpf5.
      wf_auto2.
    }

    cbn in *.
    unfold is_true in Hpf5.
    rewrite andb_true_r in Hpf5.
    rewrite Hnoakt in Hpf5.
    rewrite implb_false_r in Hpf5.
    destruct (decide (has_bound_variable_under_mu phi = true)) as [Ht|Hf].
    {
      rewrite Ht in Hpf5. simpl in Hpf5. inversion Hpf5.
    }
    apply not_true_is_false in Hf.
    remember (svar_fresh_s (free_svars ⌊ ψ ⌋ ∪ free_svars phi)) as X.
    epose proof (Htmp := @mu_and_predicate_propagation _ _ Γ phi ⌊ ψ ⌋ X _ _ _).
    feed specialize Htmp.
    {
      unfold has_bound_variable_under_mu in Hf.
      unfold mu_in_evar_path in Hf.
      rewrite negb_false_iff in Hf.
      rewrite Nat.eqb_eq in Hf.
      symmetry in Hf.
      intros.
      unfold mu_in_evar_path.
      erewrite hbvum_impl_mmdt0.
      { reflexivity. }
      { assumption. }
      3: { apply Hf. }
      { apply set_evar_fresh_is_fresh. }
      { wf_auto2. }
    }
    {
      subst X. clear.
      eapply svar_is_fresh_in_richer'.
      2: apply set_svar_fresh_is_fresh'.
      { set_solver. }
    }
    {
      subst X. clear.
      eapply svar_is_fresh_in_richer'.
      2: apply set_svar_fresh_is_fresh'.
      { set_solver. }
    }
    {
      gapply floor_is_predicate.
      { try_solve_pile. }
      { exact HΓ. }
      { wf_auto2. }
    }
    toMLGoal.
    { clear Hpf2 Hpf3 Hpf4; wf_auto2. }
    mlIntro.
    apply pf_iff_proj2 in Htmp.
    mlApplyMeta Htmp in "0". clear Htmp.
    fromMLGoal.
    apply Knaster_tarski.
    { subst pi. try_solve_pile. }
    1,4,5:clear Hpf2 Hpf3 Hpf4 Hpf5; wf_auto2.
    {
      fold no_negative_occurrence_db_b.
      apply wfc_impl_no_neg_occ.
      wf_auto2.
    }
    {
      fold no_negative_occurrence_db_b.
      apply wfc_impl_no_neg_occ.
      wf_auto2.
    }
    2: { try_solve_pile. }

    unfold instantiate.
    mlSimpl.
    apply lhs_from_and.

    1-3:clear Hpf2 Hpf3 Hpf4; wf_auto2.

    rewrite -> well_formed_bsvar_subst with (k := 0).
    3: wf_auto2.
    2: lia.
    simpl in IHpf.
    apply IHpf.

  - (* Existence *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    apply useBasicReasoning.
    apply Existence.
  - (* Singleton *)
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlClear "0". fromMLGoal.
    apply useBasicReasoning.
    apply Singleton_ctx. wf_auto2.
    Unshelve.
    2,3: wf_auto2.
    1: exact HΓ.
Defined.

Lemma MLGoal_deduct'
  {Σ : Signature}
  {syntax : Syntax}
  (Γ : Theory)
  (l : hypotheses)
  name
  (ψ g : Pattern)
  (C : PatternCtx)
  (i : ProofInfo)
  :
  theory ⊆ Γ ->
  pi_generalized_evars i ## gset_to_coGset (free_evars ψ) ->
  pi_substituted_svars i ## gset_to_coGset (free_svars ψ) ->
  pi_uses_advanced_kt i = false ->
  mkMLGoal Σ (Γ ∪ {[ψ]}) l g i ->
  mkMLGoal Σ Γ ((mkNH _ name ⌊ ψ ⌋) :: l) g AnyReasoning .
Proof.
  intros HΓ Hge Hse Hakt H.
  intros wf1 wf2. cbn in *.
  feed specialize H.
  { wf_auto2. }
  { cbn in wf2. cbn. destruct_and!. assumption. }
  cbn in *.
  eapply deduction_theorem.
  { apply H. }
  { wf_auto2. }
  { wf_auto2. }
  { exact HΓ. }
  { assumption. }
  { assumption. }
  { assumption. }
Defined.

Lemma MLGoal_deduct
  {Σ : Signature}
  {syntax : Syntax}
  (Γ : Theory)
  (l₁ l₂ : hypotheses)
  name
  (ψ g : Pattern)
  :
  theory ⊆ Γ ->
  mkMLGoal Σ (Γ ∪ {[ψ]}) (l₁ ++ l₂) g
    ((ExGen := ⊤ ∖ gset_to_coGset (free_evars ψ), SVSubst := ⊤ ∖ gset_to_coGset (free_svars ψ), KT := true, AKT := false)) ->
  mkMLGoal Σ Γ (l₁ ++ (mkNH _ name ⌊ ψ ⌋) :: l₂) g AnyReasoning .
Proof.
  intros HΓ H.
  intros wf1 wf2. cbn in *.

  rewrite map_app in wf2. cbn in wf2.
  rewrite map_app in wf2. cbn in wf2.
  rewrite foldr_app in wf2. cbn in wf2.
  rewrite foldr_andb_true_iff in wf2.

  assert (well_formed ψ).
  {
    wf_auto2.
  }
  assert (wf (map nh_patt l₁)).
  {
    destruct_and!. assumption.
  }
  assert (wf (map nh_patt l₂)).
  {
    destruct_and!. assumption.
  }

  feed specialize H.
  { wf_auto2. }
  { cbn in wf2. cbn.
    rewrite map_app. cbn.
    rewrite map_app. cbn.
    rewrite foldr_app. cbn.
    rewrite foldr_andb_true_iff.
    destruct_and!.
    split_and!;assumption.
  }
  cbn in *.
  rewrite map_app.
  apply reorder_middle_to_head_meta.
  { wf_auto2. }
  { wf_auto2. }
  { wf_auto2. }
  { wf_auto2. }
  cbn.
  eapply deduction_theorem.
  {
    rewrite map_app in H.
    apply H.
  }
  { wf_auto2. }
  { wf_auto2. }
  { exact HΓ. }
  { cbn. rewrite union_empty_l_L.
    unfold disjoint.
    unfold set_disjoint_instance.
    intros x Hx HContra.
    rewrite elem_of_gset_to_coGset in HContra.
    cbn in Hx.
    clear -Hx HContra.
    contradiction.
  }
  { cbn. rewrite union_empty_l_L.
    unfold disjoint.
    unfold set_disjoint_instance.
    intros x Hx HContra.
    rewrite elem_of_gset_to_coGset in HContra.
    cbn in Hx.
    clear -Hx HContra.
    contradiction.
  }
  {
    reflexivity.
  }
Defined.

Tactic Notation "mlDeduct" constr(name) :=
  _ensureProofMode;
  _mlReshapeHypsByName name;
  apply MLGoal_deduct;
  [try assumption|_mlReshapeHypsBack]
.

#[local]
Example ex_deduct
  {Σ : Signature} {syntax : Syntax} (Γ : Theory) (ϕ₁ ϕ₂ ϕ₃ : Pattern)
  :
  well_formed ϕ₁ ->
  well_formed ϕ₂ ->
  well_formed ϕ₃ ->
  theory ⊆ Γ ->
  Γ ⊢ ϕ₁ ---> ⌊ ϕ₂ ⌋ ---> ϕ₃ ---> ϕ₂
.
Proof.
  intros wf1 wf2 wf3 HΓ.
  mlIntro "H1".
  mlIntro "H2".
  mlIntro "H3".
  mlDeduct "H2".
  useBasicReasoning.
  mlClear "H1".
  mlClear "H3".
  fromMLGoal.
  apply hypothesis.
  { wf_auto2. }
  { set_solver. }
Defined.

Close Scope ml_scope.
Close Scope string_scope.
Close Scope list_scope.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

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

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTreceived_prepare_like.
Require Export PBFTknows_prepared.

Section PBFT_A_1_4.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Definition node0 : Rep := bij_inv node_bij nat_n_2Fp1_0.

  Definition nat2node (n : nat) : node_type.
  Proof.
    destruct node_bij as [f a b].
    destruct (lt_dec n num_nodes) as [d|d].
    - exact (f (mk_nat_n d)). (* here we now that n < num_replicas so we can use our bijection *)
    - exact node0. (* here num_replicas <= n, so we return a default value: replica0 *)
  Defined.

  Lemma A_1_4 :
    forall (eo : EventOrdering)
           (e1  : Event)
           (e2  : Event)
           (i   : Rep)
           (j   : Rep)
           (n   : SeqNum)
           (v   : View)
           (d1  : PBFTdigest)
           (d2  : PBFTdigest)
           (st1 : PBFTstate)
           (st2 : PBFTstate),
      AXIOM_authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> AXIOM_PBFTcorrect_keys eo
      -> AXIOM_exists_at_most_f_faulty [e1, e2] F
      -> loc e1 = PBFTreplica i                               (* e1 happened at location i *)
      -> loc e2 = PBFTreplica j                               (* e2 happened at location j *)
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some st1 (* state of i at e1 *)
      -> state_sm_on_event (PBFTreplicaSM j) e2 = Some st2 (* state of j at e2 *)
      -> prepared (request_data v n d1) st1 = true            (* the entry for <v,n,d1> is prepared at e1 *)
      -> prepared (request_data v n d2) st2 = true            (* the entry for <v,n,d2> is prepared at e2 *)
      -> d1 = d2.
  Proof.
    introv sendbyz corkeys fbyz eqloc1 eqloc2 eqst1 eqst2; introv prep1 prep2.

    destruct (PBFTdigestdeq d1 d2) as [d|d]; auto.
    assert False; tcsp.

    assert (well_formed_log (log st1)) as wf1 by eauto 2 with pbft.
    assert (well_formed_log (log st2)) as wf2 by eauto 2 with pbft.

    eapply prepared_as_pbft_knows_rd in prep1;[| |eauto|];auto;[].
    eapply prepared_as_pbft_knows_rd in prep2;[| |eauto|];auto;[].

    pose proof (knows_in_intersection
                  e1 e2
                  (2 * F + 1)
                  (request_data v n d1)
                  (request_data v n d2)
                  one_pre_prepare
                  [e1,e2]
                  F) as q.
    repeat (autodimp q hyp); simpl; eauto 3 with pbft;
      try (complete (unfold num_replicas; try omega));[].
    destruct q as [e1' [e2' [pl1 [pl2 q]]]]; repnd.

    pose proof (two_know_own_prepare_like eo e1' e2' pl1 pl2) as z.
    repeat (autodimp z hyp); eauto 2 with pbft; try congruence;[].
    eapply implies_prepare_like_have_same_digests in z;[|eauto|eauto]; tcsp.
  Qed.

End PBFT_A_1_4.


Require Import VST.progs.conclib.
Require Import VST.progs.ghost.
(*Require Import VST.progs.list_dt. Import LsegSpecial.*)
Require Import VST.floyd.library.
Require Import VST.progs.lock_coupling.
Require Import Sorting.

Require Export VST.floyd.Funspec_old_Notation.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).

Definition surely_malloc_spec :=
 DECLARE _surely_malloc
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).

Definition tnode := Tstruct _node noattr.

Module ZOrder <: Orders.TotalLeBool.
  Definition t := Z.
  Definition leb x y := Z.leb x y.
  Theorem leb_total : forall x y, leb x y = true \/ leb y x = true.
  Proof. intros; destruct (Zle_bool_total x y); auto. Qed.
End ZOrder.

Module Import ZSort := Sort ZOrder.

Lemma StronglySorted_imp : forall (R R' : Z -> Z -> Prop) l (HR' : forall x y, R x y -> R' x y)
  (HR : StronglySorted R l), StronglySorted R' l.
Proof.
  intros; induction HR; constructor; auto.
  eapply Forall_impl, H; auto.
Qed.

Notation sorted := (StronglySorted Z.le).

Lemma sort_sorted : forall l, sorted (sort l).
Proof.
  intro; eapply StronglySorted_imp, StronglySorted_sort.
  - intros.
    rewrite <- Z.leb_le; auto.
  - intros ???; apply Zle_bool_trans.
Qed.

Inductive set_op := Add (e : Z) | Remove (e : Z).

Fixpoint apply_hist S h :=
  match h with
  | [] => S
  | Add e :: h' => if in_dec Z_eq_dec e S then apply_hist S h' else apply_hist (sort (e :: S)) h'
  | Remove e :: h' => apply_hist (remove Z_eq_dec e S) h'
  end.

Lemma apply_hist_app : forall h1 S h2, apply_hist S (h1 ++ h2) = apply_hist (apply_hist S h1) h2.
Proof.
  induction h1; auto; simpl; intros.
  destruct a; auto.
  destruct (in_dec _ _ _); auto.
Qed.

(* up *)
Lemma In_remove : forall A (a : A) dec l, incl (remove dec a l) l.
Proof.
  induction l; simpl; auto.
  destruct (dec a a0).
  - apply incl_tl; auto.
  - apply incl_same_head; auto.
Qed.

Lemma remove_sorted : forall a l, sorted l -> sorted (remove Z_eq_dec a l).
Proof.
  induction l; auto; simpl; intro.
  inv H.
  destruct (Z.eq_dec a a0); auto.
  constructor; auto.
  rewrite Forall_forall in *; intros ? Hin.
  apply In_remove in Hin; auto.
Qed.

Lemma apply_hist_sorted : forall h S, sorted S -> sorted (apply_hist S h).
Proof.
  induction h; auto; simpl; intros.
  destruct a.
  - destruct (in_dec _ _ _); auto.
    apply IHh, sort_sorted.
  - apply IHh, remove_sorted; auto.
Qed.

Definition hist := hist_part set_op.

(*Definition q_lock_pred' (t : type) P p (vals : list (val * reptype t)) head (addc remc : val) lock gsh h :=
  !!(Zlength vals <= MAX /\ 0 <= head < MAX /\ consistent h [] vals) &&
  (data_at Tsh tqueue (rotate (complete MAX (map fst vals)) head MAX, (vint (Zlength vals),
                      (vint head, (vint ((head + Zlength vals) mod MAX), (addc, remc))))) p *
   cond_var Tsh addc * cond_var Tsh remc * malloc_token Tsh (sizeof tqueue_t) p *
   malloc_token Tsh (sizeof tcond) addc * malloc_token Tsh (sizeof tcond) remc *
   malloc_token Tsh (sizeof tlock) lock * ghost gsh (Tsh, h) p *
   fold_right sepcon emp (map (fun x => let '(p, v) := x in
     !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals)).

Definition q_lock_pred A P p lock gsh := EX vals : list (val * reptype A), EX head : Z,
  EX addc : val, EX remc : val, EX h : hist _, q_lock_pred' A P p vals head addc remc lock gsh h.*)

Definition node_lock_inv e p := EX n : val, EX l : val,(*EX h : list set_op,*)
  field_at Tsh tnode [StructField _val] (vint e) p *
  field_at Tsh tnode [StructField _next] n p * field_at Tsh tnode [StructField _lock] l n *
  node_lock_inv.

Definition node_pred sh e p := EX l : val,
  !!((*sepalg.join gsh1 gsh2 Tsh /\*) repable_signed e /\ field_compatible tnode [] p) &&
  (field_at sh tnode [StructField _lock] l p *
   lock_inv sh l (node_lock_inv e p) (* * ghost gsh1 (lsh, h) p*)).

Definition new_node_spec :=
 DECLARE _new_node
  WITH e : Z
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e))
   SEP ()
  POST [ tptr tnode ]
   EX p : val,
   PROP ()
   LOCAL (temp ret_temp p)
   SEP (node_pred Tsh e p).

Definition del_node_spec :=
 DECLARE _new_node
  WITH e : Z, p : val
  PRE [ _n OF tptr tnode ]
   PROP ()
   LOCAL (temp _n p)
   SEP (node_pred Tsh e p)
  POST [ tvoid ]
   PROP ()
   LOCAL ()
   SEP ().

Definition tnode_pair := Tstruct _node_pair noattr.

Definition list_inv sh H h := node_pred sh Int.min_signed H * ghost_hist h H.

Definition locate_spec :=
 DECLARE _locate
  WITH e : Z, sh : share, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv sh H h)
  POST [ tptr tnode_pair ]
   EX h' : hist, EX p : val, EX n1 : val, EX n2 : val, EX e1 : Z, EX e2 : Z, EX sh : share,
   PROP (incl h h'; e1 < e <= e2)
   LOCAL ()
   SEP (list_inv H h'; data_at Tsh tnode_pair (n1, n2) p; node_pred sh e1 n1;
        field_at Tsh tnode [StructField _val] (vint e1) n1; field_at Tsh tnode [StructField _next] n2 n1;
        node_pred sh e2 n2; node_lock_inv e2 n2).

Definition add_spec :=
 DECLARE _add
  WITH e : Z, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv H h)
  POST [ tint ]
   EX h' : hist, EX S : list Z, EX t' : nat,
   PROP (incl h h'; apply_hist [] h' = S)
   LOCAL (temp ret_temp (if in_dec Z_eq_dec e S then 0 else 1))
   SEP (list_inv H (h' ++ [(t', Add e)]).

Definition remove_spec :=
 DECLARE _remove
  WITH e : Z, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv H h)
  POST [ tint ]
   EX h' : hist, EX S : list Z, EX t' : nat,
   PROP (incl h h'; apply_hist [] h' = S)
   LOCAL (temp ret_temp (if in_dec Z_eq_dec e S then 1 else 0))
   SEP (list_inv H (h' ++ [(t', Remove e)]).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog tt nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=   ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
  freelock_spec; surely_malloc_spec; new_node_spec; del_node_spec; locate_spec; add_spec; remove_spec; main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma ctr_inv_precise : forall p,
  precise (cptr_lock_inv p).
Proof.
  intro; eapply derives_precise, data_at__precise with (sh := Ews)(t := tint); auto.
  intros ? (? & H); apply data_at_data_at_ in H; eauto.
Qed.
#[export] Hint Resolve ctr_inv_precise.

Lemma ctr_inv_positive : forall ctr,
  positive_mpred (cptr_lock_inv ctr).
Proof.
  intro; apply ex_positive; auto.
Qed.
#[export] Hint Resolve ctr_inv_positive.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  unfold cptr_lock_inv at 2; simpl.
  Intro z.
  forward.
  forward.
  rewrite field_at_isptr; Intros.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists (z + 1); entailer!. }
  forward.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  unfold cptr_lock_inv at 2; simpl.
  Intro z.
  forward.
  rewrite data_at_isptr; Intros.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists z; entailer!. }
  forward.
  Exists z; entailer!.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (ctr, sh, lock).
  forward_call (lockt, sh, lock_inv sh lock (cptr_lock_inv ctr), thread_lock_inv sh ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { unfold thread_lock_inv; lock_props.
    rewrite selflock_eq at 2; cancel.
    eapply derives_trans; [apply lock_inv_later | cancel]. }
  forward.
Qed.

Lemma lock_struct : forall p, data_at_ Ews (Tstruct _lock_t noattr) p |-- data_at_ Ews tlock p.
Proof.
  intros.
  unfold data_at_, field_at_; unfold_field_at 1%nat.
  unfold field_at; simpl.
  rewrite field_compatible_cons; simpl; entailer.
  (* temporarily broken *)
Admitted.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  name ctr _ctr; name lockt _thread_lock; name lock _ctr_lock.
  start_function.
  forward.
  forward.
  forward.
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { rewrite (sepcon_comm _ (fold_right_sepcon _)); apply sepcon_derives; [cancel | apply lock_struct]. }
  rewrite field_at_isptr; Intros.
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists 0; cancel. }
  (* need to split off shares for the locks here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (lockt, Ews, thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { rewrite (sepcon_comm _ (fold_right_sepcon _)); apply sepcon_derives; [cancel | apply lock_struct]. }
  get_global_function'' _thread_func.
  apply extract_exists_pre; intros f_.
  forward_spawn (val * share * val * val)%type (f_, Vint (Int.repr 0), (ctr, sh1, lock, lockt),
    fun (x : (val * share * val * val)) (_ : val) => let '(ctr, sh, lock, lockt) := x in
         !!readable_share sh && emp * lock_inv sh lock (cptr_lock_inv ctr) *
         lock_inv sh lockt (thread_lock_inv sh ctr lock lockt)).
  { simpl spawn_pre; entailer!.
    Exists _args (fun x : val * share * val * val => let '(ctr, sh, lock, lockt) := x in
      [(_ctr, ctr); (_ctr_lock, lock); (_thread_lock, lockt)]); entailer.
    rewrite !sepcon_assoc; apply sepcon_derives.
    { apply derives_refl'. f_equal.
      unfold NDmk_funspec.
      apply mk_funspec_congr; auto.
      apply eq_JMeq.
      extensionality x x0.
      destruct x0 as (?, (((?, ?), ?), ?)); simpl.
      rewrite <- !sepcon_assoc; reflexivity.  }
    erewrite <- lock_inv_share_join; try apply Hsh; auto.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto.
    entailer!. }
  forward_call (ctr, sh2, lock).
  forward_call (lockt, sh2, thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  forward_call (ctr, sh2, lock).
  Intro z.
  forward_call (lock, sh2, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  forward_call (lockt, Ews, sh1, |>lock_inv sh1 lock (cptr_lock_inv ctr), |>thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { unfold thread_lock_inv; lock_props.
    - apply later_positive; auto.
    - unfold rec_inv.
      rewrite selflock_eq at 1.
      rewrite later_sepcon; f_equal.
      apply lock_inv_later_eq.
    - rewrite selflock_eq at 2.
      erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel.
      rewrite sepcon_comm, <- !sepcon_assoc, sepcon_comm.
      apply sepcon_derives; [apply lock_inv_later | cancel]. }
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    erewrite sepcon_assoc, lock_inv_share_join; eauto; cancel. }
  forward.
Qed.

Definition extlink := ext_link_prog prog.
Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_incr.
semax_func_cons body_read.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model TSO *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition A := ((*failed: try X with emptyset_0*) emptyset_0) ⊔ ((*failed: try A with emptyset_0*) emptyset_0).
Definition P := M ⊓ !A.
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition WR r := r ⊓ [W] ⋅ top ⋅ [R].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition RR r := r ⊓ [R] ⋅ top ⋅ [R].
Definition RM r := r ⊓ [R] ⋅ top ⋅ [M].
Definition MR r := r ⊓ [M] ⋅ top ⋅ [R].
Definition WM r := r ⊓ [W] ⋅ top ⋅ [M].
Definition MW r := r ⊓ [M] ⋅ top ⋅ [W].
Definition MM r := r ⊓ [M] ⋅ top ⋅ [M].
Definition AA r := r ⊓ [A] ⋅ top ⋅ [A].
Definition AP r := r ⊓ [A] ⋅ top ⋅ [P].
Definition PA r := r ⊓ [P] ⋅ top ⋅ [A].
Definition PP r := r ⊓ [P] ⋅ top ⋅ [P].
Definition AM r := r ⊓ [A] ⋅ top ⋅ [M].
Definition MA r := r ⊓ [M] ⋅ top ⋅ [A].
Definition noid r : relation events := r ⊓ !id.
Definition atom := [A].
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition com := rf ⊔ (fr ⊔ co).
Definition test := acyclic (po_loc ⊔ com).
Definition test_0 := is_empty (rmw ⊓ fre ⋅ coe).
Definition po_ghb := WW po ⊔ RM po.
Definition mfence_0 : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence_0 : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence_0 : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition poWR := WR po.
Definition i1 := MA poWR.
Definition i2 := AM poWR.
Definition implied := i1 ⊔ i2.
Definition ghb := mfence_0 ⊔ (implied ⊔ (po_ghb ⊔ (rfe ⊔ (fr ⊔ co)))).
Definition tso := acyclic ghb.
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := test /\ (test_0 /\ tso).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW mfence lfence sfence A P WW WR RW RR RM MR WM MW MM AA AP PA PP AM MA noid atom generate_orders generate_cos cobase coi coe fr fri fre com test test_0 po_ghb mfence_0 lfence_0 sfence_0 poWR i1 i2 implied ghb tso witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model TSO *)


From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import Event Cell Memory Configuration Thread.
From imm Require Import Prog.
From imm Require Import ProgToExecution.
From imm Require Import Events.
Require Import Event_imm_promise.
Require Import PromiseLTS.

Set Implicit Arguments.
Remove Hints plus_n_O.

Definition init_threads (prog : Prog.t) : Threads.syntax :=
  IdentMap.mapi (fun tid (linstr : list Instr.t) => existT _ (thread_lts tid) linstr) prog.

Definition conf_step (PC PC' : Configuration.t) :=
  exists pe tid, Configuration.step pe tid PC PC'.

Definition final_memory_state (memory : Memory.t) (loc : location) : option value :=
  match Memory.get loc (Memory.max_ts loc memory) memory with
  | Some (_, msg) => Some msg.(Message.val)
  | None => None
  end.

Definition conf_init (prog : Prog.t) := Configuration.init (init_threads prog).

Definition promise_allows (prog : Prog.t) (final_memory : location -> value) :=
  exists PC,
    ⟪STEPS   : conf_step＊ (conf_init prog) PC⟫ /\
    ⟪FINAL   : Configuration.is_terminal PC⟫ /\
    ⟪OUTCOME : forall loc, final_memory_state PC.(Configuration.memory) loc =
                           Some (final_memory loc)⟫.


(* En este archivo se demuestra la corrección de la acción startService *)
Require Export Exec.
Require Import Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.

Section StartService.

Lemma startServiceCorrect : forall (s:System) (i:Intent) (ic:iCmp) (sValid: validstate s),
    (pre (startService i ic) s) -> post_startService i ic s (startService_post i ic s).
Proof.
    intros.
    unfold post_startService.
    simpl in H.
    unfold pre_startService in H;simpl in H.
    destruct_conj H.
    unfold addIntent.
    unfold onlyIntentsChanged.
    unfold startService_post.
    simpl.
    split; intros.
    split; intros.
    right;auto.
    split;intros.
    destruct H2.
    right.
    inversion H2.
    split;auto.
    unfold createIntent in *.
    simpl.
    repeat (split;auto).
    left;auto.
    left.
    assert (i=createIntent i None).
    case_eq i;intros.
    unfold createIntent.
    simpl.
    rewrite<- H.
    rewrite H2.
    simpl.
    auto.
    rewrite<- H2.
    auto.

    repeat (split;auto).
Qed.

Lemma notPreStartServiceThenError : forall (s:System) (i:Intent) (ic:iCmp), ~(pre (startService i ic) s) -> validstate s -> exists ec : ErrorCode, response (step s (startService i ic)) = error ec /\ ErrorMsg s (startService i ic) ec /\ s = system (step s (startService i ic)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_startService in H.
    unfold startService_safe.
    unfold startService_pre.
    case_eq (negb (intTypeEqBool (intType i) intService));intros.
    exists incorrect_intent_type.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H1.
    invertBool H1.
    intro;apply H1.
    rewrite H2.
    destruct intTypeEqBool;auto.
    case_eq (isSomethingBool Perm (brperm i));intros.
    exists faulty_intent.
    split;auto.
    split;auto.
    unfold isSomethingBool in H2.
    intro.
    destruct (brperm i).
    discriminate H3.
    discriminate H2.
    case_eq (negb (isiCmpRunningBool ic s));intros.
    exists instance_not_running.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H3.
    invertBool H3.
    intro;apply H3.
    apply isiCmpRunningCorrect;auto.
    case_eq ( existsb (fun pair : iCmp * Intent => if idInt_eq (idI i) (idI (snd pair)) then true else false) (sentIntents (state s)));intros.
    exists intent_already_sent.
    split;auto.
    split;auto.
    rewrite existsb_exists in H4.
    destruct H4.
    exists (snd x), (fst x).
    destruct H4.
    split.
    destruct x.
    simpl.
    auto.
    destruct idInt_eq in H5.
    rewrite e;auto.
    discriminate H5.
    destruct H.
    split.
    rewrite negb_false_iff in H1.
    unfold intTypeEqBool in H1.
    destruct (intType i);auto;discriminate H1.
    split.
    unfold isSomethingBool in H2.
    destruct (brperm i);auto;discriminate H2.
    split.
    rewrite negb_false_iff in H3.
    apply isiCmpRunningCorrect;auto.
    invertBool H4.
    intro;apply H4.
    rewrite existsb_exists.
    destruct H.
    destruct H.
    destruct H.
    exists (x0,x).
    split;auto.
    simpl.
    destruct idInt_eq;auto.
Qed.

Lemma startServiceIsSound : forall (s:System) (i:Intent) (ic:iCmp) (sValid: validstate s),
        exec s (startService i ic) (system (step s (startService i ic))) (response (step s (startService i ic))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (startService i ic) s));intro.
    left.
    simpl.
    assert(startService_pre i ic s = None).
    unfold startService_pre.
    destruct H.
    rewrite H.
    unfold intTypeEqBool.
    assert (negb true=false).
    rewrite negb_false_iff.
    auto.
    rewrite H1.

    destruct_conj H0.
    rewrite H2.
    unfold isSomethingBool.
    assert (negb (isiCmpRunningBool ic s)=false).
    rewrite negb_false_iff.
    apply isiCmpRunningCorrect; auto.
    rewrite H3.

    assert (existsb (fun pair : iCmp * Intent => if idInt_eq (idI i) (idI (snd pair)) then true else false) (sentIntents (state s))=false).
    rewrite <-not_true_iff_false.
    unfold not;intros.
    rewrite existsb_exists in H5.
    destruct H5.
    destruct H5.
    apply H4.
    exists (snd x).
    destruct idInt_eq in H6.
    exists (fst x).
    case_eq x;intros.
    simpl.
    rewrite<- H7.
    rewrite H7 in e.
    simpl in e.
    split;auto.
    discriminate H6.
    rewrite H5.
    auto.
    unfold startService_safe;simpl.
    rewrite H0;simpl.
    split;auto.
    split;auto.
    apply startServiceCorrect;auto.
    right.
    apply notPreStartServiceThenError;auto.
Qed.
End StartService.