(*****************************************************************************)
(** The FSC memory model splits memory into non-atomic and atomic locations. *)
(** Every location can be accessed only with corresponding mode.             *)
(** FSC's memory access instructions are compiled into IMM as follows:       *)
(** +----------------+-----------------------+----------+                    *)
(** |FSC             |IMM                    |Hypotheses|                    *)
(** +----------------+-----------------------+----------+                    *)
(** |r := [x]^{na};  | r := [x]^{rlx};       |  -       |                    *)
(** |                |                       |          |                    *)
(** +----------------+-----------------------+----------+                    *)
(** |[x]^{na} := v;  | fence(acqrel);        | WNAF     |                    *)
(** |                | [x]^{rlx} := v;       |          |                    *)
(** +----------------+-----------------------+----------+                    *)
(** |r := [x]^{at};  | fence(sc);            | RATF1,   |                    *)
(** |                | r := [x]^{rlx};       | RATF2    |                    *)
(** |                | fence(sc);            |          |                    *)
(** +----------------+-----------------------+----------+                    *)
(** |[x]^{at} := v;  | fence(sc);            | WATF1,   |                    *)
(** |                | [x]^{rlx} := v;       | WATF2    |                    *)
(** |                | fence(sc);            |          |                    *)
(** +----------------+-----------------------+----------+                    *)
(*****************************************************************************)
Require Import Classical Peano_dec.
From hahn Require Import Hahn.
Require Import IfThen.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_bob imm_ppo.
Require Import imm_hb.
Require Import imm.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section LDRF_Fsc.

Variable G : execution.
Hypothesis WF: Wf G.
Hypothesis IC : imm.imm_consistent G.

Notation "'E'" := G.(acts_set).
Notation "'Init'" := (is_init).
Notation "'NInit'" := (set_compl Init).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'rmw_dep'" := G.(rmw_dep).

Notation "'fr'" := G.(fr).
Notation "'eco'" := G.(eco).
Notation "'coe'" := G.(coe).
Notation "'coi'" := G.(coi).
Notation "'deps'" := G.(deps).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).

Notation "'detour'" := G.(detour).

Notation "'rs'" := G.(rs).
Notation "'release'" := G.(release).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(imm_hb.hb).

Notation "'ar_int'" := G.(ar_int).
Notation "'ppo'" := G.(ppo).
Notation "'bob'" := G.(bob).

Notation "'ar'" := G.(ar).

Notation "'lab'" := G.(lab).
Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (mod lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'ORlx'" := (fun a => is_true (is_only_rlx lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).

Variable NA AT: actid -> Prop.
Hypothesis LOCMODE: forall l, <<LM: Loc_ l ⊆₁ NA>> \/ <<LM: Loc_ l ⊆₁ AT>>.
Hypothesis DIFMODE: AT ∩₁ NA ≡₁ ∅.
Hypothesis RWMODE: AT ∪₁ NA ≡₁ RW.

Hypothesis WNAF : W ∩₁ NA ⊆₁ codom_rel (⦗F∩₁Acqrel⦘ ⨾ immediate sb) ∪₁ Init.
Hypothesis RATF1 : R ∩₁ AT ⊆₁ codom_rel (⦗F ∩₁ Sc⦘ ⨾ immediate sb).
Hypothesis RATF2 : R ∩₁ AT ⊆₁ dom_rel (immediate sb ⨾ ⦗F ∩₁ Sc⦘).
Hypothesis WATF1: W ∩₁ AT ⊆₁ codom_rel (⦗F ∩₁ Sc⦘ ⨾ immediate sb) ∪₁ Init.
Hypothesis WATF2: W ∩₁ AT ⊆₁ dom_rel (immediate sb ⨾ ⦗F ∩₁ Sc⦘) ∪₁ Init.

Lemma mode_split (S: actid -> Prop) (HASLOC: forall x, S x -> exists l, loc x = Some l):
  S ≡₁ (S ∩₁ NA) ∪₁ (S ∩₁ AT).
Proof using.
  red. split; [| basic_solver].
  rewrite <- set_inter_union_r.
  apply set_subset_inter_r. split; [basic_solver| ].
  red. intros x Sx. red.
  specialize (HASLOC x). apply HASLOC in Sx.
  destruct Sx as [l Lx]. specialize (LOCMODE l).
  destruct LOCMODE; specialize (H x); auto.
Qed.

Lemma sb_f_helper T M (TF: T ⊆₁ codom_rel (⦗F ∩₁ M⦘ ⨾ immediate sb)):
  ⦗RW⦘ ⨾ sb ⨾ ⦗T⦘ ⊆ ⦗RW⦘ ⨾ sb ⨾ ⦗F ∩₁ M⦘ ⨾ sb ⨾ ⦗T⦘.
Proof using.
  unfolder. intros e a H. destruct H as [RWe [SBew Ta]]. split; auto.
  red in TF. specialize (@TF a).
  pose proof (TF Ta) as [f HH].
  apply seq_eqv_l in HH. destruct HH as [[Ff Mf] [SBfw IMMfw]].
  exists f.
  assert (NIf: NInit f).
  { specialize (read_or_fence_is_not_init WF). intros RFNI.
    specialize (RFNI f). basic_solver 10. }
  assert (NEQef: e <> f).
  { destruct RWe; red; intros; type_solver. }
  assert (SBef: sb e f).
  { pose (sb_semi_total_r WF NIf NEQef SBew SBfw) as SB2.
    destruct SB2; auto. exfalso. specialize (IMMfw e). auto. }
  basic_solver.
Qed.

Lemma sb_f_w:
  ⦗RW⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ ⦗RW⦘ ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sb ⨾ ⦗W ∩₁ AT⦘ ∪ ⦗RW⦘ ⨾ sb ⨾ ⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ ⦗W ∩₁ NA⦘.
Proof using.
  assert (FENCE: forall MW MF (COMP: W ∩₁ MW
          ⊆₁ codom_rel (⦗F ∩₁ MF⦘ ⨾ immediate sb) ∪₁ Init),
             ⦗RW⦘ ⨾ sb ⨾ ⦗W ∩₁ MW⦘ ⊆ ⦗RW⦘ ⨾ sb ⨾ ⦗F ∩₁ MF⦘ ⨾ sb ⨾ ⦗W ∩₁ MW⦘).
  { ins.
    rewrite (no_sb_to_init G) at 3. rewrite seqA, <- id_inter.
    assert (TMP: NInit ∩₁ (W ∩₁ MW) ⊆₁ codom_rel (⦗F ∩₁ MF⦘ ⨾ immediate sb)).
    { rewrite COMP. rewrite set_inter_union_r.
      apply set_subset_union_l. split; [basic_solver 10 | basic_solver]. }
    rewrite (no_sb_to_init G) at 1. rewrite seqA, <- id_inter.
    apply (sb_f_helper TMP). }

  rewrite (mode_split W) at 2; [| apply is_w_loc].
  rewrite (id_union (W ∩₁ NA) _). do 2 rewrite seq_union_r.
  unionL; [unionR right;apply (FENCE NA Acqrel WNAF)
          | unionR left; apply (FENCE AT Sc WATF1)].
Qed.

Lemma sb_rf_acyclic: acyclic (sb ⨾ rfe).
Proof using.
  rewrite (WF.(wf_rfeD)). arewrite (R ⊆₁ RW).
  rewrite <- !seqA, acyclic_rotl, !seqA.
  sin_rewrite sb_f_w.
  cdes IC. cdes Cext.
  arewrite (F ∩₁ Sc ⊆₁ F ∩₁ Acq/Rel) by mode_solver.
  arewrite (F ∩₁ Acqrel ⊆₁ F ∩₁ Acq/Rel) by mode_solver.
  assert (FBOB: sb ⨾ ⦗F ∩₁ Acq/Rel⦘ ⨾ sb ⊆ bob ⨾ bob).
  { seq_rewrite <- seq_eqvK. rewrite seqA.
    sin_rewrite sb_to_f_in_bob. sin_rewrite sb_from_f_in_bob. basic_solver. }
  do 2 sin_rewrite FBOB.
  rewrite !inclusion_seq_eqv_r, !inclusion_seq_eqv_l.
  arewrite (rfe ⊆ ar). arewrite (bob ⊆ ar).
  rewrite unionK, seqA.
  red.
  red in Cext0.
  arewrite (ar ⨾ ar ⨾ ar ⊆ ar^+).
  { do 2 rewrite <- ct_unit. rewrite seqA. basic_solver 10. }
  rewrite ct_of_ct. auto.
Qed.

Lemma sb_rfe_crt_hb: (⦗RW⦘ ⨾ sb ⨾ rfe)^* ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⊆ hb.
Proof using.
  rewrite (dom_l WF.(wf_rfeD)).
  sin_rewrite sb_f_w.
  arewrite (F ∩₁ Sc ⊆₁ F ∩₁ Acqrel) by mode_solver.
  do 2 rewrite inclusion_seq_eqv_r. rewrite unionK.
  rewrite inclusion_seq_eqv_l.
  rewrite !seqA.
  rewrite rtE, seq_union_l. unionL.
  { rewrite sb_in_hb. basic_solver. }
  arewrite ((sb ⨾ ⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ rfe)⁺ ⊆ sb ⨾ ⦗F ∩₁ Acqrel⦘ ⨾ (⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ rfe ⨾ sb ⨾ ⦗F ∩₁ Acqrel⦘)^* ⨾ ⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ rfe).
  { rewrite <- seq_eqvK at 1. rewrite seqA.
    rewrite <- seqA with (r2:=⦗F ∩₁ Acqrel⦘). rewrite ct_rotl.
    basic_solver. }
  arewrite ((⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ rfe ⨾ sb ⨾ ⦗F ∩₁ Acqrel⦘) ⊆ hb).
  { seq_rewrite (dom_l (wf_rfeD WF)). rewrite seqA.
    arewrite (⦗F ∩₁ Acqrel⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ imm_hb.release G).
    { unfold imm_hb.release.
      arewrite (⦗W⦘ ⊆ imm_hb.rs G).
      { unfold imm_hb.rs. rewrite seq_union_r. unionR right.
        basic_solver. }
      hahn_frame_r.
      mode_solver 10. }
    rewrite <- sw_in_hb. unfold imm_hb.sw.
    rewrite id_inter. arewrite (Acqrel ⊆₁ Acq) by mode_solver.
    arewrite ((sb ⨾ ⦗F⦘) ⊆ (sb ⨾ ⦗F⦘)^?). hahn_frame.
    unionR right. basic_solver. }
  rewrite sb_in_hb.
  rewrite inclusion_seq_eqv_l.
  seq_rewrite <- ct_begin. sin_rewrite ct_unit.
  rewrite (ct_of_trans (@hb_trans G)).
  basic_solver.
Qed.

Lemma sl_mode r (SL: r ⊆ same_loc):
  ⦗RW⦘ ⨾ r ⨾ ⦗RW⦘ ⊆ restr_rel NA r ∪ restr_rel AT r.
Proof using.
  unfolder. ins. destruct H as [RWx [RELxy RWy]].
  assert (exists l, Loc_ l x) as [l Lx].
  { unfold Events.loc. unfold is_f in *.
    destruct (lab x) eqn:AA; simpls.
    all: eauto.
    type_solver. }
  specialize (LOCMODE l).
  red in SL.
  pose proof (SL x y RELxy) as SLxy. red in SLxy.
  rewrite Lx in SLxy.
  destruct LOCMODE; splits; auto.
Qed.

Lemma sb_f_at: RW ∩₁ AT ∩₁ NInit ⊆₁ codom_rel (⦗F ∩₁ Sc⦘ ⨾ immediate sb).
Proof using.
  do 2 rewrite set_inter_union_l.
  apply set_subset_union_l.
  split.
  { arewrite (R ∩₁ AT ∩₁ NInit ⊆₁ R ∩₁ AT) by basic_solver. }
  rewrite WATF1. rewrite set_inter_union_l. apply set_subset_union_l.
  split; [basic_solver 10 | basic_solver].
Qed.

Lemma f_sb_at: RW ∩₁ AT ∩₁ NInit  ⊆₁ dom_rel (immediate sb ⨾ ⦗F ∩₁ Sc⦘).
Proof using.
  do 2 rewrite set_inter_union_l.
  apply set_subset_union_l.
  split.
  { arewrite (R ∩₁ AT ∩₁ NInit ⊆₁ R ∩₁ AT) by basic_solver. }
  rewrite WATF2. rewrite set_inter_union_l. apply set_subset_union_l.
  split; [basic_solver 10 | basic_solver].
Qed.

Lemma ct_dom_start: forall (A: Type) (r: relation A) (dom: A -> Prop),
    ⦗dom⦘ ⨾ (r ⨾ ⦗dom⦘)^+ ≡ (⦗dom⦘ ⨾ r ⨾ ⦗dom⦘)^+.
Proof using.
  intros A r dom.
  rewrite ct_rotl.
  rewrite <- (seqA ⦗dom⦘ r ⦗dom⦘). rewrite ct_rotl.
  rewrite !seqA.
  seq_rewrite seq_eqvK.
  basic_solver.
Qed.

Lemma acyclic_empty: forall (A: Type), @acyclic A ∅₂.
Proof using.
  intros A. red.
  rewrite ct_of_trans; [| basic_solver].
  basic_solver.
Qed.

Lemma sb_eco_sb_psc: ⦗F ∩₁ Sc⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⊆ psc G.
Proof using. unfold psc. rewrite sb_in_hb. basic_solver 10. Qed.

Lemma RFE1: rfe^+ ≡ rfe.
Proof using.  apply ct_no_step. rewrite WF.(wf_rfeD). type_solver. Qed.

Lemma no_eco_to_init: eco ≡ eco ⨾ ⦗NInit⦘.
Proof using.
  split; [| basic_solver].
  arewrite (eco ≡ eco ⨾ ⦗codom_rel eco⦘) at 1 by basic_solver.
  apply seq_mori; [basic_solver|].
  rewrite (eco_alt3 WF).
  cdes IC.
  rewrite (no_rf_to_init WF), (no_co_to_init WF (coherence_sc_per_loc Cint)).
  rewrite (no_fr_to_init WF (coherence_sc_per_loc Cint)).
  do 2 rewrite <- seq_union_l.
  rewrite inclusion_ct_seq_eqv_r. rewrite codom_seq.
  basic_solver.
Qed.

Lemma acyclic_sb_rf_eco: acyclic (sb ∪ restr_rel NA rf ∪ restr_rel AT eco).
Proof using.
  rewrite rfi_union_rfe, <- union_restr, <- unionA.
  arewrite (restr_rel NA rfi ⊆ sb). rewrite unionK.
  assert (na_at_rels_empty: restr_rel NA rfe ⨾ restr_rel AT eco ≡ ∅₂).
  { generalize DIFMODE. basic_solver. }
  rewrite unionA. apply acyclic_union1; [apply Execution.sb_acyclic | |].
  { cdes IC. cdes Cint.
    apply acyclic_union1.
    { rewrite inclusion_restr.
      rewrite WF.(wf_rfeD). apply acyclic_disj. type_solver. }
    { rewrite inclusion_restr.
      red. rewrite (ct_of_trans (eco_trans WF)).
      apply (eco_irr WF). }
    rewrite ct_end, ct_begin, seqA.
    seq_rewrite na_at_rels_empty.
    rewrite seq_false_l, seq_false_r. apply acyclic_empty. }
  rewrite (ct_of_trans (@sb_trans G)).
  arewrite ((restr_rel NA rfe ∪ restr_rel AT eco)⁺ ⊆ (restr_rel NA rfe)⁺ ∪ (restr_rel AT eco)⁺).
  { rewrite path_union. apply union_mori; [basic_solver| ].
    rewrite rtE. rewrite seq_union_l.
    rewrite (ct_end (restr_rel NA rfe)) at 1. rewrite seqA.
    rewrite na_at_rels_empty.
    rewrite !seq_false_r, union_false_r. rewrite seq_id_l at 1.
    rewrite seq_union_r. unionL; [basic_solver| ].
    rewrite ct_end, ct_begin, seqA at 1.
    assert (restr_rel AT eco ⨾ restr_rel NA rfe ≡ ∅₂).
    { do 2 rewrite restr_relE, seqA.
      seq_rewrite <- id_inter. rewrite DIFMODE. basic_solver. }
    seq_rewrite H. basic_solver. }
  rewrite seq_union_r.

  apply acyclic_union1.
  { rewrite inclusion_restr.
    rewrite RFE1. apply sb_rf_acyclic. }
  { rewrite restr_relE.
    rewrite inclusion_ct_seq_eqv_l, inclusion_seq_eqv_r.
    rewrite (ct_of_trans (eco_trans WF)).
    rewrite (wf_ecoD WF). seq_rewrite <- id_inter.
    rewrite <- seqA with (r3:=⦗RW⦘), <- seqA. rewrite acyclic_rotl.
    rewrite set_interC.
    rewrite no_sb_to_init, seqA. seq_rewrite <- id_inter. rewrite set_interC.
    sin_rewrite (sb_f_helper sb_f_at).
    rewrite inclusion_seq_eqv_r,  inclusion_seq_eqv_l.
    rewrite !seqA.
    rewrite <- (seq_eqvK (F ∩₁ Sc)), seqA.
    rewrite <- seqA with (r2:=⦗F ∩₁ Sc⦘).
    apply acyclic_rotl. rewrite !seqA.
    rewrite sb_eco_sb_psc. arewrite (psc G ⊆ ar).
    cdes IC. cdes Cext. auto. }
  rewrite inclusion_restr, RFE1.
  rewrite restr_relE, inclusion_seq_eqv_r.
  rewrite acyclic_rotl.
  rewrite inclusion_ct_seq_eqv_l.
  rewrite (ct_of_trans (eco_trans WF)).
  rewrite (dom_r (wf_rfeD WF)) at 1. arewrite (R ⊆₁ RW) at 1.
  rewrite <- seqA with (r3:=⦗RW⦘).
  rewrite (@inclusion_ct_seq_eqv_r _ RW _).
  rewrite <- seqA, acyclic_rotl.
  arewrite (⦗RW⦘ ⨾ (sb ⨾ ⦗AT⦘ ⨾ eco)⁺ ⊆ (⦗RW⦘ ⨾ sb ⨾ ⦗RW ∩₁ AT⦘ ⨾ eco)⁺).
  { rewrite (wf_ecoD WF) at 1.
    rewrite <- !seqA.
    rewrite ct_dom_start, !seqA.
    apply clos_trans_mori.
    hahn_frame. basic_solver. }
  rewrite no_sb_to_init, seqA. seq_rewrite <- id_inter. rewrite set_interC.
  sin_rewrite (sb_f_helper sb_f_at).
  do 2 rewrite inclusion_seq_eqv_r.
  rewrite <- (seq_eqvK (F ∩₁ Sc)), !seqA.
  rewrite <- seqA with (r2:=⦗F ∩₁ Sc⦘). rewrite <- seqA with (r1:=⦗RW⦘).
  rewrite inclusion_seq_eqv_l.
  rewrite ct_rotl, !seqA.
  rewrite sb_eco_sb_psc.

  rewrite <- seqA. rewrite acyclic_rotl.
  rewrite !seqA.

  arewrite (eco ⨾ (sb ⨾ rfe)⁺ ⊆ eco ⨾ (⦗RW⦘ ⨾ sb ⨾ rfe)⁺).
  { rewrite (dom_r (wf_ecoD WF)) at 1. rewrite !seqA. hahn_frame_l.
    rewrite (dom_r (wf_rfeD WF)) at 1.
    arewrite (R ⊆₁ RW) at 2. rewrite <- seqA.
    rewrite ct_dom_start.
    rewrite inclusion_seq_eqv_r. basic_solver. }

  rewrite <- (seq_eqvK (F ∩₁ Sc)) at 2.
  rewrite inclusion_t_rt. sin_rewrite sb_rfe_crt_hb.
  arewrite ((⦗F ∩₁ Sc⦘ ⨾ sb ⨾ eco ⨾ hb ⨾ ⦗F ∩₁ Sc⦘) ⊆ psc G).
  rewrite <- ct_end. arewrite (psc G ⊆ ar).
  red. rewrite ct_of_ct.
  cdes IC. cdes Cext. auto.
Qed.

Lemma imm_to_ocaml_causal:
  acyclic (sb ∪ rfe ∪ restr_rel AT (coe ∪ fre G)).
Proof using.
  arewrite (rfe ⊆ rf).
  arewrite (rf ⊆ restr_rel NA rf ∪ restr_rel AT rf).
  { rewrite (wf_rfD WF) at 1. arewrite (R ⊆₁ RW). arewrite (W ⊆₁ RW) at 1.
    rewrite sl_mode; [basic_solver | apply (wf_rfl WF)]. }

  do 2 rewrite unionA.
  rewrite union_restr.
  arewrite ((rf ∪ (coe ∪ fre G)) ⊆ eco).
  { unfold Execution_eco.eco, Execution.rf, Execution.coe, Execution.fre. basic_solver 10. }
  rewrite <- unionA. apply acyclic_sb_rf_eco.
Qed.

Lemma f_sb_helper T M (TF: T ⊆₁ dom_rel (immediate sb ⨾ ⦗F ∩₁ M⦘))
  (NIT: T ∩₁ is_init ≡₁ ∅):
  ⦗T⦘ ⨾ sb ⨾ ⦗RW⦘ ⊆ ⦗T⦘ ⨾ sb ⨾ ⦗F ∩₁ M⦘ ⨾ sb ⨾ ⦗RW⦘.
Proof using.
  unfolder. intros a e [Ta [SBae RWe]]. split; auto.
  red in TF. specialize (@TF a).
  pose proof (TF Ta) as [f HH].
  apply seq_eqv_r in HH. destruct HH as [[SBaf IMMfw] [Ff Mf]].
  exists f.
  assert (NIa: ~is_init a).
  { red in NIT. destruct NIT as [NIT _]. red in NIT.
    specialize (NIT a).
    red. intros contra.
    destruct NIT. red. split; auto. }
  assert (NEQef: e <> f).
  { destruct RWe; red; intros; type_solver. }
  assert (SBfe: sb f e).
  { pose (sb_semi_total_l WF NIa NEQef SBae SBaf) as SB2.
    destruct SB2; auto. exfalso. specialize (IMMfw e). auto. }
  basic_solver.
Qed.

Lemma ac_irr: forall A (r: relation A), acyclic r <-> irreflexive r^+.
Proof using. intros A r. basic_solver. Qed.

Definition ae := (⦗AT⦘ ⨾ (rfe ∪ co) ⨾ ⦗AT⦘).

Lemma imm_to_ocaml_coherent: irreflexive ((sb ∪ ae)^+ ⨾ (co ∪ fr)).
Proof using.
  arewrite (co ∪ fr ⊆ eco) by unfold Execution_eco.eco; basic_solver 10.
  rewrite ct_unionE.
  assert (ae_in_eco: ae ⊆ eco).
  { unfold Execution_eco.eco, ae.
    rewrite inclusion_seq_eqv_l, inclusion_seq_eqv_r.
    unfold Execution.rfe.
    basic_solver 10. }
  rewrite seq_union_l. apply irreflexive_union. split.
  { rewrite ae_in_eco.
    rewrite ct_unit.
    rewrite (ct_of_trans (eco_trans WF)).
    apply (eco_irr WF). }
  rewrite seqA.
  rewrite irreflexive_seqC, seqA.
  arewrite (eco ⨾ ae＊ ⊆ eco).
  { rewrite ae_in_eco. rewrite <- ct_begin.
    apply (ct_of_trans (eco_trans WF)). }
  rewrite rtE, seq_union_r, seq_id_r.
  rewrite unionC, path_absorb2.
  2: { sin_rewrite (rewrite_trans (@sb_trans G)). basic_solver. }
  do 2 rewrite seq_union_l. rewrite unionA. apply irreflexive_union. split.
  { arewrite (ae ⊆ ⦗AT⦘ ⨾ eco ⨾ ⦗AT⦘).
    { unfold ae, Execution_eco.eco, Execution.rfe. basic_solver 10. }
    rewrite <- restr_relE.
    rewrite (ct_of_trans (transitive_restr (eco_trans WF))).
    assert (eco_sl: eco ⊆ same_loc).
    { rewrite (eco_alt3 WF).
      rewrite (wf_rfl WF), (wf_col WF), (wf_frl WF).
      do 2 rewrite unionK. apply (ct_of_trans (@same_loc_trans _ lab)). }
    rewrite (wf_ecoD WF) at 2.
    rewrite (sl_mode eco_sl).
    rewrite seq_union_r.
    apply irreflexive_union. split.
    { rewrite ct_end, seqA, seqA.
      arewrite (restr_rel AT eco ⨾ restr_rel NA eco ⊆ ∅₂).
      { do 2 rewrite restr_relE. generalize DIFMODE. basic_solver. }
      rewrite !seq_false_r. basic_solver. }
    rewrite ct_rotl, !seqA.
    rewrite (rewrite_trans (transitive_restr (eco_trans WF))).
    rewrite <- ct_rotl.
    rewrite <- ac_irr. apply acyclic_seq_from_union.
    arewrite (sb ∪ restr_rel AT eco ⊆ sb ∪ restr_rel NA rf ∪ restr_rel AT eco) by basic_solver 10.
    apply acyclic_sb_rf_eco. }

  rewrite (ct_of_trans (@sb_trans G)).
  apply irreflexive_union. split.
  { rewrite sb_in_hb.
    cdes IC. cdes Cint. auto. }
  rewrite (dom_r (wf_ecoD WF)), <- seqA.
  rewrite irreflexive_seqC, seqA.
  arewrite (⦗RW⦘ ⨾ (sb ⨾ ae⁺)⁺ ⊆  sb ⨾ ⦗F ∩₁ Sc⦘ ⨾ (psc G)^* ⨾ ⦗F ∩₁ Sc⦘ ⨾ sb ⨾ ae⁺).
  {
    arewrite (ae⁺ ⊆ ⦗RW ∩₁ AT⦘ ⨾ ae⁺ ⨾ ⦗RW⦘) at 1.
    { rewrite <- inclusion_ct_seq_eqv_r, <- inclusion_ct_seq_eqv_l.
      apply clos_trans_mori.
      unfold ae. rewrite !seqA.
      rewrite id_inter, seqA. seq_rewrite seq_eqvK.
      seq_rewrite (seq_eqvC (RW) (AT)). rewrite seqA.
      rewrite (seq_eqvC (AT) (RW)).
      hahn_frame.
      rewrite ((wf_rfeD WF)), ((wf_coD WF)) at 1.
      basic_solver. }
    do 2 rewrite <- seqA. rewrite ct_dom_start, seqA, seqA.
    rewrite no_sb_to_init at 1. rewrite seqA.
    seq_rewrite <- id_inter. rewrite set_interC.
    sin_rewrite (sb_f_helper sb_f_at). do 2 rewrite inclusion_seq_eqv_r.
    rewrite !seqA.
    rewrite inclusion_seq_eqv_l.
    rewrite <- seq_eqvK at 1. rewrite seqA.
    rewrite <- seqA with (r2:=⦗F ∩₁ Sc⦘). rewrite ct_rotl, seqA.
    hahn_frame. repeat hahn_frame_r.
    apply clos_refl_trans_mori.
    rewrite ae_in_eco. rewrite (ct_of_trans (eco_trans WF)).
    rewrite sb_in_hb.
    unfold psc. basic_solver 10. }
  arewrite (ae⁺ ⊆ eco ⨾ ⦗RW ∩₁ AT⦘).
  { unfold ae. rewrite <- seqA, inclusion_ct_seq_eqv_r.
    rewrite id_inter. hahn_frame.
    rewrite inclusion_seq_eqv_l.
    arewrite (rfe ∪ co ⊆ eco) by unfold Execution_eco.eco, Execution.rfe; basic_solver 10.
    rewrite (ct_of_trans (eco_trans WF)).
    apply (dom_r (wf_ecoD WF)). }

  rewrite (dom_l (wf_ecoD WF)) at 2.
  rewrite no_eco_to_init. rewrite seqA.
  seq_rewrite <- id_inter. rewrite (set_interC _ (RW ∩₁ AT)).
  assert (NINIT: RW ∩₁ AT ∩₁ NInit ∩₁ Init ≡₁ ∅) by basic_solver.
  sin_rewrite (f_sb_helper f_sb_at NINIT).
  rewrite !seqA.
  sin_rewrite (@inclusion_seq_eqv_r _ eco _).
  rewrite <- seq_eqvK at 3. rewrite seqA.
  arewrite (⦗RW ∩₁ AT ∩₁ NInit⦘ ⨾ sb ⊆ sb).
  sin_rewrite sb_eco_sb_psc.
  rewrite <- seqA with (r2:=psc G). rewrite <- seqA with (r1:=sb).
  rewrite irreflexive_seqC, !seqA.
  sin_rewrite (@inclusion_seq_eqv_l _ eco _).
  sin_rewrite sb_eco_sb_psc.
  seq_rewrite <- ct_end. rewrite ct_unit.
  arewrite (psc G ⊆ ar).
  cdes IC. cdes Cext. auto.
Qed.

Theorem ldrf_condition_ext:
  acyclic(sb ∪ rf ∪ ⦗F ∩₁ Sc⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗F ∩₁ Sc⦘).
Proof using.
  apply acyclic_union1.
  { rewrite (wf_rfD WF). arewrite (W ⊆₁ RW). arewrite (R ⊆₁ RW) at 2 .
    rewrite (sl_mode); [| apply (wf_rfl WF)].
    rewrite rf_in_eco at 2. rewrite <- unionA.
    apply acyclic_sb_rf_eco. }
  { sin_rewrite sb_eco_sb_psc. arewrite (psc G ⊆ ar).
    cdes IC. cdes Cext. auto. }
  rewrite rfi_union_rfe, (rfi_in_sbloc' WF), inclusion_inter_l1.
  rewrite <- unionA, unionK.
  rewrite <- seq_eqvK. rewrite !seqA.
  sin_rewrite sb_eco_sb_psc.
  rewrite unionC. rewrite path_ut2; [| apply (@sb_trans G)].
  rewrite RFE1. arewrite (rfe^* ≡ rfe^?).
  { rewrite rtE, RFE1. basic_solver. }
  rewrite <- seqA with (r3:=⦗F ∩₁ Sc⦘). rewrite inclusion_ct_seq_eqv_r.
  rewrite <- seqA. rewrite acyclic_rotl.
  seq_rewrite seq_union_r.
  arewrite (⦗F ∩₁ Sc⦘ ⨾ rfe ≡ ∅₂) by rewrite (wf_rfeD WF); type_solver.
  rewrite union_false_l.
  arewrite (⦗F ∩₁ Sc⦘ ⨾ rfe^? ≡ ⦗F ∩₁ Sc⦘) by rewrite (wf_rfeD WF); type_solver.
  rewrite inclusion_ct_seq_eqv_l.
  arewrite (rfe^? ⨾ ⦗F ∩₁ Sc⦘ ≡ ⦗F ∩₁ Sc⦘) by rewrite (wf_rfeD WF); type_solver.
  rewrite rtE. repeat case_union _ _.
  arewrite (⦗F ∩₁ Sc⦘ ⨾ ⦗fun _ : actid => True⦘ ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⊆ ar).
  { arewrite (sb ⨾ ⦗F ∩₁ Sc⦘ ⊆ bob).
    { unfold imm_bob.bob, imm_bob.fwbob.
      arewrite (Sc ⊆₁ Acq/Rel) by mode_solver.
      basic_solver 10. }
    unfold imm.ar, imm_ppo.ar_int. basic_solver 10. }
  rewrite ct_begin with (r:=(sb ⨾ rfe)).
  rewrite !seqA.
  rewrite (dom_r (wf_rfeD WF)), seqA.
  arewrite (⦗R⦘ ⨾ (sb ⨾ rfe ⨾ ⦗R⦘)＊ ⊆ (⦗RW⦘ ⨾ sb ⨾ rfe)＊).
  { rewrite rtE, seq_union_r. unionL; [basic_solver| ].
    arewrite (⦗R⦘ ⊆ ⦗RW⦘). rewrite <- seqA, ct_dom_start.
    rewrite inclusion_seq_eqv_r. basic_solver. }
  sin_rewrite sb_rfe_crt_hb.
  arewrite (rfe ⊆ eco) by unfold Execution_eco.eco, Execution.rfe; basic_solver.
  arewrite ((psc G)⁺ ⊆ ⦗F ∩₁ Sc⦘ ⨾ (psc G)⁺).
  { unfold psc. rewrite <- seq_eqvK at 1. rewrite seqA.
    rewrite inclusion_ct_seq_eqv_l at 1. basic_solver. }
  arewrite (⦗F ∩₁ Sc⦘ ⨾ sb ⨾ eco ⨾ hb ⨾ ⦗F ∩₁ Sc⦘ ⊆ psc G).
  arewrite (psc G ⊆ ar).
  rewrite inclusion_seq_eqv_l, unionK.
  rewrite acyclic_rotl, ct_unit.
  red. rewrite ct_of_ct.
  cdes IC. cdes Cext. auto.
Qed.

Theorem ldrf_condition: acyclic(sb ∪ rf ∪ ⦗AT⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗AT⦘).
Proof using.
  arewrite (sb ∪ rf ∪ ⦗AT⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗AT⦘ ⊆ (sb ∪ rf ∪ ⦗AT⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗AT⦘) ⨾ ⦗NInit⦘).
  { rewrite (no_sb_to_init G) at 1. rewrite (no_sb_to_init G) at 3.
    rewrite (no_rf_to_init WF) at 1.
    rewrite seqA. rewrite seq_eqvC.
    rewrite <- !seqA. do 2 rewrite <- seq_union_l.
    hahn_frame. basic_solver. }

  rewrite acyclic_rotl, seq_union_r.
  arewrite (AT ⊆₁ RW ∩₁ AT).
  { apply set_subset_inter_r. split; auto. generalize RWMODE. basic_solver. }
  arewrite (⦗NInit⦘ ⨾ ⦗RW ∩₁ AT⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗RW ∩₁ AT⦘ ⊆ ⦗RW ∩₁ AT⦘ ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sb ⨾ eco ⨾ sb ⨾ ⦗F ∩₁ Sc⦘ ⨾ sb).
  { seq_rewrite <- id_inter. rewrite set_interC.
    rewrite (wf_ecoD WF), !seqA.
    rewrite no_sb_to_init at 2. rewrite seqA, <- id_inter. rewrite (set_interC NInit _).
    rewrite (sb_f_helper sb_f_at). rewrite inclusion_seq_eqv_r.
    do 5 hahn_frame_r.
    assert (ninit': (RW ∩₁ AT ∩₁ NInit) ∩₁ is_init ≡₁ ∅) by basic_solver.
    sin_rewrite (f_sb_helper f_sb_at ninit').
    hahn_frame. basic_solver. }
  do 2 rewrite inclusion_seq_eqv_l.
  red.
  assert (ct_spec: forall (x y z: relation actid), (x ∪ y ∪ x ⨾ z ⨾ x)⁺ ⊆ (x ∪ y ∪ z)⁺).
  { intros x y z.
    assert (inclusion_ext: x ∪ y ∪ x ⨾ z ⨾ x ⊆ (x ∪ y ∪ z)⁺).
    { apply inclusion_union_l.
      { rewrite <- ct_step. basic_solver. }
      do 2 rewrite <- ct_unit.
      rewrite <- seqA.
      apply seq_mori; [| basic_solver]. apply seq_mori; [| basic_solver].
      rewrite <- ct_step. basic_solver. }
    apply inclusion_t_ind_right; [apply inclusion_ext| ].
    rewrite <- ct_ct with (r:=(x ∪ y ∪ z)) at 2.
    apply seq_mori; [basic_solver | apply inclusion_ext]. }
  do 4 rewrite <- seqA with (r3:=sb).
  rewrite ct_spec.
  apply -> ac_irr. apply ldrf_condition_ext.
Qed.

End LDRF_Fsc.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P D0 D1 A0 D A0prime D0prime Pprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P D0 /\ (wd_ A A0 /\ (wd_ B A0 /\ (wd_ D0 A0 /\ (wd_ D D0 /\ (wd_ B D1 /\ (wd_ A D1 /\ (wd_ D0 D0prime /\ (wd_ D D0prime /\ (wd_ D A0 /\ (wd_ A0 A0prime /\ (wd_ D A0prime /\ (wd_ P A0 /\ (wd_ D0 D1 /\ (wd_ P D /\ (wd_ P Pprime /\ (wd_ D Pprime /\ (col_ A B D0 /\ (col_ A B A0 /\ (col_ D0 D1 D /\ (col_ P D D0 /\ (col_ D P Pprime /\ (col_ D D0 D0prime /\ col_ D A0 A0prime)))))))))))))))))))))))))) -> col_ D1 P D0)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import msl.Coqlib2.
Require Import msl.eq_dec.
Require Import msl.seplog.
Require Import veric.compcert_rmaps.
Require Import veric.tycontext.
Require Import veric.res_predicates.
Require Import concurrency.lksize.
Require Import concurrency.addressFiniteMap.

Set Bullet Behavior "Strict Subproofs".

(* Those were overwritten in structured_injections *)
Notation join := sepalg.join.
Notation join_assoc := sepalg.join_assoc.

Definition islock_pred (R: pred rmap) r := exists sh sh' z, r = YES sh sh' (LK z) (SomeP rmaps.Mpred (fun _ => R)).

Lemma islock_pred_join_sub {r1 r2 R} : join_sub r1 r2 -> islock_pred R r1  -> islock_pred R r2.
Proof.
  intros [r0 J] [x [sh' [z ->]]].
  inversion J; subst; eexists; eauto.
Qed.

Definition LKspec_ext (R: pred rmap) : spec :=
   fun (rsh sh: Share.t) (l: AV.address)  =>
     allp
       (jam
          (adr_range_dec l LKSIZE)
          (jam (eq_dec l)
               (yesat (SomeP rmaps.Mpred (fun _ => R)) (LK LKSIZE) rsh sh)
               (CTat l rsh sh))
          (fun _ => TT)).

Definition LK_at R sh :=
  LKspec_ext R (Share.unrel Share.Lsh sh) (Share.unrel Share.Rsh sh).

(* We used LK_at in lock_coherence before, but we it requires that all
the LK, CT, ... have the same share, which might not be true. The
following definition has the same structure as rmap_makelock in
rmap_locking *)

Definition pack_res_inv (R: pred rmap) := SomeP rmaps.Mpred (fun _ => R).

Definition lkat (R : mpred) loc phi :=
  (forall x,
      adr_range loc LKSIZE x ->
      exists sh rsh,
        phi @ x =
        if eq_dec x loc then
          YES sh rsh (LK LKSIZE) (pack_res_inv (approx (level phi) R))
        else
          YES sh rsh (CT (snd x - snd loc)) NoneP).

Definition isLK (r : resource) := exists sh sh' z P, r = YES sh sh' (LK z) P.

Definition isCT (r : resource) := exists sh sh' z P, r = YES sh sh' (CT z) P.

Definition resource_is_lock r := exists rsh sh n pp, r = YES rsh sh (LK n) pp.

Definition same_locks phi1 phi2 :=
  forall loc, resource_is_lock (phi1 @ loc) <-> resource_is_lock (phi2 @ loc).

Definition resource_is_lock_sized n r := exists rsh sh pp, r = YES rsh sh (LK n) pp.

Definition same_locks_sized phi1 phi2 :=
  forall loc n, resource_is_lock_sized n (phi1 @ loc) <-> resource_is_lock_sized n (phi2 @ loc).

Definition lockSet_block_bound lset b :=
  forall loc, isSome (AMap.find (elt:=option rmap) loc lset) -> (fst loc < b)%positive.

Definition predat phi loc (R: pred rmap) :=
  exists sh sh' z, phi @ loc = YES sh sh' (LK z) (SomeP rmaps.Mpred (fun _ => R)).

Definition rmap_bound b phi :=
  (forall loc, (fst loc >= b)%positive -> phi @ loc = NO Share.bot).

(* Constructive version of resource_decay (equivalent to the
non-constructive version, see resource_decay_join.v) *)
Definition resource_decay_aux (nextb: block) (phi1 phi2: rmap) : Type :=
  prod (level phi1 >= level phi2)%nat
  (forall l: address,

  ((fst l >= nextb)%positive -> phi1 @ l = NO Share.bot) *
  ( (resource_fmap (approx (level phi2)) (approx (level phi2)) (phi1 @ l) = (phi2 @ l))

  + { rsh : _ & { v : _ & { v' : _ |
       resource_fmap (approx (level phi2)) (approx (level phi2)) (phi1 @ l) = YES rsh pfullshare (VAL v) NoneP /\
       phi2 @ l = YES rsh pfullshare (VAL v') NoneP }}}

  + (fst l >= nextb)%positive * { v | phi2 @ l = YES Share.top pfullshare (VAL v) NoneP }

  + { v : _ & { pp : _ | phi1 @ l = YES Share.top pfullshare (VAL v) pp /\ phi2 @ l = NO Share.bot } })).

Ltac breakhyps :=
  repeat
    match goal with
      H : _ \/ _  |- _ => destruct H
    | H : _ /\ _  |- _ => destruct H
    | H : prod _ _  |- _ => destruct H
    | H : sum _ _  |- _ => destruct H
    | H : sumbool _ _  |- _ => destruct H
    | H : sumor _ _  |- _ => destruct H
    | H : ex _  |- _ => destruct H
    | H : sig _  |- _ => destruct H
    | H : sigT _  |- _ => destruct H
    | H : sigT2 _  |- _ => destruct H
    end;
  discriminate || congruence || tauto || auto.

Ltac check_false P :=
  let F := fresh "false" in
  assert (F : P -> False) by (intro; breakhyps);
  clear F.

Ltac sumsimpl :=
  match goal with
    |- sum ?A ?B => check_false A; right
  | |- sum ?A ?B => check_false B; left
  | |- sumor ?A ?B => check_false A; right
  | |- sumor ?A ?B => check_false B; left
  | |- sumbool ?A ?B => check_false A; right
  | |- sumbool ?A ?B => check_false B; left
  end.

Definition resource_decay_at (nextb: block) n (r1 r2 : resource) b :=
  ((b >= nextb)%positive -> r1 = NO Share.bot) /\
  (resource_fmap (approx (n)) (approx (n)) (r1) = (r2) \/
  (exists rsh, exists v, exists v',
       resource_fmap (approx (n)) (approx (n)) (r1) = YES rsh pfullshare (VAL v) NoneP /\
       r2 = YES rsh pfullshare (VAL v') NoneP)
  \/ ((b >= nextb)%positive /\ exists v, r2 = YES Share.top pfullshare (VAL v) NoneP)
  \/ (exists v, exists pp, r1 = YES Share.top pfullshare (VAL v) pp /\ r2 = NO Share.bot)).

Ltac range_tac :=
  match goal with
  | H : ~ adr_range (?b, _) _ (?b, _) |- _ =>
    exfalso; apply H;
    repeat split; auto;
    try unfold Int.unsigned;
    unfold LKSIZE;
    omega
  | H : ~ adr_range ?l _ ?l |- _ =>
    destruct l;
    exfalso; apply H;
    repeat split; auto;
    try unfold Int.unsigned;
    unfold LKSIZE;
    omega
  end.

Ltac eassert :=
  let mp := fresh "mp" in
  pose (mp := fun {goal Q : Type} (x : goal) (y : goal -> Q) => y x);
  eapply mp; clear mp.


(*******************************************************************
 * Este archivo especifica las acciones
 * (Como transformadores de estado)
 ******************************************************************)

Load State.

(* Contexto global *)
Parameter contexto : context.

(********************** Predicados útiles ******************************)
Definition trusted_os (o : os_ident) : Prop :=
  contexto.(ctxt_oss) o = true.

(* Esto es que la current page table del so mapee la va con ma. *)
Definition va_mapped_to_ma (s : State) (v: vadd) (m : madd) : Prop :=
  exists osi : os, s.(oss) s.(active_os) = Some osi
  /\ exists p_to_m : padd -> option madd,
     s.(hypervisor) s.(active_os) = Some p_to_m
  /\ exists m2 : madd, p_to_m osi.(curr_page) = Some m2
  /\ exists pg : page, s.(memory) m2 = Some pg
  /\ exists v_to_m : vadd -> option madd,
     pg.(page_content) = (PT v_to_m)
  /\ v_to_m v = Some m.

Definition os_accessible (va : vadd) : Prop :=
  contexto.(ctxt_vadd_accessible) va = true.

Definition change_function (X Y : Set) (F : X -> option Y)
                           (G : forall m n : X, {m = n} + {m <> n})
                           (x:X) (y:Y) : X -> option Y :=
  fun (a : X) => if G a x then Some y
                          else F a.

Implicit Arguments change_function [X Y].

(*************** Acciones ***********************)
Inductive Action :=
| read : vadd -> Action
| write : vadd -> value -> Action
| chmod : Action.

(************** Pre y Post **********************)
Inductive Pre : State -> Action -> Prop :=
  PreRead : forall (s : State) (va : vadd),
            os_accessible va ->
            s.(aos_activity) = running
            -> (exists ma : madd, va_mapped_to_ma s va ma
                /\ exists pg : page, (s.(memory)) ma = Some pg
                /\ is_RW pg.(page_content))
            ->  Pre s (read va)
| PreWrite : forall (s : State) (va : vadd) (val : value),
            os_accessible va
            ->  s.(aos_activity) = running
            -> (exists ma : madd, va_mapped_to_ma s va ma
            /\ exists pg : page, (s.(memory)) ma = Some pg
            /\ is_RW pg.(page_content))
            ->  Pre s (write va val)
| PreChmod : forall (s : State) (va : vadd),
             s.(aos_activity) = waiting
             -> (exists o:os, s.(oss) s.(active_os) = Some o
                 /\ o.(hcall) = None)
             -> Pre s (chmod).

Inductive Post : State -> Action -> State -> Prop :=
  PostRead : forall (s : State) (va : vadd),
             Post s (read va) s
| PostWrite : forall (s s2 : State) (va : vadd) (val : value),
              (exists ma : madd, va_mapped_to_ma s va ma
              /\ s2.(memory) =
              change_function (s.(memory)) madd_eq ma (Page (RW (Some val)) (Os (s.(active_os))))
              /\ differ_memory s ma s2)
              -> Post s (write va val) s2
| PostChmod : forall (s s2 : State),
              (trusted_os (s.(active_os))
                /\ s2 = St s.(active_os) svc running s.(oss) s.(hypervisor) s.(memory))
              \/ (~trusted_os (s.(active_os))
                /\ s2 = St s.(active_os) usr running s.(oss) s.(hypervisor) s.(memory))
              -> Post s chmod s2.

(************************* Valid State ******************************)
Definition valid_state_3 (s: State) : Prop :=
  ((s.(aos_activity) = running /\ trusted_os s.(active_os))
  \/ s.(aos_activity) = waiting)
  -> s.(aos_exec_mode) = svc.

Definition valid_state_5 (s : State) : Prop :=
  forall (pa : padd) (osi : os_ident) (p_to_m : padd -> option madd),
          Some p_to_m = s.(hypervisor) osi
          -> exists ma : madd, p_to_m pa = Some ma
             /\ (exists pag : page, s.(memory) ma = Some pag
             /\ pag.(page_owned_by) = Os osi)
             /\ (forall pa2 : padd, pa <> pa2
                -> exists ma2 : madd, p_to_m pa2 = Some ma2
                /\ ma <> ma2).

Definition valid_state_6 (s : State) : Prop :=
  forall (p : page) (osi : os_ident) (v_to_m : vadd -> option madd),
           p.(page_owned_by) = Os osi
           -> p.(page_content) = PT v_to_m
           -> (exists ma : madd,
              s.(memory) ma = Some p)
           -> forall va: vadd, (os_accessible va ->
                                   (exists ma1 : madd, v_to_m va = Some ma1
                                 /\ exists pg1 : page, s.(memory) ma1 = Some pg1
                                 /\ pg1.(page_owned_by) = Os osi))
                            /\ (~os_accessible va ->
                                    (exists ma1 : madd, v_to_m va = Some ma1
                                  /\ exists pg1 : page, s.(memory) ma1 = Some pg1
                                  /\ pg1.(page_owned_by) = Hyp)).

Inductive valid_state : State -> Prop :=
  v_st : forall (s: State),
         valid_state_3 s
         -> valid_state_5 s
         -> valid_state_6 s
         -> valid_state s.

Inductive OneStepExec : State -> Action -> State -> Prop :=
  OneStepExec_intro : forall (s s2 : State) (a : Action),
                      valid_state s
                      -> Pre s a
                      -> Post s a s2
                      -> OneStepExec s a s2.

(* Ej. 7.6 *)
Lemma valid_state_3_invariant : forall (s s2 : State) (a : Action),
              OneStepExec s a s2
              -> valid_state_3 s2.
Proof.
  intros.
  inversion_clear H.
  inversion_clear H0.
  destruct a.
    inversion H2.
    rewrite <- H5.
    assumption.

    inversion_clear H2.
    inversion_clear H0.
    inversion_clear H2.
    inversion_clear H5.
    inversion_clear H6.
    unfold valid_state_3 in *.
    rewrite H8.
    rewrite H5.
    rewrite H7.
    assumption.

    inversion_clear H2.
    unfold valid_state_3 in *.
    inversion_clear H0;
    inversion_clear H2;
    inversion_clear H5;
    simpl;
    intro.
      reflexivity.

      inversion_clear H2.
        inversion_clear H5.
        elim H0.
        assumption.

        discriminate.
Qed.

(* Ej. 7.7 *)
Lemma Read_Isolation : forall (s1 s2 : State) (va : vadd),
                       OneStepExec s1 (read va) s2
                       -> exists ma : madd, va_mapped_to_ma s1 va ma
                       /\ exists pg : page, Some pg = s1.(memory) ma
                       /\ pg.(page_owned_by) = Os s1.(active_os).
Proof.
  intros.
  inversion_clear H.
  inversion_clear H0.
  inversion_clear H1.
  inversion_clear H6.
  exists x.
  inversion_clear H1.
  split.
    assumption.

    (* Paso 1 *)
    clear H7.
    inversion_clear H6.
    inversion_clear H1.
    inversion_clear H7.
    inversion_clear H1.
    inversion_clear H8.
    inversion_clear H1.
    inversion_clear H9.
    inversion_clear H1.
    inversion_clear H10.
    inversion_clear H1.

    (* Paso 2 *)
    unfold valid_state_5 in *.
    pose proof (H3 x0.(curr_page) s1.(active_os) x1). clear H3.
    symmetry in H7.
    pose proof (H1 H7). clear H1.
    inversion_clear H3.
    inversion_clear H1.
    inversion_clear H12. clear H13.
    inversion_clear H1.
    inversion_clear H12.
    rewrite H8 in H3.
    inversion H3. clear H3.
    rewrite <- H14 in H1. clear H14 x5.
    rewrite H9 in H1.
    inversion H1. clear H1.
    rewrite <- H12 in H13. clear H12 x6.

    (* Paso 3 *)
    unfold valid_state_6 in *.
    pose proof (H4 x3 s1.(active_os) x4). clear H4.
    assert (exists ma: madd, memory s1 ma = Some x3).
    exists x2. assumption.
    pose proof (H1 H13 H10 H3 va). clear H1 H13 H10 H3.
    inversion_clear H4. clear H3.
    pose proof (H1 H0). clear H1 H0.
    inversion_clear H3.
    inversion_clear H0.
    inversion_clear H3.
    inversion_clear H0.
    rewrite H11 in H1.
    inversion H1. clear H1.
    rewrite <- H10 in *.
    exists x6.
    symmetry in H3.
    split; assumption.
Qed.


Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

Module Type Kit.

  Parameter TM: Type.
  Parameter inst_vr: Vr TM.
  Parameter inst_ap: ∀ Y {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y TM}, Ap TM Y.

  Parameter inst_ap_inj: LemApInj TM Ix.
  Parameter inst_ap_vr:
    ∀ Y {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y TM}, LemApVr TM Y.
  Parameter inst_ap_comp:
    ∀ Y Z {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y TM} {vrZ: Vr Z} {wkZ: Wk Z}
      {liftZ: Lift Z TM} {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
      {apLiftYZTM: LemApLift Y Z TM}, LemApComp TM Y Z.
  Parameter inst_ap_liftSub:
    ∀ Y {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y TM}, LemApLiftSub TM Y.
  Parameter inst_ap_ixComp:
    ∀ (t: TM) (ξ: Sub Ix) (ζ: Sub TM), t[ξ][ζ] = t[⌈ξ⌉ >=> ζ].

End Kit.

Module Inst (kit: Kit).

  Local Ltac crush :=
    intros; cbn in * |-;
    repeat
      (cbn;
       repeat crushDbSyntaxMatchH;
       rewrite ?ap_vr, ?ap_comp);
    auto.

  Import kit.

  Instance inst_apTMZTM {Z} {vrZ: Vr Z} {apTMZ: Ap TM Z} :
    LemApLift TM Z TM := λ _ _, eq_refl.
  Instance inst_apLiftIxIx: LemApLift Ix Ix TM := ap_vr.

  Instance compUpTMIx: LemCompUp TM Ix := {}.
  Proof. intros; extensionality i; destruct i; crush. Qed.

  Instance inst_wkApIx: LemApWk TM Ix := λ _, eq_refl.

  Instance compUpTM: LemCompUp TM TM := {}.
  Proof.
    intros; extensionality i; destruct i; crush.
    rewrite inst_ap_ixComp; f_equal.
    extensionality j; destruct j; crush.
  Qed.

  Instance wkApTM: LemApWk TM TM := {}.
  Proof.
    crush.
    rewrite  <- ap_liftSub.
    f_equal.
    extensionality i; crush.
  Qed.

  (* Instance sbTM: Subst TM := {}. *)

  (* Automatically populate the infrastructure database for type TM with lemmas
     for which the rewrite direction is certain. *)
  (* Hint Rewrite (apply_wkm_comm TM Ix) : infrastructure. *)
  (* Hint Rewrite (apply_wkm_beta1_cancel TM TM) : infrastructure. *)
  (* Hint Rewrite (apply_beta1_comm TM TM) : infrastructure. *)

  (* Hint Rewrite (apply_wkm_up_comm TM Ix) : infrastructure. *)
  (* Hint Rewrite (apply_wkm_beta1_up_cancel TM TM) : infrastructure. *)
  (* Hint Rewrite (apply_beta1_up_comm TM TM) : infrastructure. *)

  (* Hint Rewrite (apply_wkm_up2_comm TM Ix) : infrastructure. *)
  (* Hint Rewrite (apply_wkm_beta1_up2_cancel TM TM) : infrastructure. *)
  (* Hint Rewrite (apply_beta1_up2_comm TM TM) : infrastructure. *)

  (* Hint Rewrite (apply_wkm_ups_comm TM Ix) : infrastructure. *)
  (* Hint Rewrite (apply_wkm_beta1_ups_cancel TM TM) : infrastructure. *)
  (* Hint Rewrite (apply_beta1_ups_comm TM TM) : infrastructure. *)

  (* Hint Rewrite (ap_liftSub' TM TM) : infrastructure. *)
  (* Hint Rewrite (up_liftSub TM) : infrastructure. *)
  (* Hint Rewrite (liftSub_wkm TM) : infrastructure. *)
  (* Hint Rewrite (liftSub_wkms TM) : infrastructure. *)

  (* Hint Rewrite (up_wk TM) : infrastructure. *)
  (* Hint Rewrite (wk_ap TM) : infrastructure. *)

  (* Set Printing  Implicit. *)
  (* Unset Printing Notations. *)
  (* Print Rewrite HintDb infrastructure. *)

End Inst.


Require Import Equations.Equations.
Require Import Equations.Prop.Subterm. (* lexicographic ordering *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import PeanoNat.
Require Import Psatz. (* lia tactic for linear integer arithmetic *)

Require Export Parser.HList.
Require Export Parser.Lexicographic.
Require Export Parser.Option.

Record Cell: Type := mkCell {
  (** when building networks from syntaxes, we use the field `main_type` to
      store the type of the syntax node corresponding to this cell *)
  main_type: Type;
  cell_type: Type;
  input_types: list Type;
  update: hlist input_types -> cell_type;
  measure: cell_type -> nat;
  state: cell_type;
}.

Arguments mkCell main_type { cell_type } { input_types }.

Record Network: Type := mkNetwork {
  cells: nat -> Cell;
  inputs: nat -> list nat;
  registered: nat -> list nat;
}.

Definition set_cell (N: Network) (k: nat) (cell: Cell): Network := {|
  cells := fun k' => if Nat.eq_dec k k' then cell else cells N k';
  inputs := inputs N;
  registered := registered N;
|}.

Definition io_types (N: Network): Prop :=
  forall k, map (fun k' => cell_type (cells N k')) (inputs N k) = input_types (cells N k).

Definition io_types_instantiate:
  forall N k,
    io_types N ->
    map (fun k' => cell_type (cells N k')) (inputs N k) = input_types (cells N k).
Proof.
  unfold io_types; lights.
Qed.

Ltac io_types_instantiate :=
  match goal with
  | H: io_types ?N, k: nat |- _ =>
    poseNew (Mark (k, N) "io_types_instantiate");
    pose proof (io_types_instantiate N k H)
  end.

Definition max_pointer (num_cells: nat) (N: Network): Prop :=
  forall k,
    k < num_cells ->
    forall k', In k' (registered N k) -> k' < num_cells.

Ltac rewrite_cell :=
  match goal with
  | H: cells _ _ = mkCell _ _ _ |- _ => rewrite H in *
  end.

Definition io_types_set_cell:
  forall N k cell,
    io_types N ->
    input_types (cells N k) = input_types cell ->
    cell_type (cells N k) = cell_type cell ->
    io_types (set_cell N k cell).
Proof.
  unfold set_cell;
    repeat match goal with
    | H: map _ _ = input_types _ |- _ => rewrite <- H in *
    | _ => light || unfold io_types || io_types_instantiate || destruct_match || apply map_ext
    end.
Qed.

Definition set_cell_with_inputs (N: Network) (k: nat) (cell: Cell) (ks: list nat): Network := {|
  cells := fun k' => if Nat.eq_dec k k' then cell else cells N k';
  inputs := fun k' => if Nat.eq_dec k k' then ks else inputs N k';
  registered := fun k' => if in_dec Nat.eq_dec k' ks then k :: registered N k' else registered N k';
|}.

Definition io_types_set_cell_with_inputs:
  forall N k cell ks,
    io_types N ->
    ~ In k ks ->
    (forall k', ~ In k (inputs N k')) ->
    map (fun k' => cell_type (cells N k')) ks = input_types cell ->
    io_types (set_cell_with_inputs N k cell ks).
Proof.
  unfold set_cell_with_inputs;
    repeat match goal with
    | H: map _ _ = input_types _ |- _ => rewrite <- H in *
    | _ => light || unfold io_types || io_types_instantiate || destruct_match || apply map_ext_in
    end;
    eauto with exfalso.
Qed.

Lemma max_pointer_set_cell:
  forall N k cell num_cells,
    max_pointer num_cells N ->
    max_pointer num_cells (set_cell N k cell).
Proof.
  unfold max_pointer; lights.
Qed.

Definition get_measure (cell: Cell): nat := measure cell (state cell).

Fixpoint sum_measures (num_cells: nat) (N: Network): nat :=
  match num_cells return nat with
  | 0 => 0
  | S k => sum_measures k N + get_measure (cells N k)
  end.

(* Update the state of cell `k`. Returns `None` if there is nothing to do *)
Program Definition compute_cell (N: Network) (k: nat) (pre: io_types N): option Network :=
  let cell: Cell := cells N k in
  let inputs: hlist (input_types cell) :=
    h_map (fun k' => state (cells N k')) (inputs N k) in
  let q': cell_type cell := update cell inputs in
  if (Compare_dec.lt_dec (measure cell q') (measure cell (state cell)))
  then Some (set_cell N k (mkCell (main_type cell) (update cell) (measure cell) q'))
  else None.

Fail Next Obligation. (* no more obligations for compute_cell *)

Lemma io_types_compute_cell:
  forall N k pre N',
    compute_cell N k pre = Some N' ->
    io_types N ->
    io_types N'.
Proof.
  unfold compute_cell;
    repeat light || destruct_match || apply io_types_set_cell || invert_constructor_equalities.
Qed.

Opaque io_types.

Lemma max_pointer_compute_cell:
  forall num_cells N k pre N',
    compute_cell N k pre = Some N' ->
    max_pointer num_cells N ->
    max_pointer num_cells N'.
Proof.
  unfold compute_cell;
    repeat light || destruct_match || invert_constructor_equalities.
Qed.

Lemma set_cell_different:
  forall N k k' cell,
    k <> k' ->
    cells (set_cell N k cell) k' = cells N k'.
Proof.
  unfold set_cell;
    repeat light || destruct_match.
Qed.

Lemma set_cell_same:
  forall N k cell,
    cells (set_cell N k cell) k = cell.
Proof.
  unfold set_cell;
    repeat light || destruct_match.
Qed.

Lemma sum_measure_set_cell_1:
  forall (num_cells: nat) (N: Network) (k: nat) cell,
    k >= num_cells ->
    sum_measures num_cells (set_cell N k cell) = sum_measures num_cells N.
Proof.
  induction num_cells; repeat light || destruct_match; eauto with lia.
Qed.

Opaque set_cell.

Lemma sum_measure_set_cell_2:
  forall (num_cells: nat) (N: Network) (k: nat) (cell: Cell),
    k < num_cells ->
    get_measure cell < get_measure (cells N k) ->
    sum_measures num_cells (set_cell N k cell) < sum_measures num_cells N.
Proof.
  induction num_cells; lights; eauto with lia.
  destruct (Nat.eq_dec k num_cells); lights.

  - rewrite sum_measure_set_cell_1; lights; eauto with lia.
    apply Nat.add_lt_mono_l.
    rewrite set_cell_same; auto.

  - rewrite set_cell_different; lights.
    apply Nat.add_lt_mono_r.
    eauto with lia.
Qed.

Lemma compute_cell_size:
  forall num_cells N k pre N',
    compute_cell N k pre = Some N' ->
    k < num_cells ->
    sum_measures num_cells N' < sum_measures num_cells N.
Proof.
  unfold compute_cell;
    repeat light || destruct_match || apply sum_measure_set_cell_2 || invert_constructor_equalities.
Qed.

Equations (noind) compute_cells (num_cells: nat) (N: Network) (ks: list nat)
  (pre:
     io_types N /\
     max_pointer num_cells N /\
     (forall k, In k ks -> k < num_cells)
  ): Network
  by wf (sum_measures num_cells N, length ks) lt_lex :=

  compute_cells num_cells N [] _ := N;
  compute_cells num_cells N (k :: ks) _ :=
    let opt := compute_cell N k _ in
    if (is_some_dec opt)
    then compute_cells num_cells (get_option opt _) (ks ++ registered N k) _
    else compute_cells num_cells N ks _.

Next Obligation.
  repeat light || lists || options || destruct_match;
    eauto using max_pointer_compute_cell;
    eauto using io_types_compute_cell.
Qed.

Next Obligation.
  apply left_lex;
    repeat light || options || destruct_match;
    eauto using compute_cell_size.
Qed.

Next Obligation.
  apply right_lex; auto.
Qed.

Fail Next Obligation. (* No more obligations for compute_cells *)

Ltac compute_cells_def :=
  rewrite compute_cells_equation_1 in * ||
  rewrite compute_cells_equation_2 in *.

Ltac rewrite_known_states :=
  match goal with
  | H1: state _ = eq_rect _ _ (_, ?opt) _ _,
    H2: opt_forall ?opt _ |- _ =>
    rewrite H1
  end.

Ltac rewrite_known_cell_types :=
  match goal with
  | H: cell_type _ = _ |- _ => rewrite H in *
  end.

Ltac rewrite_known_updates :=
  match goal with
  | H: update _ = _ |- _ => rewrite H in *
  end.

Ltac rewrite_known_inputs2 :=
  match goal with
  | H:inputs _ _ = [] |- _ => rewrite H in *
  | H:inputs _ _ = _ :: _ |- _ => rewrite H in *
  end.

Ltac rewrite_known_states2 :=
  match goal with
  | H: state _ = _ |- _ => rewrite H in *
  end.

Ltac rewrite_known_inputs :=
  match goal with
  | H: inputs _ _ = [] |- _ => rewrite H in *; clear H
  | H: inputs _ _ = _ :: _ |- _ => rewrite H in *; clear H
  end.

Ltac rewrite_known_cells :=
  match goal with
  | H: cells _ _ = _ |- _ => rewrite H in *; clear H
  end.

Ltac rewrite_known_input_types :=
  match goal with
  | H: input_types _ = _ |- _ => rewrite H in *
  end.

Ltac rewrite_known_measures :=
  match goal with
  | H: measure _ = _ |- _ => rewrite H in *
  end.


From stdpp Require Import gmap.
From cap_machine Require Import stdpp_extra.
From iris.proofmode Require Import proofmode.
From Equations Require Import Equations.

Section simpl_gmap.

  Variable K: Type.
  Hypothesis HeqdecK: EqDecision K.
  Hypothesis HcountK: Countable K.

  (* reified gmap *)
  Inductive rgmap {A: Type}: Type :=
  | Ins (k: nat) (a: A) (m: rgmap)
  | Del (k: nat) (m: rgmap)
  | Symb.

  Fixpoint denote {A: Type} (rm: @rgmap A) (fm: nat -> option K) (m: gmap K A): gmap K A :=
    match rm with
    | Ins k a rm =>
      match fm k with
      | Some k => <[k := a]> (denote rm fm m)
      | None => denote rm fm m
      end
    | Del k rm =>
      match fm k with
      | Some k => delete k (denote rm fm m)
      | None => denote rm fm m
      end
    | Symb => m
    end.

  Fixpoint rlength {A: Type} (rm: @rgmap A): nat :=
    match rm with
    | Ins _ _ rm => S (rlength rm)
    | Del _ rm => S (rlength rm)
    | Symb => O
    end.

  Fixpoint remove_key {A: Type} k (rm: @rgmap A) :=
    match rm with
    | Ins k' a rm => if decide (k = k') then remove_key k rm else Ins k' a (remove_key k rm)
    | Del k' rm => if decide (k = k') then remove_key k rm else Del k' (remove_key k rm)
    | Symb => Symb
    end.

  Lemma rlength_remove_key:
    forall A k (rm: @rgmap A), rlength (remove_key k rm) <= rlength rm.
  Proof.
    induction rm; simpl; auto.
    - destruct (decide (k = k0)); simpl; lia.
    - destruct (decide (k = k0)); simpl; lia.
  Qed.

  Equations simpl_rmap {A: Type} (rm: @rgmap A): @rgmap A by wf (rlength rm) lt :=
    simpl_rmap (Ins k a rm) := Ins k a (simpl_rmap (remove_key k rm));
    simpl_rmap (Del k rm) := Del k (simpl_rmap (remove_key k rm));
    simpl_rmap (Symb) := Symb.
  Next Obligation.
    generalize (rlength_remove_key _ k rm). lia. Qed.
  Next Obligation.
    generalize (rlength_remove_key _ k rm). lia. Qed.

  Lemma denote_remove_key_ins:
    forall A fm (rm: @rgmap A) k k' a (m: gmap K A),
      fm k = Some k' ->
      <[k':=a]> (denote rm fm m) = <[k':=a]> (denote (remove_key k rm) fm m).
  Proof.
    induction rm; simpl; auto.
    - intros. destruct (decide (k0 = k)).
      + subst k0. rewrite H.
        rewrite insert_insert.
        eapply IHrm; eauto.
      + case_eq (fm k); intros.
        * cbn. destruct (decide (k1 = k')).
          { subst k1. rewrite insert_insert H0.
            rewrite insert_insert.
            eapply IHrm. auto.
          }
          { simpl. rewrite insert_commute; auto.
            rewrite H0.
            erewrite IHrm; eauto.
            rewrite insert_commute; eauto. }
        * simpl. rewrite H0. eauto.
    - intros. destruct (decide (k0 = k)).
      + subst k0; rewrite H. rewrite insert_delete_insert. eapply IHrm; eauto.
      + simpl. case_eq (fm k); intros.
        * destruct (decide (k1 = k')).
          { subst k1. rewrite !insert_delete_insert.
            eapply IHrm; eauto. }
          { erewrite <- delete_insert_ne; auto.
            erewrite IHrm, delete_insert_ne; eauto. }
        * eauto.
  Qed.

  Lemma denote_remove_key_del:
    forall A fm (rm: @rgmap A) k k' (m: gmap K A),
      fm k = Some k' ->
      delete k' (denote rm fm m) = delete k' (denote (remove_key k rm) fm m).
  Proof.
    induction rm; simpl; auto.
    - intros. destruct (decide (k0 = k)).
      + subst k0. rewrite H. rewrite delete_insert_delete. eauto.
      + simpl. case_eq (fm k); intros.
        * destruct (decide (k1 = k')).
          { subst k1. rewrite !delete_insert_delete.
            eapply IHrm; eauto. }
          { rewrite delete_insert_ne; auto.
            erewrite IHrm, <- delete_insert_ne; eauto. }
        * eauto.
    - intros. destruct (decide (k0 = k)).
      + subst k0; rewrite H delete_idemp. eauto.
      + simpl. case_eq (fm k); intros.
        * destruct (decide (k1 = k')).
          { subst k1. rewrite !delete_idemp.
            eapply IHrm; eauto. }
          { rewrite delete_commute; auto.
            erewrite IHrm, delete_commute; eauto. }
        * eauto.
  Qed.

  Lemma denote_remove_key_none:
    forall A fm (rm: @rgmap A) k (m: gmap K A),
      fm k = None ->
      denote rm fm m = denote (remove_key k rm) fm m.
  Proof.
    induction rm; simpl; auto.
    - intros. destruct (decide (k0 = k)).
      + subst k0. rewrite H. auto.
      + simpl. destruct (fm k); auto.
        erewrite IHrm; eauto.
    - intros. destruct (decide (k0 = k)).
      + subst k0. rewrite H. auto.
      + simpl. destruct (fm k); auto.
        erewrite IHrm; eauto.
  Qed.

  Lemma simpl_rmap_correct':
    forall A fm n (rm: @rgmap A) (m: gmap K A),
      rlength rm <= n ->
      denote rm fm m = denote (simpl_rmap rm) fm m.
  Proof.
    induction n; intros.
    - destruct rm; simpl in H; try lia.
      reflexivity.
    - destruct rm; [| | reflexivity].
      + rewrite simpl_rmap_equation_1; simpl.
        rewrite <- (IHn (remove_key k rm)).
        * case_eq (fm k); intros.
          { apply denote_remove_key_ins; auto. }
          { apply denote_remove_key_none; auto. }
        * generalize (rlength_remove_key _ k rm). simpl in H; lia.
      + rewrite simpl_rmap_equation_2; simpl.
        rewrite <- (IHn (remove_key k rm)).
        * case_eq (fm k); intros.
          { apply denote_remove_key_del; auto. }
          { apply denote_remove_key_none; auto. }
        * generalize (rlength_remove_key _ k rm). simpl in H; lia.
  Qed.

  Lemma simpl_rmap_correct:
    forall A fm (rm rm': @rgmap A) (m: gmap K A),
      simpl_rmap rm = rm' ->
      denote rm fm m = denote rm' fm m.
  Proof.
    intros. subst rm'. apply (simpl_rmap_correct' _ fm (rlength rm)); auto; lia.
  Qed.

End simpl_gmap.

From Ltac2 Require Import Ltac2 Option Constr.

Ltac2 rec add_key (l: constr list) (k: constr) (n: constr) :=
  match l with
  | [] => (k::l, n)
  | c :: ll => match Constr.equal c k with
                | false => let (lll, nn) := add_key ll k '(S $n) in
                          ((c :: lll), nn)
                | _ => (l, n)
                end
  end.

Ltac2 rec make_list (l: constr list) :=
  match l with
  | [] => '[]
  | c :: ll => let k := make_list ll in
              '($c :: $k)
  end.

Ltac2 rec reify_helper kk aa term fm :=
  lazy_match! term with
  | <[?k := ?a]> ?m =>
    let (env, k') := add_key fm k 'O in
    let (rm, h, fm'') := reify_helper kk aa m env in
    (constr:(@Ins $aa $k' $a $rm), h, fm'')
  | delete ?k ?m =>
    let (env, k') := add_key fm k 'O in
    let (rm, h, fm'') := reify_helper kk aa m env in
    (constr:(@Del $aa $k' $rm), h, fm'')
  | ?m => (constr:(@Symb $aa), m, fm)
  end.

Local Ltac2 replace_with (lhs: constr) (rhs: constr) :=
  ltac1:(lhs rhs |- replace lhs with rhs) (Ltac1.of_constr lhs) (Ltac1.of_constr rhs).

(* Debug test *)
(* Goal <[5 := 2]> (<[5 := 2]> (<[5 := 2]> (<[5 := 2]> (<[5 := 2]> (<[5 := 2]> (<[5 := 2]> (<[6 := 3]> (∅: gmap nat nat)))))))) = <[5 := 2]> (<[6 := 3]> (∅: gmap nat nat)). *)
(*   lazy_match! goal with *)
(*   | [|- ?x = _] => let (x', m, fm) := reify_helper 'nat 'nat x [] in *)
(*                  let env := make_list fm in *)
(*                  replace_with x '(@denote _ _ _ _ $x' (fun n => @list_lookup _ n $env) $m) > [() | reflexivity]; *)
(*                  erewrite (@simpl_rmap_correct nat _ _ nat (fun n => @list_lookup _ n $env)) > [() | vm_compute; reflexivity] *)
(*   end. time (cbn [denote list_lookup lookup]). *)
(*   reflexivity. *)
(* Qed. *)

Ltac2 rec make_list_from_unions h x :=
  match! x with
  | union ?a (singleton ?b) =>
    ltac1:(h b |- try (rewrite (delete_notin _ b); [|simplify_map_eq; rewrite -not_elem_of_dom h; set_solver; fail])) (Ltac1.of_constr h) (Ltac1.of_constr b);
    make_list_from_unions h a
  | singleton ?x => ltac1:(h x |- try (rewrite (delete_notin _ x); [|simplify_map_eq; rewrite -not_elem_of_dom h; set_solver+; fail])) (Ltac1.of_constr h) (Ltac1.of_constr x)
  end.

Ltac2 post_process k m :=
  ltac1:(k m |- match goal with
               | [h : dom (gset k) m = _ ∖ ?x |- _ ] =>
                 let f := ltac2:(h x |- make_list_from_unions (Option.get (Ltac1.to_constr h)) (Option.get (Ltac1.to_constr x)))
                 in f h x
               | _ => idtac
               end) (Ltac1.of_constr k) (Ltac1.of_constr m).

(* vm_compute does not work here, as it does to much calculation, so we come up with a more refined way of simplifying `simpl_rmap` expressions *)

(* Clear all hypothesis that do not explicitly feature in the goal, to avoid incorrect substitutions later. *)
Local Ltac clear_all :=
  repeat (match goal with
        | H : _ |- _ => clear H end ).

Definition boxed {A} (P: A): A := P.
Theorem boxed_eq `(P : A): (boxed P) = P. Proof. auto. Qed.
Local Ltac box_all := repeat (match goal with
      |  |- context [Ins ?k ?v] => lazymatch v with
                                 | boxed _ => fail | _ => let name := fresh "name" in remember v as name in * at 1; rewrite -{1}(boxed_eq name) end end).

Ltac simpl_rmap_compute :=
  clear_all; box_all; vm_compute simpl_rmap; subst.

Ltac2 map_simpl_aux k a x encode :=
  let (x', m, fm) := (reify_helper k a x []) in
  let env := make_list fm in
  replace_with x '(@denote _ _ _ _ $x' (fun n => @list_lookup _ n $env) $m) > [() | reflexivity];
  (erewrite (@simpl_rmap_correct _ _ _ _ (fun n => @list_lookup _ n $env))) > [() | ltac1:(simpl_rmap_compute); reflexivity];
  cbn [denote list_lookup lookup];
  post_process k m.

Ltac2 map_simpl_aux_debug k a x encode :=
  let (x', m, fm) := (reify_helper k a x []) in
  let env := make_list fm in
  replace_with x '(@denote _ _ _ _ $x' (fun n => @list_lookup _ n $env) $m) > [() | reflexivity];
  (erewrite (@simpl_rmap_correct _ _ _ _ (fun n => @list_lookup _ n $env))) > [() | ltac1:(simpl_rmap_compute); reflexivity];
  time (cbn [denote list_lookup lookup]);
  time (post_process k m).

From iris.proofmode Require Import environments.

Set Default Proof Mode "Classic".

Ltac map_simpl name :=
  match goal with
  | |- context [ Esnoc _ (base.ident.INamed name) ([∗ map] _↦_ ∈ ?m, _)%I ] =>
    match type of m with

    | ?t => match eval compute in t with (* type will not compute for very large maps *)
      | gmap ?K ?A =>
        let f := ltac2:(k a m encode |- map_simpl_aux (Option.get (Ltac1.to_constr k)) (Option.get (Ltac1.to_constr a)) (Option.get (Ltac1.to_constr m)) (Option.get (Ltac1.to_constr encode))) in
        f K A m (@encode K _ _)
      end
    end
  end.

Ltac map_simpl_debug name :=
  match goal with
  | |- context [ Esnoc _ (base.ident.INamed name) ([∗ map] _↦_ ∈ ?m, _)%I ] =>
    match type of m with
    | gmap ?K ?A =>
      let f := ltac2:(k a m encode |- map_simpl_aux_debug (Option.get (Ltac1.to_constr k)) (Option.get (Ltac1.to_constr a)) (Option.get (Ltac1.to_constr m)) (Option.get (Ltac1.to_constr encode))) in
      f K A m (@encode K _ _)
    end
  end.

From iris.proofmode Require Import reduction proofmode.

Ltac disjunct_cases m i :=
  match m with
  | <[?k := _]> ?m' => destruct (decide (k = i)); disjunct_cases m' i
  | delete ?k ?m' => destruct (decide (k = i)); disjunct_cases m' i
  | _ => try subst i; try discriminate; simplify_map_eq; try reflexivity
  end.

Ltac solve_map_eq :=
  match goal with
  | |- ?m !! ?i = ?m' !! ?i => disjunct_cases m i
  end.

Ltac iFrameMapSolve' name :=
  lazymatch goal with
  | |- envs_entails ?H ([∗ map] _↦_ ∈ ?m, _)%I =>
    lazymatch pm_eval (envs_lookup name H) with
    | Some (_, ?X) =>
      lazymatch X with
      | ([∗ map] _↦_ ∈ ?m', _)%I =>
        match type of m' with
        | ?t => match eval compute in t with (* type will not compute for very large maps *)
          | gmap ?K ?A =>
            replace m' with m; [iFrame name| apply map_eq_iff; intros; solve_map_eq]
          end
        end
      | _ => idtac "The given hypothesis is not of the form ([∗ map] _↦_ ∈ _, _)"; idtac X
      end
    | _ => idtac "Can't find the given hypothesis"
    end
  | _ => idtac "The goal is not of the form ([∗ map] _↦_ ∈ _, _)"
  end.

Ltac iFrameMapSolve name :=
  map_simpl name; iFrameMapSolve' name.

Tactic Notation "iFrameMapSolve" "+" hyp_list(Hs) constr(name) := clear -Hs; iFrameMapSolve name.

(* From cap_machine Require Import rules logrel addr_reg_sample. *)

(* Section test. *)
(*   Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} *)
(*           {nainv: logrel_na_invs Σ} *)
(*           `{MP: MachineParameters}. *)

(*   Lemma test pc_p pc_b pc_e a_first: *)
(*     forall (rmap: gmap RegName Word), *)
(*       dom (gset RegName) rmap = all_registers_s ∖ {[PC; r_env; r_t0; r_t1]} -> *)
(*       a_first = 0%a → *)
(*       (([∗ map] k↦y ∈ <[r_t6:=WInt 0%Z]> *)
(*         (delete r_t1 *)
(*                 (<[r_t4:=WInt 0%Z]> *)
(*                  (<[r_t2:=WInt 0%Z]> *)
(*                   (<[r_t3:=WCap pc_p pc_b pc_e (a_first ^+ 0)%a]> (<[r_env:=WInt 42%Z]> (<[r_t5:=WInt 0%Z]> rmap)))))), *)
(*         k ↦ᵣ y)) -∗ *)
(*            ([∗ map] r↦w0 ∈ <[r_t3:=WInt 0%Z]> *)
(*             (<[r_t2:=WInt 0%Z]> (<[r_t4:=WInt 0%Z]> (<[r_t6:=WInt 0%Z]> (<[r_t5:=WInt 0%Z]> rmap)))), *)
(*             r ↦ᵣ w0). *)
(*   Proof. *)
(*     iIntros (rmap Hdom Heq) "Hregs". *)
(*     map_simpl_debug "Hregs". *)
(*  Abort. *)

(* End test. *)


From stdpp Require Import prelude sorting finite.
From Coq Require Import ssreflect.
From LS2NF Require Import grammar util ambiguity acyclic sub_derive slice derivation witness.

Section encoding.

  Context {Σ N : Type} `{!EqDecision Σ} `{!Inhabited Σ} `{!EqDecision N} `{!Finite N}.
  Context (G : grammar Σ N) `{!acyclic G}.

  Open Scope grammar_scope.

  (* sat model *)

  Record model := {
    term : nat → Σ;
    line : nat → nat;
    col : nat → nat;
    line_col i := (line i, col i);
    can_derive : N → nat (* start (inclusive) *) → nat (* length, positive *) → Prop;
    can_reach_from : N → nat (* start (inclusive) *) → nat (* length, positive *) → Prop;
    ε_can_reach_from : N → Prop;
  }.

  (* decode *)

  Definition decode m k : sentence Σ :=
    (λ i, term m i @ (line m i, col m i)) <$> (index_range k).

  Lemma decode_length m k :
    length (decode m k) = k.
  Proof.
    by rewrite fmap_length index_range_length.
  Qed.

  Lemma decode_lookup m k i :
    i < k → (decode m k) !! i = Some (term m i @ (line m i, col m i)).
  Proof.
    intros. rewrite list_lookup_fmap index_range_lookup //.
  Qed.

  Definition encode S (w : sentence Σ) : model := {|
    term i :=
      match w !! i with
      | Some (a @ _) => a
      | None => inhabitant
      end;
    line i :=
      match w !! i with
      | Some (_ @ (x, _)) => x
      | None => 0
      end;
    col i :=
      match w !! i with
      | Some (_ @ (_, y)) => y
      | None => 0
      end;
    can_derive A x δ := (G ⊨ A => slice w x δ);
    can_reach_from A x δ := (reachable G (S, w) (A, slice w x δ));
    ε_can_reach_from A := (reachable G (S, w) (A, []));
  |}.

  Lemma decode_encode S w :
    decode (encode S w) (length w) = w.
  Proof.
    apply list_eq_same_length with (n := length w) => //.
    { by rewrite decode_length. }
    intros i x y ?. rewrite decode_lookup //=. repeat case_match.
    all: intros ?; match goal with
    | H : ?x = _ |- ?x = _ → _ => rewrite H
    end => //.
    congruence.
  Qed.

  Implicit Type w : sentence Σ.
  Implicit Type x δ : nat.

  (* formula: a predicate over a bounded model *)

  Definition formula : Type := nat → model → Prop.

  (* encoding predicate *)

  Variable Φ_app₁ : (unary_predicate Σ) → nat → nat → formula.
  Variable Φ_app₁_spec : ∀ φ x δ k m,
    Φ_app₁ φ x δ k m ↔ app₁ φ (slice (decode m k) x δ) = true.

  Variable Φ_app₂ : (binary_predicate Σ) → nat → nat → nat → nat → formula.
  Variable Φ_app₂_spec : ∀ φ x1 δ1 x2 δ2 k m,
    Φ_app₂ φ x1 δ1 x2 δ2 k m ↔
      app₂ φ (slice (decode m k) x1 δ1) (slice (decode m k) x2 δ2) = true.

  (* encoding sentence well-formed-ness *)

  Definition Φ_well_formed : formula := λ k m,
    ∀ i, 0 ≤ i < k - 1 →
      line m i < line m (i + 1) ∨ (line m i = line m (i + 1) ∧ col m i < col m (i + 1)).

  Local Hint Resolve pos_token_lt_trans : core.
  Local Hint Unfold pos_token_lt : core.

  Lemma Φ_well_formed_sat X w :
    well_formed w →
    Φ_well_formed (length w) (encode X w).
  Proof.
    intros Hw i ?. apply Sorted_monotone in Hw; eauto.
    have [[a [l1 c1]] Ha] : is_Some (w !! i) by apply lookup_lt_is_Some; lia.
    have [[b [l2 c2]] Hb] : is_Some (w !! (i + 1)) by apply lookup_lt_is_Some; lia.
    specialize (Hw _ _ _ _ Ha Hb (ltac:(lia))).
    simpl in *. by rewrite Ha Hb.
  Qed.

  Lemma Φ_well_formed_spec k m :
    Φ_well_formed k m → well_formed (decode m k).
  Proof.
    intros HΦ. apply Sorted_monotone; eauto.
    apply monotone_trans_alt_spec; eauto.
    intros i [a [l1 c1]] [b [l2 c2]] Hi Ha Hb.
    rewrite decode_length in Hi.
    rewrite decode_lookup in Ha; [lia|]. invert Ha.
    rewrite decode_lookup in Hb; [lia|]. invert Hb.
    apply HΦ. lia.
  Qed.

  Lemma well_formed_no_dup w : well_formed w → NoDup w.
  Proof.
    induction w as [|a w IHw] => Hwf; constructor.
    - apply Sorted_extends in Hwf; last apply pos_token_lt_trans.
      rewrite ->Forall_forall in Hwf.
      intros Hin. specialize (Hwf _ Hin). destruct a as [? [x y]].
      unfold pos_token_lt in Hwf. simpl in Hwf. lia.
    - invert Hwf. eauto.
  Qed.

  Local Hint Resolve Φ_well_formed_spec well_formed_no_dup : core.

  (* encoding derivation *)

  Definition Φ_derive : formula := λ k m,
    ∀ A x δ, 0 < δ (* nonempty *) → x + δ ≤ k →
      can_derive m A x δ ↔ (
        False ∨
        (∃ a, A ↦ atom a ∈ G ∧ δ = 1 ∧ term m x = a) ∨
        (∃ B φ, A ↦ unary B φ ∈ G ∧ Φ_app₁ φ x δ k m ∧ can_derive m B x δ) ∨
        (∃ Bl Br φ, A ↦ binary Bl Br φ ∈ G ∧ (
          (G ⊨ Bl => [] ∧ can_derive m Br x δ) ∨
          (G ⊨ Br => [] ∧ can_derive m Bl x δ) ∨
          (∃ δ', 0 < δ' < δ ∧
            can_derive m Bl x δ' ∧ can_derive m Br (x + δ') (δ - δ') ∧
            Φ_app₂ φ x δ' (x + δ') (δ - δ') k m)
        ))
      ).

  Lemma Φ_derive_sat X w :
    well_formed w →
    Φ_derive (length w) (encode X w).
  Proof.
    intros ? A x δ ? ?.
    have Heq : can_derive (encode X w) A x δ ↔ check_derive G A (slice w x δ).
    { rewrite check_derive_spec derivation_spec //. }
    rewrite Heq.
    unfold check_derive. setoid_rewrite derivation_spec.
    simpl can_derive.
    setoid_rewrite Φ_app₁_spec. setoid_rewrite Φ_app₂_spec.
    setoid_rewrite decode_encode.
    repeat apply ZifyClasses.or_morph.
    - rewrite slice_nil_iff; lia.
    - split.
      + intros [a [p [Hw ?]]]. exists a.
        apply slice_singleton_iff in Hw as [-> Hw] => //.
        repeat split => //=. by rewrite Hw.
      + intros [a [? [? Hw]]].
        have [? Hx] : is_Some (w !! x) by apply lookup_lt_is_Some; lia.
        simpl in Hw. rewrite Hx in Hw. case_match; subst.
        exists a. eexists. rewrite slice_singleton_iff //.
        repeat split; eauto.
    - done.
    - split.
      + intros [Bl [Br [φ [? [w1 [w2 [Hw [Hφ [HBl HBr]]]]]]]]].
        have Hl : length (w1 ++ w2) = δ.
        { apply (f_equal length) in Hw. by rewrite slice_length in Hw. }
        exists Bl, Br, φ. split; first done.
        destruct w1 as [|tk1 w1]; last destruct w2.
        * left. rewrite app_nil_l in Hw. by rewrite Hw.
        * right; left. rewrite app_nil_r in Hw. by rewrite Hw.
        * right; right. apply slice_app_inv_NoDup in Hw as [Hw1 Hw2]; eauto.
          rewrite app_length !cons_length in Hl.
          exists (length (tk1 :: w1)). rewrite -Hw1 -Hw2.
          repeat split => //. all: rewrite cons_length; lia.
      + intros [Bl [Br [φ [? [Hd|[Hd|Hd]]]]]].
        * destruct Hd as [? ?].
          exists Bl, Br, φ. split; first done.
          exists [], (slice w x δ). rewrite app_nil_l.
          repeat split => //. destruct φ as [φ Hφ]; apply Hφ; by left.
        * destruct Hd as [? ?].
          exists Bl, Br, φ. split; first done.
          exists (slice w x δ), []. rewrite app_nil_r.
          repeat split => //. destruct φ as [φ Hφ]; apply Hφ; by right.
        * destruct Hd as [δ' [? [? [? ?]]]].
          exists Bl, Br, φ. split; first done.
          exists (slice w x δ'), (slice w (x + δ') (δ - δ')).
          rewrite slice_app_1. have -> : δ' + (δ - δ') = δ by lia.
          repeat split => //.
  Qed.

  Lemma list_nonempty_length {A} (l : list A) :
    l ≠ [] ↔ 0 < length l.
  Proof.
    have -> : 0 < length l ↔ 0 ≠ length l by split; [apply lt_0_neq | apply neq_0_lt].
    apply not_iff_compat.
    have ? := length_zero_iff_nil.
    naive_solver.
  Qed.

  Lemma Φ_derive_spec k m :
    Φ_well_formed k m →
    Φ_derive k m →
    ∀ A x δ, 0 < δ → x + δ ≤ k →
      can_derive m A x δ ↔ G ⊨ A => slice (decode m k) x δ.
  Proof.
    intros ? HΦ A x δ ? ?.
    (* induction on range length *)
    generalize dependent A.
    generalize dependent x.
    induction δ as [δ IHδ] using lt_wf_ind => x Hk A.
    (* induction on nonterminal *)
    have Hwf : wf (flip (succ G)) by apply acyclic_prec_wf.
    induction A as [A IHA] using (well_founded_induction Hwf).
    (* rewrite definition *)
    rewrite HΦ; [|done..]. setoid_rewrite Φ_app₁_spec. setoid_rewrite Φ_app₂_spec.
    rewrite -derivation_spec -check_derive_spec /check_derive. setoid_rewrite derivation_spec.
    repeat apply ZifyClasses.or_morph.
    - rewrite slice_nil_iff ?decode_length; lia.
    - split.
      + intros [a [? [-> ?]]]. exists a, (line m x, col m x).
        rewrite slice_singleton_iff ?decode_length //.
        rewrite decode_lookup; [lia|].
        naive_solver.
      + intros [a [p [Hw ?]]]. exists a.
        apply slice_singleton_iff in Hw as [-> Hw]; last by rewrite decode_length.
        rewrite decode_lookup in Hw; [lia|].
        naive_solver.
    - split.
      + intros [B [φ [? [? ?]]]]. exists B, φ.
        repeat split => //. apply IHA => //. eapply succ_unary; eauto.
      + intros [B [φ [? [? ?]]]]. exists B, φ.
        repeat split => //. apply IHA => //. eapply succ_unary; eauto.
    - split.
      + intros [Bl [Br [φ [? [Hd|[Hd|Hd]]]]]].
        * destruct Hd as [? ?].
          exists Bl, Br, φ. split; first done.
          exists []. eexists. rewrite app_nil_l.
          repeat split => //; first by destruct φ as [φ Hφ]; apply Hφ; by left.
          apply IHA => //. eapply succ_right; eauto.
        * destruct Hd as [? ?].
          exists Bl, Br, φ. split; first done.
          eexists. exists []. rewrite app_nil_r.
          repeat split => //; first by destruct φ as [φ Hφ]; apply Hφ; by right.
          apply IHA => //. eapply succ_left; eauto.
        * destruct Hd as [δ' [? [? [? ?]]]].
          exists Bl, Br, φ. split; first done.
          do 2 eexists. repeat split; eauto.
          { rewrite -slice_split; [lia | done]. }
          all: apply IHδ => //; lia.
      + intros [Bl [Br [φ [? [w1 [w2 [Hw [Hφ [HBl HBr]]]]]]]]].
        have Hl : length (w1 ++ w2) = δ.
        { apply (f_equal length) in Hw. rewrite slice_length in Hw; [rewrite decode_length; lia | done]. }
        exists Bl, Br, φ. split; first done.
        destruct w1 as [|tk1 w1]; last destruct w2.
        * left. rewrite app_nil_l in Hw. split => //.
          apply IHA => //. eapply succ_right; eauto. by rewrite Hw.
        * right; left. rewrite app_nil_r in Hw. split => //.
          apply IHA => //. eapply succ_left; eauto. by rewrite Hw.
        * right; right. apply slice_app_inv_NoDup in Hw as [Hw1 Hw2]; eauto.
          all: rewrite ?decode_length //.
          rewrite Hw1 in HBl, Hφ. rewrite Hw2 in HBr, Hφ.
          rewrite app_length !cons_length in Hl.
          exists (length (tk1 :: w1)). repeat split => //.
          all: try apply IHδ => //.
          all: rewrite cons_length; lia.
  Qed.

  (* encoding reachable from (S, [0..k]) *)
  Definition Φ_reach_nonempty S : formula := λ k m,
    ∀ B x δ, 0 < δ → x + δ ≤ k →
      can_reach_from m B x δ ↔ (
        (B = S ∧ x = 0 ∧ δ = k) ∨
        (∃ A φ, A ↦ unary B φ ∈ G ∧ can_reach_from m A x δ ∧ Φ_app₁ φ x δ k m) ∨
        (∃ A B' φ δ', x + δ + δ' ≤ k ∧ A ↦ binary B B' φ ∈ G ∧ can_reach_from m A x (δ + δ') ∧
          (if bool_decide (δ' = 0) then G ⊨ B' => [] else can_derive m B' (x + δ) δ') ∧
          Φ_app₂ φ x δ (x + δ) δ' k m) ∨
        (∃ A B' φ δ', δ' ≤ x ∧ A ↦ binary B' B φ ∈ G ∧ can_reach_from m A (x - δ') (δ' + δ) ∧
          (if bool_decide (δ' = 0) then G ⊨ B' => [] else can_derive m B' (x - δ') δ') ∧
          Φ_app₂ φ (x - δ') δ' x δ k m)
      ).

  Definition Φ_reach_empty S : formula := λ k m,
    ∀ B, ε_can_reach_from m B ↔ (
      (B = S ∧ k = 0) ∨
      (∃ A φ, A ↦ unary B φ ∈ G ∧ ε_can_reach_from m A) ∨
      (∃ A B' φ, A ↦ binary B B' φ ∈ G ∧ (
        (ε_can_reach_from m A ∧ G ⊨ B' => []) ∨
        (∃ x δ, 0 < δ ∧ x + δ ≤ k ∧
          can_reach_from m A x δ ∧ can_derive m B' x δ))) ∨
      (∃ A B' φ, A ↦ binary B' B φ ∈ G ∧ (
        (ε_can_reach_from m A ∧ G ⊨ B' => []) ∨
        (∃ x δ, 0 < δ ∧ x + δ ≤ k ∧
          can_reach_from m A x δ ∧ can_derive m B' x δ)))
    ).

  Definition Φ_reach S : formula := λ k m,
    Φ_reach_nonempty S k m ∧ Φ_reach_empty S k m.

  Lemma Φ_reach_nonempty_sat X w k :
    well_formed w →
    length w = k →
    Φ_reach_nonempty X k (encode X w).
  Proof.
    intros ? <- B x δ ? ?.
    have Heq : can_reach_from (encode X w) B x δ ↔ check_reachable_from G (X, w) (B, slice w x δ).
    { rewrite check_reachable_from_spec reachable_from_spec //. }
    rewrite Heq /=.
    setoid_rewrite reachable_from_spec.
    setoid_rewrite Φ_app₁_spec. setoid_rewrite Φ_app₂_spec.
    setoid_rewrite decode_encode.
    repeat apply ZifyClasses.or_morph.
    - rewrite slice_full_iff //. apply list_nonempty_length; lia.
    - done.
    - split.
      + intros [A [B' [φ [wr [? [Hr [? ?]]]]]]].
        exists A, B', φ, (length wr).
        destruct wr as [|tk l].
        * rewrite /= slice_nil !Nat.add_0_r.
          rewrite app_nil_r in Hr.
          repeat split => //.
        * case_bool_decide => //.
          have Hsub : sublist (slice w x δ ++ tk :: l) w by eapply reachable_sublist; eauto.
          apply sublist_app_slice_NoDup in Hsub as [x' [Hlen [Hx' Hl]]];
            [| eauto | rewrite slice_length; lia | lia].
          rewrite slice_length in Hlen => //.
          apply slice_eq_inv_NoDup in Hx' as [? Hδ]; eauto; [|rewrite slice_length; lia..].
          subst. rewrite Hδ in Hl. rewrite -slice_app_1 -Hl.
          repeat split => //.
      + intros [A [B' [φ [δ' [? [? [Hr [Hd Hφ]]]]]]]].
        exists A, B', φ, (slice w (x + δ) δ').
        rewrite slice_app_1.
        repeat split => //.
        case_bool_decide; [by subst | done].
    - split.
      + intros [A [B' [φ [wl [? [Hr [? ?]]]]]]].
        exists A, B', φ, (length wl).
        destruct wl as [|tk l].
        * rewrite /= slice_nil !Nat.sub_0_r.
          rewrite app_nil_l in Hr.
          repeat split => //. lia.
        * case_bool_decide => //.
          have Hsub : sublist ((tk :: l) ++ slice w x δ) w by eapply reachable_sublist; eauto.
          apply sublist_app_slice_NoDup in Hsub as [x' [Hlen [Hx' Hl]]];
            [| eauto | rewrite cons_length; lia | rewrite slice_length; lia].
          rewrite slice_length in Hlen => //. rewrite slice_length in Hl => //.
          apply slice_eq_inv_NoDup in Hl as [? Hδ]; eauto; [|rewrite slice_length; lia..].
          subst. rewrite Nat.add_sub -slice_app_1 -Hx'.
          repeat split => //. lia.
      + intros [A [B' [φ [δ' [? [? [Hr [Hd Hφ]]]]]]]].
        exists A, B', φ, (slice w (x - δ') δ').
        rewrite slice_app_2; [lia|].
        repeat split => //.
        case_bool_decide; [by subst | done].
  Qed.

  Lemma apply_unary_nil (φ : unary_predicate Σ) :
    app₁ φ [] = true.
  Proof. by destruct φ. Qed.

  Lemma apply_binary_nil_l (φ : binary_predicate Σ) w :
    app₂ φ [] w = true.
  Proof. destruct φ; naive_solver. Qed.

  Lemma apply_binary_nil_r (φ : binary_predicate Σ) w :
    app₂ φ w [] = true.
  Proof. destruct φ; naive_solver. Qed.

  Lemma Φ_reach_empty_sat k X w :
    length w = k →
    Φ_reach_empty X k (encode X w).
  Proof.
    intros <- B.
    have Heq : ε_can_reach_from (encode X w) B ↔ check_reachable_from G (X, w) (B, []).
    { rewrite check_reachable_from_spec reachable_from_spec //. }
    rewrite Heq /=.
    setoid_rewrite reachable_from_spec.
    repeat apply ZifyClasses.or_morph.
    - rewrite length_zero_iff_nil. naive_solver.
    - setoid_rewrite apply_unary_nil. naive_solver.
    - setoid_rewrite apply_binary_nil_l. split.
      + intros [A [B' [φ [w' [? [Hr [? ?]]]]]]].
        exists A, B', φ. split; first done.
        destruct w' as [|t w']; [by left | right].
        have Hsub : sublist (t :: w') w by eapply reachable_sublist; eauto.
        apply sublist_slice in Hsub as [a [? Hw]].
        exists a, (length (t :: w')).
        rewrite -Hw. repeat split => //. rewrite cons_length; lia.
      + intros [A [B' [φ [? [Hr|Hr]]]]].
        * destruct Hr as [? ?].
          exists A, B', φ, [].
          repeat split => //.
        * destruct Hr as [x [δ [? [? [? ?]]]]].
          exists A, B', φ, (slice w x δ).
          repeat split => //.
    - setoid_rewrite apply_binary_nil_r.
      setoid_rewrite app_nil_r. split.
      + intros [A [B' [φ [w' [? [Hr [? ?]]]]]]].
        exists A, B', φ. split; first done.
        destruct w' as [|t w']; [by left | right].
        have Hsub : sublist (t :: w') w by eapply reachable_sublist; eauto.
        apply sublist_slice in Hsub as [a [? Hw]].
        exists a, (length (t :: w')).
        rewrite -Hw. repeat split => //. rewrite cons_length; lia.
      + intros [A [B' [φ [? [Hr|Hr]]]]].
        * destruct Hr as [? ?].
          exists A, B', φ, [].
          repeat split => //.
        * destruct Hr as [x [δ [? [? [? ?]]]]].
          exists A, B', φ, (slice w x δ).
          repeat split => //.
  Qed.

  Lemma Φ_reach_sat k X w :
    well_formed w →
    length w = k →
    Φ_reach X k (encode X w).
  Proof.
    intros ? <-. split; by [apply Φ_reach_nonempty_sat | apply Φ_reach_empty_sat].
  Qed.

  Lemma Φ_reach_nonempty_spec k S m :
    Φ_well_formed k m →
    Φ_derive k m →
    Φ_reach_nonempty S k m →
    ∀ B x δ, 0 < δ → x + δ ≤ k →
      can_reach_from m B x δ → (* only this direction is needed *)
      reachable G (S, decode m k) (B, slice (decode m k) x δ).
  Proof.
    intros ? HΦ' HΦ B x δ ? ? ?. rewrite -reachable_from_spec.
    (* induction on range length *)
    generalize dependent B.
    generalize dependent x.
    induction δ as [δ IHδ] using (induction_ltof1 _ (λ δ, k - δ)) => x Hk B.
    unfold ltof in IHδ.
    (* induction on nonterminal *)
    have Hwf : wf (succ G) by apply acyclic_succ_wf.
    induction B as [B IHB] using (well_founded_induction Hwf).
    rewrite HΦ //.
    setoid_rewrite Φ_app₁_spec. setoid_rewrite Φ_app₂_spec.
    intros [Hr|[Hr|[Hr|Hr]]].
    - destruct Hr as [-> [-> ->]].
      rewrite slice_full ?decode_length //.
      constructor.
    - destruct Hr as [A [φ [? [? ?]]]].
      eapply reachable_from_unary; eauto.
      apply IHB => //. eapply succ_unary; eauto.
    - destruct Hr as [A [B' [φ [δ' [? [? [? [? ?]]]]]]]].
      case_bool_decide; subst.
      * eapply reachable_from_left; eauto.
        rewrite app_nil_r. apply IHB.
        { eapply succ_left; eauto. }
        have -> : δ = δ + 0 by lia. done.
      * eapply reachable_from_left; eauto.
        rewrite slice_app_1. apply IHδ => //; lia.
        { eapply Φ_derive_spec; eauto; lia. }
    - destruct Hr as [A [B' [φ [δ' [? [? [Hr [? ?]]]]]]]].
      case_bool_decide; subst; eapply reachable_from_right; eauto.
      * rewrite Nat.sub_0_r Nat.add_0_l in Hr. rewrite app_nil_l.
        apply IHB => //. eapply succ_right; eauto.
      * rewrite slice_app_2 //. apply IHδ => //; lia.
      * eapply Φ_derive_spec; eauto; lia.
  Qed.

  Lemma Φ_reach_empty_spec S k m :
    Φ_well_formed k m →
    Φ_derive k m →
    Φ_reach_nonempty S k m →
    Φ_reach_empty S k m →
    ∀ B,
      ε_can_reach_from m B → (* only this direction is needed *)
      reachable G (S, decode m k) (B, []).
  Proof.
    intros ? ? ? HΦ B. rewrite -reachable_from_spec.
    (* induction on nonterminal *)
    have Hwf : wf (succ G) by apply acyclic_succ_wf.
    induction B as [B IHB] using (well_founded_induction Hwf).
    rewrite HΦ //. intros [Hr|[Hr|[Hr|Hr]]].
      + destruct Hr as [<- ->]. constructor.
      + destruct Hr as [A [φ [Hp ?]]].
        eapply reachable_from_unary; [apply Hp | | apply apply_unary_nil].
        apply IHB => //. eapply succ_unary; eauto.
      + destruct Hr as [A [B' [φ [Hp [Hr|Hr]]]]].
        * destruct Hr as [? ?].
          eapply reachable_from_left; [apply Hp | | eauto | apply apply_binary_nil_l].
          rewrite app_nil_l. apply IHB => //. eapply succ_left; eauto.
        * destruct Hr as [x [δ [? [? [Hr Hd]]]]].
          eapply Φ_derive_spec in Hd; eauto.
          eapply reachable_from_left; [apply Hp | | eauto | apply apply_binary_nil_l].
          rewrite app_nil_l. apply reachable_from_spec, Φ_reach_nonempty_spec; eauto.
      + destruct Hr as [A [B' [φ [Hp [Hr|Hr]]]]].
        * destruct Hr as [? ?].
          eapply reachable_from_right; [apply Hp | | eauto | apply apply_binary_nil_r].
          rewrite app_nil_r. apply IHB => //. eapply succ_right; eauto.
        * destruct Hr as [x [δ [? [? [Hr Hd]]]]].
          eapply Φ_derive_spec in Hd; eauto.
          eapply reachable_from_right; [apply Hp | | eauto | apply apply_binary_nil_r].
          rewrite app_nil_r. apply reachable_from_spec, Φ_reach_nonempty_spec; eauto.
  Qed.

  (* encoding derivations using different productions *)

  Inductive using_clause : Type :=
  | using_ε : using_clause
  | using_atom : Σ → using_clause
  | using_unary : N → unary_predicate Σ → using_clause
  | using_binary : N → N → binary_predicate Σ → nat (* length of first part *) → using_clause
  .

  Definition usable_clauses A δ : list using_clause :=
    clauses G A ≫= (λ α, match α with
    | ε => [using_ε]
    | atom a => [using_atom a]
    | unary B φ => [using_unary B φ]
    | binary Bl Br φ => (λ δ', using_binary Bl Br φ δ') <$> (index_range δ ++ [δ])
    end).

  Lemma elem_of_usable_clauses ψ A δ :
    ψ ∈ usable_clauses A δ ↔ match ψ with
    | using_ε => A ↦ ε ∈ G
    | using_atom a => A ↦ atom a ∈ G
    | using_unary B φ => A ↦ unary B φ ∈ G
    | using_binary Bl Br φ δ' => A ↦ binary Bl Br φ ∈ G ∧ δ' ≤ δ
    end.
  Proof.
    rewrite /usable_clauses elem_of_list_bind. split.
    - (* -> *)
      intros [α [Hin ?]]. repeat case_match => //.
      all: repeat match goal with
      | [H : _ ∈ [_] |- _ ] => apply elem_of_list_singleton in H; invert H
      | [H : _ ∈ _ <$> _ |- _ ] => apply elem_of_list_fmap in H as [x [H Hx]]; invert H
      end => //.
      split => //. apply elem_of_app in Hx as [|Hx].
      * suff : x < δ by lia. by apply index_range_elem_of.
      * suff : x = δ by lia. by apply elem_of_list_singleton in Hx.
    - (* <- *)
      destruct ψ as [| a | B φ | Bl Br φ δ'] => Hp.
      * exists ε. split => //. by apply elem_of_list_singleton.
      * exists (atom a). split => //. by apply elem_of_list_singleton.
      * exists (unary B φ). split => //. by apply elem_of_list_singleton.
      * exists (binary Bl Br φ). destruct Hp as [? Hδ']. split => //. apply elem_of_list_fmap.
        exists δ'. split => //. apply Nat.le_lteq in Hδ' as [?|?]; apply elem_of_app; by
          [left; apply index_range_elem_of | right; apply elem_of_list_singleton].
  Qed.

  Definition Φ_using_derive ψ x δ : formula :=
    match ψ with
    | using_ε => λ k m, δ = 0
    | using_atom a => λ k m, δ = 1 ∧ term m x = a
    | using_unary B φ => λ k m,
      if bool_decide (δ = 0) then G ⊨ B => []
      else Φ_app₁ φ x δ k m ∧ can_derive m B x δ
    | using_binary Bl Br φ δ' => λ k m,
      (if bool_decide (δ' = 0) then G ⊨ Bl => [] else can_derive m Bl x δ') ∧
      (if bool_decide (δ - δ' = 0) then G ⊨ Br => [] else can_derive m Br (x + δ') (δ - δ')) ∧
      Φ_app₂ φ x δ' (x + δ') (δ - δ') k m
    end.

  Lemma Φ_using_derive_witness k m x δ A ψ :
    Φ_well_formed k m →
    Φ_derive k m →
    x + δ ≤ k →
    ψ ∈ usable_clauses A δ →
    Φ_using_derive ψ x δ k m ↔ match ψ with
    | using_ε => δ = 0 ∧ ε_tree A ▷ A ={G}=> slice (decode m k) x δ
    | using_atom a => δ = 1 ∧ a = term m x ∧ let p := (line m x, col m x) in
      (token_tree A (a @ p)) ▷ A ={G}=> slice (decode m k) x δ
    | using_unary B _ => ∃ t, root t = B ∧ (unary_tree A t) ▷ A ={G}=> slice (decode m k) x δ
    | using_binary Bl Br _ δ' => ∃ t1 t2, root t1 = Bl ∧ root t2 = Br ∧
      word t1 = slice (decode m k) x δ' ∧ (binary_tree A t1 t2) ▷ A ={G}=> slice (decode m k) x δ
    end.
  Proof.
    intros ? ? ? Hψ. destruct ψ as [| a | B φ | Bl Br φ δ'] => /=.
    all: apply elem_of_usable_clauses in Hψ.
    - split; last naive_solver.
      intros ->. split; first done. by apply witness_ε.
    - split; last naive_solver.
      intros [-> Hx]. split; first done.
      erewrite slice_singleton; last by rewrite decode_lookup; [lia|eauto].
      rewrite Hx. split; first done. by apply witness_atom.
    - unfold derive. case_bool_decide.
      + subst. rewrite slice_nil. split.
        * intros [t [? [? ?]]]. subst. exists t.
          rewrite witness_unary; eauto. repeat split => //. apply apply_unary_nil.
        * intros [t [? Ht]]. subst. eapply witness_unary in Ht; eauto. naive_solver.
      + rewrite Φ_app₁_spec.
        rewrite Φ_derive_spec; eauto; [|lia]. unfold derive.
        split.
        * intros [? [t [? [? ?]]]]. subst. exists t.
          rewrite witness_unary; eauto. repeat split => //.
        * intros [t [? Ht]]. subst. eapply witness_unary in Ht; eauto. naive_solver.
    - destruct Hψ as [Hψ ?]. unfold derive. rewrite Φ_app₂_spec. repeat case_bool_decide.
      Ltac finish := split;
        [ intros [[t1 [? [Hw1 ?]]] [[t2 [? [? ?]]] ?]]; subst; exists t1, t2;
          rewrite -{2}Hw1 witness_binary ?Hw1; eauto; repeat split => //
        | intros [t1 [t2 [? [? [Hw1 Ht]]]]]; subst;
          rewrite -{1}Hw1 in Ht; eapply witness_binary in Ht; eauto; rewrite Hw1 in Ht; naive_solver
        ].
      + have -> : δ = 0 by lia.
        have -> : slice (decode m k) x 0 = [] ++ [] by rewrite slice_nil.
        have -> : δ' = 0 by lia. rewrite slice_nil.
        finish.
      + have -> : slice (decode m k) x δ = [] ++ slice (decode m k) x δ by rewrite app_nil_l.
        subst. rewrite Nat.add_0_r Nat.sub_0_r slice_nil.
        rewrite Φ_derive_spec; eauto; [|lia]. unfold derive.
        finish.
      + have -> : slice (decode m k) x δ = slice (decode m k) x δ ++ [] by rewrite app_nil_r.
        have -> : δ' = δ by lia. rewrite Nat.sub_diag slice_nil.
        rewrite Φ_derive_spec; eauto; [|lia]. unfold derive.
        finish.
      + have -> : slice (decode m k) x δ = slice (decode m k) x δ' ++ slice (decode m k) (x + δ') (δ - δ')
          by rewrite -slice_split.
        rewrite !Φ_derive_spec; eauto; [|lia..]. unfold derive.
        finish.
  Qed.

  Definition Φ_multi_usable (A : N) (x δ : nat) : formula := λ k m,
    ∃ ψ1, ψ1 ∈ usable_clauses A δ ∧
      ∃ ψ2, ψ2 ∈ usable_clauses A δ ∧
        ψ1 ≠ ψ2 ∧ Φ_using_derive ψ1 x δ k m ∧ Φ_using_derive ψ2 x δ k m.

  Lemma app_length_le_l {A} (l1 l2 l : list A) :
    l1 ++ l2 = l →
    length l1 ≤ length l.
  Proof.
    intros Hl. apply (f_equal length) in Hl. rewrite app_length in Hl. lia.
  Qed.

  Local Lemma wrap_with_id (P : Prop) :
    P ↔ id P.
  Proof. done. Qed.

  Local Ltac wrap H := apply ->wrap_with_id in H.

  Local Ltac congruence_by H :=
    match goal with
    | H1 : ?x = ?z1, H2 : ?y = ?z2, H : ?x = ?y |- _ =>
      rewrite H1 in H; rewrite H2 in H
    end.

  Lemma Φ_multi_usable_spec k m x δ A :
    Φ_well_formed k m →
    Φ_derive k m →
    x + δ ≤ k →
    Φ_multi_usable A x δ k m ↔ ∃ t1, t1 ▷ A ={G}=> slice (decode m k) x δ ∧
      ∃ t2, t2 ▷ A ={G}=> slice (decode m k) x δ ∧ ¬ similar t1 t2.
  Proof.
    intros ? ?. split.
    - (* -> *)
      intros [ψ1 [Hψ1 [ψ2 [Hψ2 [Hne [HΦ1 HΦ2]]]]]].
      eapply Φ_using_derive_witness in HΦ1; eauto.
      eapply Φ_using_derive_witness in HΦ2; eauto.
      repeat case_match.
      all: apply elem_of_usable_clauses in Hψ1, Hψ2.
      all: repeat match goal with
      | [ H : _ ∧ _ |- _ ] => destruct H as [H ?]
      | [ H : ∃ _, _ |- _ ] => destruct H as [? H]
      end.
      all: simpl in *; try congruence.
      all: repeat match goal with
      | [ H : ?t ▷ ?A ={?G}=> ?w |- ∃ t, t ▷ ?A ={?G}=> ?w ∧ _ ] =>
        exists t; split; [by apply H|]; clear H
      end => //=.
      * intros Heq. subst. rewrite Heq in Hψ2.
        eapply unary_clause_predicate_unique in Hψ1; [|exact Hψ2].
        subst. congruence.
      * intros [Heq1 [Heq2 Heqw]]. subst. rewrite Heq1 Heq2 in Hψ2.
        eapply binary_clause_predicate_unique in Hψ1; [|exact Hψ2].
        subst. congruence_by Heqw.
        apply slice_eq_inv in Heqw. 2-3: rewrite decode_length; lia.
        congruence.
    - (* <- *)
      intros [t1 [[? [? Ht1]] [t2 [[? [? Ht2]] ?]]]].
      destruct t1 as [?|??|??|? t11 t12]; destruct t2 as [?|??|??|? t21 t22].
      all: simpl in *; try done; try congruence.
      all: invert Ht1.
      all: invert Ht2.
      all: unfold Φ_multi_usable.
      all: repeat match goal with
      | [ H : ?A ↦ ε ∈ _ |- ∃ ψ, ψ ∈ usable_clauses ?A ?δ ∧ _ ] =>
        assert (using_ε ∈ usable_clauses A δ) by (by apply elem_of_usable_clauses);
        eexists; split; [eauto|]; wrap H
      | [ H : ?A ↦ atom ?a ∈ _ |- ∃ ψ, ψ ∈ usable_clauses ?A ?δ ∧ _ ] =>
        assert (using_atom a ∈ usable_clauses A δ) by (by apply elem_of_usable_clauses);
        eexists; split; [eauto|]; wrap H
      | [ H : ?A ↦ unary ?B ?φ ∈ _ |- ∃ ψ, ψ ∈ usable_clauses ?A ?δ ∧ _ ] =>
        assert (using_unary B φ ∈ usable_clauses A δ) by (by apply elem_of_usable_clauses);
        eexists; split; [eauto|]; wrap H
      | [ H : ?A ↦ binary (root ?t1) (root ?t2) ?φ ∈ _ |- ∃ ψ, ψ ∈ usable_clauses ?A ?δ ∧ _ ] =>
        assert (using_binary (root t1) (root t2) φ (length (word t1)) ∈ usable_clauses A δ) by
          (apply elem_of_usable_clauses; split; [done
            | erewrite <-slice_length; [ eapply app_length_le_l; eauto | by rewrite decode_length ]
          ]);
        eexists; split; [eauto|]; wrap H
      end.
      all: split; first try congruence.
      12: {
        intros Heq. invert Heq.
        have Hw : word t11 ++ word t12 = word t21 ++ word t22 by congruence.
        apply app_inj_1 in Hw => //. naive_solver.
      }
      all: try (split; eapply Φ_using_derive_witness; simpl; eauto).
      all: repeat match goal with
      | [ |- _ ▷ _ ={ _ }=> _ ] =>
        repeat split; simpl; try done; try congruence; econstructor; eauto
      | [ H : [] = slice (decode _ _) _ ?δ |- ?δ = 0 ∧ _ ] =>
        rewrite -H; symmetry in H; apply slice_nil_iff in H; [|by rewrite decode_length]; split; first done
      | [ H : [_] = slice (decode _ _) _ ?δ |- ?δ = 1 ∧ _ = term _ _ ∧ _ ] =>
        rewrite -H; symmetry in H; apply slice_singleton_iff in H; [|by rewrite decode_length];
        let H' := fresh in destruct H as [-> H']; rewrite decode_lookup in H'; [lia|];
        invert H'; do 2 (split; first done)
      | [ |- ∃ t, root t = root ?t' ∧ _ ] =>
        exists t'; split; first done
      | [ |- ∃ t1 t2, root t1 = root ?t1' ∧ root t2 = root ?t2' ∧ _ ] =>
        exists t1', t2'; do 2 (split; first done)
      | [ |- word ?t = slice (decode _ _) _ _ ∧ _ ] =>
        split; first by (eapply slice_app_inv_NoDup; eauto; rewrite decode_length; lia)
      end.
  Qed.

  (* Main theorems *)

  Definition Φ_amb A : formula := λ k m,
    Φ_well_formed k m ∧ Φ_derive k m ∧ Φ_reach A k m ∧ ∃ H,
     (ε_can_reach_from m H ∧ Φ_multi_usable H 0 0 k m) ∨
     (∃ x δ, 0 < δ ∧ x + δ ≤ k ∧ can_reach_from m H x δ ∧ Φ_multi_usable H x δ k m).

  Theorem Φ_amb_sound A k m :
    Φ_amb A k m → derive_amb G A (decode m k).
  Proof.
    intros [? [? [[? ?] [X HX]]]].
    apply derive_amb_iff_local_amb => //.
    destruct HX as [[? Hm]|[x [δ [? [? [? Hm]]]]]].
    - exists X, []; split; first by apply Φ_reach_empty_spec.
      eapply Φ_multi_usable_spec in Hm; eauto; last lia.
      simpl in Hm. naive_solver.
    - exists X, (slice (decode m k) x δ); split; first by apply Φ_reach_nonempty_spec.
      eapply Φ_multi_usable_spec in Hm; eauto. naive_solver.
  Qed.

  Theorem Φ_amb_complete X k w :
    well_formed w → length w = k → derive_amb G X w → ∃ m, Φ_amb X k m.
  Proof.
    intros ? <- Hamb.
    apply derive_amb_iff_local_amb in Hamb; eauto.
    destruct Hamb as [C [h [Hr [t1 [t2 [Ht1 [Ht2 Hne]]]]]]].
    exists (encode X w).
    have ? : Φ_well_formed (length w) (encode X w) by apply Φ_well_formed_sat.
    have ? : Φ_derive (length w) (encode X w) by apply Φ_derive_sat.
    have ? : Φ_reach X (length w) (encode X w) by apply Φ_reach_sat.
    do 3 (split; first done). exists C.
    destruct h as [|tk h].
    - left. split; first done.
      eapply Φ_multi_usable_spec; eauto; lia.
    - right.
      have Hsub : sublist (tk :: h) w by eapply reachable_sublist; eauto.
      apply sublist_slice in Hsub as [x [? Hh]].
      exists x, (length (tk :: h)).
      simpl can_reach_from. rewrite -Hh. repeat split => //.
      { rewrite cons_length; lia. }
      eapply Φ_multi_usable_spec; eauto.
      rewrite decode_encode -Hh; eauto.
  Qed.

End encoding.