(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From compcert Require Import Coqlib Integers AST Maps Values Memory Memtype Memdata.
From bpf.comm Require Import MemRegion State rBPFAST.
From bpf.model Require Import Semantics.
From bpf.isolation Require Import AlignChunk.
From Coq Require Import ZArith Lia List.
Import ListNotations.

Open Scope Z_scope.

Definition is_byte_memval (mv: memval): Prop :=
  match mv with
  | Byte b => True
  | _ => False
  end.

Definition is_byte_block (b:block) (m:mem): Prop :=
  forall o,
      Mem.perm m b o Cur Readable ->
      is_byte_memval (ZMap.get o ((Mem.mem_contents m) !! b)). (**r Notation "a !! b" := (PMap.get b a) *)

Lemma is_byte_memval_iff:
  forall mv,
    is_byte_memval mv <-> exists b, mv = Byte b.
Proof.
  unfold is_byte_memval; split; intros.
  - destruct mv; try intuition.
    exists i; reflexivity.
  - destruct H as (b & H).
    rewrite H.
    constructor.
Qed.

Definition inv_memory_region (m:mem) (mr: memory_region): Prop :=
  exists b,
    (block_ptr mr) = Vptr b Ptrofs.zero /\ Mem.valid_block m b /\ is_byte_block b m /\
    exists base len,
      start_addr mr = Vint base /\ block_size mr = Vint len /\
      perm_order (block_perm mr) Readable /\
      Mem.range_perm m b 0 (Int.unsigned len) Cur (block_perm mr).

(**TODO: exists start_blk, ... *)
Fixpoint disjoint_blocks (n:nat) (mrs: list memory_region): Prop :=
  match mrs with
  | [] => True
  | hd :: tl => Vptr (Pos.of_nat n) Ptrofs.zero = block_ptr hd /\ disjoint_blocks (n+1) tl
  end.

Fixpoint inv_memory_regions (m:mem) (mrs: list memory_region): Prop :=
  match mrs with
  | [] => True
  | hd :: tl => inv_memory_region m hd /\ inv_memory_regions m tl
  end.

Lemma In_inv_memory_regions:
  forall mr m l,
    List.In mr l -> inv_memory_regions m l ->
      inv_memory_region m mr.
Proof.
  intros.
  induction l;
  simpl in *.
  inversion H.
  destruct H.
  - subst. intuition.
  - apply IHl.
    assumption.
    intuition.
Qed.

Definition memory_inv (st: state): Prop :=
  (1 <= mrs_num st)%nat /\
  List.length (bpf_mrs st) = mrs_num st /\
  (exists start_blk,
    disjoint_blocks start_blk (bpf_mrs st)) /\
  inv_memory_regions (bpf_m st) (bpf_mrs st).

Fixpoint is_byte_list_memval (l: list memval): Prop :=
  match l with
  | nil => True
  | hd :: tl => is_byte_memval hd /\ is_byte_list_memval tl
  end.

Lemma memval_proj_bytes_some:
    forall l, is_byte_list_memval l ->
      exists lb, proj_bytes l = Some lb.
Proof.
  intros l H.
  unfold proj_bytes.
  induction l.
  - exists nil; reflexivity.
  - simpl in H.
    destruct H.
    apply (is_byte_memval_iff _) in H; destruct H.
    rewrite H.
    apply IHl in H0; destruct H0.
    rewrite H0.
    exists (x::x0); reflexivity.
Qed.

Definition is_vlong_or_vint (v: val): Prop :=
  match v with
  | Vlong _ | Vint _ => True
  | _ => False
  end.

Lemma is_vlong_or_vint_iff_some:
  forall v, is_vlong_or_vint v <->
    (exists vl, v = Vlong vl) \/ exists vi, v = Vint vi.
Proof.
  split; intros.
  - destruct v; try inversion H.
    + right; exists i; reflexivity.
    + left; exists i; reflexivity.
  - do 2 destruct H; rewrite H; apply I.
Qed.

Lemma decode_val_byte_some_vlong_or_vint:
  forall chunk l,
    is_well_chunk chunk ->
    is_byte_list_memval l ->
      (exists vl, decode_val chunk l = Vlong vl) \/ (exists vi, decode_val chunk l = Vint vi).
Proof.
  intros chunk l IWC IBLM.
  unfold decode_val.
  apply memval_proj_bytes_some in IBLM; destruct IBLM.
  rewrite H.
  destruct chunk; simpl in IWC; try contradiction.
  - right; exists (Int.zero_ext 8 (Int.repr (decode_int x))); reflexivity.
  - right; exists (Int.zero_ext 16 (Int.repr (decode_int x))); reflexivity.
  - right; exists (Int.repr (decode_int x)); reflexivity.
  - left;  exists (Int64.repr (decode_int x)); reflexivity.
Qed.

Lemma inv_memory_region_freeable_implies_is_byte_memval:
  forall b m lo hi,
    Mem.range_perm m b lo hi Cur Readable ->
    is_byte_block b m ->
     forall ofs, lo <= ofs < hi -> is_byte_memval (ZMap.get ofs (Mem.mem_contents m) !! b).
Proof.
  unfold is_byte_block.
  intros.
  apply (H0 ofs) in H; try assumption.
Qed.

Lemma getN_byte_list_memval:
  forall chunk m b lo hi,
    Mem.range_perm m b lo hi Cur Readable ->
    is_byte_block b m ->
    is_well_chunk chunk ->
      forall ofs, lo <= ofs /\ ofs + (size_chunk chunk) < hi -> is_byte_list_memval (Mem.getN (size_chunk_nat chunk) ofs ((Mem.mem_contents m) !! b)).
Proof.
  intro chunk.
  assert (Ha: forall x y z n, x <= y /\ y + (size_chunk chunk) < z -> 0 <=n <= (size_chunk chunk) -> x <= y+n < z). {
    intros x y z n H0 H1.
    unfold size_chunk in *; destruct chunk; try lia.
  }
  intros m b lo hi H0 H1 H2.
  assert (Hb: forall ofs, lo <= ofs < hi -> is_byte_memval (ZMap.get ofs (Mem.mem_contents m) !! b)). {
    apply (inv_memory_region_freeable_implies_is_byte_memval _ _ _ _); assumption.
  }
  unfold size_chunk_nat, size_chunk.
  destruct chunk eqn:k in H2; try contradiction; subst; simpl; simpl in *; unfold is_byte_list_memval, Mem.getN; intros ofs H3.
  - split; try (apply I).
    apply (Hb _); assert (H4: lo <= ofs + 0 < hi -> lo <= ofs < hi); try lia.
  - split.
    apply (Hb _); assert (H4: lo <= ofs + 0 < hi -> lo <= ofs < hi); try lia.
    split; try (apply I).
    apply (Hb _); apply (Ha _ _ _ 1); lia.
  - split.
    apply (Hb _); assert (H4: lo <= ofs + 0 < hi -> lo <= ofs < hi); try lia.
    split.
    apply (Hb _); apply (Ha _ _ _ 1); lia.
    split.
    apply (Hb _); assert (H4: lo <= ofs + 2 < hi -> lo <= ofs+1+1 < hi); try lia.
    split;try (apply I).
    apply (Hb _); assert (H4: lo <= ofs + 3 < hi -> lo <= ofs+1+1+1 < hi); try lia.
  - split.
    apply (Hb _); assert (H4: lo <= ofs + 0 < hi -> lo <= ofs < hi); try lia.
    split.
    apply (Hb _); apply (Ha _ _ _ 1); lia.
    split.
    apply (Hb _); assert (H4: lo <= ofs + 2 < hi -> lo <= ofs+1+1 < hi); try lia.
    split.
    apply (Hb _); assert (H4: lo <= ofs + 3 < hi -> lo <= ofs+1+1+1 < hi); try lia.
    split.
    apply (Hb _); assert (H4: lo <= ofs + 4 < hi -> lo <= ofs+1+1+1+1 < hi); try lia.
    split.
    apply (Hb _); assert (H4: lo <= ofs + 5 < hi -> lo <= ofs+1+1+1+1+1 < hi); try lia.
    split.
    apply (Hb _);
    assert (H4: lo <= ofs + 6 < hi -> lo <= ofs+1+1+1+1+1+1 < hi); try lia.
    split.
    apply (Hb _);
    assert (H4: lo <= ofs + 7 < hi -> lo <= ofs+1+1+1+1+1+1+1 < hi); try lia.
    split;try (apply I).
Qed.

Lemma load_some_well_chunk_vlong_or_vint:
  forall m mr chunk b ofs v len,
    inv_memory_region m mr ->
    block_ptr mr = Vptr b Ptrofs.zero ->
    block_size mr = Vint len ->
    is_well_chunk chunk ->
    0 <= ofs /\ ofs + size_chunk chunk < Int.unsigned len ->
    Mem.load chunk m b ofs = Some v ->
      is_vlong_or_vint v.
Proof.
  Transparent Mem.load.
  unfold Mem.load.
  intros m mr chunk b ofs v len IMR Hptr Hsize IWC Hrange Hload.
  destruct IMR as [bi [Hi1 [Hi2 [Hi3 [basei [leni [Hi4 [Hi5 [Hpermi Hi6]]]]]]]]].
  rewrite Hi1 in Hptr; inversion Hptr; subst.
  rewrite Hi5 in Hsize; inversion Hsize; subst.
  assert (HpermReadable: Mem.range_perm m b 0 (Int.unsigned len) Cur Readable). {
    eapply Mem.range_perm_implies; eauto.
  }

  unfold inv_memory_region in Hload.
  destruct (Mem.valid_access_dec _ _ _ _ _) in Hload.
  - assert (Hiblm: forall o,
      0%Z <= o /\ o + (size_chunk chunk) < Int.unsigned len ->
      is_byte_list_memval (Mem.getN (size_chunk_nat chunk) o ((Mem.mem_contents m) !! b))). {
        apply (getN_byte_list_memval _ _ _ _ _ HpermReadable Hi3 IWC).
    }
    apply (Hiblm _) in Hrange.
    inversion Hload.
    rewrite -> H0 in *.
    set (l := Mem.getN (size_chunk_nat chunk) ofs (Mem.mem_contents m) !! b).
    assert (Hdecode: (exists vl, v = Vlong vl) \/ (exists vi, v = Vint vi)). {
      rewrite <- H0.
      apply (decode_val_byte_some_vlong_or_vint _ _ IWC Hrange).
    }
    rewrite -> is_vlong_or_vint_iff_some; assumption.
  - inversion Hload.
Qed.

Lemma range_perm_included:
  forall m b p lo hi ofs_lo ofs_hi,
    lo <= ofs_lo -> ofs_lo < ofs_hi -> ofs_hi < hi ->
    Mem.range_perm m b lo hi Cur p ->
      Mem.range_perm m b ofs_lo ofs_hi Cur p.
Proof.
  intros.
  apply (Mem.range_perm_implies _ _ _ _ _ p _). 2:{ constructor. }
  unfold Mem.range_perm in *; intros.
  apply H2.
  lia.
Qed.

(** Store operations *)

Lemma inj_bytes_is_byte_list_memval:
  forall bl,
    is_byte_list_memval (inj_bytes bl).
Proof.
  unfold is_byte_list_memval, is_byte_memval.
  induction bl.
  - simpl. apply I.
  - simpl.
    split; try (apply I).
    assumption.
Qed.

Lemma encode_val_is_byte_list_memval:
  forall chunk v src
    (Hwell_chunk: is_well_chunk chunk)
    (Hvlong: exists vl, v = Vlong vl)
    (Hvint_vlong: vlong_to_vint_or_vlong chunk v = src),
    is_byte_list_memval (encode_val chunk src).
Proof.
  unfold vlong_to_vint_or_vlong.
  intros.
  destruct Hvlong as [vl Hvlong].
  rewrite -> Hvlong in Hvint_vlong.
  destruct chunk in *; try inversion Hwell_chunk; rewrite <- Hvint_vlong; simpl; try apply (inj_bytes_is_byte_list_memval _).
Qed.

Lemma encode_val_is_byte_list_memval_vint:
  forall chunk v src
    (Hwell_chunk: is_well_chunk chunk)
    (Hvint: exists vi, v = Vint vi)
    (Hvint_vlong: vint_to_vint_or_vlong chunk v = src),
    is_byte_list_memval (encode_val chunk src).
Proof.
  unfold vint_to_vint_or_vlong.
  intros.
  destruct Hvint as [vl Hvint].
  rewrite -> Hvint in Hvint_vlong.
  destruct chunk in *; try inversion Hwell_chunk; rewrite <- Hvint_vlong; simpl; try apply (inj_bytes_is_byte_list_memval _).
Qed.

Lemma setN_other_is_byte_list_memval:
  forall vl c p q,
    is_byte_list_memval vl ->
    is_byte_memval (ZMap.get q c) ->
    p <= q < p + Z_of_nat (length vl) ->
      is_byte_memval (ZMap.get q (Mem.setN vl p c)).
Proof.
  induction vl; intros; unfold is_byte_list_memval, is_byte_memval in *; simpl.
  - assumption.
  - destruct (zeq p q).
    + subst q.
      rewrite Mem.setN_outside.
      * rewrite ZMap.gss.
        destruct H as [Ha H]; assumption.
      * left; lia.
    + apply IHvl.
      * destruct H as [Ha H]; assumption.
      * rewrite ZMap.gso.
        assumption.
        lia.
      * simpl length in H1; rewrite inj_S in H1.
        lia.
Qed.

Lemma get_setN_is_byte_list_memval:
  forall vl c p q,
    is_byte_list_memval vl ->
    is_byte_memval (ZMap.get q c) ->
    ~(p <= q < p + Z_of_nat (length vl)) ->
      is_byte_memval (ZMap.get q (Mem.setN vl p c)).
Proof.
  intros; unfold is_byte_list_memval, is_byte_memval in *; simpl.
  destruct (zle p q).
  destruct (zlt q (p + Z.of_nat (length vl))).
  - apply (setN_other_is_byte_list_memval _ _ _ _ H H0).
    split; assumption.
  - rewrite Mem.setN_outside.
    assumption.
    right; assumption.
  - rewrite Mem.setN_outside.
    assumption.
    left; lia.
Qed.

Lemma setN_is_byte_list_memval:
  forall vl c p q,
    is_byte_list_memval vl ->
    is_byte_memval (ZMap.get q c) ->
      is_byte_memval (ZMap.get q (Mem.setN vl p c)).
Proof.
  intros.
  destruct (zle p q).
  destruct (zlt q (p + Z_of_nat (length vl))).
  - apply (setN_other_is_byte_list_memval _ _ _ _ H H0).
    split; assumption.
  - apply (get_setN_is_byte_list_memval _ _ _ _ H H0).
    lia.
  - apply (get_setN_is_byte_list_memval _ _ _ _ H H0).
    lia.
Qed.

Lemma store_is_byte_block:
  forall chunk m1 blk ofs v m2
    (Hwell_chunk: is_well_chunk chunk)
    (Hvlong: exists vl, v = Vlong vl)
    (Hstore: Mem.store chunk m1 blk ofs (vlong_to_vint_or_vlong chunk v) = Some m2)
    (His_byte: is_byte_block blk m1),
      is_byte_block blk m2.
Proof.
  intros.
  unfold is_byte_block.
  intros o Hperm.
  apply (Mem.perm_store_2 _ _ _ _ _ _ Hstore) in Hperm.
  apply His_byte in Hperm.

  Transparent Mem.store.
  unfold Mem.store in Hstore.
  destruct (Mem.valid_access_dec _ _ _ _ _) in Hstore. 2:{ inversion Hstore. }
  inversion Hstore; clear Hstore H0.
  simpl.

  assert (His_byte_list: is_byte_list_memval (encode_val chunk (vlong_to_vint_or_vlong chunk v))). {
    apply (encode_val_is_byte_list_memval _ _ _ Hwell_chunk Hvlong); reflexivity.
  }
  rewrite PMap.gss.
  apply (setN_is_byte_list_memval _ _ _ _ His_byte_list Hperm).
Qed.

Lemma store_is_byte_block_vint:
  forall chunk m1 blk ofs v m2
    (Hwell_chunk: is_well_chunk chunk)
    (HVint: exists vi, v = Vint vi)
    (Hstore: Mem.store chunk m1 blk ofs (vint_to_vint_or_vlong chunk v) = Some m2)
    (His_byte: is_byte_block blk m1),
      is_byte_block blk m2.
Proof.
  intros.
  unfold is_byte_block.
  intros o Hperm.
  apply (Mem.perm_store_2 _ _ _ _ _ _ Hstore) in Hperm.
  apply His_byte in Hperm.

  Transparent Mem.store.
  unfold Mem.store in Hstore.
  destruct (Mem.valid_access_dec _ _ _ _ _) in Hstore. 2:{ inversion Hstore. }
  inversion Hstore; clear Hstore H0.
  simpl.

  assert (His_byte_list: is_byte_list_memval (encode_val chunk (vint_to_vint_or_vlong chunk v))). {
    apply (encode_val_is_byte_list_memval_vint _ _ _ Hwell_chunk HVint); reflexivity.
  }
  rewrite PMap.gss.
  apply (setN_is_byte_list_memval _ _ _ _ His_byte_list Hperm).
Qed.

Lemma store_is_byte_block_disjoint:
  forall chunk m1 m2 b1 b2 ofs v,
    is_byte_list_memval (encode_val chunk v) ->
    Mem.store chunk m1 b1 ofs v = Some m2 ->
    b1 <> b2 ->
    is_byte_block b1 m1 ->
    is_byte_block b2 m1 ->
      is_byte_block b2 m2.
Proof.
  unfold is_byte_block.
  intros.
  assert (H5:= H0).
  unfold Mem.store in H0.
  destruct (Mem.valid_access_dec _ _ _ _ _); try inversion H0.
  simpl.
  rewrite PMap.gso. 2:{ lia. }
  apply H3.
  apply (Mem.perm_store_2 _ _ _ _ _ _ H5).
  assumption.
Qed.

Lemma store_is_region_freeable_disjoint:
  forall chunk m1 m2 b1 b2 ofs v lo_1 hi_1 lo_2 hi_2 p,
    is_byte_list_memval (encode_val chunk v) ->
    Mem.store chunk m1 b1 ofs v = Some m2 ->
    b1 <> b2 ->
    Mem.range_perm m1 b1 lo_1 hi_1 Cur p ->
    Mem.range_perm m1 b2 lo_2 hi_2 Cur p ->
      Mem.range_perm m2 b2 lo_2 hi_2 Cur p.
Proof.
  unfold Mem.range_perm.
  intros.
  apply H3 in H4.
  apply (Mem.perm_store_1 _ _ _ _ _ _ H0 _ _ _ _ H4).
Qed.

Lemma store_memory_region_including:
  forall m1 m2 mr1 mr2 b1 b2 len1 len2 chunk ofs v,
    inv_memory_region m1 mr1 ->
    block_ptr mr1 = Vptr b1 Ptrofs.zero ->
    block_size mr1 = Vint len1 ->
    inv_memory_region m1 mr2 ->
    block_ptr mr2 = Vptr b2 Ptrofs.zero ->
    block_size mr2 = Vint len2 ->
    b1 <> b2 ->
    Mem.store chunk m1 b1 ofs v = Some m2 ->
    is_byte_list_memval (encode_val chunk v) ->
    inv_memory_region m2 mr2.
Proof.
  intros.
  destruct H as [blk1 [Hptr1 [Hvalid_blk1 [Hbyte1 [start1 [len_1 [Haddr1 [Hlen1 Hperm1]]]]]]]].
  rewrite Hptr1 in H0; inversion H0; subst blk1; clear H0.
  rewrite Hlen1 in H1; inversion H1; subst len_1; clear H1.

  destruct H2 as [blk2 [Hptr2 [Hvalid_blk2 [Hbyte2 [start2 [len_2 [Haddr2 [Hlen2 Hperm2]]]]]]]].
  rewrite Hptr2 in H3; inversion H3; subst blk2; clear H3.
  rewrite Hlen2 in H4; inversion H4; subst len_2; clear H4.

  unfold inv_memory_region.
  exists b2.
  split; try assumption.
  split.
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ H6 _ Hvalid_blk2).
  split.
  apply (store_is_byte_block_disjoint _ _ _ _ _ _ _ H7 H6 H5 Hbyte1 Hbyte2).
  exists start2, len2.
  split; try assumption.
  split; try assumption.
  unfold Mem.range_perm in *.
  split; [intuition | idtac].
  intros ofs0 Hofs0_range.
  apply Hperm2 in Hofs0_range.
  apply (Mem.perm_store_1 _ _ _ _ _ _ H6); assumption.
Qed.

(*
Definition inv_memory_regions_state (st: state) := inv_memory_regions (eval_mem st) (eval_mem_regions st). *)

(** alu: upd_reg wiil never have effect on memory and memory regions *)
Lemma mem_inv_upd_reg_mem:
  forall st1 st2 r n
    (Halu: upd_reg r (Vlong n) st1 = st2),
      eval_mem st1 = eval_mem st2.
Proof.
  unfold upd_reg, eval_mem; intros.
  inversion Halu.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_reg_memregions:
  forall st1 st2 r n
    (Halu: upd_reg r (Vlong n) st1 = st2),
      eval_mem_regions st1 = eval_mem_regions st2.
Proof.
  unfold upd_reg, eval_mem_regions; intros.
  inversion Halu.
  simpl; reflexivity.
Qed.

(** alu: upd_flag wiil have no effect on memory and memory regions *)
Lemma mem_inv_upd_flag_mem:
  forall st1 st2 f
    (Halu: upd_flag f st1 = st2),
      eval_mem st1 = eval_mem st2.
Proof.
  unfold upd_flag, eval_mem; intros.
  inversion Halu.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_flag_memregions:
  forall st1 st2 f
    (Halu: upd_flag f st1 = st2),
      eval_mem_regions st1 = eval_mem_regions st2.
Proof.
  unfold upd_flag, eval_mem_regions; intros.
  inversion Halu.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_mem_mem:
  forall st1 st2 m
    (Hmem: upd_mem m st1 = st2),
      eval_mem st2 = m.
Proof.
  unfold upd_mem, eval_mem; intros.
  inversion Hmem.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_mem_memregions:
  forall st1 st2 m
    (Hmem: upd_mem m st1 = st2),
      eval_mem_regions st1 = eval_mem_regions st2.
Proof.
  unfold upd_mem, eval_mem_regions; intros.
  inversion Hmem.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_pc_incr_mem:
  forall st1 st2
    (Hpc: upd_pc_incr st1 = st2),
      eval_mem st1 = eval_mem st2.
Proof.
  unfold upd_pc_incr, eval_mem; intros.
  inversion Hpc.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_pc_incr_memregions:
  forall st1 st2
    (Hpc: upd_pc_incr st1 = st2),
      eval_mem_regions st1 = eval_mem_regions st2.
Proof.
  unfold upd_pc_incr, eval_mem_regions; intros.
  inversion Hpc.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_pc_mem:
  forall st1 st2 p
    (Hpc: upd_pc p st1 = st2),
      eval_mem st1 = eval_mem st2.
Proof.
  unfold upd_pc, eval_mem; intros.
  inversion Hpc.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_pc_memregions:
  forall st1 st2 p
    (Hpc: upd_pc p st1 = st2),
      eval_mem_regions st1 = eval_mem_regions st2.
Proof.
  unfold upd_pc, eval_mem_regions; intros.
  inversion Hpc.
  simpl; reflexivity.
Qed.

Lemma mem_inv_upd_reg:
  forall st1 st2 r n
    (Hmem_inv: memory_inv st1)
    (Halu: upd_reg r (Vlong n) st1 = st2),
      memory_inv st2.
Proof.
  unfold memory_inv, upd_reg.
  intros.
  rewrite <- Halu.
  simpl.
  assumption.
Qed.

Lemma mem_inv_upd_flag:
  forall st1 st2 f
    (Hmem_inv: memory_inv st1)
    (Hflag: upd_flag f st1 = st2),
      memory_inv st2.
Proof.
  unfold memory_inv, upd_flag.
  intros.
  rewrite <- Hflag.
  simpl.
  assumption.
Qed.

Lemma Mem_range_perm_store:
  forall m m0 b b0 lo hi k p chunk i v
  (Hrange_perm : Mem.range_perm m0 b0 lo hi k p)
  (Hstore : Mem.store chunk m0 b i v = Some m),
    Mem.range_perm m b0 lo hi k p.
Proof.
  unfold Mem.range_perm.
  intros.
  eapply Mem.perm_store_1; eauto.
Qed.

Lemma mem_inv_store_mem_regions_vlong:
  forall m m0 chunk l b i vl
    (Hwell_chunk: is_well_chunk chunk)
    (Hmem_inv : inv_memory_regions m0 l)
    (Hstore: Mem.store chunk m0 b (Ptrofs.unsigned i) (vlong_to_vint_or_vlong chunk (Vlong vl)) = Some m),
      inv_memory_regions m l.
Proof.
  induction l.
  simpl; intros.
  constructor.

  simpl; intros.
  destruct Hmem_inv as (Hmem_inv_mr & Hmem_inv_mrs).
  split.
  -
    unfold inv_memory_region in *.
    destruct Hmem_inv_mr as (b0 & Hptr & Hvalid & Hbyte & base & len & Hstart & Hsize & Hperm & Hrange_perm).
    exists b0.
    repeat (split; [try assumption | idtac]).
    + eapply Mem.store_valid_block_1; eauto.
    + destruct ((b =? b0)%positive) eqn: Hb_eq.
      * rewrite Pos.eqb_eq in Hb_eq.
        subst.
        eapply store_is_byte_block; eauto.
      * rewrite Pos.eqb_neq in Hb_eq.
        unfold is_byte_block in *.
        erewrite Mem.store_mem_contents; eauto.
        erewrite PMap.gso; eauto.
        intros.
        apply Hbyte.
        eapply Mem.perm_store_2; eauto.
    + exists base, len.
      repeat (split; [try assumption | idtac]).
      eapply Mem_range_perm_store; eauto.
  - eapply IHl; eauto.
Qed.

Lemma mem_inv_store_mem_regions_vint:
  forall m m0 chunk l b i vl
    (Hwell_chunk: is_well_chunk chunk)
    (Hmem_inv : inv_memory_regions m0 l)
    (Hstore: Mem.store chunk m0 b (Ptrofs.unsigned i) (vint_to_vint_or_vlong chunk (Vint vl)) = Some m),
      inv_memory_regions m l.
Proof.
  induction l.
  simpl; intros.
  constructor.

  simpl; intros.
  destruct Hmem_inv as (Hmem_inv_mr & Hmem_inv_mrs).
  split.
  -
    unfold inv_memory_region in *.
    destruct Hmem_inv_mr as (b0 & Hptr & Hvalid & Hbyte & base & len & Hstart & Hsize & Hperm & Hrange_perm).
    exists b0.
    repeat (split; [try assumption | idtac]).
    + eapply Mem.store_valid_block_1; eauto.
    + destruct ((b =? b0)%positive) eqn: Hb_eq.
      * rewrite Pos.eqb_eq in Hb_eq.
        subst.
        eapply store_is_byte_block_vint with (v:= Vint vl); eauto.
      * rewrite Pos.eqb_neq in Hb_eq.
        unfold is_byte_block in *.
        erewrite Mem.store_mem_contents; eauto.
        erewrite PMap.gso; eauto.
        intros.
        apply Hbyte.
        eapply Mem.perm_store_2; eauto.
    + exists base, len.
      repeat (split; [try assumption | idtac]).
      eapply Mem_range_perm_store; eauto.
  - eapply IHl; eauto.
Qed.

Lemma mem_inv_store_length:
  forall st1 st2 m chunk b i vl
    (Hmem_inv : Datatypes.length (bpf_mrs st1) = mrs_num st1)
    (Hstore: Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned i) (vlong_to_vint_or_vlong chunk (Vlong vl)) = Some m)
    (Hst2: upd_mem m st1 = st2),
      Datatypes.length (bpf_mrs st2) = mrs_num st2.
Proof.
  intros.
  subst.
  unfold upd_mem, bpf_mrs in *.
  intuition.
Qed.

Lemma mem_inv_store_disjoint:
  forall st1 st2 m chunk b i vl
    (Hmem_inv : disjoint_blocks 0 (bpf_mrs st1))
    (Hstore: Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned i) (vlong_to_vint_or_vlong chunk (Vlong vl)) = Some m)
    (Hst2: upd_mem m st1 = st2),
      disjoint_blocks 0 (bpf_mrs st2).
Proof.
  intros.
  subst.
  unfold upd_mem, bpf_mrs in *.
  intuition.
Qed.

Lemma mem_inv_store_length_vint:
  forall st1 st2 m chunk b i vl
    (Hmem_inv : Datatypes.length (bpf_mrs st1) = mrs_num st1)
    (Hstore: Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned i) (vint_to_vint_or_vlong chunk (Vint vl)) = Some m)
    (Hst2: upd_mem m st1 = st2),
      Datatypes.length (bpf_mrs st2) = mrs_num st2.
Proof.
  intros.
  subst.
  unfold upd_mem, bpf_mrs in *.
  intuition.
Qed.

Lemma mem_inv_store_disjoint_vint:
  forall st1 st2 m chunk b i vl blk
    (Hmem_inv : disjoint_blocks blk (bpf_mrs st1))
    (Hstore: Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned i) (vint_to_vint_or_vlong chunk (Vint vl)) = Some m)
    (Hst2: upd_mem m st1 = st2),
      disjoint_blocks blk (bpf_mrs st2).
Proof.
  intros.
  subst.
  unfold upd_mem, bpf_mrs in *.
  intuition.
Qed.

Lemma store_mem_reg_well_chunk:
  forall st1 chunk addr src
    (Hwell_chunk: is_well_chunk chunk),
    store_mem_reg addr chunk (Vlong src) st1 =
    match
      Mem.storev chunk (bpf_m st1) addr (vlong_to_vint_or_vlong chunk (Vlong src))
    with
    | Some m => Some (upd_mem m st1)
    | None => None
    end.
Proof.
  unfold is_well_chunk, store_mem_reg; intros.
  destruct chunk; try inversion Hwell_chunk.
  all: reflexivity.
Qed.

Lemma mem_inv_store_reg:
  forall st1 st2 chunk addr src
    (Hwell_chunk: is_well_chunk chunk)
    (Hmem_inv: memory_inv st1)
    (Hstore: store_mem_reg addr chunk (Vlong src) st1 = Some st2),
      memory_inv st2.
Proof.
  intros.
  rewrite store_mem_reg_well_chunk in Hstore; [| assumption].
  unfold vlong_to_vint_or_vlong, Mem.storev in Hstore.
  assert (Hmem_inv' := Hmem_inv).
  unfold memory_inv in Hmem_inv'.
  destruct Hmem_inv' as (Hmem_inv_low & Hmem_inv_length & Hmem_inv_disjoint &_ ).
  unfold memory_inv.

  destruct addr; try inversion Hstore; clear Hstore.
  destruct Mem.store eqn: Hstore; try inversion H0.
  clear H0.

  split.
  unfold upd_mem; simpl; assumption.
  split.
  eapply mem_inv_store_length; eauto.
  split.
  destruct Hmem_inv_disjoint as (start_blk & Hmem_inv_disjoint).
  exists start_blk. unfold upd_mem; simpl. assumption.

  subst.
  clear Hmem_inv_length Hmem_inv_disjoint.
  eapply mem_inv_store_mem_regions_vlong; eauto.
  unfold memory_inv in Hmem_inv.
  intuition.
Qed.

Lemma mem_inv_store_imm_well_chunk:
  forall st1 chunk addr i
    (Hwell_chunk: is_well_chunk chunk),
      store_mem_imm addr chunk (Vint i) st1 =
       match
         match addr with
         | Vptr b ofs =>
             Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned ofs)
               (vint_to_vint_or_vlong chunk (Vint i))
         | _ => None
         end
       with
       | Some m => Some (upd_mem m st1)
       | None => None
       end.
Proof.
  unfold is_well_chunk, store_mem_imm; intros.
  destruct chunk; try inversion Hwell_chunk.
  all: reflexivity.
Qed.

Lemma mem_inv_store_imm:
  forall st1 st2 chunk addr i
    (Hwell_chunk: is_well_chunk chunk)
    (Hmem_inv: memory_inv st1)
    (Hstore: store_mem_imm addr chunk (Vint i) st1 = Some st2),
      memory_inv st2.
Proof.
  intros.
  rewrite mem_inv_store_imm_well_chunk in Hstore; [| assumption].
  unfold rBPFAST.vlong_to_vint_or_vlong, Mem.storev in Hstore.
  assert (Hmem_inv' := Hmem_inv).
  unfold memory_inv in Hmem_inv'.
  destruct Hmem_inv' as (Hmem_inv_low & Hmem_inv_length & Hmem_inv_disjoint &_ ).
  unfold memory_inv.

  destruct addr; try inversion Hstore; clear Hstore.
  destruct (Mem.store chunk (bpf_m st1) b (Ptrofs.unsigned i0)) eqn: Hstore; try inversion H0.
  clear H0.

  unfold upd_mem; simpl.
  split; [assumption |].
  split; [assumption |].
  split; [assumption |].

  subst.
  clear Hmem_inv_length Hmem_inv_disjoint.
  eapply mem_inv_store_mem_regions_vint; eauto.
  unfold memory_inv in Hmem_inv.
  intuition.
Qed.

Lemma mem_inv_upd_pc:
  forall st1 st2 p
    (Hmem_inv: memory_inv st1)
    (Hpc: upd_pc p st1 = st2),
      memory_inv st2.
Proof.
  unfold memory_inv.
  intros.
  rewrite <- Hpc.
  simpl; assumption.
Qed.

Lemma mem_inv_upd_pc_incr:
  forall st1 st2
    (Hmem_inv: memory_inv st1)
    (Hpc: upd_pc_incr st1 = st2),
      memory_inv st2.
Proof.
  unfold memory_inv.
  intros.
  rewrite <- Hpc.
  simpl; assumption.
Qed.

Close Scope Z_scope.


Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.
Require Import Coq.Classes.RelationClasses.

Require Import dqtt_ott.
Require Import dqtt_inf.
Require Import usage.
Require Import dctx.
Require Import dctx_sub.
Require Import semimodule.
Require Import tactics.

Require Import beta.
Require Import structural.

(* ------------------------------------------------------- *)

Lemma invert_Type {D G A} :
  Typing D G a_Type A ->
  exists G1, Beta (subst_def D A) a_Type /\ ctx_mul 0 G1 = G1 /\ ctx_sub D G1 G.
Proof.
  intros HA.
  dependent induction HA.
  - destruct IHHA as [G3 [h0 [ h1 h2]]]; auto.
    exists G3. subst. repeat split; auto. transitivity G1; auto.
  - exists nil. repeat split; auto.

  - (* T_weak *) destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Tm A) ++ G3). repeat split; auto. simpl.  ring_simpl. f_equal.  auto.
    econstructor; auto. reflexivity.
  - (* T_weak_def *) destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Def a A) ++ G3).
    repeat split. asimpl.
    erewrite subst_def_subst_tm_tm; eauto.
    replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
    eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
    eauto using Typing_ctx_wff_regularity.
    asimpl. f_equal. auto.
    econstructor; auto. reflexivity.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto.
    exists G3. repeat split; auto.
    asimpl.
    eapply B_Trans. eapply B_Sym. eauto. eauto.
Qed.

Lemma invert_Unit {D G A} :
  Typing D G a_TmUnit A ->
  exists G1, Beta (subst_def D A) a_TyUnit /\ ctx_mul 0 G1 = G1 /\ ctx_sub D G1 G.
Proof.
  intros HA.
  dependent induction HA.
  - destruct IHHA as [G3 [h0 [ h1 h2]]]; auto.
    exists G3. subst. repeat split; auto. transitivity G1; auto.
  - (* T_weak *) destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Tm A) ++ G3). repeat split; auto. simpl.  ring_simpl. f_equal.  auto.
    econstructor; auto. reflexivity.
  - (* T_weak_def *) destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Def a A) ++ G3).
    repeat split.
    asimpl.
    erewrite subst_def_subst_tm_tm; eauto.
    replace a_TyUnit with (subst_tm_tm (subst_def D5 a) x a_TyUnit); try reflexivity.
    eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
    eauto using Typing_ctx_wff_regularity.
    asimpl. f_equal. auto.
    econstructor; auto. reflexivity.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto.
    exists G3. repeat split; auto.
    asimpl.
    eapply B_Trans. eapply B_Sym. eauto. eauto.
  - exists nil. repeat split; auto.
Qed.

Lemma invert_box {D G q a A} :
 Typing D G (a_box q a) A ->
 exists A0,
   Beta (subst_def D A) (a_Box q (subst_def D A0)) /\
   exists G0, ctx_sub D (ctx_mul q G0) G /\ Typing D G0 a A0.
Proof.
  intros HA.
  dependent induction HA.
  + edestruct IHHA as [A0 [HB [G0 [SS TA]]]]. eauto.
    eexists. split. eauto.
    exists G0. split.
    transitivity G1; auto. auto.
  + (* T_weak *) clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    exists A0. split. asimpl. auto.
    exists (x ~ (0, Tm A) ++ G0). split.
    econstructor. auto. rewrite qmul_0_r. reflexivity.
    eauto. eauto.
    eapply T_weak. eauto. auto. eauto.
  + (* T_weak_def *) clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    exists A0. split. asimpl.
          erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
          erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
          replace (a_Box q (subst_tm_tm (subst_def D5 a0) x (subst_def D5 A0))) with  (subst_tm_tm (subst_def D5 a0) x (a_Box q (subst_def D5 A0))); try reflexivity.
      eapply subst_Beta1. eauto using subst_def_lc_tm, Typing_lc_ctx, Typing_lc. auto.
    exists (x ~ (0, Def a0 A) ++ G0). split.
    econstructor. auto. rewrite qmul_0_r. reflexivity.
    eauto. eauto.
    eapply T_weak_def. eauto. auto. eauto.
  + clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    eexists.  split. eapply B_Trans. eapply B_Sym; eauto. eauto.
    eexists. split. eauto. auto.
  + clear IHHA.
    eexists.  split.
    rewrite <- subst_def_Box.
    eapply subst_def_Beta; eauto using Typing_lc_ctx.
    eapply B_Refl. econstructor. eapply Typing_lc2; eauto.
    exists G. split.
    eapply ctx_sub_refl. eclarify_ctx. eauto.
Qed.

Lemma invert_Box {D G q A B} :
   Typing D G (a_Box q A) B ->
   Beta (subst_def D B) a_Type /\ Typing D G A a_Type.
Proof.
  intros HA.
  dependent induction HA; intros.
  + specialize (IHHA _ _ ltac:(auto)). destruct IHHA.
    split. auto.
    eapply T_sub; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. auto.
    eapply T_weak; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. asimpl.
    erewrite subst_def_subst_tm_tm; eauto.
    replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
    eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
    eauto using Typing_ctx_wff_regularity.
    eapply T_weak_def; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. eapply B_Trans. eapply B_Sym. eauto. eauto. auto.
  + clear IHHA.
    split.
    rewrite subst_def_Type.
    eapply B_Refl. eauto. eauto.
Qed.

Lemma invert_Pi : forall D G q A B A0,
  Typing D G (a_Pi q A B) A0 ->
  Beta (subst_def D A0) a_Type /\
  exists G1, exists G2, exists r,
      ctx_sub D (ctx_plus G1 G2) G /\
      Typing D G1 A a_Type /\
      forall x, x `notin` dom D \u fv_tm_tm (subst_def D B) ->
           Typing ([(x, Tm A)] ++ D) ([(x, (r, Tm A))] ++ G2)
                  (open_tm_wrt_tm B (a_Var_f x)) a_Type.
Proof.
intros.
dependent induction H.
- (* sub *)
  move: (IHTyping _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? ?]]]]]].
  split; auto.
  eexists. eexists. eexists.
  split; eauto.
  transitivity G1; auto.
- (* weak *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  split; auto.
  clear IHTyping1 IHTyping2.
  exists (x ~ (0,Tm A0) ++ G1'). exists (x ~ (0,Tm A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak; eauto.
  + intros y Fr.
    asimpl in Fr.
    specialize (hb y ltac:(auto)).
    eapply weakening. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    eauto.
- (* weak def *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
  split.
  (* Beta equal to Type *)
  asimpl.
  erewrite subst_def_subst_tm_tm; eauto.
  replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
  eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
  eauto using Typing_ctx_wff_regularity.

  exists (x ~ (0,Def a A0) ++ G1'). exists (x ~ (0,Def a A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak_def; eauto.
  + intros y Fr.
    asimpl in Fr.
    rewrite <- fv_subst_def_lower in Fr; eauto using Typing_ctx_wff_regularity.
    rewrite <- fv_tm_tm_subst_tm_tm_lower in Fr.
    specialize (hb y).
    rewrite -> fv_subst_def in hb; eauto using Typing_ctx_wff_regularity.
    specialize (hb ltac:(fsetdec)).
    eapply weakening_sort. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    econstructor; eauto.
- (* pi *)
  pick fresh z. move:(H0 z ltac:(auto)) => h.
  move: (Typing_ctx h) => C0. destruct_ctx.
  clear IHTyping H1.
  rewrite subst_def_Type.
  split; auto.
  exists G1. exists G2. exists r.
  repeat split.
  + eapply ctx_sub_refl. eclarify_ctx.
  + auto.
  + intros.
  pick fresh y for (L \u {{x}} \u dom D5 \u fv_tm_tm (subst_def D5 B) \u fv_tm_tm B).
  specialize (H0 y ltac:(auto)).
  eapply Typing_rename with (y:= x) in H0; eauto.
  asimpl in H0.
  rewrite <- subst_tm_tm_intro in H0.
  auto.
  fsetdec.
- (* conv *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
  split.
  eapply B_Trans with (A1 := subst_def D5 A0). eapply B_Sym. eauto. eauto.
  eexists. eexists. eexists.
  split.
  2: { split. eauto.
       eauto. }
  transitivity G1. auto.
  eapply ctx_sub_refl. eclarify_ctx.
Qed.

Lemma invert_Sigma : forall D G q A B A0,
  Typing D G (a_Sigma q A B) A0 ->
  Beta (subst_def D A0) a_Type /\
  exists G1, exists G2, exists r,
      ctx_sub D (ctx_plus G1 G2) G /\
      Typing D G1 A a_Type /\
      forall x, x `notin` dom D \u fv_tm_tm (subst_def D B) ->
           Typing ([(x, Tm A)] ++ D) ([(x, (r, Tm A))] ++ G2)
                  (open_tm_wrt_tm B (a_Var_f x)) a_Type.
Proof.
intros.
dependent induction H.
- (* sub *)
  move: (IHTyping _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? ?]]]]]].
  split; auto.
  eexists. eexists. eexists.
  split; eauto.
  transitivity G1; auto.
- (* weak *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  split; auto.
  clear IHTyping1 IHTyping2.
  exists (x ~ (0,Tm A0) ++ G1'). exists (x ~ (0,Tm A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak; eauto.
  + intros y Fr.
    asimpl in Fr.
    specialize (hb y ltac:(auto)).
    eapply weakening. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    eauto.
- (* weak_def *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
  split.
  (* Beta equal to Type *)
  asimpl.
  erewrite subst_def_subst_tm_tm; eauto.
  replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
  eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
  eauto using Typing_ctx_wff_regularity.

  exists (x ~ (0,Def a A0) ++ G1'). exists (x ~ (0,Def a A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak_def; eauto.
  + intros y Fr.
    asimpl in Fr.
    rewrite <- fv_subst_def_lower in Fr; eauto using Typing_ctx_wff_regularity.
    rewrite <- fv_tm_tm_subst_tm_tm_lower in Fr.
    specialize (hb y).
    rewrite -> fv_subst_def in hb; eauto using Typing_ctx_wff_regularity.
    specialize (hb ltac:(fsetdec)).
    eapply weakening_sort. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    econstructor; eauto.
- (* conv *)
  move: (IHTyping1 _ _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
(*   pick fresh z. move: (hb z ltac:(auto)) => Thb. move: (Typing_ctx Thb) => C. destruct_ctx. clear dependent z. *)
  split.
  eapply B_Trans with (subst_def D5 A0); auto.
  eexists. eexists. eexists.
  repeat split; eauto.
- (* sigma *)
  pick fresh z. move:(H0 z ltac:(auto)) => h.
  move: (Typing_ctx h) => C0. destruct_ctx.
  clear IHTyping H1.
  rewrite subst_def_Type.
  split; auto.
  exists G1. exists G2. exists r.
  repeat split.
  + eapply ctx_sub_refl. eclarify_ctx.
  + auto.
  + intros.
  pick fresh y for (L \u {{x}} \u dom D5 \u fv_tm_tm B).
  specialize (H0 y ltac:(auto)).
  eapply Typing_rename with (y:= x) in H0; eauto.
  asimpl in H0.
  rewrite <- subst_tm_tm_intro in H0.
  auto.
  fsetdec.
Qed.

Lemma invert_With : forall D G A B A0,
  Typing D G (a_With A B) A0 ->
  Beta (subst_def D A0) a_Type /\
  exists G1, exists G2, exists r,
      ctx_sub D (ctx_plus G1 G2) G /\
      Typing D G1 A a_Type /\
      forall x, x `notin` dom D \u fv_tm_tm (subst_def D B) ->
           Typing ([(x, Tm A)] ++ D) ([(x, (r, Tm A))] ++ G2)
                  (open_tm_wrt_tm B (a_Var_f x)) a_Type.
Proof.
intros.
dependent induction H.
- (* sub *)
  move: (IHTyping _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? ?]]]]]].
  split; auto.
  eexists. eexists. eexists.
  split; eauto.
  transitivity G1; auto.
- (* weak *)
  move: (IHTyping1 _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  split; auto.
  clear IHTyping1 IHTyping2.
  exists (x ~ (0,Tm A0) ++ G1'). exists (x ~ (0,Tm A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak; eauto.
  + intros y Fr.
    asimpl in Fr.
    specialize (hb y ltac:(auto)).
    eapply weakening. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    eauto.
- (* weak_def *)
  move: (IHTyping1 _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
  split.
  (* Beta equal to Type *)
  asimpl.
  erewrite subst_def_subst_tm_tm; eauto.
  replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
  eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
  eauto using Typing_ctx_wff_regularity.

  exists (x ~ (0,Def a A0) ++ G1'). exists (x ~ (0,Def a A0) ++ G2'). eexists.
  repeat split.
  + asimpl.
    econstructor; eauto.
    reflexivity.
  + eapply T_weak_def; eauto.
  + intros y Fr.
    asimpl in Fr.
    rewrite <- fv_subst_def_lower in Fr; eauto using Typing_ctx_wff_regularity.
    rewrite <- fv_tm_tm_subst_tm_tm_lower in Fr.
    specialize (hb y).
    rewrite -> fv_subst_def in hb; eauto using Typing_ctx_wff_regularity.
    specialize (hb ltac:(fsetdec)).
    eapply weakening_sort. eapply hb.
    move: (Typing_ctx hb) => CB.
    destruct_ctx.
    eclarify_ctx.
    simpl_env. fsetdec.
    econstructor; eauto.
- (* conv *)
  move: (IHTyping1 _ _ ltac:(reflexivity)) => [E [G1' [G2' [r [? [? hb]]]]]].
  clear IHTyping1 IHTyping2.
  split.
  eapply B_Trans with (subst_def D5 A0); auto.
  eexists. eexists. eexists.
  repeat split; eauto.
- (* with *)
  pick fresh z. move:(H0 z ltac:(auto)) => h.
  move: (Typing_ctx h) => C0. destruct_ctx.
  clear IHTyping H1.
  rewrite subst_def_Type.
  split; auto.
  exists G1. exists G2. exists r.
  repeat split.
  + eapply ctx_sub_refl. eclarify_ctx.
  + auto.
  + intros.
  pick fresh y for (L \u {{x}} \u dom D5 \u fv_tm_tm B).
  specialize (H0 y ltac:(auto)).
  eapply Typing_rename with (y:= x) in H0; eauto.
  asimpl in H0.
  rewrite <- subst_tm_tm_intro in H0.
  auto.
  fsetdec.
Qed.

(* Lemma 6.1 *)
Lemma Typing_regularity :
  forall {D G a B}, Typing D G a B -> exists G', Typing D G' B a_Type.
Proof.
  intros. induction H.
  all: try destruct IHTyping as [G' h].
  all: try destruct IHTyping1 as [G1' h1].
  all: try destruct IHTyping2 as [G2' h2].

  all: try solve [eexists; eauto].
  all: try solve [eexists; eapply T_weak; eauto].
  - exists (x ~ (0, Def a A) ++ G').
    eapply weakening_sort with (D1 :=nil) (G1:=nil); eauto.
    econstructor; eauto. eapply Typing_ctx; eauto.
  - exists (x ~ (0, Def a A) ++ G1').
    eapply weakening_sort with (D1 :=nil) (G1:=nil); eauto.
    econstructor; eauto. eapply Typing_ctx; eauto.
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H x ltac:(auto)).
    specialize (H0 x ltac:(auto)).
    destruct H0 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_pi_exists x); eauto.
    asimpl in h0.
    eapply h0.
  - apply invert_Pi in h1.
    move: h1 => [_ [G1'' [G2'' [r [? [? hb]]]]]].
    pick fresh x for (dom D5 \u fv_tm_tm (subst_def D5 B) \u fv_tm_tm B).
    specialize (hb x ltac:(auto)).
    move: (substitution _ nil _ nil _ _ _ _ _ hb _ _ H0) => hs.
    asimpl in hs.
    erewrite <- subst_tm_tm_intro in hs; auto.
    eauto.
  - (* UnitE *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* unbox *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* inj1 *)
    eexists. eapply T_sum; eauto.
  - (* inj2 *)
    eexists. eapply T_sum; eauto.
  - (* case *)
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H1 x ltac:(auto)).
    specialize (H2 x ltac:(auto)).
    destruct H2 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_Sigma_exists x); eauto.
  - (* spread *)
    subst A.
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
  - (* with *)
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    eexists.
    eapply T_With_exists with (x:=x); eauto.
  - (* Prj1 *)
    move: (invert_With _ _ _ _ _ h) => [Be [G0 [G2 [Ta [r [Sub Tb]]]]]].
    eexists.
    eauto.
  - (* Prj2 *)
    move: (invert_With _ _ _ _ _ h) => [Be [G0 [G2 [Ta [r [Sub Tb]]]]]].
    pick fresh z for (dom D5 \u fv_tm_tm (subst_def D5 B) \u fv_tm_tm B).
    specialize (Tb z ltac:(auto)).
    have Tp1: Typing D5 G (a_Prj1 a) A; eauto.
    eapply substitution with (D2 := nil) (G2 := nil)  in Tp1.
    2: { simpl_env. eapply Tb. }
    asimpl in Tp1.
    rewrite subst_tm_tm_open_tm_wrt_tm in Tp1; eauto using Typing_lc.
    rewrite subst_tm_same in Tp1; auto.
    rewrite subst_tm_tm_fresh_eq in Tp1; auto.
    eexists.
    eauto.
Qed.

Lemma invert_Lam D G q a A C :
  Typing D G (a_Lam q A a) C ->
     (forall x, x `notin` fv_tm_tm a `union` dom G `union` dom D ->
           exists B,  Beta (subst_def D C) (subst_def D (a_Pi q A B)) /\
           exists G1, Typing D G1 (a_Pi q A B) a_Type /\
           Typing
             (x ~ Tm A ++ D)
             ([(x, (q, Tm A))] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                                     (open_tm_wrt_tm B (a_Var_f x))).
Proof.
  intros HA.
  dependent induction HA; intros y Fr.
  - have D: dom G1 = dom G2. eapply dom_ctx_sub; eauto.
    rewrite <- D in Fr.
    specialize (IHHA q a A ltac:(auto) y ltac:(auto)).
    move: IHHA => [B [HB [GA [hA HT]]]].
    exists B. split; auto.
    exists GA. split; auto.
    eapply T_sub. eauto. econstructor; eauto. reflexivity.
  - (* T_weak *)
    specialize (IHHA1 _ _ _  ltac:(auto) y ltac:(auto)).
    clear IHHA2.
    move: IHHA1 => [B0 [HB [GA [hA  HT]]]].
    exists B0. split. auto.
    exists (x ~ (0, Tm A0) ++ GA). split.
    eapply T_weak; eauto.
    eapply weakening. eauto. eclarify_ctx. solve_uniq. eauto.
  - (* T_weak_def *)
    specialize (IHHA1 _ _ _  ltac:(auto) y ltac:(auto)).
    clear IHHA2.
    move: IHHA1 => [B0 [HB [GA [hA  HT]]]].
    exists B0. split. simpl.
    rewrite subst_def_Pi.
    repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
    eapply (subst_Beta1 (subst_def D5 a0) x) in HB; eauto using Typing_lc, subst_def_lc_tm, Typing_lc_ctx.
    rewrite subst_def_Pi in HB. simpl in HB. auto.

    exists (x ~ (0, Def a0 A0) ++ GA). split.
    eapply T_weak_def; eauto.
    eapply weakening_sort. eauto. eclarify_ctx. solve_uniq. eauto.

  - (* lam *)
    clear IHHA. clear H0.
    exists B. split.
      eapply subst_def_Beta. eauto using Typing_lc_ctx.
      eapply B_Refl.
      pick fresh z.
      move: (Typing_regularity (H z ltac:(auto))) => [GG TB].
      eapply (lc_a_Pi_exists z);
      eapply Typing_lc; eauto.
    + pick fresh z.
      move: (H z ltac:(auto)) => h.
      move: (Typing_regularity h) => [G h1].
      move: (Typing_ctx h1) => C1.
      destruct_ctx.
      eexists. split.
      eapply (T_pi_exists z); eauto.
      eapply h1.
      move: (Typing_rename _ _ _ z y _ _ _ _ HA h ltac:(auto)) => rn.
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. {  clear Fr H3 H8. fsetdec. }
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. { clear Fr H3 H8. fsetdec. }
      eapply rn.
  - (* conv *)
    specialize (IHHA1 _ _ _ ltac:(reflexivity) y Fr).
    destruct IHHA1 as [B0 [BB [G2' [T1 T2]]]]. clear IHHA2.
    exists B0.
    split. eapply B_Sym. eauto. eauto.
Qed.

Lemma invert_inj1 :
       forall {D G a A}, Typing D G (a_Inj1 a) A ->
                    exists A1, exists A2, exists G1, Beta (subst_def D (a_Sum A1 A2)) (subst_def D A) /\
                                Typing D G a A1 /\ Typing D G1 A2 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. asimpl. eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists.
         split. simpl.
         replace (a_Sum (subst_tm_tm a0 x A1) (subst_tm_tm a0 x A2)) with
                 (subst_tm_tm a0 x (a_Sum A1 A2)); try reflexivity.
         repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
         eapply subst_Beta1; eauto using Typing_lc, subst_def_lc_tm, Typing_lc_ctx.
         split.
         eapply T_weak_def; eauto.
         eapply T_weak_def; eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split.
         eapply subst_def_Beta. eauto using Typing_lc_ctx.
         eapply B_Refl. econstructor. eapply Typing_lc2; eauto. eapply Typing_lc; eauto.
         split; eauto.
Qed.

Lemma invert_inj2 :
       forall {D G a A}, Typing D G (a_Inj2 a) A ->
                    exists A1, exists A2, exists G1, Beta (subst_def D (a_Sum A1 A2)) (subst_def D A) /\
                                Typing D G a A2 /\ Typing D G1 A1 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. asimpl.
         eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists.
         split. simpl.
         replace (a_Sum (subst_tm_tm a0 x A1) (subst_tm_tm a0 x A2)) with
                 (subst_tm_tm a0 x (a_Sum A1 A2)); try reflexivity.
         repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
         eapply subst_Beta1; eauto using Typing_lc, subst_def_lc_tm, Typing_lc_ctx.
         split.
         eapply T_weak_def; eauto.
         eapply T_weak_def; eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split.
         eapply subst_def_Beta. eauto using Typing_lc_ctx.
         eapply B_Refl. econstructor. eapply Typing_lc; eauto. eapply Typing_lc2; eauto.
         split; eauto.
Qed.

Lemma invert_Sum : forall {D G A1 A2 B},
       Typing D G (a_Sum A1 A2) B ->
       Beta (subst_def D B) a_Type /\
       exists G1, exists G2, ctx_sub D (ctx_plus G1 G2) G /\ Typing D G1 A1 a_Type /\ Typing D G2 A2 a_Type.
Proof.
       intros. dependent induction H.
       - destruct (IHTyping _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists G1'. exists G2'.
         split. transitivity G1; auto.
         split; auto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2').
         split. econstructor; eauto. ring_simpl; reflexivity.
         split. eapply T_weak; eauto.
                eapply T_weak; eauto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. asimpl.

         (* Beta equal to Type *)
         asimpl.
         erewrite subst_def_subst_tm_tm; eauto.
         replace a_Type with (subst_tm_tm (subst_def D5 a) x a_Type); try reflexivity.
         eapply subst_Beta1. eapply subst_def_lc_tm; eauto using Typing_lc_ctx, Typing_lc. auto.
         eauto using Typing_ctx_wff_regularity.

         exists (x ~ (0, Def a A) ++ G1'). exists (x ~ (0, Def a A) ++ G2').
         split. econstructor; eauto. ring_simpl; reflexivity.
         split. eapply T_weak_def; eauto.
                eapply T_weak_def; eauto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. eapply B_Trans. eapply B_Sym. eauto. auto.
         exists G1'. exists G2'. split. eauto. split. eauto. eauto.
       - split.
         rewrite subst_def_Type.
         eapply B_Refl. auto.
         exists G1. exists G2. split. eapply ctx_sub_refl. eclarify_ctx.
         split; auto.
Qed.

Lemma invert_Tensor : forall {D G a1 a2 B},
       Typing D G (a_Tensor a1 a2) B ->
       exists A1, exists A2, exists q, Beta (subst_def D B) (subst_def D (a_Sigma q A1 A2)) /\
       exists G1, exists G2, exists G3, exists r,
             ctx_sub D (ctx_plus (ctx_mul q G1) G2) G
             /\ Typing D G1 a1 A1
             /\ Typing D G2 a2 (open_tm_wrt_tm A2 a1)
             /\ (forall x, x `notin` dom D ->
                    Typing (x ~ Tm A1 ++ D) (x ~ (r, Tm A1) ++ G3) (open_tm_wrt_tm A2 (a_Var_f x)) a_Type).
Proof.
  intros. dependent induction H.
  - destruct (IHTyping a1 a2 ltac:(auto)) as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; auto. transitivity G1; auto.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2'). exists (x ~ (0, Tm A) ++ G3). exists r.
    repeat split; auto. econstructor; eauto.  ring_simpl; reflexivity.
    eapply T_weak; eauto.
    eapply T_weak; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. asimpl.
    rewrite subst_def_Sigma.
    repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
    eapply (subst_Beta1 (subst_def D5 a) x) in BA; eauto using Typing_lc, subst_def_lc_tm, Typing_lc_ctx.
    rewrite subst_def_Sigma in BA. simpl in BA. auto.

    exists (x ~ (0, Def a A) ++ G1'). exists (x ~ (0, Def a A) ++ G2'). exists (x ~ (0, Def a A) ++ G3). exists r.
    repeat split; auto. asimpl. econstructor; eauto.  ring_simpl; reflexivity.
    eapply T_weak_def; eauto.
    eapply T_weak_def; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening_sort; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.

  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. eapply B_Trans. eapply B_Sym. eauto. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; eauto.
  -  clear H2 IHTyping1 IHTyping2.
     move: (Typing_ctx H) => C1. move: (Typing_ctx H0) => C2.
     have LC: lc_tm (a_Sigma q A B). {
       pick fresh z.
       eapply lc_a_Sigma_exists. eapply Typing_lc2; eauto.
       eapply Typing_lc; eauto.
     }
     exists A. exists B. exists q. split. eapply subst_def_Beta; eauto using Typing_lc_ctx.
     exists G1. exists G2. exists G3. exists r.
     repeat split; eauto.
     eapply ctx_sub_refl. solve_ctx.
     pick fresh z.
     intros x Frx.
     move: (Typing_regularity H) => [GA TA].
     move: (H1 z ltac:(auto)) => h.
     move: (Typing_regularity h) => [G h1].
     move: (Typing_ctx h1) => C3.
     destruct_ctx.
     move: (Typing_rename _ _ _ z x _ _ _ _ TA h ltac:(auto)) => rn.
     rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
     rewrite subst_tm_same in rn. auto.
     rewrite subst_tm_tm_fresh_eq in rn. { clear Frx H5 H10. fsetdec. }
     asimpl in rn.
     eapply rn.
Qed.

Lemma invert_Pair : forall {D G a1 a2 B},
       Typing D G (a_Pair a1 a2) B ->
       exists A1, exists A2, Beta (subst_def D B) (subst_def D (a_With A1 A2)) /\
       exists G3, exists r,
               Typing D G a1 A1
             /\ Typing D G a2 (open_tm_wrt_tm A2 a1)
             /\ (forall x, x `notin` dom D ->
                    Typing (x ~ Tm A1 ++ D) (x ~ (r, Tm A1) ++ G3)
                           (open_tm_wrt_tm A2 (a_Var_f x)) a_Type).
Proof.
  intros. dependent induction H.
  - (* sub *) destruct (IHTyping a1 a2 ltac:(auto)) as [A1 [A2 [BA [G3 [r [Ta1 [Ta2 U]]]]]]].
    exists A1. exists A2. split. auto.
    exists G3. exists r.
    repeat split; auto.
    eapply T_sub; eauto.
    eapply T_sub; eauto.
  - (* weak *) destruct (IHTyping1 a1 a2 ltac:(auto)) as [A1 [A2 [BA [G3 [r [Ta1 [Ta2 U]]]]]]].
    clear IHTyping2.
    exists A1. exists A2. split. auto.
    exists (x ~ (0, Tm A) ++ G3). exists r.
    repeat split; auto.
    eapply T_weak; eauto.
    eapply T_weak; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.
  - (* weak_def *)
    destruct (IHTyping1 a1 a2 ltac:(auto)) as [A1 [A2 [BA [G3 [r [Ta1 [Ta2 U]]]]]]].
    clear IHTyping2.
    exists A1. exists A2. split. asimpl.
    rewrite subst_def_With.
    repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
    eapply (subst_Beta1 (subst_def D5 a) x) in BA; eauto using Typing_lc, subst_def_lc_tm, Typing_lc_ctx.
    rewrite subst_def_With in BA. simpl in BA. auto.
    exists (x ~ (0, Def a A) ++ G3). exists r.
    repeat split; auto.
    eapply T_weak_def; eauto.
    eapply T_weak_def; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening_sort; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.
  - destruct (IHTyping1 a1 a2 ltac:(auto)) as [A1 [A2 [BA [G3 [r [Ta1 [Ta2 U]]]]]]].
    clear IHTyping2.
    exists A1. exists A2. split. eapply B_Trans. eapply B_Sym. eauto. auto.
    exists G3. exists r.
    repeat split; eauto.
  - clear H2 IHTyping1 IHTyping2.
     move: (Typing_ctx H) => C1. move: (Typing_ctx H0) => C2.
     have LC: lc_tm (a_With A B). {
       pick fresh z.
       eapply lc_a_With_exists. eapply Typing_lc2; eauto.
       eapply Typing_lc; eauto.
     }
     exists A. exists B. split. eapply subst_def_Beta; eauto using Typing_lc_ctx.
     exists G2. exists r.
     repeat split; eauto.
     pick fresh z.
     intros x Frx.
     move: (Typing_regularity H) => [GA TA].
     move: (H1 z ltac:(auto)) => h.
     move: (Typing_ctx h) => C3.
     destruct_ctx.
     move: (Typing_rename _ _ _ z x _ _ _ _ TA h ltac:(auto)) => rn.
     rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
     rewrite subst_tm_same in rn. auto.
     rewrite subst_tm_tm_fresh_eq in rn. { fsetdec. }
     asimpl in rn.
     eapply rn.
Qed.


Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.
Require Import Verdi.NameOverlay.

Require Import NameAdjacency.
Require Import FailureRecorderStatic.

Require Import Sumbool.
Require Import MSetFacts.
Require Import MSetProperties.

Require Import mathcomp.ssreflect.ssreflect.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Set Implicit Arguments.

Module FailureRecorderCorrect (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (Import ANT : AdjacentNameType NT) (Import A : Adjacency NT NOT NSet ANT).

Module FR := FailureRecorder NT NOT NSet ANT A.
Import FR.

Module NSetFacts := Facts NSet.
Module NSetProps := Properties NSet.
Module NSetOrdProps := OrdProperties NSet.

Lemma Failure_node_not_adjacent_self :
forall net failed tr n,
 step_ordered_failure_star step_ordered_failure_init (failed, net) tr ->
 ~ In n failed ->
 ~ NSet.In n (onwState net n).(adjacent).
Proof.
move => net failed tr n H.
remember step_ordered_failure_init as y in *.
have ->: failed = fst (failed, net) by [].
have ->: net = snd (failed, net) by [].
move: Heqy.
induction H using refl_trans_1n_trace_n1_ind => H_init /=.
  rewrite H_init /step_ordered_failure_init /=.
  move => H_f.
  exact: not_adjacent_self.
move => H_f.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; rewrite /=.
- find_apply_lem_hyp net_handlers_NetHandler.
  rewrite /update /=.
  case name_eq_dec => H_dec /=; last exact: IHrefl_trans_1n_trace1.
  rewrite -H_dec in H3.
  net_handler_cases.
  apply NSet.remove_spec in H0.
  by move: H0 => [H0 H_neq].
- by find_apply_lem_hyp input_handlers_IOHandler.
- exact: IHrefl_trans_1n_trace1.
Qed.

Lemma Failure_self_channel_empty :
forall onet failed tr,
 step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
 forall n, ~ In n failed ->
   onet.(onwPackets) n n = [].
Proof.
move => onet failed tr H.
have H_eq_f: failed = fst (failed, onet) by [].
have H_eq_o: onet = snd (failed, onet) by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in *.
move: Heqy.
induction H using refl_trans_1n_trace_n1_ind => H_init {failed}; first by rewrite H_init /step_ordered_failure_init /=.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /= /update2.
  case (sumbool_and _ _ _ _) => H_dec; last exact: IHrefl_trans_1n_trace1.
  move: H_dec => [H_dec H_dec'].
  rewrite H_dec H_dec' in H2.
  by rewrite IHrefl_trans_1n_trace1 in H2.
- by find_apply_lem_hyp input_handlers_IOHandler.
- move => n H_in.
  rewrite collate_neq.
  apply: IHrefl_trans_1n_trace1.
    move => H_in'.
    case: H_in.
    by right.
  move => H_eq.
  by case: H_in; left.
Qed.

Lemma Failure_not_failed_no_fail :
forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
  ~ In n failed ->
  ~ In Fail (onet.(onwPackets) n n').
Proof.
move => onet failed tr H.
have H_eq_f: failed = fst (failed, onet) by [].
have H_eq_o: onet = snd (failed, onet) by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in *.
move: Heqy.
induction H using refl_trans_1n_trace_n1_ind => H_init {failed}; first by rewrite H_init /step_ordered_failure_init /=.
concludes.
move => n n' H_in.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /= in H0, H_in.
  contradict H0.
  have H_in' := IHrefl_trans_1n_trace1 _ n' H_in.
  rewrite /update2 /=.
  case (sumbool_and _ _ _ _) => H_dec //.
  move: H_dec => [H_eq H_eq'].
  rewrite H_eq H_eq' in H2.
  rewrite H2 in H_in'.
  move => H_inn.
  case: H_in'.
  by right.
- by find_apply_lem_hyp input_handlers_IOHandler.
- rewrite /= in H_in.
  have H_neq: h <> n by move => H_eq; case: H_in; left.
  have H_f: ~ In n failed by move => H_in''; case: H_in; right.
  rewrite collate_neq //.
  exact: IHrefl_trans_1n_trace1.
Qed.

Section SingleNodeInv.

Variable onet : ordered_network.

Variable failed : list name.

Variable tr : list (name * (input + output)).

Hypothesis H_step : step_ordered_failure_star step_ordered_failure_init (failed, onet) tr.

Variable n : name.

Hypothesis not_failed : ~ In n failed.

Variable P : Data -> Prop.

Hypothesis after_init : P (InitData n).

Hypothesis recv_fail :
  forall onet failed tr n',
    step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
    ~ In n failed ->
    P (onet.(onwState) n) ->
    P (mkData (NSet.remove n' (onet.(onwState) n).(adjacent))).

Theorem P_inv_n : P (onwState onet n).
Proof.
move: onet failed tr H_step not_failed.
clear onet failed not_failed tr H_step.
move => onet' failed' tr H'_step.
have H_eq_f: failed' = fst (failed', onet') by [].
have H_eq_o: onet' = snd (failed', onet') by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in H'_step.
move: Heqy.
induction H'_step using refl_trans_1n_trace_n1_ind => /= H_init.
  rewrite H_init /step_ordered_init /= => H_in_f.
  exact: after_init.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- move => H_in_f.
  find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /update /=.
  case name_eq_dec => H_dec //.
  rewrite -H_dec {H_dec H'_step2 to} in H0 H1 H5.
  case: d H5 => /=.
  move => adjacent0 H_eq.
  rewrite H_eq {H_eq adjacent0}.
  exact: (recv_fail _ H'_step1).
- by find_apply_lem_hyp input_handlers_IOHandler.
- move => H_in_f.
  apply: IHH'_step1.
  move => H'_in_f.
  case: H_in_f.
  by right.
Qed.

End SingleNodeInv.

Section SingleNodeInvOut.

Variable onet : ordered_network.

Variable failed : list name.

Variable tr : list (name * (input + output)).

Hypothesis H_step : step_ordered_failure_star step_ordered_failure_init (failed, onet) tr.

Variables n n' : name.

Hypothesis not_failed : ~ In n failed.

Variable P : Data -> list msg -> Prop.

Hypothesis after_init : P (InitData n) [].

Hypothesis recv_fail_from_eq :
  forall onet failed tr ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  ~ In n failed ->
  In n' failed ->
  n' <> n ->
  onet.(onwPackets) n' n = Fail :: ms ->
  P (onet.(onwState) n) (onet.(onwPackets) n n') ->
  P (mkData (NSet.remove n' (onet.(onwState) n).(adjacent))) (onet.(onwPackets) n n').

Hypothesis recv_fail_from_neq :
  forall onet failed tr from ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  ~ In n failed ->
  In from failed ->
  from <> n ->
  from <> n' ->
  onet.(onwPackets) from n = Fail :: ms ->
  P (onet.(onwState) n) (onet.(onwPackets) n n') ->
  P (mkData (NSet.remove from (onet.(onwState) n).(adjacent))) (onet.(onwPackets) n n').

Theorem P_inv_n_out : P (onet.(onwState) n) (onet.(onwPackets) n n').
Proof.
move: onet failed tr H_step not_failed.
clear onet failed not_failed tr H_step.
move => onet' failed' tr H'_step.
have H_eq_f: failed' = fst (failed', onet') by [].
have H_eq_o: onet' = snd (failed', onet') by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2 3}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in H'_step.
move: Heqy.
induction H'_step using refl_trans_1n_trace_n1_ind => /= H_init.
  rewrite H_init /step_ordered_failure_init /= => H_in_f.
  exact: after_init.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- move => H_in_f.
  find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /update /=.
  case name_eq_dec => H_dec.
    rewrite -H_dec in H1 H5 H0.
    rewrite -H_dec /update2 /= {H_dec to H'_step2}.
    case (sumbool_and _ _ _ _) => H_dec.
      move: H_dec => [H_eq H_eq'].
      rewrite H_eq {H_eq from} in H5 H0.
      by rewrite (Failure_self_channel_empty H'_step1) in H0.
    case: d H5 => /=.
    move => adjacent0 H_eq.
    rewrite H_eq {adjacent0 H_eq}.
    case: H_dec => H_dec.
      case (name_eq_dec from n') => H_dec'.
        rewrite H_dec'.
        rewrite H_dec' in H0 H_dec.
        case (In_dec name_eq_dec n' failed) => H_in; first exact: (recv_fail_from_eq H'_step1 _ _ _ H0).
        have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in.
        rewrite H0 in H_inl.
        by case: H_inl; left.
      case (In_dec name_eq_dec from failed) => H_in; first exact: (recv_fail_from_neq H'_step1 _ _ _ _ H0).
      have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in.
      rewrite H0 in H_inl.
      by case: H_inl; left.
    case (name_eq_dec from n) => H_neq; first by rewrite H_neq (Failure_self_channel_empty H'_step1) in H0.
    case (name_eq_dec from n') => H_dec'.
      rewrite H_dec'.
      rewrite H_dec' in H0 H_dec.
      case (In_dec name_eq_dec n' failed) => H_in; first by apply: (recv_fail_from_eq H'_step1 _ _ _ H0) => //; auto.
      have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in.
      rewrite H0 in H_inl.
      by case: H_inl; left.
    case (In_dec name_eq_dec from failed) => H_in; first exact: (recv_fail_from_neq H'_step1 _ _ _ _ H0).
    have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in.
    rewrite H0 in H_inl.
    by case: H_inl; left.
  rewrite /update2 /=.
  case (sumbool_and _ _ _ _) => H_dec' //.
  move: H_dec' => [H_eq H_eq'].
  rewrite H_eq H_eq' in H0 H1 H5 H_dec.
  have H_f := Failure_not_failed_no_fail H'_step1 _ n' H_in_f.
  rewrite H0 in H_f.
  by case: H_f; left.
- by find_apply_lem_hyp input_handlers_IOHandler.
- move => H_in.
  have H_neq: h <> n by move => H_eq; case: H_in; left.
  have H_f: ~ In n failed by move => H_in'; case: H_in; right.
  rewrite collate_neq //.
  exact: IHH'_step1.
Qed.

End SingleNodeInvOut.

Section SingleNodeInvIn.

Variable onet : ordered_network.

Variable failed : list name.

Variable tr : list (name * (input + output)).

Hypothesis H_step : step_ordered_failure_star step_ordered_failure_init (failed, onet) tr.

Variables n n' : name.

Hypothesis not_failed : ~ In n failed.

Variable P : Data -> list msg -> Prop.

Hypothesis after_init : P (InitData n) [].

Hypothesis recv_fail_neq :
  forall onet failed tr ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  ~ In n failed ->
  In n' failed ->
  n <> n' ->
  onet.(onwPackets) n' n = Fail :: ms ->
  P (onet.(onwState) n) (onet.(onwPackets) n' n) ->
  P (mkData (NSet.remove n' (onet.(onwState) n).(adjacent))) ms.

Hypothesis recv_fail_other_neq :
  forall onet failed tr from ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  ~ In n failed ->
  n <> from ->
  n' <> from ->
  onet.(onwPackets) from n = Fail :: ms ->
  P (onet.(onwState) n) (onet.(onwPackets) n' n) ->
  P (mkData (NSet.remove from (onet.(onwState) n).(adjacent))) (onet.(onwPackets) n' n).

Hypothesis fail_adjacent :
  forall onet failed tr,
    step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
    n' <> n ->
    ~ In n failed ->
    ~ In n' failed ->
    adjacent_to n' n ->
    P (onet.(onwState) n) (onet.(onwPackets) n' n) ->
    P (onwState onet n) (onwPackets onet n' n ++ [Fail]).

Theorem P_inv_n_in : P (onet.(onwState) n) (onet.(onwPackets) n' n).
Proof.
move: onet failed tr H_step not_failed.
clear onet failed not_failed tr H_step.
move => onet' failed' tr H'_step.
have H_eq_f: failed' = fst (failed', onet') by [].
have H_eq_o: onet' = snd (failed', onet') by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2 3}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in H'_step.
move: Heqy.
induction H'_step using refl_trans_1n_trace_n1_ind => /= H_init.
  rewrite H_init /step_ordered_failure_init /= => H_in_f.
  exact: after_init.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- move => H_in_f.
  find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /update /=.
  case name_eq_dec => H_dec.
    rewrite -H_dec in H1 H5 H0.
    have H_neq: n <> from.
      move => H_eq.
      rewrite -H_eq in H0.
      by rewrite (Failure_self_channel_empty H'_step1) in H0.
    rewrite -H_dec /update2 /= {H_dec to H'_step2}.
    case (sumbool_and _ _ _ _) => H_dec.
      move: H_dec => [H_eq H_eq'].
      rewrite H_eq {H_eq from} in H0 H5 H_neq.
      case: d H5 => /= adjacent0 H_eq.
      rewrite H_eq {H_eq adjacent0}.
      case (In_dec name_eq_dec n' failed) => H_in; first exact: (recv_fail_neq H'_step1).
      have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in.
      rewrite H0 in H_inl.
      by case: H_inl; left.
    case: H_dec => H_dec //.
    case: d H5 => /= adjacent0 H_eq.
    rewrite H_eq {H_eq adjacent0}.
    apply: (recv_fail_other_neq H'_step1 _ _ _ H0) => //.
    move => H_neq'.
    by case: H_dec.
  rewrite /update2 /=.
  case (sumbool_and _ _ _ _) => H_dec' //.
  move: H_dec' => [H_eq H_eq'].
  by rewrite H_eq' in H_dec.
- by find_apply_lem_hyp input_handlers_IOHandler.
- move => H_in.
  have H_neq: h <> n by move => H_eq; case: H_in; left.
  have H_f: ~ In n failed by move => H_in'; case: H_in; right.
  case (name_eq_dec h n') => H_dec.
    rewrite H_dec in H0 H_neq H_f.
    rewrite H_dec {H_dec h H'_step2 H_in}.
    case (adjacent_to_dec n' n) => H_dec.
      rewrite collate_map2snd_not_in_related //.
      * apply (fail_adjacent H'_step1) => //.
        exact: IHH'_step1.
      * exact: all_names_nodes.
      * exact: no_dup_nodes.
    rewrite collate_map2snd_not_related //.
    exact: IHH'_step1.
  rewrite collate_neq //.
  exact: IHH'_step1.
Qed.

End SingleNodeInvIn.

Section DualNodeInv.

Variable onet : ordered_network.

Variable failed : list name.

Variable tr : list (name * (input + output)).

Hypothesis H_step : step_ordered_failure_star step_ordered_failure_init (failed, onet) tr.

Variables n n' : name.

Hypothesis not_failed_n : ~ In n failed.

Hypothesis not_failed_n' : ~ In n' failed.

Variable P : Data -> Data -> list msg -> list msg -> Prop.

(* FIXME *)
Hypothesis after_init : P (InitData n) (InitData n') [] [].

Hypothesis recv_fail_self :
  forall onet failed tr from ms,
    step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
    n' = n ->
    ~ In n failed ->
    onet.(onwPackets) from n = Fail :: ms ->
    n <> from ->
    P (onet.(onwState) n) (onet.(onwState) n) (onet.(onwPackets) n n) (onet.(onwPackets) n n) ->
    P (mkData (NSet.remove from (onet.(onwState) n).(adjacent)))
      (mkData (NSet.remove from (onet.(onwState) n).(adjacent)))
      (onet.(onwPackets) n n) (onet.(onwPackets) n n).

Hypothesis recv_fail_other :
  forall onet failed tr from ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
    ~ In n failed ->
    ~ In n' failed ->
    onet.(onwPackets) from n = Fail :: ms ->
    n <> n' ->
    from <> n ->
    from <> n' ->
    P (onet.(onwState) n) (onet.(onwState) n') (onet.(onwPackets) n n') (onet.(onwPackets) n' n) ->
    P (mkData (NSet.remove from (onet.(onwState) n).(adjacent))) (onet.(onwState) n')
      (onet.(onwPackets) n n') (onet.(onwPackets) n' n).

Hypothesis recv_other_fail :
  forall onet failed tr from ms,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
    ~ In n failed ->
    ~ In n' failed ->
    onet.(onwPackets) from n' = Fail :: ms ->
    n <> n' ->
    from <> n ->
    from <> n' ->
    P (onet.(onwState) n) (onet.(onwState) n') (onet.(onwPackets) n n') (onet.(onwPackets) n' n) ->
    P (onet.(onwState) n) (mkData (NSet.remove from (onet.(onwState) n').(adjacent)))
      (onet.(onwPackets) n n') (onet.(onwPackets) n' n).

Theorem P_dual_inv : P (onet.(onwState) n) (onet.(onwState) n') (onet.(onwPackets) n n') (onet.(onwPackets) n' n).
Proof.
move: onet failed tr H_step not_failed_n not_failed_n'.
clear onet failed not_failed_n not_failed_n' tr H_step.
move => onet' failed' tr H'_step.
have H_eq_f: failed' = fst (failed', onet') by [].
have H_eq_o: onet' = snd (failed', onet') by [].
rewrite H_eq_f {H_eq_f}.
rewrite {3 4 5 6}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in H'_step.
move: Heqy.
induction H'_step using refl_trans_1n_trace_n1_ind => /= H_init.
  rewrite H_init /step_ordered_failure_init /= => H_in_f H_in_f'.
  exact: after_init.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- rewrite /= in IHH'_step1.
  move {H'_step2}.
  move => H_in_f H_in_f'.
  find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /update /=.
  case name_eq_dec => H_dec_n.
    rewrite -H_dec_n.
    rewrite -H_dec_n {H_dec_n to} in H5 H6 H1 H0.
    case name_eq_dec => H_dec_n'.
      rewrite H_dec_n'.
      rewrite H_dec_n' in H_in_f' H6.
      rewrite /update2.
      case (sumbool_and _ _ _ _) => H_dec.
        move: H_dec => [H_eq H_eq'].
        rewrite H_eq in H0.
        by rewrite (Failure_self_channel_empty H'_step1) in H0.
      case: H_dec => H_dec //.
      case: d H5 => /= adjacent0 H_eq.
      rewrite H_eq {H_eq adjacent0}.
      apply (recv_fail_self H'_step1 H_dec_n' H1 H0) => //.
      move => H_neq.
      by rewrite H_neq in H_dec.
    case: d H5 => /= adjacent0 H_eq.
    rewrite H_eq {H_eq adjacent0}.
    rewrite /update2 /=.
    case (sumbool_and _ _ _ _) => H_dec; case (sumbool_and _ _ _ _) => H_dec'.
    * move: H_dec => [H_eq_n H_eq_n'].
      by rewrite H_eq_n' in H_dec_n'.
    * move: H_dec => [H_eq_n H_eq_n'].
      by rewrite H_eq_n' in H_dec_n'.
    * move: H_dec' => [H_eq_n H_eq_n'].
      rewrite H_eq_n in H0.
      have H_inl := Failure_not_failed_no_fail H'_step1 _ n H_in_f'.
      case: H_inl.
      by rewrite H0; left.
    * case: H_dec' => H_dec' //.
      have H_neq: from <> n.
        move => H_eq'.
        rewrite H_eq' in H0.
        by rewrite (Failure_self_channel_empty H'_step1) in H0.
      move {H_dec}.
      apply (recv_fail_other H'_step1 H_in_f H_in_f' H0) => //.
      move => H_neq'.
      by rewrite H_neq' in H_dec_n'.
    case name_eq_dec => H_dec_n'.
      rewrite -H_dec_n'.
      rewrite -H_dec_n' {to H_dec_n'} in H0 H_dec_n H1 H5.
      case: d H5 => /= adjacent0 H_eq.
      rewrite H_eq {adjacent0 H_eq}.
      rewrite /update2 /=.
      case (sumbool_and _ _ _ _) => H_dec; case (sumbool_and _ _ _ _) => H_dec'.
      * move: H_dec' => [H_eq H_eq'].
        by rewrite H_eq' in H_dec_n.
      * move: H_dec => [H_eq H_eq'].
        rewrite H_eq in H0.
        have H_inl := Failure_not_failed_no_fail H'_step1 _ n' H_in_f.
        case: H_inl.
        rewrite H0.
        by left.
      * move: H_dec' => [H_eq H_eq'].
        by rewrite H_eq' in H_dec_n.
      * case: H_dec => H_dec //.
        have H_neq: from <> n'.
          move => H_eq'.
          rewrite H_eq' in H0.
          by rewrite (Failure_self_channel_empty H'_step1) in H0.
        move {H_dec'}.
        exact: (recv_other_fail H'_step1 H_in_f H_in_f' H0).
      rewrite /update2 /=.
      case (sumbool_and _ _ _ _) => H_dec; case (sumbool_and _ _ _ _) => H_dec'.
      * move: H_dec => [H_eq H_eq'].
        by rewrite H_eq' in H_dec_n'.
      * move: H_dec => [H_eq H_eq'].
        by rewrite H_eq' in H_dec_n'.
      * move: H_dec' => [H_eq H_eq'].
        by rewrite H_eq' in H_dec_n.
      * exact: H6.
- rewrite /= in IHH'_step1.
  move {H'_step2}.
  move => H_in_f H_in_f'.
  find_apply_lem_hyp input_handlers_IOHandler.
  by io_handler_cases.
- rewrite /= in IHH'_step1.
  move => H_nor H_nor'.
  have H_neq: h <> n.
    move => H_eq.
    case: H_nor.
    by left.
  have H_in_f: ~ In n failed.
    move => H_in_f.
    case: H_nor.
    by right.
  have H_neq': h <> n'.
    move => H_eq.
    case: H_nor'.
    by left.
  have H_in_f': ~ In n' failed.
    move => H_in_f'.
    case: H_nor'.
    by right.
  have IH := IHH'_step1 H_in_f H_in_f'.
  move {H_nor H_nor' IHH'_step1}.
  rewrite collate_neq //.
  by rewrite collate_neq.
Qed.

End DualNodeInv.

Lemma Failure_in_adj_adjacent_to :
forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall (n n' : name),
    ~ In n failed ->
    NSet.In n' (onet.(onwState) n).(adjacent) ->
    adjacent_to n' n.
Proof.
move => net failed tr H_st.
move => n n' H_f.
pose P_curr (d : Data) := NSet.In n' d.(adjacent) -> adjacent_to n' n.
rewrite -/(P_curr _).
apply: (P_inv_n H_st); rewrite /P_curr //= {P_curr net tr H_st failed H_f}.
- move => H_ins.
  apply adjacent_to_node_adjacency in H_ins.
  apply filter_rel_related in H_ins.
  move: H_ins => [H_in H_adj].
  by apply adjacent_to_symmetric in H_adj.
- move => net failed tr n0 H_st H_in_f IH H_adj.
  apply: IH.
  by apply NSetFacts.remove_3 in H_adj.
Qed.

Lemma Failure_in_adj_or_incoming_fail :
forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    NSet.In n' (onet.(onwState) n).(adjacent) ->
    ~ In n' failed \/ (In n' failed /\ In Fail (onet.(onwPackets) n' n)).
Proof.
move => onet failed tr H.
have H_eq_f: failed = fst (failed, onet) by [].
have H_eq_o: onet = snd (failed, onet) by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2 5}H_eq_o {H_eq_o}.
remember step_ordered_failure_init as y in *.
move: Heqy.
induction H using refl_trans_1n_trace_n1_ind => /= H_init.
  rewrite H_init /= {H_init}.
  move => n n' H_ins.
  by left.
concludes.
match goal with
| [ H : step_ordered_failure _ _ _ |- _ ] => invc H
end; simpl.
- move => n n' H_in_f H_ins.
  find_apply_lem_hyp net_handlers_NetHandler.
  net_handler_cases.
  rewrite /= /update2 {H1}.
  case (sumbool_and _ _ _ _) => H_dec.
    move: H_dec => [H_eq H_eq'].
    rewrite H_eq H_eq' {H_eq H_eq' to from} in H7 H_ins H3 H2.
    rewrite /= in IHrefl_trans_1n_trace1.
    move: H_ins.
    rewrite /update /=.
    case name_eq_dec => H_dec //.
    move => H_ins.
    case: d H7 H_ins => /= adjacent0 H_eq H_adj.
    rewrite H_eq in H_adj.
    by apply NSetFacts.remove_1 in H_adj.
  move: H_ins.
  rewrite /update /=.
  case name_eq_dec => H_dec'.
    case: H_dec => H_dec; last by rewrite H_dec' in H_dec.
    case: d H7 => /= adjacent0 H_eq.
    move => H_ins.
    rewrite H_eq {adjacent0 H_eq} in H_ins.
    rewrite -H_dec' {to H_dec'} in H2 H3 H_ins.
    apply NSetFacts.remove_3 in H_ins.
    exact: IHrefl_trans_1n_trace1.
  move => H_ins.
  exact: IHrefl_trans_1n_trace1.
- find_apply_lem_hyp input_handlers_IOHandler.
  by io_handler_cases.
- move => n n' H_in_f H_ins.
  rewrite /= in IHrefl_trans_1n_trace1.
  have H_neq: h <> n.
    move => H_eq.
    case: H_in_f.
    by left.
  have H_in_f': ~ In n failed0.
    move => H_in.
    case: H_in_f.
    by right.
  have IH := IHrefl_trans_1n_trace1 _ _ H_in_f' H_ins.
  case (name_eq_dec h n') => H_dec.
    rewrite H_dec.
    right.
    split; first by left.
    rewrite H_dec in H2.
    have H_adj := Failure_in_adj_adjacent_to H _ H_in_f' H_ins.
    rewrite collate_map2snd_not_in_related //.
    * apply in_or_app.
      by right; left.
    * exact: all_names_nodes.
    * exact: no_dup_nodes.
  case: IH => IH.
    left.
    move => H_or.
    by case: H_or => H_or.
  move: IH => [H_in H_fail].
  right.
  split; first by right.
  by rewrite collate_neq.
Qed.

Lemma Failure_le_one_fail :
  forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    count_occ Msg_eq_dec (onet.(onwPackets) n' n) Fail <= 1.
Proof.
move => onet failed tr H_st.
move => n n' H_in_f.
pose P_curr (d : Data) (l : list Msg) :=
  count_occ Msg_eq_dec l Fail <= 1.
rewrite -/(P_curr (onet.(onwState) n) _).
apply: (P_inv_n_in H_st); rewrite /P_curr //= {P_curr onet tr H_st failed H_in_f}.
- by auto with arith.
- move => onet failed tr ms.
  move => H_st H_in_f H_in_f' H_neq H_eq IH.
  rewrite H_eq /= in IH.
  by omega.
- move => onet failed tr H_st H_neq H_in_f H_in_f'.
  move => H_adj IH.
  have H_f := Failure_not_failed_no_fail H_st _ n H_in_f'.
  have H_cnt : ~ count_occ Msg_eq_dec (onwPackets onet n' n) Fail > 0.
    move => H_cnt.
    by apply count_occ_In in H_cnt.
  have H_cnt_eq: count_occ Msg_eq_dec (onwPackets onet n' n) Fail = 0 by omega.
  rewrite count_occ_app /= H_cnt_eq.
  by auto with arith.
Qed.

Lemma Failure_adjacent_to_in_adj :
forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    ~ In n' failed ->
    adjacent_to n' n ->
    NSet.In n' (onet.(onwState) n).(adjacent).
Proof.
move => onet failed tr H_st.
move => n n' H_f H_f'.
pose P_curr (d d' : Data) (l l' : list Msg) :=
  adjacent_to n' n ->
  NSet.In n' d.(adjacent).
rewrite -/(P_curr _ (onet.(onwState) n') (onet.(onwPackets) n n')
 (onet.(onwPackets) n' n)).
apply: (P_dual_inv H_st); rewrite /P_curr //= {P_curr onet tr H_st failed H_f H_f'}.
- move => H_adj.
  apply adjacent_to_node_adjacency.
  apply related_filter_rel; first exact: all_names_nodes.
  exact: adjacent_to_symmetric.
- move => onet failed tr from ms H_st H_eq H_in_f H_eq' H_neq H_adj H_adj_to.
  rewrite H_eq in H_adj_to.
  contradict H_adj_to.
  exact: adjacent_to_irreflexive.
- move => onet failed tr from ms H_st H_in_f H_in_f' H_eq H_neq H_neq_f H_neq_f' IH H_adj.
  concludes.
  by apply NSetFacts.remove_2.
Qed.

Lemma Failure_in_queue_fail_then_adjacent :
  forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    In Fail (onet.(onwPackets) n' n) ->
    NSet.In n' (onet.(onwState) n).(adjacent).
Proof.
move => onet failed tr H_st.
move => n n' H_in_f.
pose P_curr (d : Data) (l : list Msg) :=
  In Fail l ->
  NSet.In n' d.(adjacent).
rewrite -/(P_curr _ _).
apply: (P_inv_n_in H_st); rewrite /P_curr //= {P_curr onet tr H_st failed H_in_f}.
- move => onet failed tr ms H_st H_in_f H_in_f' H_neq H_eq IH H_in.
  have H_cnt: count_occ Msg_eq_dec ms Fail > 0 by apply count_occ_In.
  have H_cnt': count_occ Msg_eq_dec (onet.(onwPackets) n' n) Fail > 1 by rewrite H_eq /=; auto with arith.
  have H_le := Failure_le_one_fail H_st _ n' H_in_f.
  by omega.
- move => onet failed tr from ms H_st H_in_f H_neq H_neq'.
  move => H_eq IH H_in.
  apply NSetFacts.remove_2; first by move => H_eq'; rewrite H_eq' in H_neq'.
  exact: IH.
- move => onet failed tr H_st H_neq H_in_f H_in_f' H_adj IH H_in.
  exact (Failure_adjacent_to_in_adj H_st H_in_f H_in_f' H_adj).
Qed.

Lemma Failure_first_fail_in_adj :
  forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    head (onet.(onwPackets) n' n) = Some Fail ->
    NSet.In n' (onet.(onwState) n).(adjacent).
Proof.
move => onet failed tr H_st.
move => n n' H_in_f.
pose P_curr (d : Data) (l : list Msg) :=
  hd_error l = Some Fail ->
  NSet.In n' d.(adjacent).
rewrite -/(P_curr _ _).
apply: (P_inv_n_in H_st); rewrite /P_curr //= {P_curr onet tr H_st failed H_in_f}.
- move => onet failed tr ms H_st H_in_f H_in_f' H_neq H_eq IH H_hd.
  have H_neq' := hd_error_some_nil H_hd.
  case: ms H_eq H_hd H_neq' => //.
  case => ms H_eq H_hd H_neq'.
  have H_cnt: count_occ Msg_eq_dec (onwPackets onet n' n) Fail > 1 by rewrite H_eq /=; auto with arith.
  have H_le := Failure_le_one_fail H_st _ n' H_in_f.
  by omega.
- move => onet failed tr from ms H_st H_in_f H_neq H_neq' H_eq IH H_hd.
  concludes.
  apply NSetFacts.remove_2 => //.
  move => H_eq'.
  by rewrite H_eq' in H_neq'.
- move => onet failed tr H_st H_neq H_in_f H_in_f' H_adj IH H_hd.
  by have H_a := Failure_adjacent_to_in_adj H_st H_in_f H_in_f' H_adj.
Qed.

Lemma Failure_adjacent_failed_incoming_fail :
  forall onet failed tr,
  step_ordered_failure_star step_ordered_failure_init (failed, onet) tr ->
  forall n n',
    ~ In n failed ->
    NSet.In n' (onet.(onwState) n).(adjacent) ->
    In n' failed ->
    In Fail (onet.(onwPackets) n' n).
Proof.
move => onet failed tr H_st n n' H_in_f H_adj H_in_f'.
have H_or := Failure_in_adj_or_incoming_fail H_st _ H_in_f H_adj.
case: H_or => H_or //.
by move: H_or => [H_in H_in'].
Qed.

End FailureRecorderCorrect.


From HypVeri.algebra Require Import base.
From HypVeri.rules Require Import rules_base.

Section instr.
  (* shorthands for writing programs *)

  Context `{hypparams: HypervisorParameters}.

  Definition mov_word_I ra w := encode_instruction (Mov ra (inl w)).
  Definition mov_reg_I ra rb := encode_instruction (Mov ra (inr rb)).
  Definition add_I ra rb := encode_instruction (Add ra rb).
  Definition halt_I := encode_instruction Halt.
  Definition str_I ra rb := encode_instruction (Str ra rb).
  Definition ldr_I ra rb := encode_instruction (Ldr ra rb).
  Definition br_I r := encode_instruction (Br r).
  Definition cmp_word_I ra w := encode_instruction (Cmp ra (inl w)).
  Definition bne_I r := encode_instruction (Bne r).

  Definition hvc_I := encode_instruction Hvc.
  Definition run_I := encode_hvc_func Run.
  Definition yield_I := encode_hvc_func Yield.
  Definition mem_lend_I := encode_hvc_func Lend.
  Definition mem_share_I := encode_hvc_func Share.
  Definition mem_reclaim_I := encode_hvc_func Reclaim.
  Definition mem_retrieve_I := encode_hvc_func Retrieve.
  Definition mem_relinquish_I := encode_hvc_func Relinquish.
  Definition msg_send_I := encode_hvc_func Send.
  Definition msg_poll_I := encode_hvc_func Poll.

  Definition encode_instructions (l: list instruction) :=
    map encode_instruction l.

  Lemma encode_instructions_length l :
   length (encode_instructions l) = length l.
  Proof. rewrite map_length //. Qed.

  Context `{gen_VMG Σ}.

  Definition program (instr: list Word) (b:Addr):=
    ([∗ list] a;w ∈ (finz.seq b (length instr));instr, (a ->a w))%I.

End instr.