From trillium.prelude Require Import classical.
From trillium.traces Require Import trace.
From trillium.program_logic Require Import
     ectx_language language traces.

(** Ideally, all definitions in this file should be computational.
    But that's is too much work. Hence, since we already assume classical
    axioms in this work we can use those to axiomatize the function that
    given an execution extracts its observations. *)

Record Event (Λ : language) := mkEvent {
  is_triggered :> expr Λ → state Λ → expr Λ → state Λ → Prop;
  (* The following two axioms ensure that events are only triggered
     on head steps. *)
  is_triggered_not_val :
    ∀ e1 σ1 e2 σ2, is_triggered e1 σ1 e2 σ2 → to_val e1 = None;
  is_triggered_ectx_free :
    ∀ e1 σ1 e2 σ2,
      is_triggered e1 σ1 e2 σ2 →
      ∀ K e1', e1 = ectx_fill K e1' → is_Some (to_val e1') ∨ K = ectx_emp;
  is_triggered_not_stuttering :
    ∀ e1 σ1 e2 σ2,
      is_triggered e1 σ1 e2 σ2 → e1 ≠ e2;
}.

Arguments is_triggered {_} _ _ _ _.
Arguments is_triggered_not_val {_} _ _ _ _.
Arguments is_triggered_ectx_free {_} _.
Arguments is_triggered_not_stuttering {_} _.

Record EventObservation (Λ : language) := mkEventObservation {
  pre_expr : expr Λ;
  pre_state : state Λ;
  post_expr : expr Λ;
  post_state : state Λ;
}.

Arguments mkEventObservation {_} _ _ _ _.
Arguments pre_state {_} _.
Arguments pre_expr {_} _.
Arguments post_state {_} _.
Arguments post_expr {_} _.

Definition validEventObservation
           {Λ : language} (EV : Event Λ) (eo : EventObservation Λ) :=
  EV eo.(pre_expr) eo.(pre_state) eo.(post_expr) eo.(post_state).

Definition event_obs (Λ : language) := list (EventObservation Λ).

Definition valid_event_obs
           {Λ : language} (EV : Event Λ) (eo : event_obs Λ)  : Prop :=
  Forall (validEventObservation EV) eo.

Inductive trace_has_events {Λ : language} (EV : Event Λ) :
          execution_trace Λ → event_obs Λ → Prop :=
| singleton_events c : trace_has_events EV {tr[c]} []
| extend_observed ex c c' tp1 tp2 efs K eo eobs oζ:
    trace_ends_in ex c →
    c.2 = eo.(pre_state) →
    c.1 = tp1 ++ ectx_fill K eo.(pre_expr) :: tp2 →
    c'.2 = eo.(post_state) →
    c'.1 = tp1 ++ ectx_fill K eo.(post_expr) :: tp2 ++ efs →
    validEventObservation EV eo →
    trace_has_events EV ex eobs →
    trace_has_events EV (ex :tr[oζ]: c') (eobs ++ [eo])
| extend_not_observed ex c c' eobs oζ:
    trace_ends_in ex c →
    (∀ tp1 tp2 efs K e1 e2,
      c.1 = tp1 ++ ectx_fill K e1 :: tp2 →
      c'.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs →
      ¬ EV e1 c.2 e2 c'.2) →
    trace_has_events EV ex eobs →
    trace_has_events EV (ex :tr[oζ]: c') eobs.

Section properties.
  Context {Λ : language} (EV : Event Λ).

  Implicit Types e : expr Λ.
  Implicit Types tp : list (expr Λ).
  Implicit Types σ : state Λ.
  Implicit Types eobs : event_obs Λ.
  Implicit Types obs : EventObservation Λ.
  Implicit Types ex : execution_trace Λ.

  Lemma validEventObservation_exprs_neq obs :
    validEventObservation EV obs → obs.(pre_expr) ≠ obs.(post_expr).
  Proof. intros; eapply is_triggered_not_stuttering; done. Qed.

  Lemma validEventObservation_not_val obs :
    validEventObservation EV obs → to_val obs.(pre_expr) = None.
  Proof. intros; eapply is_triggered_not_val; done. Qed.

  Lemma trace_has_events_valid ex eobs :
    trace_has_events EV ex eobs → valid_event_obs EV eobs.
  Proof.
    induction 1 as [|ex [tp σ] [tp' σ']|]; simplify_eq/=.
    - by constructor.
    - apply Forall_app; split; first done.
      apply Forall_singleton; done.
    - done.
  Qed.

  Lemma event_in_the_middle tp1 tp2 K e1 e2 efs tp1' tp2' K' eo efs' :
    validEventObservation EV eo →
    to_val e1 = None →
    (∀ e1' K'', e1 = ectx_fill K'' e1' → is_Some (to_val e1') ∨ K'' = ectx_emp) →
    tp1 ++ ectx_fill K e1 :: tp2 = tp1' ++ ectx_fill K' (pre_expr eo) :: tp2' →
    tp1 ++ ectx_fill K e2 :: tp2 ++ efs =
    tp1' ++ ectx_fill K' (post_expr eo) :: tp2' ++ efs' →
    pre_expr eo = e1 ∧ post_expr eo = e2.
  Proof.
    intros HEV He1 Hnectx Heq1 Heq2.
    destruct (decide (length tp1' < length tp1)).
    { pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'.
      rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq1'.
      pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'.
      rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq2'.
      rewrite Heq1' in Heq2'; simplify_eq.
      apply ectx_fill_inj in Heq2'.
      exfalso; eapply validEventObservation_exprs_neq; done. }
    pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'.
    rewrite /= lookup_app_r in Heq1'; last lia.
    rewrite // lookup_app_r // Nat.sub_diag /= in Heq1'.
    pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'.
    rewrite /= lookup_app_r in Heq2'; last lia.
    rewrite // lookup_app_r // Nat.sub_diag /= in Heq2'.
    rewrite /= app_comm_cons lookup_app_l in Heq2'; last first.
    { simpl.
      assert (length tp1' < length tp1 + S (length tp2)); last lia.
      pose proof (f_equal length Heq1) as Heq'.
      rewrite !app_length //= in Heq'; lia. }
    destruct (length tp1' - length tp1); last first.
    { simpl in *.
      rewrite Heq1' in Heq2'; simplify_eq.
      apply ectx_fill_inj in Heq2'.
      exfalso; eapply validEventObservation_exprs_neq; done. }
    simplify_eq/=.
    pose proof Heq1' as Heq1''.
    apply ectx_fill_positive in Heq1'' as [[K'' ->]|[K'' ->]];
          [| |done|
             by apply validEventObservation_not_val].
    - rewrite ectx_comp_comp in Heq2'.
      apply ectx_fill_inj in Heq2'.
      rewrite ectx_comp_comp in Heq1'.
      apply ectx_fill_inj in Heq1'.
      simplify_eq.
      assert (K'' = ectx_emp) as ->.
      { edestruct Hnectx as [[]|]; [done| |done].
        pose proof (validEventObservation_not_val _ HEV); simplify_eq. }
      rewrite !ectx_fill_emp; done.
    - rewrite ectx_comp_comp in Heq1'.
      apply ectx_fill_inj in Heq1'.
      rewrite ectx_comp_comp in Heq2'.
      apply ectx_fill_inj in Heq2'.
      assert (K'' = ectx_emp) as ->.
      { edestruct @is_triggered_ectx_free as [[]|];
          [done|symmetry; done| |done].
        pose proof (validEventObservation_not_val _ HEV); simplify_eq. }
      rewrite ectx_fill_emp in Heq1'.
      rewrite ectx_fill_emp in Heq2'.
      simplify_eq; done.
  Qed.

  (** This lemma, proven completely constructively, is an evidence why we
      are justified in using classical logic in constructing observations of
      a valid execution trace. *)
  Lemma trace_has_events_functional ex eobs eobs' :
    valid_exec ex →
    trace_has_events EV ex eobs →
    trace_has_events EV ex eobs' →
    eobs = eobs'.
  Proof.
    intros Hex; revert eobs eobs'.
    induction Hex as [|ex [tp σ] oζ [tp' σ'] Hendsin Hstep Hex IHex];
      intros eobs eobs'.
    { do 2 inversion 1; simplify_eq; done. }
    inversion 1 as [|ex' [tpz σz] [tpy σy] tp1z tp2z ? ? obs3 ? eobs3 Hendsin'|
                    ex' [tpz σz] [tpy σy] ? ? Hendsin' Hnobs]; simplify_eq/=.
    - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq.
      inversion 1 as [|ex' [tpx σx] [tpw σw] tp1x tp2x ? ? obs4 ? eobs4 Hendsin''
                           ??? Htpseq| ex' [tpx σx] [tpw σw] ? ? Hendsin'' Hnobs];
        simplify_eq/=.
      + repeat f_equal; first by apply IHex.
        pose proof (trace_ends_in_inj _ _ _ Hendsin' Hendsin'') as Htpseq'.
        simplify_eq Htpseq'; intros Htpseq'1 Htpseq'2; clear Htpseq'.
        assert (pre_expr obs3 = pre_expr obs4 ∧ post_expr obs3 = post_expr obs4)
          as [? ?].
        eapply event_in_the_middle; [done| | |done|].
        { apply validEventObservation_not_val; done. }
        { intros; eapply is_triggered_ectx_free; eauto. }
        { done. }
        destruct obs3; destruct obs4; simplify_eq/=; done.
      + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq.
        exfalso; eapply Hnobs; eauto.
    - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq.
      inversion 1 as [|ex' [tpx σx] [tpw σw] ? ? ? ? obs4 eobs4 ?  Hendsin''|
                    ex' [tpx σx] [tpw σw] ? Hendsin'' Hnobs']; simplify_eq/=.
      + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq.
        exfalso; eapply Hnobs; eauto.
      + apply IHex; done.
  Qed.

  Lemma trace_has_valid_events ex eobs :
    trace_has_events EV ex eobs → valid_event_obs EV eobs.
  Proof.
    induction 1; [constructor| |done].
    apply Forall_app_2; first done.
    apply Forall_singleton; done.
  Qed.

  Lemma events_for_trace ex : ∃ eobs, trace_has_events EV ex eobs.
  Proof.
    induction ex as [c|ex [eobs Hthe] ? c].
    { eexists; econstructor. }
    destruct (ExcludedMiddle ((∃ tp1 tp2 efs K e1 e2,
      (trace_last ex).1 = tp1 ++ ectx_fill K e1 :: tp2 ∧
      c.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs ∧
      EV e1 (trace_last ex).2 e2 c.2))) as
        [(tp1&tp2&efs&K&e1&e2&Heq1&Heq2&HEV)|Hnex].
    - exists (eobs ++ [mkEventObservation e1 (trace_last ex).2 e2 c.2]).
      econstructor; eauto using trace_ends_in_last.
    - exists eobs; econstructor; [done| |done].
      intros ?????????; apply Hnex; eauto 10.
  Qed.

  Definition events_of_trace ex : event_obs Λ := epsilon (events_for_trace ex).

  Lemma trace_has_events_of_trace ex :
    trace_has_events EV ex (events_of_trace ex).
  Proof. apply (epsilon_correct _ (events_for_trace ex)). Qed.

  Lemma events_of_trace_valid ex : valid_event_obs EV (events_of_trace ex).
  Proof. eapply trace_has_valid_events; apply trace_has_events_of_trace. Qed.

  Lemma events_of_trace_extend_same_tp ex c c' oζ:
    valid_exec (ex :tr[oζ]: c') →
    c.1 = c'.1 →
    trace_ends_in ex c →
    events_of_trace (ex :tr[oζ]: c') = events_of_trace ex.
  Proof.
    intros Hex Htps Hc.
    destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=.
    cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs).
    { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. }
    intros eobs Heobs.
    eapply trace_has_events_functional; [|apply trace_has_events_of_trace|].
    { inversion Hex; done. }
    inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done.
    pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=.
    exfalso; eapply validEventObservation_exprs_neq; first done.
    eapply ectx_fill_inj; done.
  Qed.

  Lemma events_of_singleton_trace c : events_of_trace {tr[c]} = [].
  Proof.
    eapply trace_has_events_functional;
      [constructor|apply trace_has_events_of_trace|constructor].
  Qed.

  Lemma events_of_trace_extend_pure ex c c' oζ:
    (∀ eo, validEventObservation EV eo → eo.(pre_state) ≠ eo.(post_state)) →
    valid_exec (ex :tr[oζ]: c') →
    c.2 = c'.2 →
    trace_ends_in ex c →
    events_of_trace (ex :tr[oζ]: c') = events_of_trace ex.
  Proof.
    intros Himpure Hex Htps Hc.
    destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=.
    cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs).
    { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. }
    intros eobs Heobs.
    eapply trace_has_events_functional; [|apply trace_has_events_of_trace|].
    { inversion Hex; done. }
    inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done.
    pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=.
    exfalso; eapply Himpure; eauto.
  Qed.

    Definition event_is_triggered (ob : EventObservation Λ) (c c' : cfg Λ) :=
    ∃ K tp1 tp2 efs,
      c.2 = ob.(pre_state) ∧
      c.1 = tp1 ++ ectx_fill K ob.(pre_expr) :: tp2 ∧
      c'.2 = ob.(post_state) ∧
      c'.1 = tp1 ++ ectx_fill K ob.(post_expr) :: tp2 ++ efs.

  Lemma events_of_trace_extend_app (ex : execution_trace Λ) (c : cfg Λ) oζ:
    valid_exec (ex :tr[oζ]: c) →
    ∃ evs,
      length evs ≤ 1 ∧
      events_of_trace (ex :tr[oζ]: c) = events_of_trace ex ++ evs ∧
      ∀ ev, ev ∈ evs → event_is_triggered ev (trace_last ex) c.
  Proof.
    intros Hvl.
    pose proof (trace_has_events_of_trace (ex :tr[oζ]: c)) as Hthe.
    inversion Hthe as [|?????????? Hend|]; simplify_eq.
    - eexists [_]; split; first done.
      erewrite (trace_has_events_functional ex (events_of_trace ex));
        [|by eapply valid_exec_exec_extend_inv; eauto|by apply trace_has_events_of_trace|by eauto].
      split; first done.
      intros ev; rewrite elem_of_list_singleton; intros ->.
      apply last_eq_trace_ends_in in Hend; simplify_eq.
      eexists _, _, _, _; eauto.
    - exists []; split; simpl; first lia.
      rewrite app_nil_r.
      split; last set_solver.
      apply (trace_has_events_functional (ex :tr[oζ]: c)); [done|by apply trace_has_events_of_trace|].
      eapply extend_not_observed; [eauto|eauto|by apply trace_has_events_of_trace].
  Qed.

  Lemma events_of_trace_app (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) :
    valid_exec (ex +trl+ l) →
    ∃ evs,
      length evs ≤ length l ∧
      events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧
      ∀ ev  oζ1 oζ2,
        ev ∈ evs →
        ∃ i c1 c2 oζ1' oζ2',
          ((oζ1, trace_last ex) :: l) !! i = Some (oζ1', c1) ∧
          ((oζ2, trace_last ex) :: l) !! S i = Some (oζ2', c2) ∧
          event_is_triggered ev c1 c2.
  Proof.
    induction l as [|[??]  ?] using rev_ind.
    { exists []; rewrite /= app_nil_r; split_and!; [done|done|]. set_solver. }
    rewrite -trace_append_list_assoc /=.
    intros Hvl.
    destruct IHl as (evs & Hevs1 & Hevs2 & Hevs3).
    { eapply valid_exec_exec_extend_inv; eauto. }
    apply events_of_trace_extend_app in Hvl as (evs' & Hevs'1 & Hevs'2 & Hevs'3).
    rewrite Hevs2 in Hevs'2; rewrite Hevs'2.
    rewrite -app_assoc.
    eexists; split_and!; [|done|].
    { rewrite !app_length /=; lia. }
    intros ev oζ1 oζ2 [Hev|Hev]%elem_of_app.
    - destruct (Hevs3 ev oζ1 oζ2 Hev) as (i & c1 & c2 & oζ1' & oζ2' & Hc1 & Hc2 & Htrg).
      exists i, c1, c2, oζ1', oζ2'.
      rewrite (lookup_app_l (_ :: _)); last first.
      { apply lookup_lt_Some in Hc1; simpl in *; lia. }
      rewrite lookup_app_l; last first.
      { apply lookup_lt_Some in Hc2; simpl in *; lia. }
      done.
    - destruct (trace_last_of_append_list ex l oζ1) as [oζ Heq].
      eexists (length l), _, _, oζ, _; split_and!; last by apply Hevs'3.
      + rewrite -Heq.
        rewrite (lookup_app_l (_ :: _)); first done.
        simpl; lia.
      + rewrite lookup_app_r; last done.
        rewrite Nat.sub_diag //.
  Qed.

  Lemma events_of_trace_app_map (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) :
    valid_exec (ex +trl+ l) →
    ∃ evs,
      length evs ≤ length l ∧
      events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧
      ∀ ev,
        ev ∈ evs →
        ∃ i c1 c2,
          (trace_last ex :: map snd l) !! i = Some c1 ∧
          (trace_last ex ::  map snd l) !! S i = Some c2 ∧
          event_is_triggered ev c1 c2.
  Proof.
    intros Hval. destruct (events_of_trace_app ex l Hval) as (evs & Hlen & Hevs & H).
    exists evs; repeat (split =>//). intros ev Hin.
    destruct (H ev inhabitant inhabitant Hin) as (i & c1 & c2 & oζ1 & oζ2 & Hi & HSi & Htrig).
    exists i, c1, c2. change (trace_last ex :: map snd l) with (map snd $ (inhabitant, trace_last ex) :: l).
    rewrite ->!list_lookup_fmap, Hi, HSi. done.
  Qed.
End properties.

Section properties.
  Context {Λ : ectxLanguage} (EV : Event Λ).

  Implicit Types e : expr Λ.
  Implicit Types tp : list (expr Λ).
  Implicit Types K : ectx Λ.
  Implicit Types σ : state Λ.
  Implicit Types eobs : event_obs Λ.
  Implicit Types obs : EventObservation Λ.
  Implicit Types ex : execution_trace Λ.

  Lemma events_of_trace_extend_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ :
    valid_exec ex →
    trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) →
    head_step e1 σ1 e2 σ2 efs →
    EV e1 σ1 e2 σ2 →
    events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) =
    events_of_trace EV ex ++ [mkEventObservation e1 σ1 e2 σ2].
  Proof.
    intros HexV Hex Hhstep HEV.
    pose proof (trace_has_events_of_trace
                  EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs.
    inversion Hhasevs as
        [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4|
         ????? Hei HnEV]; simplify_eq.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      rewrite -Heq4.
      assert (eobs = events_of_trace EV ex) as ->.
      { eapply trace_has_events_functional;
          [done|done| apply trace_has_events_of_trace]. }
      repeat f_equal. simpl in *.
      assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?].
      eapply event_in_the_middle; [done| | |done|].
      { eapply val_head_stuck; done. }
      { intros ?? ->; eapply head_ctx_step_val; done. }
      { done. }
      destruct eo; simplify_eq/=; done.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      exfalso; eapply HnEV; eauto.
  Qed.

  Lemma events_of_trace_extend_not_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ:
    valid_exec ex →
    trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) →
    head_step e1 σ1 e2 σ2 efs →
    ¬ EV e1 σ1 e2 σ2 →
    events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) =
    events_of_trace EV ex.
  Proof.
    intros HexV Hex Hhstep HEV.
    pose proof (trace_has_events_of_trace
                  EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs.
    inversion Hhasevs as
        [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4|
         ????? Hei HnEV Hhasevs']; simplify_eq/=.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq/=.
      exfalso.
      assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?].
      eapply event_in_the_middle; [done| | |done|].
      { eapply val_head_stuck; done. }
      { intros ?? ->; eapply head_ctx_step_val; done. }
      { done. }
      destruct eo; simplify_eq/=; done.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      eapply trace_has_events_functional;
        [done|done| apply trace_has_events_of_trace].
  Qed.

End properties.


From iris.algebra Require Import excl.
From iris_ora.algebra Require Export ora.
From iris.prelude Require Import options.

Section excl.
Context {A : ofe}.

Instance excl_orderN : OraOrderN (excl A) := dist.
Instance excl_order : OraOrder (excl A) := equiv.

Definition excl_ora_mixin : OraMixin (excl A).
Proof.
  split; try apply _; try done.
  - intros ???? Hv Ho.
    by rewrite -Ho in Hv; apply exclusiveN_r in Hv.
  - eauto.
  - apply dist_S.
  - by intros ???? ->.
  - apply equiv_dist.
  - inversion 1.
Qed.

Canonical Structure exclR := Ora (excl A) excl_ora_mixin.

End excl.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export types integer_operations.
Local Open Scope ctype_scope.
Local Unset Elimination Schemes.

Class Env (K : iType) : iType := {
  env_type_env :> IntEnv K;
  size_of : env K → type K → nat;
  align_of : env K → type K → nat;
  field_sizes : env K → list (type K) → list nat;
  alloc_can_fail : bool
}.

Arguments size_of _ _ _ _ : simpl never.
Arguments align_of _ _ _ _ : simpl never.
Arguments field_sizes _ _ _ _ : simpl never.

Definition ptr_size_of `{Env K} (Γ : env K) (τp : ptr_type K) : nat :=
  match τp with TType τ => size_of Γ τ | _ => 1 end.
Definition offset_of `{Env K} (Γ : env K) (τs : list (type K))
  (i : nat) : nat := sum_list $ take i $ field_sizes Γ τs.
Definition bit_size_of `{Env K} (Γ : env K)
  (τ : type K) : nat := size_of Γ τ * char_bits.
Definition bit_align_of `{Env K} (Γ : env K)
  (τ : type K) : nat := align_of Γ τ * char_bits.
Definition ptr_bit_size_of `{Env K} (Γ : env K) (τp : ptr_type K) : nat :=
  match τp with TType τ => bit_size_of Γ τ | _ => char_bits end.
Definition field_bit_sizes `{Env K} (Γ : env K)
    (τs : list (type K)) : list nat :=
  (λ sz, sz * char_bits) <$> field_sizes Γ τs.
Definition field_bit_padding `{Env K}
    (Γ : env K) (τs : list (type K)) : list nat :=
  zip_with (λ sz τ, sz - bit_size_of Γ τ) (field_bit_sizes Γ τs) τs.
Definition bit_offset_of `{Env K}
    (Γ : env K) (τs : list (type K)) (i : nat) : nat :=
  sum_list $ take i $ field_bit_sizes Γ τs.

Class EnvSpec (K : iType) `{Env K} := {
  int_env_spec :> IntEnvSpec K;
  size_of_ptr_ne_0 Γ τp : size_of Γ (τp.*) ≠ 0;
  size_of_int Γ τi : size_of Γ (intT τi) = rank_size (rank τi);
  size_of_void_ne_0 Γ : size_of Γ voidT ≠ 0;
  size_of_array Γ τ n : size_of Γ (τ.[n]) = n * size_of Γ τ;
  size_of_struct Γ t τs :
    ✓ Γ → Γ !! t = Some τs →
    size_of Γ (structT t) = sum_list (field_sizes Γ τs);
  size_of_fields Γ τs :
    ✓ Γ → Forall2 (λ τ sz, size_of Γ τ ≤ sz) τs (field_sizes Γ τs);
  size_of_union Γ t τs :
    ✓ Γ → Γ !! t = Some τs →
    Forall (λ τ, size_of Γ τ ≤ size_of Γ (unionT t)) τs;
  align_of_array Γ τ n : (align_of Γ τ | align_of Γ (τ.[n]));
  align_of_compound Γ c t τs i τ :
    ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ →
    (align_of Γ τ | align_of Γ (compoundT{c} t));
  align_of_divide Γ τ :
    ✓ Γ → ✓{Γ} τ → (align_of Γ τ | size_of Γ τ);
  align_of_offset_of Γ τs i τ :
    ✓ Γ → ✓{Γ}* τs → τs !! i = Some τ → (align_of Γ τ | offset_of Γ τs i);
  size_of_weaken Γ1 Γ2 τ :
    ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → size_of Γ1 τ = size_of Γ2 τ;
  align_of_weaken Γ1 Γ2 τ :
    ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → align_of Γ1 τ = align_of Γ2 τ;
  fields_sizes_weaken Γ1 Γ2 τs :
    ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 → field_sizes Γ1 τs = field_sizes Γ2 τs
}.

Section env_spec.
Context `{EnvSpec K}.
Implicit Types τ σ : type K.
Implicit Types τs σs : list (type K).
Implicit Types Γ : env K.

Lemma size_of_char Γ si : size_of Γ (intT (IntType si char_rank)) = 1.
Proof. rewrite size_of_int. by apply rank_size_char. Qed.
Lemma field_sizes_length Γ τs : ✓ Γ → length (field_sizes Γ τs) = length τs.
Proof. symmetry. by eapply Forall2_length, size_of_fields. Qed.
Lemma field_sizes_nil Γ : ✓ Γ → field_sizes Γ [] = [].
Proof. intros. apply nil_length_inv. by rewrite field_sizes_length. Qed.
Lemma size_of_union_lookup Γ t τs i τ :
  ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ →
  size_of Γ τ ≤ size_of Γ (unionT t).
Proof.
  intros. assert (Forall (λ τ, size_of Γ τ ≤ size_of Γ (unionT t)) τs) as Hτs
    by eauto using size_of_union; rewrite Forall_lookup in Hτs. eauto.
Qed.
Lemma size_of_struct_lookup Γ t τs i τ :
  ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ →
  size_of Γ τ ≤ size_of Γ (structT t).
Proof.
  intros HΓ Ht Hτs. erewrite size_of_struct by eauto. clear Ht. revert i Hτs.
  induction (size_of_fields Γ τs HΓ) as [|σ sz σs szs]; intros [|?] ?;
    simplify_equality'; auto with lia.
  transitivity (sum_list szs); eauto with lia.
Qed.
Lemma size_of_union_singleton Γ t τ :
  ✓ Γ → Γ !! t = Some [τ] → size_of Γ τ ≤ size_of Γ (unionT t).
Proof. intros. by apply (size_of_union_lookup Γ t [τ] 0). Qed.
Lemma sizes_of_weaken P Γ1 Γ2 τs :
  ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 →
  Forall (λ τ', P (size_of Γ1 τ')) τs → Forall (λ τ', P (size_of Γ2 τ')) τs.
Proof.
  induction 4; decompose_Forall_hyps; constructor; simpl;
    erewrite <-1?size_of_weaken by eauto; eauto.
Qed.

Lemma bit_size_of_weaken Γ1 Γ2 τ :
  ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → bit_size_of Γ1 τ = bit_size_of Γ2 τ.
Proof. intros. unfold bit_size_of. f_equal. by apply size_of_weaken. Qed.
Lemma bit_size_of_int Γ τi : bit_size_of Γ (intT τi) = int_width τi.
Proof. unfold bit_size_of. by rewrite size_of_int. Qed.
Lemma bit_size_of_char Γ si :
  bit_size_of Γ (intT (IntType si char_rank)) = char_bits.
Proof. rewrite bit_size_of_int. by apply int_width_char. Qed.
Lemma bit_size_of_int_same_kind Γ τi1 τi2 :
  rank τi1 = rank τi2 → bit_size_of Γ (intT τi1) = bit_size_of Γ (intT τi2).
Proof.
  destruct τi1, τi2; intros; simplify_equality'. by rewrite !bit_size_of_int.
Qed.
Lemma bit_size_of_array Γ τ n : bit_size_of Γ (τ.[n]) = n * bit_size_of Γ τ.
Proof. unfold bit_size_of. by rewrite !size_of_array, Nat.mul_assoc. Qed.
Lemma bit_size_of_struct Γ t τs :
  ✓ Γ → Γ !! t = Some τs →
  bit_size_of Γ (structT t) = sum_list (field_bit_sizes Γ τs).
Proof.
  unfold bit_size_of, field_bit_sizes. intros.
  erewrite size_of_struct by eauto.
  induction (field_sizes Γ τs); csimpl; auto with lia.
Qed.
Lemma bit_size_of_fields Γ τs :
  ✓ Γ → Forall2 (λ τ sz, bit_size_of Γ τ ≤ sz) τs (field_bit_sizes Γ τs).
Proof.
  intros HΓ. unfold bit_size_of, field_bit_sizes.
  induction (size_of_fields Γ τs HΓ);
    simpl; constructor; auto using Nat.mul_le_mono_nonneg_r with lia.
Qed.
Lemma bit_size_of_union Γ t τs :
  ✓ Γ → Γ !! t = Some τs →
  Forall (λ τ, bit_size_of Γ τ ≤ bit_size_of Γ (unionT t)) τs.
Proof.
  intros ? Hτs. apply size_of_union in Hτs; auto. unfold bit_size_of.
  induction Hτs; constructor; auto using Nat.mul_le_mono_nonneg_r with lia.
Qed.
Lemma bit_size_of_union_lookup Γ t τs i τ :
  ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ →
  bit_size_of Γ τ ≤ bit_size_of Γ (unionT t).
Proof.
  intros. unfold bit_size_of. apply Nat.mul_le_mono_nonneg_r;
    eauto using size_of_union_lookup with lia.
Qed.
Lemma bit_size_of_union_singleton Γ t τ :
  ✓ Γ → Γ !! t = Some [τ] → bit_size_of Γ τ ≤ bit_size_of Γ (unionT t).
Proof. intros. by apply (bit_size_of_union_lookup Γ t [τ] 0). Qed.
Lemma ptr_bit_size_of_alt Γ τp :
  ptr_bit_size_of Γ τp = ptr_size_of Γ τp * char_bits.
Proof. destruct τp; simpl; unfold bit_size_of; lia. Qed.

Lemma field_bit_sizes_weaken Γ1 Γ2 τs :
  ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 → field_bit_sizes Γ1 τs = field_bit_sizes Γ2 τs.
Proof. unfold field_bit_sizes. auto using fields_sizes_weaken with f_equal. Qed.
Lemma field_bit_sizes_length Γ τs :
  ✓ Γ → length (field_bit_sizes Γ τs) = length τs.
Proof. symmetry. by eapply Forall2_length, bit_size_of_fields. Qed.
Lemma field_bit_sizes_nil Γ : ✓ Γ → field_bit_sizes Γ [] = [].
Proof. intros. apply nil_length_inv. by rewrite field_bit_sizes_length. Qed.
Lemma field_bit_padding_weaken Γ1 Γ2 τs :
  ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 →
  field_bit_padding Γ1 τs = field_bit_padding Γ2 τs.
Proof.
  intros HΓ1 Hτs ?. unfold field_bit_padding.
  erewrite <-(field_bit_sizes_weaken Γ1 Γ2) by eauto.
  induction (bit_size_of_fields _ τs HΓ1); decompose_Forall_hyps;
    auto using bit_size_of_weaken with f_equal.
Qed.
Lemma field_bit_padding_length Γ τs :
  ✓ Γ → length (field_bit_padding Γ τs) = length τs.
Proof.
  intros. unfold field_bit_padding.
  rewrite zip_with_length, field_bit_sizes_length by done; lia.
Qed.
Lemma bit_offset_of_weaken Γ1 Γ2 τs i :
  ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 →
  bit_offset_of Γ1 τs i = bit_offset_of Γ2 τs i.
Proof.
  unfold bit_offset_of. eauto using field_bit_sizes_weaken with f_equal.
Qed.
Lemma bit_offset_of_alt Γ τs i :
  bit_offset_of Γ τs i = offset_of Γ τs i * char_bits.
Proof.
  unfold bit_offset_of, offset_of, field_bit_sizes.
  revert i. induction (field_sizes Γ τs) as [|?? IH];
    intros [|i]; simpl; auto with lia.
  by rewrite IH, Nat.mul_add_distr_r.
Qed.
Lemma bit_offset_of_lt Γ τs i j σ :
  ✓ Γ → τs !! i = Some σ → i < j →
  bit_offset_of Γ τs i + bit_size_of Γ σ ≤ bit_offset_of Γ τs j.
Proof.
  intros HΓ. revert i j σ. unfold bit_offset_of.
  induction (bit_size_of_fields _ τs HΓ) as [|τ sz τs szs ?? IH];
    intros [|i] [|j] σ ??; simplify_equality'; try lia.
  specialize (IH i j σ). intuition lia.
Qed.
Lemma bit_offset_of_size Γ t τs i σ :
  ✓ Γ → Γ !! t = Some τs → τs !! i = Some σ →
  bit_offset_of Γ τs i + bit_size_of Γ σ ≤ bit_size_of Γ (structT t).
Proof.
  intros HΓ Ht. erewrite bit_size_of_struct by eauto; clear Ht.
  revert i σ. unfold bit_offset_of. induction (bit_size_of_fields _ τs HΓ)
    as [|τ sz τs szs ?? IH]; intros [|i] σ ?; simplify_equality'; [lia|].
  specialize (IH i σ). intuition lia.
Qed.

Lemma align_of_char Γ si : ✓ Γ → align_of Γ (intT (IntType si char_rank)) = 1.
Proof.
  intros. apply Nat.divide_1_r; rewrite <-(size_of_char Γ si).
  apply align_of_divide; repeat constructor; auto.
Qed.
Lemma bit_align_of_array Γ τ n : (bit_align_of Γ τ | bit_align_of Γ (τ.[n])).
Proof. apply Nat.mul_divide_mono_r, align_of_array. Qed.
Lemma bit_align_of_compound Γ c t τs i τ :
  ✓ Γ → Γ !! t = Some τs → τs !! i = Some τ →
  (bit_align_of Γ τ | bit_align_of Γ (compoundT{c} t)).
Proof. eauto using Nat.mul_divide_mono_r, align_of_compound. Qed.
Lemma bit_align_of_divide Γ τ :
  ✓ Γ → ✓{Γ} τ → (bit_align_of Γ τ | bit_size_of Γ τ).
Proof. eauto using Nat.mul_divide_mono_r, align_of_divide. Qed.
Lemma bit_align_of_offset_of Γ τs i τ :
  ✓ Γ → ✓{Γ}* τs → τs !! i = Some τ →
  (bit_align_of Γ τ | bit_offset_of Γ τs i).
Proof.
  rewrite bit_offset_of_alt.
  eauto using Nat.mul_divide_mono_r, align_of_offset_of.
Qed.
Lemma bit_align_of_weaken Γ1 Γ2 τ :
  ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → bit_align_of Γ1 τ = bit_align_of Γ2 τ.
Proof. unfold bit_align_of; auto using align_of_weaken, f_equal. Qed.

Lemma size_of_base_ne_0 Γ τb : size_of Γ (baseT τb) ≠ 0.
Proof.
  destruct τb; auto using size_of_void_ne_0, size_of_ptr_ne_0.
  rewrite size_of_int. apply rank_size_ne_0.
Qed.
Lemma bit_size_of_base_ne_0 Γ τb : bit_size_of Γ (baseT τb) ≠ 0.
Proof. apply Nat.neq_mul_0. auto using char_bits_ne_0, size_of_base_ne_0. Qed.
#[global] Instance: ∀ Γ τb, PropHolds (size_of Γ (baseT τb) ≠ 0).
Proof. apply size_of_base_ne_0. Qed.
#[global] Instance: ∀ Γ τb, PropHolds (bit_size_of Γ (baseT τb) ≠ 0).
Proof. apply bit_size_of_base_ne_0. Qed.
Lemma size_of_ne_0 Γ τ : ✓ Γ → ✓{Γ} τ → size_of Γ τ ≠ 0.
Proof.
  intros HΓ. revert τ. refine (type_env_ind _ HΓ _ _ _ _).
  * auto using size_of_base_ne_0.
  * intros. rewrite size_of_array. by apply Nat.neq_mul_0.
  * intros [] t τs Ht Hτs IH Hlen.
    + erewrite size_of_struct by eauto. clear Ht.
      destruct (size_of_fields Γ τs HΓ); decompose_Forall_hyps; auto with lia.
    + apply size_of_union in Ht; auto.
      destruct Ht; decompose_Forall_hyps; auto with lia.
Qed.
Lemma align_of_ne_0 Γ τ : ✓ Γ → ✓{Γ} τ → align_of Γ τ ≠ 0.
Proof. eauto using Nat_divide_ne_0, size_of_ne_0, align_of_divide. Qed.
Lemma size_of_pos Γ τ : ✓ Γ → ✓{Γ} τ → 0 < size_of Γ τ.
Proof. intros. by apply Nat.neq_0_lt_0, size_of_ne_0. Qed.
Lemma bit_size_of_ne_0 Γ τ : ✓ Γ → ✓{Γ} τ → bit_size_of Γ τ ≠ 0.
Proof. intros. apply Nat.neq_mul_0. auto using char_bits_ne_0,size_of_ne_0. Qed.
Lemma bit_size_of_pos Γ τ : ✓ Γ → ✓{Γ} τ → 0 < bit_size_of Γ τ.
Proof. intros. by apply Nat.neq_0_lt_0, bit_size_of_ne_0. Qed.
End env_spec.


Require Export MicroBFTprops2.

Section MicroBFTass_uniq.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  Lemma ASSUMPTION_disseminate_unique_true :
    forall (eo : EventOrdering), assume_eo eo ASSUMPTION_disseminate_unique.
  Proof.
    introv h; simpl in *; exrepnd; subst; GC.
    rewrite h0 in h1; ginv.

    unfold disseminate_data in *; simpl in *.
    unfold M_byz_output_sys_on_event in *; simpl in *.
    rewrite M_byz_output_ls_on_event_as_run in h5, h6.
    rewrite h0 in *; simpl in *.
    unfold MicroBFTheader.node2name in *; simpl in *; subst.
    unfold MicroBFTsys in *; simpl in *.

    remember (M_byz_run_ls_before_event (MicroBFTlocalSys (loc e)) e) as ls; symmetry in Heqls.
    apply M_byz_run_ls_before_event_ls_is_microbft in Heqls.
    repndors; exrepnd; subst.

    { rewrite h5 in *; ginv.
      unfold M_byz_output_ls_on_this_one_event in h5.
      unfold M_byz_run_ls_on_one_event in h5.
      revert dependent o.
      unfold data_is_in_out, event2out in *.
      remember (trigger e) as trig; symmetry in Heqtrig.
      destruct trig; simpl in *; ginv; tcsp; introv a run b.

      { allrw in_flat_map; exrepnd.
        unfold M_run_ls_on_input in *.
        autorewrite with microbft in *.
        Time microbft_dest_msg Case;
          repeat (simpl in *; autorewrite with microbft in *; smash_microbft2);
          try (complete (repndors; ginv; tcsp)). }

      { unfold M_run_ls_on_trusted, M_run_ls_on_input in *; simpl in *.
        destruct i, o; simpl in *; repndors; ginv; tcsp. } }

    { rewrite h5 in *; ginv.
      unfold M_byz_output_ls_on_this_one_event in h5.
      unfold M_byz_run_ls_on_one_event in h5.
      revert dependent o.
      unfold data_is_in_out, event2out in *.
      remember (trigger e) as trig; symmetry in Heqtrig.
      destruct trig; simpl in *; ginv; tcsp; introv a run b.

      unfold M_run_ls_on_trusted, M_run_ls_on_input in *; simpl in *.
      autorewrite with microbft in *.
      destruct i, o; simpl in *; repndors; ginv; tcsp. }
  Qed.
  Hint Resolve ASSUMPTION_disseminate_unique_true : microbft.

End MicroBFTass_uniq.

Hint Resolve ASSUMPTION_disseminate_unique_true : microbft.


Require Export CoqRecon.Mono.Mono.

(** Completeness is never true :(. *)

Lemma tsub_twice : forall t s,
    (s ‡ s) † t = s † s † t.
Proof.
  intro t;
    induction t as [| | t1 IHt1 t2 IHt2 | T];
    intros s; simpl; try reflexivity.
  - rewrite IHt1, IHt2. reflexivity.
  - unfold "‡",env_map.
    destruct (s T) as [t |] eqn:HeqT; simpl; auto.
    rewrite HeqT. reflexivity.
Qed.

Lemma tsub_gamma_twice : forall (s : tenv) (g : gamma),
    s ‡ s × g = s × s × g.
Proof.
  intros s g. extensionality T.
  unfold "×", env_map.
  destruct (g T) as [tg |] eqn:Heqtg; auto.
  f_equal. apply tsub_twice.
Qed.

Section Complete.
  Local Hint Resolve sound : core.
  Local Hint Resolve preservation : core.
  Local Hint Resolve Subset_perm_l : core.
  Local Hint Resolve Subset_perm_r : core.
  Local Hint Resolve union_perm : core.
  Local Hint Constructors Permutation : core.

  Lemma tvars_subset : forall Γ e τ X C,
      Γ ⊢ e ∴ τ ⊣ X ≀ C -> (Ctvars C ⊆ X).
  Proof.
    intros g e t X C H; induction H;
      simpl; try firstorder.
    - apply Subset_perm_l
        with (T :: tvars τ1 ∪ tvars τ2 ∪ Ctvars (C1 ∪ C2))%set.
      + rewrite <- app_assoc with (m := [T]); simpl.
        rewrite app_assoc.
        apply Permutation_middle.
      + apply Subset_cons. (** Dang. *) admit.
    - (** Same problem. *) admit.
    - (** Same problem. *) admit.
  Abort.

  (* Pierce's proof in TAPL relies upon this assumption. *)
  Lemma tsub_inverse : forall t s,
      exists t', s † t' = t /\ forall n, n ∈ tvars t' -> s n = None.
  Proof.
    intros t s;
      induction t as
        [| | t1 [t1' [IHt1 IHs1]] t2 [t2' [IHt2 IHs2]] | m].
    - exists TBool; intuition.
    - exists TNat; intuition.
    - exists (t1' → t2')%typ; simpl.
      rewrite IHt1, IHt2.
      split; [reflexivity |].
      intros n H. rewrite in_app_iff in H.
      intuition.
    - destruct (env_binds m s) as [HNone | [t HSome]].
      + exists (TVar m); simpl. rewrite HNone.
        intuition; subst; assumption.
      + (* Which is difficult to formally verify...*)
  Abort.

  (** I used Pierce's [CT-Abs-Inf] rule
      in place of [CT-Abs].
      It seems his form of completenss is impossible
      with this... *)
  Theorem complete_weak : forall Γ e t X C,
      Γ ⊢ e ∴ t ⊣ X ≀ C ->
      forall σ τ,
        (σ × Γ) ⊨ e ∴ τ ->
        (forall m, m ∈ X -> σ m = None) ->
        exists σ', Forall (uncurry (satisfy σ')) C /\
              σ' † t = τ /\ mask σ' X = σ.
  Proof.
    intros g e τ X C H; induction H;
      intros s t Ht Hd; inv Ht;
        try (exists s; intuition; assumption).
    - exists s; intuition.
      unfold bound,env_map in *.
      rewrite H in H1. inv H1.
      reflexivity.
    - (* This case is intractable.
         There is no way to use the induction hypothesis. *)
      admit.
    - apply IHconstraint_typing1 in H7 as IH1;
        [clear IHconstraint_typing1 H7 | intuition].
      apply IHconstraint_typing2 in H9 as IH2;
        [clear IHconstraint_typing2 H9 | intuition].
      destruct IH1 as [s1 [HC1 [Ht1 Hs1]]].
      destruct IH2 as [s2 [HC2 [Ht2 Hs2]]].
      assert (HX12: member T X1 = false /\ member T X2 = false).
      { repeat rewrite Not_In_member_iff; split;
          intros ?; apply H2; repeat rewrite in_app_iff;
            intuition. }
      destruct HX12 as [HX1 HX2].
      exists (fun Y =>
           if Y == T then Some t else
             if member Y X1 then s1 Y else
               if member Y X2 then s2 Y else s Y).
      repeat split.
      + constructor; simpl.
        * unfold satisfy; simpl.
          dispatch_eqdec.
          (* Need induction...probably...*) admit.
        * rewrite Forall_app; split.
          -- (* Need induction. *) admit.
          -- (* Need induction. *) admit.
      + simpl; dispatch_eqdec; reflexivity.
      + extensionality Y; unfold "∉"; simpl.
        destruct (equiv_dec Y T) as [HYT | HYT];
          unfold equiv, complement in *; subst. admit. admit.
    - apply IHconstraint_typing1 in H8 as IH1;
        [ clear IHconstraint_typing1 H8 | intuition ].
      apply IHconstraint_typing2 in H10 as IH2;
        [ clear IHconstraint_typing2 H10 | intuition ].
      apply IHconstraint_typing3 in H11 as IH3;
        [ clear IHconstraint_typing3 H11 | intuition ].
      destruct IH1 as [s1 [HC1 [Ht1 Hs1]]].
      destruct IH2 as [s2 [HC2 [Ht2 Hs2]]].
      destruct IH3 as [s3 [HC3 [Ht3 Hs3]]].
      exists (fun Y =>
           if member Y X1 then s1 Y else
             if member Y X2 then s2 Y else
               if member Y X3 then s3 Y else s Y).
      repeat split.
      + repeat constructor.
        * unfold satisfy, uncurry; simpl.
          (* Requires induction... *) admit.
        * unfold satisfy, uncurry; simpl.
          (* Requires induction... *) admit.
        * repeat rewrite Forall_app; repeat split.
          (* Requires induction...*) admit. admit. admit.
      + (* Nope. *) admit.
      + extensionality Y; unfold mask; simpl.
        destruct (member Y (X1 ∪ X2 ∪ X3)%set) eqn:HYmem.
        * symmetry; apply Hd; auto using member_In.
        * assert (HY123:
                    member Y X1 = false /\
                    member Y X2 = false /\
                    member Y X3 = false).
          { repeat rewrite Not_In_member_iff in *.
            repeat rewrite in_app_iff in HYmem.
            intuition. }
          destruct HY123 as [HY1 [HY2 HY3]].
          rewrite HY1,HY2,HY3. reflexivity.
      + apply Hd;
          repeat rewrite in_app_iff;
          intuition.
      + apply Hd;
          repeat rewrite in_app_iff;
          intuition.
    - (* Same stuff... *)
  Abort.
End Complete.


(* Order of imports: import proofmode after utils after robinson *)
From FOL Require Import FullSyntax Arithmetics.

From FOL.Incompleteness Require Import utils fol_utils.
From FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia.
Require Import String.

Open Scope string_scope.

(* ** Q-decidability *)
Section Qdec.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Definition Qdec φ := forall (pei : peirce) ρ, (forall k, bounded_t 0 (ρ k)) -> Qeq ⊢ φ[ρ] \/ Qeq ⊢ ¬φ[ρ].

  Lemma subst_t_closed t ρ : (forall k, bounded_t 0 (ρ k)) -> bounded_t 0 t`[ρ].
  Proof.
    intros H. destruct (find_bounded_t t) as [n Hn].
    eapply subst_bounded_max_t; last eassumption.
    intros l _. apply H.
  Qed.
  Lemma subst_closed φ ρ : (forall k, bounded_t 0 (ρ k)) -> bounded 0 φ[ρ].
  Proof.
    intros H. destruct (find_bounded φ) as [n Hn].
    eapply subst_bounded_max; last eassumption.
    intros l _. apply H.
  Qed.

  Lemma Qdec_subst φ ρ : Qdec φ -> Qdec φ[ρ].
  Proof.
    intros H pei ρ' Hb. rewrite subst_comp. apply H.
    intros k. apply subst_t_closed, Hb.
  Qed.

  Lemma Qdec_iff φ ψ : Qeq ⊢I φ ↔ ψ -> Qdec φ -> Qdec ψ.
  Proof.
    intros H Hφ pei ρ Hρ. apply prv_intu_peirce in H.
    pose proof (subst_Weak ρ H) as Hiff. cbn in Hiff. change (List.map _ _) with Qeq in Hiff.
    destruct (Hφ pei ρ Hρ) as [H1|H1].
    - left. fapply Hiff. fapply H1.
    - right. fintros. fapply H1. fapply Hiff. ctx.
  Qed.
  Lemma Qdec_iff' φ ψ :
    (forall ρ, (forall k, bounded_t 0 (ρ k)) -> Qeq ⊢I φ[ρ] ↔ ψ[ρ]) ->
    Qdec φ -> Qdec ψ.
  Proof.
    intros H Hφ pei ρ Hρ.
    specialize (H _ Hρ). apply prv_intu_peirce in H.
    destruct (Hφ _ _ Hρ) as [H1|H1].
    - left. fapply H. fapply H1.
    - right. fintros. fapply H1. fapply H. ctx.
  Qed.

  Lemma Qdec_bot : Qdec ⊥.
  Proof.
    intros ρ Hb. right. fintros. ctx.
  Qed.

  Lemma Qdec_and φ ψ : Qdec φ -> Qdec ψ -> Qdec (φ ∧ ψ).
  Proof.
    intros Hφ Hψ pei ρ Hb. cbn.
    destruct (Hφ _ _ Hb) as [H1|H1], (Hψ _ _ Hb) as [H2|H2].
    2-4: right; fintros; fdestruct 0.
    - left. now fsplit.
    - fapply H2. ctx.
    - fapply H1. ctx.
    - fapply H1. ctx.
  Qed.

  Lemma Qdec_or φ ψ : Qdec φ -> Qdec ψ -> Qdec (φ ∨ ψ).
  Proof.
    intros Hφ Hψ ρ pei Hb. cbn.
    destruct (Hφ _ _ Hb) as [H1|H1], (Hψ _ _ Hb) as [H2|H2].
    1-3: left; now (fleft + fright).
    right. fintros "[H|H]".
    - fapply H1. ctx.
    - fapply H2. ctx.
  Qed.

  Lemma Qdec_impl φ ψ : Qdec φ -> Qdec ψ -> Qdec (φ → ψ).
  Proof.
    intros Hφ Hψ pei ρ Hb. cbn.
    destruct (Hφ _ _ Hb) as [H1|H1], (Hψ _ _ Hb) as [H2|H2].
    - left. fintros. fapply H2.
    - right. fintros. fapply H2. fapply 0. fapply H1.
    - left. fintros. fapply H2.
    - left. fintros. fexfalso. fapply H1. ctx.
  Qed.

  Lemma Qdec_eq t s : Qdec (t == s).
  Proof.
    intros pei ρ Hb. cbn.
    destruct (@closed_term_is_num _ t`[ρ]) as [k1 Hk1].
    { apply subst_t_closed, Hb. }
    destruct (@closed_term_is_num _ s`[ρ]) as [k2 Hk2].
    { apply subst_t_closed, Hb. }
    assert (k1 = k2 \/ k1 <> k2) as [->|Hk] by lia; [left|right].
    all: frewrite Hk1; frewrite Hk2.
    - fapply ax_refl.
    - clear Hk1. clear Hk2. revert Hk. induction k1 in k2 |-*; intros Hk.
      + destruct k2; first congruence. cbn.
        fapply ax_zero_succ.
      + cbn. destruct k2.
        * fintros. fapply (ax_zero_succ (num k1)). fapply ax_sym. ctx.
        * cbn. fintros. assert (H' : k1 <> k2) by congruence.
          specialize (IHk1 k2 H'). fapply IHk1.
          fapply ax_succ_inj. ctx.
  Qed.
  Lemma Qdec_le t s : Qdec (t ⧀= s).
  Proof.
    intros pei ρ Hb.
    destruct (@closed_term_is_num _ t`[ρ]) as [k1 Hk1].
    { apply subst_t_closed, Hb. }
    destruct (@closed_term_is_num _ s`[ρ]) as [k2 Hk2].
    { apply subst_t_closed, Hb. }
    rewrite PAle_subst.
    enough (Qeq ⊢ num k1 ⧀= num k2 \/ Qeq ⊢ ¬(num k1 ⧀= num k2)) as [H|H].
    { left. unfold PAle. frewrite Hk1. frewrite Hk2. apply H. }
    { right. unfold PAle. frewrite Hk1. frewrite Hk2. apply H. }
    clear Hk1 Hk2.
    induction k1 as [|k1 IH] in k2 |-*.
    - left. fexists (num k2).
      frewrite (ax_add_zero (num k2)). fapply ax_refl.
    - destruct k2 as [|k2].
      + right.
        fstart. fintros "[z H]". fapply (ax_zero_succ (num k1 ⊕ z)).
        frewrite <-(ax_add_rec z (num k1)). fapply "H".
      + destruct (IH k2) as [IH'|IH'].
        * left. fstart.
          fassert (num k1 ⧀= num k2) as "H"; first apply IH'.
          fdestruct "H" as "[z Hz]".
          fexists z. frewrite (ax_add_rec z (num k1)).
          fapply ax_succ_congr. fapply "Hz".
        * right. fstart. fintros "H". fapply IH'.
          fdestruct "H" as "[z Hz]".
          fexists z. fapply ax_succ_inj.
          frewrite <-(ax_add_rec z (num k1)). fapply "Hz".
  Qed.

  Section lemmas.
    Context `{pei : peirce}.

    Lemma Qsdec_le x y : bounded_t 0 x -> Qeq ⊢ ((x ⧀= y) ∨ (y ⧀= x)).
    Proof.
      intros Hx. destruct (closed_term_is_num Hx) as [k Hk].
      unfold PAle. frewrite Hk. clear Hk.
      induction k as [|k IH] in y |-*; fstart.
      - fleft. fexists y. frewrite (ax_add_zero y). fapply ax_refl.
      - fassert (ax_cases); first ctx.
        fdestruct ("H" y) as "[H|[y' H]]".
        + fright. fexists (σ (num k)).
          frewrite "H". frewrite (ax_add_zero (σ num k)).
          fapply ax_refl.
        + specialize (IH y').
          fdestruct IH.
          * fleft.
            fdestruct "H0". fexists x0. frewrite "H". frewrite "H0".
            fapply ax_sym. fapply ax_add_rec.
          * fright. custom_simpl.
            fdestruct "H0". fexists x0. frewrite "H". frewrite "H0".
            fapply ax_sym. fapply ax_add_rec.
    Qed.
    Lemma Q_eqdec t x : Qeq ⊢ x == (num t) ∨ ¬(x == num t).
    Proof.
      induction t in x |-*; fstart; fintros.
      - fassert (ax_cases); first ctx.
        fdestruct ("H" x).
        + fleft. frewrite "H".
          fapply ax_refl.
        + fright. fdestruct "H". frewrite "H".
          fintros. fapply (ax_zero_succ x0).
          fapply ax_sym. ctx.
      - fassert (ax_cases); first ctx.
        fdestruct ("H" x).
        + fright. frewrite "H".
          fapply ax_zero_succ.
        + fdestruct "H". frewrite "H".
          specialize (IHt x0).
          fdestruct IHt.
          * fleft. fapply ax_succ_congr. fapply "H0".
          * fright. fintros. fapply "H0".
            fapply ax_succ_inj. fapply "H1".
    Qed.

    Lemma PAle_zero_eq x : Qeq ⊢ x ⧀= zero → x == zero.
    Proof.
      fstart. fintros. unfold PAle. fdestruct "H".
      fassert ax_cases.
      { ctx. }
      unfold ax_cases.
      fdestruct ("H0" x).
      - fapply "H0".
      - fdestruct "H0".
        fexfalso. fapply (ax_zero_succ (x1 ⊕ x0)).
        frewrite <- (ax_add_rec x0 x1). frewrite <- "H0".
        fapply "H".
    Qed.
    Lemma PAle'_zero_eq x : Qeq ⊢ (x ⧀=' zero) → x == zero.
    Proof.
      fstart. fintros. unfold PAle'. fdestruct "H".
      fassert ax_cases as "C"; first ctx.
      fdestruct ("C" x0) as "[Hx'|[x' Hx']]".
      - frewrite <-(ax_add_zero x). frewrite <-"Hx'".
        frewrite <-"H". frewrite "Hx'". fapply ax_refl.
      - fexfalso. fapply (ax_zero_succ (x' ⊕ x)).
        frewrite <-(ax_add_rec x x'). frewrite <-"Hx'".
        fapply "H".
    Qed.

    Lemma add_zero_swap t x :
      Qeq ⊢ x ⊕ zero == num t → x == num t.
    Proof.
      fstart. induction t in x |-*; fintros.
      - fassert (ax_cases); first ctx.
        fdestruct ("H0" x).
        + ctx.
        + fdestruct "H0".
          fexfalso. fapply (ax_zero_succ (x0 ⊕ zero)).
          frewrite <- (ax_add_rec zero x0).
          frewrite <-"H0". fapply ax_sym. ctx.
      - fassert (ax_cases); first ctx.
        fdestruct ("H0" x).
        + fexfalso. fapply (ax_zero_succ (num t)).
          frewrite <-"H". frewrite "H0".
          frewrite (ax_add_zero zero).
          fapply ax_refl.
        + fdestruct "H0".
          frewrite "H0". fapply ax_succ_congr.
          specialize (IHt x0).
          fapply IHt. fapply ax_succ_inj.
          frewrite <-(ax_add_rec zero x0).
          frewrite <- "H0". fapply "H".
    Qed.

    Lemma add_rec_swap t x y:
      Qeq ⊢ x ⊕ σ y == σ num t → x ⊕ y == num t.
    Proof.
      induction t in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "Hx". frewrite (ax_add_zero y).
          fapply ax_succ_inj. frewrite <-(ax_add_zero (σ y)).
          frewrite <-"H". frewrite "Hx". fapply ax_refl.
        + frewrite "Hx'". fassert ax_cases as "C"; first ctx.
          fdestruct ("C" x') as "[Hx''|[x'' Hx'']]".
          * fexfalso. fapply (ax_zero_succ y).
            fapply ax_succ_inj. frewrite <-"H".
            frewrite "Hx'". frewrite "Hx''".
            frewrite (ax_add_rec (σ y) zero). frewrite (ax_add_zero (σ y)).
            fapply ax_refl.
          * fexfalso. fapply (ax_zero_succ (x'' ⊕ σ y)).
            fapply ax_succ_inj. frewrite <-"H".
            frewrite "Hx'". frewrite "Hx''".
            frewrite (ax_add_rec (σ y) (σ x'')).
            frewrite (ax_add_rec (σ y) x''). fapply ax_refl.
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx'|[x' Hx']]".
        + fapply ax_succ_inj. frewrite <-"H".
          frewrite "Hx'". frewrite (ax_add_zero y).
          frewrite (ax_add_zero (σ y)). fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec y x').
          fapply ax_succ_congr.
          specialize (IHt x'). fapply IHt.
          fapply ax_succ_inj. frewrite <-(ax_add_rec (σ y) x').
          frewrite <-"Hx'". ctx.
    Qed.

    Lemma PAle_sigma_neq t x : Qeq ⊢ (x ⧀= σ(num t)) → ¬(x == σ(num t)) → x ⧀= num t.
    Proof.
      fstart. fintros. unfold PAle. fdestruct "H". custom_simpl.
      fassert (ax_cases); first ctx.
      fdestruct ("H1" x0).
      - fexfalso. fapply "H0".
        pose proof (add_zero_swap (S t) x). cbn in H.
        fapply H. frewrite <- "H1". fapply ax_sym.
        ctx.
      - fdestruct "H1". fexists x1. custom_simpl.
        fapply ax_sym. fapply add_rec_swap.
        frewrite <-"H1". fapply ax_sym. fapply "H".
    Qed.
    Lemma PAle'_sigma_neq t x : Qeq ⊢ (x ⧀=' σ(num t)) → ¬(x == σ(num t)) → x ⧀=' num t.
    Proof.
      fstart. fintros. unfold PAle'.
      fdestruct "H" as "[z Hz]".
      fassert ax_cases as "C"; first ctx.
      fdestruct ("C" z) as "[Hz'|[z' Hz']]".
      - fexfalso. fapply "H0". frewrite "Hz". frewrite "Hz'".
        fapply ax_sym. fapply ax_add_zero.
      - fexists z'. fapply ax_succ_inj.
        frewrite <-(ax_add_rec x z').
        frewrite <-"Hz'". ctx.
    Qed.

    Lemma add_rec_swap2 t x y :
      Qeq ⊢ x ⊕ y == num t → x ⊕ (σ y) == num (S t).
    Proof.
      induction t in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx'|[x' Hx']]".
        + frewrite <-"H". frewrite "Hx'".
          frewrite (ax_add_zero (σ y)). frewrite (ax_add_zero y).
          fapply ax_refl.
        + fexfalso. fapply (ax_zero_succ (x' ⊕ y)). frewrite <-"H".
          frewrite "Hx'". frewrite (ax_add_rec y x'). fapply ax_refl.
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx'|[x' Hx']]".
        + frewrite <-"H". frewrite "Hx'".
          frewrite (ax_add_zero (σ y)). frewrite (ax_add_zero y).
          fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec (σ y) x').
          fapply ax_succ_congr.
          fapply IHt. fapply ax_succ_inj.
          frewrite <-(ax_add_rec y x'). frewrite <-"Hx'".
          fapply "H".
    Qed.

    Lemma PAle_succ t x : Qeq ⊢ (x ⧀= num t) → (x ⧀= σ (num t)).
    Proof.
      fstart. fintros "[z Hz]". fexists (σ z).
      fapply ax_sym. fapply add_rec_swap2. fapply ax_sym. fapply "Hz".
    Qed.
    Lemma PAle'_succ t x : Qeq ⊢ (x ⧀=' num t) → (x ⧀=' σ (num t)).
    Proof.
      fstart. fintros "[z Hz]". fexists (σ z).
      frewrite (ax_add_rec x z). fapply ax_succ_congr. ctx.
    Qed.

    Lemma add_zero_num t :
      Qeq ⊢ num t ⊕ zero == num t.
    Proof.
      induction t.
      - cbn. frewrite (ax_add_zero zero). fapply ax_refl.
      - cbn. frewrite (ax_add_rec zero (num t)).
        fapply ax_succ_congr. apply IHt.
    Qed.
    Lemma PAle_num_eq t x :
      Qeq ⊢ x == num t → x ⧀= num t.
    Proof.
      fstart. fintros "H". fexists zero.
      frewrite "H". fapply ax_sym. fapply add_zero_num.
    Qed.
    Lemma PAle'_num_eq t x :
      Qeq ⊢ x == num t → x ⧀=' num t.
    Proof.
      fstart. fintros "H". fexists zero.
      frewrite (ax_add_zero x). fapply ax_sym. fapply "H".
    Qed.

    Fixpoint fin_disj n φ := match n with
                             | 0 => φ[(num 0) ..]
                             | S n => (fin_disj n φ) ∨ φ[(num (S n)) ..]
                             end.
    Fixpoint fin_conj n φ := match n with
                             | 0 => φ[(num 0) ..]
                             | S n => (fin_conj n φ) ∧ φ[(num (S n)) ..]
                             end.

    Lemma le_fin_disj t x :
      Qeq ⊢ x ⧀= num t ↔ fin_disj t (x`[↑] == $0).
    Proof.
      induction t; cbn; rewrite subst_term_shift; fstart; fsplit.
      - fapply PAle_zero_eq.
      - fintros "H". unfold PAle.
        frewrite "H". fexists zero.
        frewrite (ax_add_zero zero). fapply ax_refl.
      - fintros "H". fassert (x == σ num t ∨ (¬ x == σ num t)) as "H1".
        { pose proof (Q_eqdec (S t) x). cbn in H. fapply H. }
        fdestruct "H1" as "[H1|H1]".
        + fright. ctx.
        + fleft. fapply IHt.
          fapply PAle_sigma_neq; ctx.
      - fintros "H". fdestruct "H" as "[H|H]".
        + fapply PAle_succ. fapply IHt. fapply "H".
        + pose proof (PAle_num_eq (S t) x). cbn in H.
          fapply H. fapply "H".
    Qed.
    Lemma le_swap_fin_disj t x :
      Qeq ⊢ x ⧀=' num t ↔ fin_disj t (x`[↑] == $0).
    Proof.
      induction t; cbn; rewrite subst_term_shift; fstart; fsplit.
      - fapply PAle'_zero_eq.
      - unfold PAle'.  fintros "H". frewrite "H".
        fexists zero. frewrite (ax_add_zero zero). fapply ax_refl.
      - fintros "H". fassert (x == σ num t ∨ (¬ x == σ num t)) as "H1".
        { pose proof (Q_eqdec (S t) x). cbn in H. fapply H. }
        fdestruct "H1" as "[H1|H1]".
        + fright. ctx.
        + fleft. fapply IHt.
          fapply PAle'_sigma_neq; ctx.
      - fintros "H". fdestruct "H" as "[H|H]".
        + fapply PAle'_succ. fapply IHt. fapply "H".
        + pose proof (PAle'_num_eq (S t) x). cbn in H.
          fapply H. fapply "H".
    Qed.

    Lemma Q_leibniz_t a x y : Qeq ⊢ x == y → a`[x..] == a`[y..].
    Proof.
      induction a.
      - destruct x0; cbn.
        + fintros. ctx.
        + fintros. fapply ax_refl.
      - destruct F.
        + cbn in v. rewrite (vec_0_nil v).
          fintros. fapply ax_refl.
        + cbn in v.
          destruct (vec_1_inv v) as [z ->]. cbn.
          fintros. fapply (ax_succ_congr z`[y..] z`[x..]).
          frevert 0. fapply IH. apply Vector.In_cons_hd.
        + destruct (vec_2_inv v) as (a & b & ->).
          cbn. fintros. fapply ax_add_congr.
          all: frevert 0; fapply IH.
          * apply Vector.In_cons_hd.
          * apply Vector.In_cons_tl, Vector.In_cons_hd.
        + destruct (vec_2_inv v) as (a & b & ->).
          cbn. fintros. fapply ax_mult_congr.
          all: frevert 0; fapply IH.
          * apply Vector.In_cons_hd.
          * apply Vector.In_cons_tl, Vector.In_cons_hd.
    Qed.

    Lemma Q_leibniz φ x y :
      Qeq ⊢ x == y → φ[x..] → φ[y..].
    Proof.
      enough (Qeq ⊢ x == y → φ[x..] ↔ φ[y..]).
      { fintros. fapply H; ctx. }
      induction φ using form_ind_subst.
      - cbn. fintros. fsplit; fintros; ctx.
      - destruct P0. cbn in t.
        destruct (vec_2_inv t) as (a & b & ->).
        cbn. fstart. fintros.
        fassert (a`[x..] == a`[y..]).
        { pose proof (Q_leibniz_t a x y).
          fapply H. fapply "H". }
        fassert (b`[x..] == b`[y..]).
        { pose proof (Q_leibniz_t b x y).
          fapply H. fapply "H". }
        frewrite "H0". frewrite "H1".
        fsplit; fintros; ctx.
      - fstart; fintros.
        fassert (φ1[x..] ↔ φ1[y..]) by (fapply IHφ1; fapply "H").
        fassert (φ2[x..] ↔ φ2[y..]) by (fapply IHφ2; fapply "H").
        destruct b0; fsplit; cbn.
        + fintros "[H2 H3]". fsplit.
          * fapply "H0". ctx.
          * fapply "H1". ctx.
        + fintros "[H2 H3]". fsplit.
          * fapply "H0". ctx.
          * fapply "H1". ctx.
        + fintros "[H2|H3]".
          * fleft. fapply "H0". ctx.
          * fright. fapply "H1". ctx.
        + fintros "[H2|H3]".
          * fleft. fapply "H0". ctx.
          * fright. fapply "H1". ctx.
        + fintros "H2" "H3".
          fapply "H1". fapply "H2". fapply "H0". ctx.
        + fintros "H2" "H3".
          fapply "H1". fapply "H2". fapply "H0". ctx.
      - fstart. fintros. fsplit; destruct q; cbn; fintros.
        + specialize (H (x0`[↑]..)).
          asimpl in H. asimpl. fapply H.
          * ctx.
          * fspecialize ("H0" x0). asimpl. ctx.
        + fdestruct "H0". fexists x0.
          specialize (H (x0`[↑]..)).
          asimpl in H. asimpl. fapply H; ctx.
        + specialize (H (x0`[↑]..)).
          asimpl in H. asimpl. fapply H.
          * ctx.
          * fspecialize ("H0" x0). asimpl. ctx.
        + fdestruct "H0". fexists x0.
          specialize (H (x0`[↑]..)).
          asimpl in H. asimpl. fapply H; ctx.
    Qed.

    (* Could probably be generalised to arbitrary finite disjunctions *)
    Lemma forall_fin_disj_conj φ t :
      Qeq ⊢ (∀ (fin_disj t ($1 == $0)) → φ) ↔ fin_conj t φ.
    Proof.
      induction t as [|t IH]; cbn; fstart; fsplit.
      - fintros "H". fapply "H". fapply ax_refl.
      - fintros "H" x "H1".
        feapply Q_leibniz.
        + feapply ax_sym. fapply "H1".
        + ctx.
      - fintros "H". fsplit.
        + fapply IH. fintros x "H1". fapply "H". fleft. fapply "H1".
        + fapply "H". fright. rewrite num_subst. fapply ax_refl.
      - fintros "[H1 H2]" x "[H3|H3]".
        + fdestruct IH as "[H4 H5]".
          fapply "H5"; ctx.
        + rewrite num_subst. feapply Q_leibniz.
          * feapply ax_sym. fapply "H3".
          * fapply "H2".
    Qed.

    Lemma exists_fin_disj φ t :
      Qeq ⊢ (∃ (fin_disj t ($1 == $0)) ∧ φ) ↔ fin_disj t φ.
    Proof.
      induction t as [|t IH]; cbn; fstart; fsplit.
      - fintros "[x [H1 H2]]". feapply Q_leibniz.
        + fapply "H1".
        + ctx.
      - fintros "H". fexists zero. fsplit.
        + fapply ax_refl.
        + ctx.
      - fintros "[x [[H1|H1] H2]]".
        + fleft. fapply IH. fexists x. fsplit.
          * fapply "H1".
          * fapply "H2".
        + fright. rewrite num_subst. feapply Q_leibniz.
          * fapply "H1".
          * ctx.
      - fintros "[H1|H1]".
        + fapply IH in "H1". fdestruct "H1" as "[x [H1 H2]]".
          fexists x. fsplit.
          * fleft. ctx.
          * ctx.
        + fexists (σ num t). fsplit.
          * fright. rewrite num_subst. fapply ax_refl.
          * ctx.
    Qed.

    Lemma forall_bound_iff φ ψ χ:
      Qeq ⊢ φ ↔ ψ -> Qeq ⊢ (∀ φ → χ) ↔ (∀ ψ → χ).
    Proof.
      intros H. fstart. fsplit.
      - fintros "H1" x "H2". fapply "H1".
        apply (subst_Weak x..) in H. change (List.map _ _) with Qeq in H.
        cbn in H. fapply H. fapply "H2".
      - fintros "H1" x "H2". fapply "H1".
        apply (subst_Weak x..) in H. change (List.map _ _) with Qeq in H.
        cbn in H. fapply H. fapply "H2".
    Qed.

  End lemmas.

  Lemma Qdec_fin_conj φ t :
    Qdec φ -> Qdec (fin_conj t φ).
  Proof.
    intros Hφ. induction t; cbn.
    - apply Qdec_subst, Hφ.
    - apply Qdec_and.
      + assumption.
      + apply Qdec_subst, Hφ.
  Qed.

  Lemma Qdec_fin_disj φ t :
    Qdec φ -> Qdec (fin_disj t φ).
  Proof.
    intros Hφ. induction t; cbn.
    - apply Qdec_subst, Hφ.
    - apply Qdec_or.
      + assumption.
      + apply Qdec_subst, Hφ.
  Qed.
  Lemma fin_disj_subst n φ ρ :
    (fin_disj n φ)[ρ] = fin_disj n φ[up ρ].
  Proof.
    induction n; cbn.
    - now asimpl.
    - cbn. f_equal; first assumption.
      asimpl. now rewrite num_subst.
  Qed.

  Theorem Qdec_bounded_forall t φ :
    Qdec φ -> Qdec (∀ $0 ⧀= t`[↑] → φ).
  Proof.
    intros H pei ρ Hρ.
    destruct (@closed_term_is_num _ t`[ρ]) as [x Hx].
    { apply subst_t_closed, Hρ. }
    enough (Qeq ⊢ (∀ (fin_disj x ($1 == $0))  → φ)[ρ] \/ Qeq ⊢ ¬ (∀ (fin_disj x ($1 == $0)) → φ)[ρ]) as H'.
    { cbn. asimpl. rewrite <-!subst_term_comp.
      cbn in H'. rewrite fin_disj_subst in H'.
      cbn in H'. unfold "↑" in H'.
      destruct H' as [H1|H1].
      - left. fstart. fintros. fapply H1.
        rewrite fin_disj_subst. cbn.
        fapply le_fin_disj.
        fdestruct "H" as "[z H]". fexists z.
        fassert (t`[ρ] == num x); first fapply Hx.
        frewrite <-"H0". asimpl. fapply "H".
      - right.  fstart. fintros. fapply H1. fstop.
        fintros. fstart.
        fapply "H".
        rewrite fin_disj_subst. cbn.
        fassert (x0 ⧀= num x).
        { fapply le_fin_disj. fapply "H0". }
        fdestruct "H1" as "[z Hz]".
        fexists z.
        fassert (t`[ρ] == num x); first fapply Hx.
        asimpl. frewrite "H1". fapply "Hz". }
    eapply Qdec_iff.
    - apply frewrite_equiv_switch. apply forall_fin_disj_conj.
    - apply Qdec_fin_conj, H.
    - apply Hρ.
  Qed.
  Theorem Qdec_bounded_exists t φ :
    Qdec φ -> Qdec (∃ ($0 ⧀= t`[↑]) ∧ φ).
  Proof.
    intros H pei ρ Hρ.
    destruct (@closed_term_is_num _ t`[ρ]) as [x Hx].
    { apply subst_t_closed, Hρ. }
    enough (Qeq ⊢ (∃ (fin_disj x ($1 == $0)) ∧ φ)[ρ] \/ Qeq ⊢ ¬ (∃ (fin_disj x ($1 == $0)) ∧ φ)[ρ]) as H'.
    { cbn.
      cbn in H'. rewrite fin_disj_subst in H'.
      cbn in H'. unfold "↑" in H'.
      destruct H' as [H1|H1].
      - left. fstart.
        fassert (∃ fin_disj x ($1 == $0) ∧ φ[up ρ]).
        { fapply H1. }
        fdestruct "H" as "[z [H1 H2]]".
        rewrite fin_disj_subst. cbn.
        fexists z. fsplit; last ctx.
        fassert (z ⧀= num x).
        { fapply le_fin_disj. fapply "H1". }
        unfold PAle. fdestruct "H". fexists x0.
        asimpl. frewrite Hx. fapply "H".
      - right.  fstart. fintros. fapply H1.
        fdestruct "H" as "[z [H1 H2]]". fexists z.
        fsplit; last ctx.
        rewrite fin_disj_subst. cbn. fapply le_fin_disj.
        cbn. fdestruct "H1" as "[z' Hz']". fexists z'.
        fassert (t`[ρ] == num x) by fapply Hx.
        asimpl. frewrite <-"H". fapply "Hz'". }
    eapply Qdec_iff.
    - apply frewrite_equiv_switch. apply exists_fin_disj.
    - apply Qdec_fin_disj, H.
    - apply Hρ.
  Qed.

  Theorem Qdec_bounded_exists_comm t φ :
    Qdec φ -> Qdec (∃ ($0 ⧀=' t`[↑]) ∧ φ).
  Proof.
    intros H pei ρ Hρ.
    destruct (@closed_term_is_num _ t`[ρ]) as [x Hx].
    { apply subst_t_closed, Hρ. }
    enough (Qeq ⊢ (∃ (fin_disj x ($1 == $0)) ∧ φ)[ρ] \/ Qeq ⊢ ¬ (∃ (fin_disj x ($1 == $0)) ∧ φ)[ρ]) as H'.
    { cbn.
      cbn in H'. rewrite fin_disj_subst in H'.
      cbn in H'. unfold "↑" in H'.
      destruct H' as [H1|H1].
      - left. fstart.
        fassert (∃ fin_disj x ($1 == $0) ∧ φ[up ρ]) by apply H1.
        fdestruct "H" as "[z [H1 H2]]".
        rewrite fin_disj_subst. cbn.
        fexists z. fsplit; last ctx.
        fassert (z ⧀=' num x).
        { fapply le_swap_fin_disj. fapply "H1". }
        unfold PAle'. fdestruct "H". fexists x0.
        asimpl. frewrite Hx. fapply "H".
      - right.  fstart. fintros. fapply H1.
        fdestruct "H" as "[z [H1 H2]]". fexists z.
        fsplit; last ctx.
        rewrite fin_disj_subst. cbn. fapply le_swap_fin_disj.
        cbn. fdestruct "H1". fexists x0.
        fassert (t`[ρ] == num x) by fapply Hx.
        asimpl. frewrite <-"H0". fapply "H". }
    eapply Qdec_iff.
    - apply frewrite_equiv_switch. apply exists_fin_disj.
    - apply Qdec_fin_disj, H.
    - apply Hρ.
  Qed.
End Qdec.


Require Import Coqlib.
Require Import Asm.
Require Import Integers.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_div_2_to_shr_example : code :=
  Pmov_ri ECX two :: Pdiv ECX :: nil.

Section DIV_2_TO_SHIFT.

  Variable concrete : code.

  Definition peep_div_2_to_shr_defs : rewrite_defs :=
    {|
      fnd :=
        Pmov_ri ECX two ::
                Pdiv ECX ::
                nil
      ; rpl :=
          Pshr_ri EAX Int.one ::
                  Pnop ::
                  nil
      ; lv_in := IR EAX :: PC :: nil
      ; lv_out := IR EAX :: PC :: nil
      ; clobbered := IR EDX :: IR ECX :: flags
    |}.

  Lemma peep_div_2_to_shr_selr :
    StepEquiv.step_through_equiv_live (fnd peep_div_2_to_shr_defs) (rpl peep_div_2_to_shr_defs) (lv_in peep_div_2_to_shr_defs) (lv_out peep_div_2_to_shr_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    intros.
    simpl_and_clear.
    (*EAX*)
    break_or'.
    {
      subst reg.
      subst_max.
      preg_simpl.
      unfold Val.divu in *.
      simpl_match_hyp.
      repeat inv_some.
      simpl.
      unfold Val.shru.
      P0 preg_simpl_hyp nextinstr.
      inv_vint.
      rewrite Heqv1 in *.
      P0 _simpl val_eq.
      break_match; try congruence.
      break_if.
      f_equal.
      inv_vint.
      erewrite Int.divu_pow2.
      eauto.
      unfold Int.one.
      unfold two.
      cut (2 = two_p 1). intro. rewrite H0.
      apply Int.is_power2_two_p.
      unfold Int.zwordsize in *.
      unfold Int.wordsize in *.
      unfold Wordsize_32.wordsize in *.
      simpl.
      omega.
      vm_compute.
      reflexivity.
      inv_vint.
      clear -Heqb1.
      exfalso.
      unfold Int.ltu in *.
      break_if.
      congruence.
      clear Heqs.
      rewrite Int.unsigned_one in g.
      rewrite Int.unsigned_repr_wordsize in *.
      unfold Int.zwordsize in *.
      unfold Int.wordsize in *.
      unfold Wordsize_32.wordsize in *.
      simpl in *.
      omega.
    }
    (*PC*)
    break_or'.
    2: inv_false.
    subst reg.
    P0 _clear False.
    subst_max.
    preg_simpl.
    repeat find_rewrite_goal.
    simpl.
    reflexivity.
  Qed.

  Definition peep_div_2_to_shr_proofs : rewrite_proofs :=
    {|
      defs := peep_div_2_to_shr_defs
      ; selr := peep_div_2_to_shr_selr
    |}.

  Definition peep_div_2_to_shr :
    concrete = fnd peep_div_2_to_shr_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_div_2_to_shr_defs peep_div_2_to_shr_proofs.
  Qed.

End DIV_2_TO_SHIFT.

Definition peep_div_2_to_shr_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_div_2_to_shr p.
  unfold peep_div_2_to_shr_defs in p.
  simpl in p.
  specialize (p (Pmov_ri ECX two :: Pdiv ECX :: nil)).
  specialize (p eq_refl).
  exact (Some p).
Defined.

Definition div_2_to_shr (c : code) : list StepEquiv.rewrite :=
  collect (map peep_div_2_to_shr_rewrite (ParamSplit.matched_pat peep_div_2_to_shr_example c)).


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import PSCI.Specs.psci_cpu_suspend.
Require Import PSCI.LowSpecs.psci_cpu_suspend.
Require Import PSCI.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       set_psci_result_forward_psci_call_spec
       set_psci_result_x0_spec
    .

  Lemma psci_cpu_suspend_spec_exists:
    forall habd habd'  labd rec entry_point_address context_id
           (Hspec: psci_cpu_suspend_spec rec entry_point_address context_id habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', psci_cpu_suspend_spec0 rec entry_point_address context_id labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. inv Hrel. destruct rec.
    unfold psci_cpu_suspend_spec, psci_cpu_suspend_spec0 in *.
    destruct entry_point_address, context_id.
    eexists; split. reflexivity. constructor. inv Hspec. reflexivity.
  Qed.

End Refine.


Require Import Coqlib Maps.
Require Import AST Linking.
Require Import Values Memory Globalenvs Events.
Require Import RelationClasses.
Require Import sflib.

Set Implicit Arguments.

Record t := mk {
  unreach:> block -> bool; (* for finiteness' `j` function. *)
  ge_nb: block;
  nb: block;
}.

Notation "'prange' '#' hi" := (fun blk => Plt blk hi) (at level 50, no associativity).
Notation "'prange' lo '#'" := (fun blk => Ple lo blk) (at level 50, no associativity).
Notation "'prange' lo hi" := (fun blk => Ple lo blk /\ Plt blk hi) (at level 50, no associativity).

Inductive wf (su: t): Prop :=
| wf_intro
  (WFLO: su <1= prange su.(ge_nb) #)
  (WFHI: su <1= prange # su.(nb)).

(* One strong point of definiton compared to inductive:
elimination of multiple predicate requires
- (inductive) multiple "inv"
- (definition) unfold __ in *; des *)
Definition hle_old (su0 su1: t): Prop :=
  (<<PRIV: su0.(unreach) <1= su1.(unreach)>>)
  /\ (<<OLD: su1.(unreach) /1\ (prange # su0.(nb)) <1= su0.(unreach)>>)
  /\ (<<NB: Ple su0.(nb) su1.(nb)>>)
  /\ (<<GENB: su0.(ge_nb) = su1.(ge_nb)>>).

Definition hle (su0 su1: t): Prop :=
  (<<OLD: forall blk (LT: Plt blk su0.(nb)), su0 blk = su1 blk>>)
  /\ (<<NB: Ple su0.(nb) su1.(nb)>>)
  /\ (<<GENB: su0.(ge_nb) = su1.(ge_nb)>>).

Lemma hle_old_hle: forall su0 su1, hle_old su0 su1 -> hle su0 su1.
Proof.
  split; i; rr in H; des; rr; esplits; eauto.
  - ii. destruct (su1 blk) eqn:T; ss.
    + exploit OLD; eauto.
    + destruct (su0 blk) eqn:T2; ss. exploit PRIV; eauto.
Qed.
Lemma hle_hle_old: forall su0 su1 (WF: wf su0), hle su0 su1 -> hle_old su0 su1.
Proof.
  split; i; rr in H; des; rr; esplits; eauto.
  - i. erewrite <- OLD; eauto.
    inv WF. exploit WFHI; eauto.
  - i. des. erewrite OLD; eauto.
Qed.

Lemma hle_update
      (su0 su1 su2: t)
      (EQ: forall blk (LT: Plt blk su0.(nb)), su1 blk = su2 blk)
      (NB: Ple su1.(nb) su2.(nb))
      (GENB: su1.(ge_nb) = su2.(ge_nb))
      (HLE: hle su0 su1):
    <<HLE: hle su0 su2>>.
Proof.
  rr in HLE. des. rr. esplits; eauto; try xomega. rewrite <- GENB. ss.
Qed.

Lemma hle_old_update
      (su0 su1 su2: t)
      (EQ: forall blk (LT: Plt blk su0.(nb)), su1 blk = su2 blk)
      (NB: Ple su1.(nb) su2.(nb))
      (GENB: su1.(ge_nb) = su2.(ge_nb))
      (HLE: hle_old su0 su1)
      (WF: wf su0):
    <<HLE: hle_old su0 su2>>.
Proof.
  rr in HLE. rr. des. esplits; eauto.
  - inv WF. i. exploit PRIV; eauto. i. erewrite <- EQ; eauto.
  - i; des. erewrite <- EQ in PR; eauto.
  - rewrite <- NB. xomega.
  - rewrite <- GENB. ss.
Qed.

Global Program Instance hle_old_PreOrder: PreOrder hle_old.
Next Obligation.
  rr. ii; des. esplits; eauto.
  - ii. des; ss.
  - xomega.
Qed.
Next Obligation.
  ii; des.
  unfold hle_old in *. des.
  esplits; eauto; try xomega.
  - ii. des; ss. eapply OLD0; eauto. esplits; eauto. eapply OLD; eauto. esplits; eauto. xomega.
  - congruence.
Qed.

Global Program Instance hle_PreOrder: PreOrder hle.
Next Obligation.
  rr. ii; des. esplits; eauto. reflexivity.
Qed.
Next Obligation.
  ii; des. unfold hle in *. des. esplits; eauto; try xomega.
  - ii. rewrite <- OLD; ss; try xomega. rewrite OLD0; ss.
  - congruence.
Qed.

Inductive mle (su: t) (m0 m1: Memory.mem): Prop :=
| mle_intro
    (PERM: forall blk ofs
        (VALID: (Mem.valid_block m0) blk),
        (Mem.perm m1) blk ofs Max <1= (Mem.perm m0) blk ofs Max)
    (RO: Mem.unchanged_on (loc_not_writable m0) m0 m1)
    (PRIV: Mem.unchanged_on (Basics.flip (fun _ => su)) m0 m1).

Global Program Instance mle_PreOrder su: PreOrder (mle su).
Next Obligation.
  rr. ii. econs; eauto with mem.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; ss; eauto.
  - ii. eapply PERM; eauto. eapply PERM0; eauto. unfold Mem.valid_block in *. inv RO. xomega.
  - eapply Mem.unchanged_on_implies with (P:= fun blk ofs => loc_not_writable x blk ofs /\ Mem.valid_block x blk); ss.
    eapply Mem.unchanged_on_trans.
    + eapply Mem.unchanged_on_implies; try apply RO. i. des. ss.
    + eapply Mem.unchanged_on_implies; try apply RO0; eauto.
      ii. des. rr in H. eapply H; eauto.
  - eapply Mem.unchanged_on_trans; eauto.
Qed.

Lemma store_mle
      chunk m0 blk ofs v m1 (su: t)
      (STR: Mem.store chunk m0 blk ofs v = Some m1)
      (SU: ~su blk):
    <<MLE: mle su m0 m1>>.
Proof.
  econs; eauto.
  - ii. eauto with mem.
  - (* Copied from Events.volatile_store_readonly *)
    eapply Mem.store_unchanged_on; eauto.
    exploit Mem.store_valid_access_3; eauto. intros [P Q].
    intros. unfold loc_not_writable. red; intros. elim H0.
    apply Mem.perm_cur_max. apply P. auto.
  - eapply Mem.store_unchanged_on; eauto.
Qed.

Lemma free_mle
      m0 blk lo hi m1 (su: t)
      (FREE: Mem.free m0 blk lo hi = Some m1)
      (SU: ~su blk):
    <<MLE: mle su m0 m1>>.
Proof.
  econs; eauto.
  - ii. eauto with mem.
  - (* Copied from Events.extcall_free_ok *)
    inv FREE. eapply Mem.free_unchanged_on; eauto.
    intros. red; intros. elim H1.
    apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
    eapply Mem.free_range_perm; eauto.
  - eapply Mem.free_unchanged_on; eauto.
Qed.

Lemma storebytes_mle
      m0 blk ofs mvs m1 (su: t)
      (STR: Mem.storebytes m0 blk ofs mvs = Some m1)
      (SU: ~su blk):
    <<MLE: mle su m0 m1>>.
Proof.
  econs; eauto.
  - ii. eauto with mem.
  - (* Copied from Events.volatile_store_readonly *)
    inv STR. eapply Mem.storebytes_unchanged_on; eauto.
    intros. red; intros. elim H1.
    apply Mem.perm_cur_max.
    eapply Mem.storebytes_range_perm; eauto.
  - eapply Mem.storebytes_unchanged_on; eauto.
Qed.

Lemma alloc_mle
      m0 lo hi m1 blk (su: t)
      (ALC: Mem.alloc m0 lo hi = (m1, blk)):
    <<MLE: mle su m0 m1>>.
Proof.
  econs; eauto.
  - ii. eauto with mem.
  - eapply Mem.alloc_unchanged_on; eauto.
  - eapply Mem.alloc_unchanged_on; eauto.
Qed.

Lemma mle_monotone
      m0 m1 (su0 su1: t)
      (LE: su0 <1= su1)
      (MLE: su1.(mle) m0 m1):
    <<MLE: su0.(mle) m0 m1>>.
Proof.
  inv MLE. econs; eauto. eapply Mem.unchanged_on_implies; eauto. unfold Basics.flip in *. rr. ii. eapply LE; eauto.
Qed.

Ltac nb_tac :=
  repeat
    multimatch goal with
    | [ H: nb _ = _ |- _ ] => rewrite H in *
    | [ H: ge_nb _ = _ |- _ ] => rewrite H in *
    end.


From QuickChick Require Import QuickChick.

(* begin hide *)
Set Warnings "-extraction-opaque-accessed,-extraction".
(* end hide *)
Declare ML Module "extract".

Parameter plus' : nat -> nat -> nat.

Extract Constant plus' => "Extract.plus".

Definition plus_prop x y :=
  plus' x y = x + y?.

(*! QuickChick plus_prop. *)