From isla Require Import opsem.

Definition a10 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R3" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop (Bvmanyarith Bvadd) [Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 38%Z) Mk_annot) Mk_annot) Mk_annot; Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R3" [] (RegVal_Base (Val_Symbolic 61%Z)) Mk_annot :t:
  Smt (DeclareConst 62%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 62%Z)) Mk_annot :t:
  Smt (DefineConst 63%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 62%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 63%Z)) Mk_annot :t:
  tnil
.


(*******************************************************************************

 Sections of displayed bicategories

 Contents:
 1. Definition of a section
 2. Builder for locally propositional/groupoidal displayed bicategories
 3. Every section gives a pseudofunctor from the base to the total bicategory

 *******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.

Local Open Scope cat.

(**
 1. Definition of a section
 *)
Definition section_disp_bicat_data
           {B : bicat}
           (D : disp_bicat B)
  : UU
  := ∑ (s_ob : ∏ (x : B), D x)
       (s_mor : ∏ (x y : B) (f : x --> y), s_ob x -->[ f ] s_ob y),
     (∏ (x y : B)
        (f g : x --> y)
        (τ : f ==> g),
      s_mor _ _ f ==>[ τ ] s_mor _ _ g)
     ×
     (∏ (x : B),
      disp_invertible_2cell
        (id2_invertible_2cell _)
        (id_disp _)
        (s_mor _ _ (id₁ x)))
     ×
     (∏ (x y z : B)
        (f : x --> y)
        (g : y --> z),
      disp_invertible_2cell
        (id2_invertible_2cell _)
        (s_mor _ _ f ;; s_mor _ _ g)
        (s_mor _ _ (f · g))).

Section SectionDataProjections.
  Context {B : bicat}
          {D : disp_bicat B}
          (s : section_disp_bicat_data D).

  Definition section_on_ob
             (x : B)
    : D x
    := pr1 s x.

  Definition section_on_mor
             {x y : B}
             (f : x --> y)
    : section_on_ob x -->[ f ] section_on_ob y
    := pr12 s _ _ f.

  Definition section_on_cell
             {x y : B}
             {f g : x --> y}
             (τ : f ==> g)
    : section_on_mor f ==>[ τ ] section_on_mor g
    := pr122 s _ _ _ _ τ.

  Definition section_on_id
             (x : B)
    : disp_invertible_2cell
        (id2_invertible_2cell _)
        (id_disp _)
        (section_on_mor (id₁ x))
    := pr1 (pr222 s) x.

  Definition section_on_comp
             {x y z : B}
             (f : x --> y)
             (g : y --> z)
    : disp_invertible_2cell
        (id2_invertible_2cell _)
        (section_on_mor f ;; section_on_mor g)
        (section_on_mor (f · g))
    := pr2 (pr222 s) _ _ _ f g.
End SectionDataProjections.

Definition section_disp_bicat_laws_id
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y : B) (f : x --> y),
     section_on_cell s (id₂ f) = disp_id2 (section_on_mor s f).

Definition section_disp_bicat_laws_comp
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y : B) (f g h : x --> y) (τ : f ==> g) (θ : g ==> h),
     section_on_cell s (τ • θ)
     =
     section_on_cell s τ •• section_on_cell s θ.

Definition section_disp_bicat_laws_lunitor_base
           {B : bicat}
           {x y : B}
           (f : x --> y)
  : lunitor f
    =
    ((id₂ _ ▹ f) • id₂ _) • lunitor f.
Proof.
  rewrite id2_rwhisker.
  rewrite !id2_left.
  apply idpath.
Qed.

Definition section_disp_bicat_laws_lunitor
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y : B)
       (f : x --> y),
     transportf
       (λ z, _ ==>[ z ] _)
       (section_disp_bicat_laws_lunitor_base f)
       (disp_lunitor (section_on_mor s f))
     =
     ((pr1 (section_on_id s _) ▹▹ section_on_mor s f)
     •• pr1 (section_on_comp s (id₁ _) f))
     •• section_on_cell s (lunitor f).

Definition section_disp_bicat_laws_runitor_base
           {B : bicat}
           {x y : B}
           (f : x --> y)
  : runitor f
    =
    ((f ◃ id₂ _) • id₂ _) • runitor f.
Proof.
  rewrite lwhisker_id2.
  rewrite !id2_left.
  apply idpath.
Qed.

Definition section_disp_bicat_laws_runitor
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y : B)
       (f : x --> y),
     transportf
       (λ z, _ ==>[ z ] _)
       (section_disp_bicat_laws_runitor_base f)
       (disp_runitor (section_on_mor s f))
     =
     ((section_on_mor s f ◃◃ pr1 (section_on_id s _))
     •• pr1 (section_on_comp s f (id₁ _)))
     •• section_on_cell s (runitor f).

Definition section_disp_bicat_laws_lassociator_base
           {B : bicat}
           {w x y z : B}
           (f : w --> x)
           (g : x --> y)
           (h : y --> z)
  : ((f ◃ id₂ _) • id₂ _) • lassociator f g h
    =
    (lassociator f g h • (id₂ _ ▹ h)) • id₂ _.
Proof.
  rewrite id2_rwhisker, lwhisker_id2.
  rewrite !id2_left, !id2_right.
  apply idpath.
Qed.

Definition section_disp_bicat_laws_lassociator
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  := ∏ (w x y z : B)
       (f : w --> x)
       (g : x --> y)
       (h : y --> z),
     transportf
       (λ z, _ ==>[ z ] _)
       (section_disp_bicat_laws_lassociator_base f g h)
       (((section_on_mor s f ◃◃ pr1 (section_on_comp s g h))
        •• pr1 (section_on_comp s f (g · h)))
        •• section_on_cell s (lassociator f g h))
     =
     (disp_lassociator (section_on_mor s f) (section_on_mor s g) (section_on_mor s h)
     •• (pr1 (section_on_comp s f g) ▹▹ section_on_mor s h))
     •• pr1 (section_on_comp s (f · g) h).

Definition section_disp_bicat_laws_lwhisker_base
           {B : bicat}
           {x y z : B}
           (f : x --> y)
           {g₁ g₂ : y --> z}
           (η : g₁ ==> g₂)
  : id₂ _ • (f ◃ η) = (f ◃ η) • id₂ _.
Proof.
  rewrite id2_left, id2_right.
  apply idpath.
Qed.

Definition section_disp_bicat_laws_lwhisker
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y z : B)
       (f : x --> y)
       (g₁ g₂ : y --> z)
       (η : g₁ ==> g₂),
    transportf
       (λ z, _ ==>[ z ] _)
       (section_disp_bicat_laws_lwhisker_base f η)
       (pr1 (section_on_comp s f g₁) •• section_on_cell s (f ◃ η))
     =
     (section_on_mor s f ◃◃ section_on_cell s η) •• pr1 (section_on_comp s f g₂).

Definition section_disp_bicat_laws_rwhisker_base
           {B : bicat}
           {x y z : B}
           {f₁ f₂ : x --> y}
           (g : y --> z)
           (η : f₁ ==> f₂)
  : id₂ _ • (η ▹ g) = (η ▹ g) • id₂ _.
Proof.
  rewrite id2_left, id2_right.
  apply idpath.
Qed.

Definition section_disp_bicat_laws_rwhisker
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := ∏ (x y z : B)
       (f₁ f₂ : x --> y)
       (g : y --> z)
       (η : f₁ ==> f₂),
     transportf
       (λ z, _ ==>[ z ] _)
       (section_disp_bicat_laws_rwhisker_base g η)
       (pr1 (section_on_comp s f₁ g) •• section_on_cell s (η ▹ g))
     =
     (section_on_cell s η ▹▹ section_on_mor s g) •• pr1 (section_on_comp s f₂ g).

Definition section_disp_bicat_laws
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat_data D)
  : UU
  := section_disp_bicat_laws_id s
     ×
     section_disp_bicat_laws_comp s
     ×
     section_disp_bicat_laws_lunitor s
     ×
     section_disp_bicat_laws_runitor s
     ×
     section_disp_bicat_laws_lassociator s
     ×
     section_disp_bicat_laws_lwhisker s
     ×
     section_disp_bicat_laws_rwhisker s.

Definition section_disp_bicat
           {B : bicat}
           (D : disp_bicat B)
  : UU
  := ∑ (s : section_disp_bicat_data D), section_disp_bicat_laws s.

Coercion section_to_section_data
          {B : bicat}
          {D : disp_bicat B}
          (s : section_disp_bicat D)
: section_disp_bicat_data D
  := pr1 s.

Definition section_disp_bicat_id
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_id s
  := pr12 s.

Definition section_disp_bicat_comp
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_comp s
  := pr122 s.

Definition section_disp_bicat_lunitor
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_lunitor s
  := pr1 (pr222 s).

Definition section_disp_bicat_runitor
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_runitor s
  := pr12 (pr222 s).

Definition section_disp_bicat_lassociator
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_lassociator s
  := pr122 (pr222 s).

Definition section_disp_bicat_lwhisker
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_lwhisker s
  := pr1 (pr222 (pr222 s)).

Definition section_disp_bicat_rwhisker
           {B : bicat}
           {D : disp_bicat B}
           (s : section_disp_bicat D)
  : section_disp_bicat_laws_rwhisker s
  := pr2 (pr222 (pr222 s)).

(**
 2. Builder for locally propositional/groupoidal displayed bicategories
 *)
Section MakeSection.
  Context {B : bicat}
          (D : disp_bicat B)
          (HD₁ : disp_2cells_isaprop D)
          (HD₂ : disp_locally_groupoid D)
          (s_ob : ∏ (x : B), D x)
          (s_mor : ∏ (x y : B) (f : x --> y), s_ob x -->[ f ] s_ob y)
          (s_cell : ∏ (x y : B)
                      (f g : x --> y)
                      (τ : f ==> g),
                    s_mor _ _ f ==>[ τ ] s_mor _ _ g)
          (s_id : ∏ (x : B), id_disp _ ==>[ id2 _ ] s_mor _ _ (id₁ x))
          (s_comp : ∏ (x y z : B)
                      (f : x --> y)
                      (g : y --> z),
                    s_mor _ _ f ;; s_mor _ _ g
                    ==>[ id2 _ ]
                    s_mor _ _ (f · g)).

  Definition make_section_disp_bicat_data
    : section_disp_bicat_data D.
  Proof.
    simple refine (s_ob ,, s_mor ,, s_cell ,, _ ,, _).
    - intro x.
      refine (s_id x ,, _).
      apply HD₂.
    - intros x y z f g.
      refine (s_comp _ _ _ f g ,, _).
      apply HD₂.
  Defined.

  Definition make_section_disp_bicat_laws
    : section_disp_bicat_laws make_section_disp_bicat_data.
  Proof.
    repeat split ; intro ; intros ; apply HD₁.
  Qed.

  Definition make_section_disp_bicat
    : section_disp_bicat D.
  Proof.
    simple refine (_ ,, _).
    - exact make_section_disp_bicat_data.
    - exact make_section_disp_bicat_laws.
  Defined.
End MakeSection.

(**
 3. Every section gives a pseudofunctor from the base to the total bicategory
 *)
Section SectionToPsfunctor.
  Context {B : bicat}
          {D : disp_bicat B}
          (s : section_disp_bicat D).

  Definition section_to_psfunctor_data
    : psfunctor_data B (total_bicat D).
  Proof.
    use make_psfunctor_data.
    - exact (λ x, x ,, section_on_ob s x).
    - exact (λ x y f, f ,, section_on_mor s f).
    - exact (λ x y f g τ, τ ,, section_on_cell s τ).
    - exact (λ x, id2 _ ,, pr1 (section_on_id s x)).
    - exact (λ x y z f g, id2 _ ,, pr1 (section_on_comp s f g)).
  Defined.

  Definition section_to_psfunctor_laws
    : psfunctor_laws section_to_psfunctor_data.
  Proof.
    repeat split ; intro ; intros ; cbn.
    - apply maponpaths.
      apply (section_disp_bicat_id s).
    - apply maponpaths.
      apply (section_disp_bicat_comp s).
    - use total2_paths_f.
      + apply section_disp_bicat_laws_lunitor_base.
      + apply (section_disp_bicat_lunitor s).
    - use total2_paths_f.
      + apply section_disp_bicat_laws_runitor_base.
      + apply (section_disp_bicat_runitor s).
    - use total2_paths_f.
      + apply section_disp_bicat_laws_lassociator_base.
      + apply (section_disp_bicat_lassociator s).
    - use total2_paths_f.
      + apply section_disp_bicat_laws_lwhisker_base.
      + apply (section_disp_bicat_lwhisker s).
    - use total2_paths_f.
      + apply section_disp_bicat_laws_rwhisker_base.
      + apply (section_disp_bicat_rwhisker s).
  Qed.

  Definition section_to_psfunctor_invertible_cells
    : invertible_cells section_to_psfunctor_data.
  Proof.
    split.
    - intro x ; cbn.
      use is_invertible_disp_to_total.
      simple refine (_ ,, _).
      + apply is_invertible_2cell_id₂.
      + exact (pr2 (section_on_id s x)).
    - intros x y z f g ; cbn.
      use is_invertible_disp_to_total.
      simple refine (_ ,, _).
      + apply is_invertible_2cell_id₂.
      + exact (pr2 (section_on_comp s f g)).
  Defined.

  Definition section_to_psfunctor
    : psfunctor B (total_bicat D).
  Proof.
    use make_psfunctor.
    - exact section_to_psfunctor_data.
    - exact section_to_psfunctor_laws.
    - exact section_to_psfunctor_invertible_cells.
  Defined.
End SectionToPsfunctor.


Require Import StlcIso.SpecAnnot.
Require Import CompilerFI.Compiler.

Require Import UValFI.UVal.

Require Import LogRelFI.LR.

Require Import BacktransFI.Emulate.
Require Import BacktransFI.InjectExtract.
Require Import BacktransFI.UpgradeDowngrade.

Definition backtranslateCtx n τ Cu : F.PCtx := (F.eraseAnnot_pctx (F.pctxA_cat
                      (F.a_papp₂ τ (UValFI n (compfi_ty τ)) (injectA n τ) F.a_phole)
                      (emulate_pctx n Cu))).

Lemma backtranslateCtx_works {Cu m n d p τs τu ts tu} :
  ValidTy τu →
  dir_world_prec m n d p →
  ⟪ ia⊢ Cu : I.empty, compfi_ty τs → I.empty, τu ⟫ →
  ⟪ pempty ⊩ ts ⟦ d, n ⟧ tu : embed τs ⟫ →
  ⟪ pempty ⊩ (F.pctx_app ts (backtranslateCtx m τs Cu)) ⟦ d, n ⟧ I.pctx_app tu (eraseAnnot_pctx
      Cu) : pEmulDV m p τu ⟫.
Proof.
  intros vτu dwp tCu lr; destruct p; unfold backtranslateCtx;
  rewrite F.eraseAnnot_pctx_cat, F.pctx_cat_app;
  [change pempty with (toEmulDV m precise I.empty) | change pempty with (toEmulDV m imprecise I.empty)];
  eapply emulate_pctx_works; eauto using dwp_precise, dwp_imprecise with tyvalid;
  eapply inject_works_open; eauto using dwp_precise, dwp_imprecise with tyvalid.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Platform-specific built-in functions *)

Require Import String Coqlib.
Require Import AST Integers Floats Values.
Require Import Builtins0.

Inductive platform_builtin : Type :=
  | BI_fmin
  | BI_fmax.

Local Open Scope string_scope.

Definition platform_builtin_table : list (string * platform_builtin) :=
     ("__builtin_fmin", BI_fmin)
  :: ("__builtin_fmax", BI_fmax)
  :: nil.

Definition platform_builtin_sig (b: platform_builtin) : signature :=
  match b with
  | BI_fmin | BI_fmax =>
      mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default true
  end.

Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) :=
  match b with
  | BI_fmin =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Eq | Some Lt => f1
                      | Some Gt | None => f2
                      end)
  | BI_fmax =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Eq | Some Gt => f1
                      | Some Lt | None => f2
                      end)
  end.


(** * 6.887 Formal Reasoning About Programs - Lab 12
    * Concurrent Separation Logic *)

Require Import Frap Setoid Classes.Morphisms SepCancel.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

Set Implicit Arguments.
Set Asymmetric Patterns.

(* This lab is pure practice verifying specific programs with Concurrent
 * Separation Logic.  We first copy a bunch of content from the lecture code.
 * Skip ahead to the text "Examples" to see the lab material that we ask you to
 * work through. *)

(** * Shared notations and definitions; main material starts afterward. *)

Notation heap := (fmap nat nat).
Notation locks := (set nat).

Hint Extern 1 (_ <= _) => linear_arithmetic.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * A shared-memory concurrent language with loops *)

Inductive loop_outcome acc :=
| Done (a : acc)
| Again (a : acc).

Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Fail {result} : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc

| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Lock (a : nat) : cmd unit
| Unlock (a : nat) : cmd unit
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit

| Par (c1 c2 : cmd unit) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).
Infix "||" := Par.

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

Inductive step : forall A, heap * locks * cmd A -> heap * locks * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h l h' l',
  step (h, l, c1) (h', l', c1')
  -> step (h, l, Bind c1 c2) (h', l', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h l,
  step (h, l, Bind (Return v) c2) (h, l, c2 v)

| StepLoop : forall (acc : Set) (init : acc) (body : acc -> cmd (loop_outcome acc)) h l,
  step (h, l, Loop init body) (h, l, o <- body init; match o with
                                                     | Done a => Return a
                                                     | Again a => Loop a body
                                                     end)

| StepRead : forall h l a v,
  h $? a = Some v
  -> step (h, l, Read a) (h, l, Return v)
| StepWrite : forall h l a v v',
  h $? a = Some v
  -> step (h, l, Write a v') (h $+ (a, v'), l, Return tt)
| StepAlloc : forall h l numWords a,
  a <> 0
  -> (forall i, i < numWords -> h $? (a + i) = None)
  -> step (h, l, Alloc numWords) (initialize h a numWords, l, Return a)
| StepFree : forall h l a numWords,
  step (h, l, Free a numWords) (deallocate h a numWords, l, Return tt)

| StepLock : forall h l a,
  ~a \in l
  -> step (h, l, Lock a) (h, l \cup {a}, Return tt)
| StepUnlock : forall h l a,
  a \in l
  -> step (h, l, Unlock a) (h, l \setminus {a}, Return tt)

| StepPar1 : forall h l c1 c2 h' l' c1',
  step (h, l, c1) (h', l', c1')
  -> step (h, l, Par c1 c2) (h', l', Par c1' c2)
| StepPar2 : forall h l c1 c2 h' l' c2',
  step (h, l, c2) (h', l', c2')
  -> step (h, l, Par c1 c2) (h', l', Par c1 c2').

Definition trsys_of (h : heap) (l : locks) {result} (c : cmd result) := {|
  Initial := {(h, l, c)};
  Step := step (A := result)
|}.

Module Import S <: SEP.
  Definition hprop := heap -> Prop.

  Definition himp (p q : hprop) := forall h, p h -> q h.
  Definition heq (p q : hprop) := forall h, p h <-> q h.

  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

  Definition exis A (p : A -> hprop) : hprop :=
    fun h => exists x, p x h.

  Notation "[| P |]" := (lift P) : sep_scope.
  Infix "*" := star : sep_scope.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
  Delimit Scope sep_scope with sep.
  Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
  Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

  Local Open Scope sep_scope.

  Lemma iff_two : forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x)
    -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
  Proof.
    firstorder.
  Qed.

  Local Ltac t := (unfold himp, heq, lift, star, exis; propositional; subst);
                 repeat (match goal with
                         | [ H : forall x, _ <-> _ |- _  ] =>
                           apply iff_two in H
                         | [ H : ex _ |- _ ] => destruct H
                         | [ H : split _ _ $0 |- _ ] => apply split_empty_fwd in H
                         end; propositional; subst); eauto 15.

  Theorem himp_heq : forall p q, p === q
    <-> (p ===> q /\ q ===> p).
  Proof.
    t.
  Qed.

  Theorem himp_refl : forall p, p ===> p.
  Proof.
    t.
  Qed.

  Theorem himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Proof.
    t.
  Qed.

  Hint Resolve split_empty_bwd'.

  Theorem extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.
  Proof.
    t.
    apply split_empty_fwd' in H1; subst; auto.
  Qed.

  Theorem star_comm : forall p q, p * q === q * p.
  Proof.
    t.
  Qed.

  Theorem star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Proof.
    t.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.
  Proof.
    t.
  Qed.

  Theorem exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Proof.
    t.
  Qed.

  Theorem exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Proof.
    t.
  Qed.

  Theorem exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
  Proof.
    t.
  Qed.
End S.

Export S.
Module Import Se := SepCancel.Make(S).

(* ** Some extra predicates outside the set that the engine knows about *)

Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

Notation "[| P |]" := (lift P) : sep_scope.
Notation emp := (lift True).
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).
Infix "|->" := ptsto (at level 30) : sep_scope.

Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

Infix "|-->" := multi_ptsto (at level 30) : sep_scope.

Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

Infix "|->?" := allocated (at level 30) : sep_scope.

(** * Finally, the Hoare logic *)

Inductive hoare_triple (linvs : list hprop) : forall {result}, hprop -> cmd result -> (result -> hprop) -> Prop :=

| HtReturn : forall P {result : Set} (v : result),
    hoare_triple linvs P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple linvs P c1 Q
    -> (forall r, hoare_triple linvs (Q r) (c2 r) R)
    -> hoare_triple linvs P (Bind c1 c2) R
| HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
    (forall acc, hoare_triple linvs (I (Again acc)) (body acc) I)
    -> hoare_triple linvs (I (Again init)) (Loop init body) (fun r => I (Done r))
| HtFail : forall {result},
    hoare_triple linvs [| False |]%sep (Fail (result := result)) (fun _ => [| False |])%sep
| HtRead : forall a R,
    hoare_triple linvs (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
| HtWrite : forall a v',
    hoare_triple linvs (exists v, a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
| HtAlloc : forall numWords,
    hoare_triple linvs emp%sep (Alloc numWords) (fun r => r |--> zeroes numWords * [| r <> 0 |])%sep
| HtFree : forall a numWords,
    hoare_triple linvs (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep

| HtLock : forall a I,
    nth_error linvs a = Some I
    -> hoare_triple linvs emp%sep (Lock a) (fun _ => I)
| HtUnlock : forall a I,
    nth_error linvs a = Some I
    -> hoare_triple linvs I (Unlock a) (fun _ => emp)%sep

| HtPar : forall P1 c1 Q1 P2 c2 Q2,
    hoare_triple linvs P1 c1 Q1
    -> hoare_triple linvs P2 c2 Q2
    -> hoare_triple linvs (P1 * P2)%sep (Par c1 c2) (fun _ => Q1 tt * Q2 tt)%sep

| HtConsequence : forall {result} (c : cmd result) P Q (P' : hprop) (Q' : _ -> hprop),
    hoare_triple linvs P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple linvs P' c Q'
| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple linvs P c Q
    -> hoare_triple linvs (P * R)%sep c (fun r => Q r * R)%sep.

Notation "linvs ||- {{ P }} c {{ r ~> Q }}" :=
  (hoare_triple linvs P%sep c (fun r => Q%sep)) (at level 90, c at next level).

Lemma HtStrengthen : forall linvs {result} (c : cmd result) P Q (Q' : _ -> hprop),
    hoare_triple linvs P c Q
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple linvs P c Q'.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

Lemma HtWeaken : forall linvs {result} (c : cmd result) P Q (P' : hprop),
    hoare_triple linvs P c Q
    -> P' ===> P
    -> hoare_triple linvs P' c Q.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

(** * Automation tactics *)

Opaque heq himp lift star exis ptsto.

Theorem use_lemma : forall linvs result P' (c : cmd result) (Q : result -> hprop) P R,
  hoare_triple linvs P' c Q
  -> P ===> P' * R
  -> hoare_triple linvs P c (fun r => Q r * R)%sep.
Proof.
  simp.
  eapply HtWeaken.
  eapply HtFrame.
  eassumption.
  eauto.
Qed.

Theorem HtRead' : forall linvs a v,
  hoare_triple linvs (a |-> v)%sep (Read a) (fun r => a |-> v * [| r = v |])%sep.
Proof.
  simp.
  apply HtWeaken with (exists r, a |-> r * [| r = v |])%sep.
  eapply HtStrengthen.
  apply HtRead.
  simp.
  cancel; auto.
  subst; cancel.
  cancel; auto.
Qed.

Theorem HtRead'' : forall linvs p P R,
  P ===> (exists v, p |-> v * R v)
  -> hoare_triple linvs P (Read p) (fun r => p |-> r * R r)%sep.
Proof.
  simp.
  eapply HtWeaken.
  apply HtRead.
  assumption.
Qed.

Lemma HtReturn' : forall linvs P {result : Set} (v : result) Q,
    P ===> Q v
    -> hoare_triple linvs P (Return v) Q.
Proof.
  simp.
  eapply HtStrengthen.
  constructor.
  simp.
  cancel.
Qed.

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree
              || (eapply HtLock; simplify; solve [ eauto ])
              || (eapply HtUnlock; simplify; solve [ eauto ]).
Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel; auto ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                      || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
Ltac loop_inv Inv := loop_inv0 Inv; ht.
Ltac fork0 P1 P2 := apply HtWeaken with (P := (P1 * P2)%sep); [ apply HtPar | ].
Ltac fork P1 P2 := fork0 P1 P2 || (eapply HtStrengthen; [ fork0 P1 P2 | ]).
Ltac use H := (eapply use_lemma; [ eapply H | cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel ] | ]).

Ltac heq := intros; apply himp_heq; split.

Instance hoare_triple_morphism : forall linvs A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple linvs A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.
  Opaque himp.
Qed.

Theorem try_ptsto_first : forall a v, try_me_first (ptsto a v).
Proof.
  simplify.
  apply try_me_first_easy.
Qed.

Hint Resolve try_ptsto_first.

(** * Examples *)

(* We'll be working with pointer-based binary trees.  Here's a definition of the
 * functional version of trees, with data in internal nodes but not leaves. *)
Inductive tree :=
| Leaf
| Node (l : tree) (data : nat) (r : tree).

(* And here's a predicate explaining how a functional tree might be laid out in
 * memory with pointers.  (It may seem familiar from a past pset!) *)
Fixpoint mtree (p : nat) (t : tree) :=
  match t with
  | Leaf => [| p = 0 |]
  | Node l data r => [| p <> 0 |]
                     * exists lp rp, p |--> [lp; data; rp]
                                     * mtree lp l
                                     * mtree rp r
  end%sep.

(* We can prove two basic lemmas about trees, for when their root pointers are
 * null or nonnull, respectively. *)

Theorem mtree_null : forall t,
  mtree 0 t === [| t = Leaf |].
Proof.
  heq; cases t; cancel.
Qed.

Theorem mtree_nonnull : forall p t,
  p <> 0
  -> mtree p t === exists l d r lp rp, [| t = Node l d r |] * p |--> [lp; d; rp]
                                       * mtree lp l * mtree rp r.
Proof.
  heq; cases t; cancel; match goal with
                        | [ H : _ = Node _ _ _ |- _ ] => invert H
                        end; cancel.
Qed.

(** ** Example verification *)

(* As a warm-up to the proof style we suggest for this lab, here's a quick (and
 * silly) example.  Lock #0 owns a tree whose root pointer is stored in address
 * #0.  We don't really care what tree it is, and the thread here loops,
 * repeatedly grafting some arbitrary nonsense onto the tree! *)

Example grow_forever :=
  for _ := tt loop
    _ <- Lock 0;
    root <- Read 0;
    newNode <- Alloc 3;
    _ <- Write newNode root;
    _ <- Write 0 newNode;
    _ <- Unlock 0;
    Return (Again tt)
  done.

(* Lock invariant: address 0 stores the root pointer of some tree. *)
Definition gfinv := (exists p t, 0 |-> p * mtree p t)%sep.

Lemma grow_forever_ok :
  [gfinv] ||- {{emp}} grow_forever {{_ ~> emp}}.
Proof.
  unfold grow_forever, gfinv.
  loop_inv (fun _ : loop_outcome unit => emp)%sep.
  erewrite (mtree_nonnull _ H).
  cancel.
  rewrite mtree_null.
  cancel.
  cancel.
  cancel.
Qed.

(* We can prove the same theorem for a parallel composition of two grower
 * threads. *)
Lemma grows_forever_ok :
  [gfinv] ||- {{emp}} grow_forever || grow_forever {{_ ~> emp}}.
Proof.
  unfold grow_forever, gfinv.
  fork (emp%sep) (emp%sep).
  apply grow_forever_ok.
  apply grow_forever_ok.
  cancel.
  cancel.
Qed.

(* Quick summary of specialized tactics:
 * - [simp]: general simplification
 * - [step]: apply one basic rule of Concurrent Separation Logic.
 * - [ht]: apply as many basic rules of CSL as possible.
 *         (Often it's more pleasant to manually run [step] over and over.
 *          We recommend doing so if [ht] is running for a long time, as [ht]
 *          can get stuck in a loop when it needs your help choosing some
 *          rewrite rules to apply.)
 * - [fork P1 P2]: prove a parallel composition, using [P1] as the precondition
 *                 for the first thread and [P2] for the second.
 * - [loop_inv I]: apply loop rule with this invariant.
 * - [cancel]: prove implications by cancelation.
 * - [setoid_rewrite E]: rewrite with [E] underneath [exists] binders.
 *)

(** ** Your turn! *)

(* Let's prove a program that uses multiple threads to search a tree for a
 * particular data value.  Each thread is looping forever, trying to pop from a
 * shared stack of trees.  If it pops a leaf, it just goes back to looping.  If
 * it pops a node, it checks if the data value matches the "needle" we are
 * searching for in this "haystack."  If so, it sets a flag to indicate that we
 * found the value.  The thread also pushes both children of the node onto the
 * stack, in addition to freeing the memory used for the node, before looping
 * again.  One lock controls the "found it?" flag, and another lock controls the
 * stack of trees. *)

(* This predicate defines linked lists of trees, suitable for the stack. *)
Fixpoint linkedList (p : nat) (ls : list tree) :=
  match ls with
    | nil => [| p = 0 |]
    | t :: ls' => [| p <> 0 |]
                  * exists tp p', p |--> [tp; p'] * mtree tp t * linkedList p' ls'
  end%sep.

(* And here are modified versions of our usual main lemmas about linked
 * lists. *)
Theorem linkedList_null : forall ls,
  linkedList 0 ls === [| ls = nil |].
Proof.
  heq; cases ls; cancel.
Qed.

Theorem linkedList_nonnull : forall p ls,
  p <> 0
  -> linkedList p ls === exists t tp ls' p', [| ls = t :: ls' |] * p |--> [tp; p'] * mtree tp t * linkedList p' ls'.
Proof.
  heq; cases ls; cancel; match goal with
                         | [ H : _ = _ :: _ |- _ ] => invert H
                         end; cancel.
Qed.

Opaque mtree linkedList.

(* Now, here's the code, expanding on the outline from the longish comment
 * above. *)
Example worker needle :=
  for i := tt loop
    _ <- Lock 1;
    head <- Read 1;
    if head ==n 0 then
      _ <- Unlock 1;
      Return (Again tt)
    else
      tp <- Read head;
      tail <- Read (head+1);

      if tp ==n 0 then
        _ <- Write 1 tail;
        _ <- Unlock 1;
        _ <- Free head 2;
        Return (Again tt)
      else
        lp <- Read tp;
        d <- Read (tp+1);
        rp <- Read (tp+1+1);

        ln <- Alloc 2;
        _ <- Write ln lp;
        _ <- Write (ln+1) tail;

        rn <- Alloc 2;
        _ <- Write rn rp;
        _ <- Write (rn+1) ln;

        _ <- Write 1 rn;
        _ <- Unlock 1;

        _ <- Free head 2;
        _ <- Free tp 3;

        if d ==n needle then
          _ <- Lock 0;
          _ <- Write 0 1;
          _ <- Unlock 0;
          Return (Again tt)
        else
          Return (Again tt)
  done.

Example two_workers needle :=
  worker needle || worker needle.

(* To specify this program, we define a predicate for presence of a data value
 * in a tree. *)
Fixpoint inTree (needle : nat) (t : tree) :=
  match t with
  | Leaf => False
  | Node l d r => inTree needle l \/ d = needle \/ inTree needle r
  end.

(* Invariant associated with lock #0: memory address 0 stores a value that may
 * only be 1 if the needle is found in the tree. *)
Definition flag_inv (needle : nat) (t : tree) :=
  (exists b, 0 |-> b * [| b = 1 -> inTree needle t |])%sep.

(* CHALLENGE #1: choose a good invariant for lock #1, concerning the shared
 * stack of trees. *)
Definition stack_inv (needle : nat) (t : tree) := emp%sep.

(* CHALLENGE #2: prove that a single thread obeys the invariants. *)
Lemma worker_ok : forall needle t,
  [flag_inv needle t; stack_inv needle t] ||- {{emp}} worker needle {{_ ~> emp}}.
Proof.
  unfold worker, flag_inv, stack_inv.
  simp.
Admitted.

(* CHALLENGE #3: prove that 2 workers are also OK together. *)
Theorem workers_ok : forall needle t,
  [flag_inv needle t; stack_inv needle t] ||- {{emp}} two_workers needle {{_ ~> emp}}.
Proof.
Admitted.

Fixpoint n_workers (needle n : nat) :=
  match n with
  | O => worker needle
  | S n' => n_workers needle n' || n_workers needle n'
  end.

(* CHALLENGE #4: prove that 2^n workers are also OK. *)
Theorem n_workers_ok : forall needle t n,
  [flag_inv needle t; stack_inv needle t] ||- {{emp}} n_workers needle n {{_ ~> emp}}.
Proof.
Admitted.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Fsub.
Require Export Coq.micromega.Lia.

Hint Constructors Algo.typing.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : typ => fl_tt x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : env => fv_env x) in
  let H := gather_atoms_with (fun x : env => fl_env x) in
  let A1 := gather_atoms_with (fun x : exp => fv_te x) in
  let A2 := gather_atoms_with (fun x : exp => fv_ee x) in
  let A3 := gather_atoms_with (fun x : list (var * nat) => dom x) in
  let CF := gather_atoms_with (fun x : list (var * Fsub.typ) => dom x) in
  let DF := gather_atoms_with (fun x : Fsub.typ => Fsub.fl_tt x) in
  let EF := gather_atoms_with (fun x : Fsub.typ => Fsub.fv_tt x) in
  let FF := gather_atoms_with (fun x : Fsub.env => dom x) in
  let GF := gather_atoms_with (fun x : Fsub.env => Fsub.fv_env x) in
  let HF := gather_atoms_with (fun x : Fsub.env => Fsub.fl_env x) in
  let A1F := gather_atoms_with (fun x : Fsub.exp => Fsub.fv_te x) in
  let A2F := gather_atoms_with (fun x : Fsub.exp => Fsub.fv_ee x) in
  let A3F := gather_atoms_with (fun x : list (var * nat) => dom x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u A1 \u A2 \u A3
  \u CF \u DF \u EF \u FF \u GF \u HF \u A1F \u A2F \u A3F).

Coercion Fsub.typ_bvar : nat >-> Fsub.typ.
Coercion Fsub.typ_fvar : atom >-> Fsub.typ.

Module ExtDefs.

Inductive typ_ext : Fsub.typ -> typ -> Prop :=
| typ_ext_nat : typ_ext Fsub.typ_nat typ_nat
| typ_ext_top : typ_ext Fsub.typ_top typ_top
| typ_ext_bvar : forall (n : nat),
    typ_ext (Fsub.typ_bvar n) (typ_bvar n)
| typ_ext_fvar : forall (x : atom),
    typ_ext (Fsub.typ_fvar x) (typ_fvar x)
| typ_ext_arrow : forall (T1 T2 : Fsub.typ) T1' T2',
    typ_ext T1 T1' -> typ_ext T2 T2' ->
    typ_ext (Fsub.typ_arrow T1 T2) (typ_arrow T1' T2')
| typ_ext_all : forall (T1 T2 : Fsub.typ) T1' T2',
    typ_ext T1 T1' -> typ_ext T2 T2' ->
    typ_ext (Fsub.typ_all T1 T2) (typ_all T1' T2')
| typ_ext_nil:
    typ_ext Fsub.typ_rcd_nil typ_rcd_nil
| typ_ext_cons: forall i (T1 T2 : Fsub.typ) T1' T2',
    typ_ext T1 T1' -> typ_ext T2 T2' ->
    typ_ext (Fsub.typ_rcd_cons i T1 T2) (typ_rcd_cons i T1' T2')
.

Inductive exp_ext : Fsub.exp -> exp -> Prop :=
| exp_ext_nat :
    exp_ext Fsub.exp_nat exp_nat
| exp_ext_bvar : forall i,
    exp_ext (Fsub.exp_bvar i) (exp_bvar i)
| exp_ext_fvar : forall x,
    exp_ext (Fsub.exp_fvar x) (exp_fvar x)
| exp_ext_abs : forall T T' e e',
    typ_ext T T' ->
    exp_ext e e' ->
    exp_ext (Fsub.exp_abs T e) (exp_abs T' e')
| exp_ext_app : forall e1 e2 e1' e2',
    exp_ext e1 e1' ->
    exp_ext e2 e2' ->
    exp_ext (Fsub.exp_app e1 e2) (exp_app e1' e2')
| exp_ext_tabs : forall T T' e e',
    typ_ext T T' ->
    exp_ext e e' ->
    exp_ext (Fsub.exp_tabs T e) (exp_tabs T' e')
| exp_ext_tapp : forall T T' e  e',
    exp_ext e e' ->
    typ_ext T T' ->
    exp_ext (Fsub.exp_tapp e T) (exp_tapp e' T')
| exp_ext_proj: forall i e e',
    exp_ext e e' ->
    exp_ext (Fsub.exp_rcd_proj e i) (exp_rcd_proj e' i)
| exp_ext_rcd_nil: exp_ext Fsub.exp_rcd_nil exp_rcd_nil
| exp_ext_rcd_cons: forall i e1 e2 e1' e2',
    exp_ext e1 e1' ->
    exp_ext e2 e2' ->
    exp_ext (Fsub.exp_rcd_cons i e1 e2) (exp_rcd_cons i e1' e2')
.

Inductive binding_ext : Fsub.binding -> binding -> Prop :=
| binding_sub_ext: forall T T',
    typ_ext T T' ->
    binding_ext (Fsub.bind_sub T) (bind_sub T')
| binding_typ_ext: forall T T',
    typ_ext T T' ->
    binding_ext (Fsub.bind_typ T) (bind_typ T')
.

Inductive env_ext: Fsub.env -> env -> Prop :=
| env_ext_empty : env_ext nil nil
| env_ext_cons : forall (x : atom) b b' E E',
    env_ext E E' ->
    binding_ext b b' ->
    env_ext ((x, b) :: E) ((x, b') :: E').

Hint Constructors typ_ext exp_ext binding_ext env_ext.

Ltac inv_rt :=
  try (solve
   [ repeat match goal with
          | H:Fsub.rt_type ?T |- _ => inversion H; clear H
	        | H:rt_type ?T |- _ => inversion H; clear H
            end ]).

Ltac inv H := inversion H; subst;inv_rt.

Lemma typ_ext_inj1: forall { T T1' T2' },
  typ_ext T T1' -> typ_ext T T2' ->
  T1' = T2'.
Proof with auto.
  intros T. induction T;intros T1' T2' E1 E2;
  try solve [inv E1; inv E2; inv_rt; auto];inv_rt.
  - inv E1;inv_rt. inv E2;inv_rt...
    rewrite (IHT1 T1'0 T1')...
    rewrite (IHT2 T2'0 T2'1)...
  - inv E1. inv E2...
    rewrite (IHT1 T1'0 T1')...
    rewrite (IHT2 T2'0 T2'1)...
  - inv E1. inv E2...
    rewrite (IHT1 T1'0 T1')...
    rewrite (IHT2 T2'0 T2'1)...
Qed.

Lemma typ_ext_inj2: forall { T' T1 T2 },
  typ_ext T1 T' -> typ_ext T2 T' ->
  T1 = T2.
Proof with auto.
  intros T. induction T;intros T1' T2' E1 E2;
  try solve [inv E1; inv E2; auto].
  - inv E1. inv E2...
    rewrite (IHT1 T0 T4)...
    rewrite (IHT2 T3 T5)...
  - inv E1. inv E2...
    rewrite (IHT1 T0 T4)...
    rewrite (IHT2 T3 T5)...
  - inv E1. inv E2...
    rewrite (IHT1 T0 T4)...
    rewrite (IHT2 T3 T5)...
Qed.

Lemma typ_ext_ex: forall T ,
  exists T', typ_ext T T'.
Proof with auto.
  intros T. induction T;
  try solve [eexists; constructor; auto]...
  - destruct IHT1. destruct IHT2.
    exists (typ_arrow x x0)...
  - destruct IHT1. destruct IHT2.
    exists (typ_all x x0)...
  - destruct IHT1. destruct IHT2.
    exists (typ_rcd_cons a x x0)...
Qed.

End ExtDefs.

Lemma env_ext_dom : forall { E E' },
  ExtDefs.env_ext E E' -> dom E = dom E'.
Proof with auto.
  intros.
  induction H...
  simpl. rewrite IHenv_ext...
Qed.

Lemma collectLabel_conserv : forall { T T' },
  ExtDefs.typ_ext T T' -> Fsub.collectLabel T = collectLabel T'.
Proof with auto.
  intros.
  induction H...
  simpl. rewrite IHtyp_ext2...
Qed.

Lemma rt_type_conserv : forall { T T' },
  ExtDefs.typ_ext T T' -> Fsub.rt_type T <-> rt_type T'.
Proof with auto.
  intros.
  induction H;try solve [
    split;intro C;try inversion C
  ]...
  - split;intros...
  - split;intros...
Qed.

Lemma rt_expr_conserv : forall { e e' },
  ExtDefs.exp_ext e e' -> Fsub.rt_expr e <-> rt_expr e'.
Proof with auto.
  intros.
  induction H;try solve [
    split;intro C;try inversion C
  ]...
  - split;intros...
  - split;intros...
Qed.

Lemma collectLabele_conserv : forall { e e' },
ExtDefs.exp_ext e e' -> Fsub.collectLabele e = collectLabele e'.
Proof with auto.
  intros.
  induction H...
  simpl. rewrite IHexp_ext2...
Qed.

Lemma Tlookup_conserv2: forall {i A A' t},
  ExtDefs.typ_ext A A' ->
  Fsub.Tlookup i A = Some t ->
  exists t', Tlookup i A' = Some t' /\ ExtDefs.typ_ext t t'.
Proof with auto.
  intros.
  induction H;try solve [inv H0].
  - simpl in *. destruct (i0==i).
    + inv H0. exists T1'. split...
    + destruct (IHtyp_ext2 H0). destruct_hypos.
      exists x. split...
Qed.

Lemma Tlookup_conserv: forall {i A A' t'},
  ExtDefs.typ_ext A A' ->
  Tlookup i A' = Some t' ->
  exists t, Fsub.Tlookup i A = Some t /\ ExtDefs.typ_ext t t'.
Proof with auto.
  intros.
  induction H;try solve [inv H0].
  - simpl in *. destruct (i0==i).
    + inv H0. exists T1. split...
    + destruct (IHtyp_ext2 H0). destruct_hypos.
      exists x. split...
Qed.

Theorem bind_sub_conserv: forall E E' X U,
ExtDefs.env_ext E E' ->
binds X (Fsub.bind_sub U) E ->
exists U', binds X (bind_sub U') E' /\
    ExtDefs.typ_ext U U'.
Proof with auto.
  intros.
  induction H.
  - inv H0.
  - inv H0.
    + inv H2. inv H1.
      exists T'. split...
    + apply IHenv_ext in H2. destruct H2 as [U' [? ?]].
      exists U'...
Qed.

Theorem bind_typ_conserv: forall E E' X U,
ExtDefs.env_ext E E' ->
binds X (Fsub.bind_typ U) E ->
exists U', binds X (bind_typ U') E' /\
    ExtDefs.typ_ext U U'.
Proof with auto.
  intros.
  induction H.
  - inv H0.
  - inv H0.
    + inv H2. inv H1.
      exists T'. split...
    + apply IHenv_ext in H2. destruct H2 as [U' [? ?]].
      exists U'...
Qed.

Lemma open_tt_conserv: forall T T' U U',
ExtDefs.typ_ext T T' ->
ExtDefs.typ_ext U U' -> forall n,
ExtDefs.typ_ext (Fsub.open_tt_rec n U T) (open_tt_rec n U' T').
Proof with auto.
  intros. unfold open_tt.
  unfold Fsub.open_tt.  revert n.
  induction H...
  - intros. simpl. destruct (n0==n)...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
Qed.

Lemma open_close_tt_conserv_rec: forall T T' (X:atom) n,
X \notin fv_tt T ->
ExtDefs.typ_ext T' (open_tt_rec n X T) ->
ExtDefs.typ_ext (Fsub.close_tt_rec n X T') T.
Proof with auto.
  induction T; induction T'; intros; try solve [inv H0];simpl...
  - simpl in H0. destruct (n0 == n)... inv H0.
  - simpl in H0. destruct (n0 == n)... inv H0.
  - simpl in H0. destruct (n1 == n)... inv H0.
  - simpl in H0. destruct (n0 == n)...
    + inv H0. destruct (X == X)... exfalso...
    + inv H0.
  - simpl in H0. destruct (n0 == n)... inv H0.
    inv H0.
  - simpl in H0. destruct (n0 == n)... inv H0.
    inv H0.
  - simpl in H0. destruct (n0 == n)... inv H0.
  - simpl in H0. destruct (n0 == n)... inv H0.
    inv H0.
  - simpl in H0. destruct (a0 == X)... subst. inv H0.
    simpl in H. exfalso...
  - simpl in H0, H. inv H0...
  - simpl in H0, H. inv H0...
  - simpl in H0, H. inv H0...
Qed.

Lemma open_close_tt_conserv: forall T T' (X:atom),
X \notin fv_tt T ->
ExtDefs.typ_ext T' (open_tt T X) ->
ExtDefs.typ_ext (Fsub.close_tt T' X) T.
Proof with auto.
  intros.
  apply open_close_tt_conserv_rec...
Qed.

Lemma open_ee_conserv: forall e e' u u',
ExtDefs.exp_ext e e' ->
ExtDefs.exp_ext u u' ->
ExtDefs.exp_ext (Fsub.open_ee e u) (open_ee e' u').
Proof with auto.
  intros. unfold open_ee.
  unfold Fsub.open_ee. generalize 0.
  induction H...
  - intros. simpl. destruct (n==i)...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
  - intros. simpl...
Qed.

Lemma open_te_conserv: forall e e' u u',
ExtDefs.exp_ext e e' ->
ExtDefs.typ_ext u u' ->
ExtDefs.exp_ext (Fsub.open_te e u) (open_te e' u').
Proof with auto.
  intros. unfold open_te.
  unfold Fsub.open_te. generalize 0.
  induction H;try solve[intros;simpl;auto]...
  - simpl. intros. constructor...
    apply open_tt_conserv...
  - simpl. intros. constructor...
    apply open_tt_conserv...
  - simpl. intros. constructor...
    apply open_tt_conserv...
Qed.

Module Fsub2Ext.
(* T |- e : A -> T |-ext e : A  *)

Theorem wf_conserv:
forall E T,
Fsub.WF E T ->
forall  E' T',
ExtDefs.env_ext E E' ->
ExtDefs.typ_ext T T' ->
WF E' T'.
Proof with auto.
  intros E T H0.
  induction H0;intros.
  - inversion H0...
  - inversion H0...
  - inversion H1;subst...
    eapply bind_sub_conserv in H;eauto.
    destruct H as [U' [? ?]]...
    apply WF_var with (U:=U')...
  - inv H0...
  - inv H3... apply WF_all with (L:=L)...
    intros. specialize_x_and_L X L.
    apply H1...
    { constructor... }
    { apply open_tt_conserv... }
  - inv H0...
  - inv H2... apply WF_rcd_cons...
    + apply rt_type_conserv in H8... tauto.
    + apply collectLabel_conserv in H8... rewrite <- H8...
Qed.

Theorem wf_env_conserv:
forall E E',
ExtDefs.env_ext E E' ->
Fsub.wf_env E -> wf_env E'.
Proof with auto.
  intros. generalize dependent E'.
  induction H0;intros.
  - inversion H;subst...
  - inversion H2;subst.
    inversion H8;subst.
    rewrite_env ([(X, bind_sub T')] ++ E'0).
    constructor...
    { eapply wf_conserv;eassumption. }
    { rewrite <- (env_ext_dom H7)... }
  - inv H2. inv H8.
    rewrite_env ([(x, bind_typ T')] ++ E'0).
    constructor...
    { eapply wf_conserv;eassumption. }
    { rewrite <- (env_ext_dom H7)... }
Qed.

Theorem sub_conserv:
forall E E' T1 T2 T1' T2',
ExtDefs.env_ext E E' ->
ExtDefs.typ_ext T1 T1' ->
ExtDefs.typ_ext T2 T2' ->
Fsub.sub E T1 T2 -> sub E' T1' T2'.
Proof with auto.
  intros.
  generalize dependent E'.
  generalize dependent T1'.
  generalize dependent T2'.
  induction H2;intros.
  - inv H1. inv H0...
    apply sa_nat.
    eapply wf_env_conserv;eassumption...
  - inv H1. inv H2...
    apply sa_fvar.
    eapply wf_env_conserv;eassumption...
    eapply wf_conserv;eassumption...
  - inv H1.
    apply sa_top.
    eapply wf_env_conserv;eassumption...
    eapply wf_conserv;eassumption...
  - inv H0...
    eapply bind_sub_conserv in H;try eassumption...
    destruct H as [? [? ?]].
    eapply sa_trans_tvar...
    { apply H... }
    { apply IHsub... }
  - inv H1... inv H0...
  - assert (Hwfe: Fsub.wf_env E).
    { apply Fsub.sub_regular in H2_.
      destruct_hypos... }
    inv H2... inv H1...
    (* rewrite (ExtDefs.typ_ext_inj1 H7 H8) in *... *)
    apply sa_all with (L:=L)...
    { intros. specialize_x_and_L x L.
      apply H0...
      { apply open_tt_conserv... }
      { apply open_tt_conserv... }
      { constructor... }
    }
  - apply sa_rcd...
    + eapply wf_env_conserv;eassumption...
    + apply rt_type_conserv in H8... tauto.
    + apply rt_type_conserv in H7... tauto.
    + apply collectLabel_conserv in H8...
      apply collectLabel_conserv in H7...
      rewrite <- H8, <- H7...
    + eapply wf_conserv with (T:=A1); eassumption...
    + eapply wf_conserv with (T:=A2); eassumption...
    + intros.
      destruct (Tlookup_conserv H8 H10).
      destruct (Tlookup_conserv H7 H11). destruct_hypos.
      eapply H6 with (i:=i) (t1:=x) (t2:=x0)...
Qed.

Theorem typing_conserv:
forall E E' e e' t t',
ExtDefs.env_ext E E' ->
ExtDefs.exp_ext e e' ->
ExtDefs.typ_ext t t' ->
Fsub.typing E e t -> typing E' e' t'.
Proof with auto.
  intros.
  generalize dependent E'.
  generalize dependent e'.
  generalize dependent t'.
  induction H2;intros.
  - inv H0. inv H1.
    apply typing_nat.
    eapply wf_env_conserv;eassumption...
  - inv H2.
    apply typing_var.
    { eapply wf_env_conserv;eassumption... }
    { eapply bind_typ_conserv in H3;eauto.
      destruct H3 as [U' [? ?]]...
      rewrite (ExtDefs.typ_ext_inj1 H1 H4)... }
  - inv H2. inv H1.
    rewrite (ExtDefs.typ_ext_inj1 H6 H7) in *...
    apply typing_abs with (L:=L).
    intros. specialize_x_and_L x L.
    apply H0...
    { apply open_ee_conserv... }
    { constructor... }
  - inv H0.
  (* TODO: MIGHT TROUBLESOME in the reverse direction *)
    destruct (ExtDefs.typ_ext_ex T1).
    apply typing_app with (T1:=x)...
  - inv H1. inv H2.
    rewrite (ExtDefs.typ_ext_inj1 H6 H7) in *...
    apply typing_tabs with (L:=L).
    intros. specialize_x_and_L x L.
    apply H0...
    { apply open_tt_conserv... }
    { apply open_te_conserv... }
    { constructor... }
  - inv H0.
    destruct (ExtDefs.typ_ext_ex T2) as [T2' ?].
    pose proof open_tt_conserv H4 H8 0.
    rewrite (ExtDefs.typ_ext_inj1 H1 H5) in *.
    destruct (ExtDefs.typ_ext_ex T1) as [T1' ?].
    apply typing_tapp with (T1:=T1')...
    { eapply sub_conserv;try eassumption... }
  - destruct (ExtDefs.typ_ext_ex S) as [S' ?].
    apply typing_sub with (S:=S')...
    eapply sub_conserv;try eassumption...
  - destruct (ExtDefs.typ_ext_ex T) as [T' ?].
    inv H0.
    epose proof Tlookup_conserv2 H4 H.
    destruct H5 as [Ti']. destruct_hypos.
    rewrite (ExtDefs.typ_ext_inj1 H1 H6) in *.
    apply typing_proj with (T:=T')...
  - inv H1. inv H0. constructor.
    apply wf_env_conserv with (E:=G)...
  - inv H2. inv H3. constructor...
    + apply rt_type_conserv in H10. tauto.
    + apply rt_expr_conserv in H12. tauto.
    + apply collectLabele_conserv in H12...
      rewrite <- H12...
Qed.

End Fsub2Ext.

Module Ext2Fsub.

(* T |-ext e : A -> Fsub e -> Fsub A -> Fsub T -> T |- e : A  *)

Theorem bind_sub_conserv: forall E E' X U,
ExtDefs.env_ext E E' ->
binds X (bind_sub U) E' ->
exists U', binds X (Fsub.bind_sub U') E /\
    ExtDefs.typ_ext U' U.
Proof with auto.
  intros.
  induction H.
  - inv H0.
  - inv H0.
    + inv H2. inv H1.
      exists T. split...
    + apply IHenv_ext in H2. destruct H2 as [U' [? ?]].
      exists U'...
Qed.

Theorem bind_typ_conserv: forall E E' X U,
ExtDefs.env_ext E E' ->
binds X (bind_typ U) E' ->
exists U', binds X (Fsub.bind_typ U') E /\
    ExtDefs.typ_ext U' U.
Proof with auto.
  intros.
  induction H.
  - inv H0.
  - inv H0.
    + inv H2. inv H1.
      exists T. split...
    + apply IHenv_ext in H2. destruct H2 as [U' [? ?]].
      exists U'...
Qed.

Theorem wf_conserv:
forall E' T',
WF E' T' ->
forall  E T,
ExtDefs.env_ext E E' ->
ExtDefs.typ_ext T T' ->
Fsub.WF E T.
Proof with auto.
  intros E' T' H0.
  induction H0;intros.
  - inversion H0...
  - inversion H0...
  - inversion H1;subst...
    eapply bind_sub_conserv in H;eauto.
    destruct H as [U' [? ?]]...
    apply Fsub.WF_var with (U:=U')...
  - inv H0...
  - inv H3... apply Fsub.WF_all with (L:=L)...
    intros. specialize_x_and_L X L.
    apply H1...
    { constructor... }
    { apply open_tt_conserv... }
  - inv H4.
  - inv H1.
  - inv H0. constructor.
  - inv H2. constructor.
    + apply IHWF1...
    + apply IHWF2...
    + apply rt_type_conserv in H8. tauto.
    + apply collectLabel_conserv in H8. rewrite H8...
Qed.

Theorem wf_env_conserv:
forall E E',
ExtDefs.env_ext E E' ->
wf_env E' -> Fsub.wf_env E.
Proof with auto.
  intros. generalize dependent E.
  induction H0;intros.
  - inversion H;subst...
  - inversion H2;subst.
    inversion H8;subst.
    rewrite_env ([(X, Fsub.bind_sub T0)] ++ E1).
    constructor...
    { eapply wf_conserv;eassumption. }
    { rewrite  (env_ext_dom H6)... }
  - inv H2. inv H8.
    rewrite_env ([(x, Fsub.bind_typ T0)] ++ E1).
    constructor...
    { eapply wf_conserv;eassumption. }
    { rewrite (env_ext_dom H6)... }
Qed.

Theorem sub_conserv:
forall E E' T1 T2 T1' T2',
ExtDefs.env_ext E E' ->
ExtDefs.typ_ext T1 T1' ->
ExtDefs.typ_ext T2 T2' ->
sub E' T1' T2' -> Fsub.sub E T1 T2.
Proof with auto.
  intros.
  generalize dependent E.
  generalize dependent T1.
  generalize dependent T2.
  induction H2;intros.
  - inv H1. inv H0...
    apply Fsub.sa_nat.
    eapply wf_env_conserv;eassumption...
  - inv H1. inv H2...
    apply Fsub.sa_fvar.
    eapply wf_env_conserv;eassumption...
    eapply wf_conserv;eassumption...
  - inv H1.
    apply Fsub.sa_top.
    eapply wf_env_conserv;eassumption...
    eapply wf_conserv;eassumption...
  - inv H0...
    eapply bind_sub_conserv in H;try eassumption...
    destruct H as [? [? ?]].
    eapply Fsub.sa_trans_tvar...
    { apply H... }
    { apply IHsub... }
  - inv H1... inv H0...
  - inv H2... inv H1...
    (* rewrite (ExtDefs.typ_ext_inj2 H8 H10) in *... *)
    apply Fsub.sa_all with (L:=L)...
    { intros. specialize_x_and_L x L.
      apply H0...
      { apply open_tt_conserv... }
      { apply open_tt_conserv... }
      { constructor... }
    }
  - inv H3...
  - inv H0...
  - apply Fsub.sa_rcd...
    + eapply wf_env_conserv;eassumption...
    + apply rt_type_conserv in H8... tauto.
    + apply rt_type_conserv in H7... tauto.
    + apply collectLabel_conserv in H8...
      apply collectLabel_conserv in H7...
      rewrite H8, H7...
    + eapply wf_conserv with (T':=A1); eassumption...
    + eapply wf_conserv with (T':=A2); eassumption...
    + intros.
      destruct (Tlookup_conserv2 H8 H10).
      destruct (Tlookup_conserv2 H7 H11). destruct_hypos.
      eapply H6 with (i:=i) (t1:=x) (t2:=x0)...
Qed.

Lemma typ_ext_env_ex:
forall E E' X  T',
  ExtDefs.env_ext E E' ->
  binds X (bind_sub T') E' ->
  exists T, binds X (Fsub.bind_sub T) E /\ ExtDefs.typ_ext T T'.
Proof with auto.
  intros. induction H.
  - inv H0.
  - inv H0.
    + inv H2. inv H1. exists T. split...
    + destruct IHenv_ext as [T [? ?]]...
      exists T. split...
Qed.

Lemma exposure_ext_ex2:
forall E E' t t' s',
  ExtDefs.env_ext E E' ->
  ExtDefs.typ_ext t t' ->
  Algo.exposure E' t' s' ->
  exists s, ExtDefs.typ_ext s s'.
Proof with auto.
  intros. generalize dependent E.
  generalize dependent t.
  induction H1;intros.
  - exists Fsub.typ_nat...
  - exists Fsub.typ_top...
  - inv H0. destruct (typ_ext_env_ex _ _ H2 H) as [U' ?].
    destruct_hypos.
    destruct IHexposure with (t:=U') (E0:=E0)...
    exists x...
  - inv H0... exists (Fsub.typ_arrow T1 T2)...
  - inv H0. exists (Fsub.typ_all T1 T2)...
  - inv H0.
  - inv H0.
  - inv H.
    + inv H0. exists Fsub.typ_rcd_nil...
    + inv H0. exists (Fsub.typ_rcd_cons i T0 T3)...
Qed.

Lemma typ_ext_ex2:
forall E E' e e' t',
  ExtDefs.env_ext E E' ->
  ExtDefs.exp_ext e e' ->
  Algo.typing E' e' t' ->
  exists t, Fsub.typing E e t /\ ExtDefs.typ_ext t t'.
Proof with auto.
  intros.
  generalize dependent E.
  generalize dependent e.
  dependent induction H1;intros.
  - inv H0... exists Fsub.typ_nat. split...
    constructor.
    eapply wf_env_conserv;eassumption.
  - inv H1. eapply bind_typ_conserv in H0.
    2:{ apply H2. } destruct H0 as [? [? ?]].
    exists x0... split...
    constructor...
    eapply wf_env_conserv;eassumption.
  - inv H1.
    pick_fresh X.
    specialize_x_and_L X L.
    destruct H0 with (e:= Fsub.open_ee e0 (Fsub.exp_fvar X))
    (E0 := X ~ Fsub.bind_typ T ++ E0) as [T1' [? ?]]...
    { apply open_ee_conserv... }
    { constructor... }
    { exists (Fsub.typ_arrow T T1'). split...
      + apply Fsub.typing_abs with (L:={{X}} \u (union L
      (union (Fsub.fl_tt T)
         (union (Fsub.fv_tt T)
            (union (dom E0)
               (union (Fsub.fv_env E0)
                  (union (Fsub.fl_env E0)
                     (union (Fsub.fv_te e0) (Fsub.fv_ee e0))))))))).
        intros.
        rewrite_env (nil ++ X ~ Fsub.bind_typ T ++ E0) in H3.
        rewrite Fsub.subst_ee_intro with (x:=X)...
        apply Fsub.typing_replacing with (Y:=x) in H3...
        { apply Algo.typing_regular in H. destruct_hypos.
          inv H. constructor...
          eapply wf_env_conserv; eassumption.
          eapply wf_conserv;eassumption.
        }
    }
  - inv H1.
    destruct IHtyping1 with (e:=e0) (E0:=E0) as [T1' [? ?]]...
    destruct IHtyping2 with (e:=e3) (E0:=E0) as [T2' [? ?]]...
    pose proof (Algo.typing_regular H1_). destruct_hypos.
    destruct (exposure_ext_ex2 H2 H4 H) as [Tarr' ?].
    inv H12.
    apply Algo.exposure_sound in H...
    pose proof sub_conserv H2 H4 H12 H.
    exists T3.
    split...
    + apply Fsub.typing_app with (T1:=T0)...
      { eapply Fsub.typing_sub with (S:=T1')... }
      { apply Fsub.typing_sub with (S:=T2')...
        pose proof sub_conserv H2 H8 H16 H0... }
  - inv H1.
    pick_fresh X.
    specialize_x_and_L X L.
    destruct H0 with (e:= Fsub.open_te e0 (Fsub.typ_fvar X))
    (E0 := X ~ Fsub.bind_sub T ++ E0) as [T1' [? ?]]...
    { apply open_te_conserv... }
    { constructor... }
    { exists (Fsub.typ_all T (Fsub.close_tt T1' X)). split...
      + apply Fsub.typing_tabs with (L:={{X}} \u (union L
      (union (Fsub.fl_tt T)
         (union (Fsub.fv_tt T)
            (union (dom E0)
               (union (Fsub.fv_env E0)
                  (union (Fsub.fl_env E0)
                     (union (Fsub.fv_te e0) (Fsub.fv_ee e0))))))))\u Fsub.fv_tt T1').
        intros.
        rewrite_env (nil ++ X ~ Fsub.bind_sub T ++ E0) in H3.
        rewrite Fsub.subst_te_intro with (X:=X)...
        apply Fsub.typing_replacing2 with (Y:=X0) in H3...
        2:{ apply Algo.typing_regular in H. destruct_hypos.
          inv H. constructor...
          eapply wf_env_conserv; eassumption.
          eapply wf_conserv;eassumption.
        }
        { rewrite <- Fsub.open_close_reverse...
          { apply Fsub.typing_regular in H3. destruct_hypos.
            apply Fsub.WF_type in H9.
            rewrite Fsub.subst_tt_twice with (X:=X0) (Y:=X)...
            apply Fsub.subst_tt_type...
          }
        }
      + constructor...
        apply open_close_tt_conserv...
    }
  - inv H2.
    destruct IHtyping with (e:=e0) (E0:=E0) as [Tall' [? ?]]...
    destruct (exposure_ext_ex2 H3 H5 H) as [Tall'' ?].
    inv H6.
    exists (Fsub.open_tt T3 T). split...
    2:{ eapply open_tt_conserv... }
    apply Fsub.typing_tapp with (T1:=T0)...
    { apply Fsub.typing_sub with (S:=Tall')...
      pose proof (Algo.typing_regular H1). destruct_hypos.
      apply Algo.exposure_sound in H...
      eapply sub_conserv;[..|apply H]...
    }
    { eapply sub_conserv;[..|apply H0]... }
  - inv H3.
  - inv H2.
  - inv H2.
    destruct IHtyping with (e0:=e1) (E:=E) as [Trcd' [? ?]]...
    destruct (exposure_ext_ex2 H3 H5 H) as [Trcd'' ?].
    epose proof Tlookup_conserv H7 H0.
    destruct H8 as [Ti']. destruct_hypos.
    exists Ti'. split...
    + eapply Fsub.typing_proj with (T:=Trcd'')...
      apply Fsub.typing_sub with (S:=Trcd')...
      pose proof (Algo.typing_regular H1). destruct_hypos.
      apply Algo.exposure_sound in H...
      eapply sub_conserv;[..|apply H]...
  - inv H0. exists Fsub.typ_rcd_nil. split...
    constructor... apply wf_env_conserv with (E':=G)...
  - inv H2.
    destruct IHtyping1 with (e:=e0) (E:=E) as [T1' [? ?]]...
    destruct IHtyping2 with (e:=e3) (E:=E) as [T2' [? ?]]...
    exists (Fsub.typ_rcd_cons i T1' T2')...
    split...
    constructor...
    + apply rt_type_conserv in H8. tauto.
    + apply rt_expr_conserv in H9. tauto.
    + apply collectLabele_conserv in H9...
      rewrite H9...
Qed.

Theorem typing_algo_conserv:
forall E E' e e' t t',
ExtDefs.env_ext E E' ->
ExtDefs.exp_ext e e' ->
ExtDefs.typ_ext t t' ->
Algo.typing E' e' t' -> Fsub.typing E e t.
Proof with auto.
  intros.
  generalize dependent E.
  generalize dependent e.
  generalize dependent t.
  induction H2;intros.
  - inv H0. inv H1.
    apply Fsub.typing_nat.
    eapply wf_env_conserv;eassumption...
  - inv H2.
    apply Fsub.typing_var.
    { eapply wf_env_conserv;eassumption... }
    { eapply bind_typ_conserv in H3;eauto.
      destruct H3 as [U' [? ?]]...
      rewrite (ExtDefs.typ_ext_inj2 H1 H4)... }
  - inv H2. inv H1.
    rewrite (ExtDefs.typ_ext_inj2 H9 H7) in *...
    apply Fsub.typing_abs with (L:=L).
    intros. specialize_x_and_L x L.
    apply H0...
    { apply open_ee_conserv... }
    { constructor... }
  - inv H2.
    destruct (typ_ext_ex2 H3 H7 H2_)
    as [T1' [? ?]].
    destruct (exposure_ext_ex2 H3 H5 H) as [Tarr' ?].
    inv H6.
    rewrite (ExtDefs.typ_ext_inj2 H13 H1) in *...
    apply Fsub.typing_app with (T1:=T0).
    { apply Fsub.typing_sub with (S:=T1')...
      pose proof (Algo.typing_regular H2_). destruct_hypos.
      apply Algo.exposure_sound in H...
      eapply sub_conserv;[..|apply H]...
    }
    { destruct (typ_ext_ex2 H3 H8 H2_0) as [T2' ?].
      destruct_hypos.
      apply Fsub.typing_sub with (S:=T2')...
      eapply sub_conserv;[..|apply H0]... }

  - inv H1. inv H2.
    rewrite (ExtDefs.typ_ext_inj2 H9 H7) in *...
    apply Fsub.typing_tabs with (L:=L).
    intros. specialize_x_and_L x L.
    apply H0...
    { apply open_tt_conserv... }
    { apply open_te_conserv... }
    { constructor... }
  - inv H3.
    destruct (typ_ext_ex2 H4 H8 H2) as [Tall' [? ?]].
    destruct (exposure_ext_ex2 H4 H6 H) as [Tall'' ?].
    inv H7.
    pose proof open_tt_conserv H14 H9 0.
    rewrite (ExtDefs.typ_ext_inj2 H1 H10) in *...
    apply Fsub.typing_tapp with (T1:=T0)...
    { eapply Fsub.typing_sub with (S:=Tall')...
      pose proof (Algo.typing_regular H2). destruct_hypos.
      apply Algo.exposure_sound in H...
      eapply sub_conserv;[..|apply H]...
    }
    { eapply sub_conserv;[..|apply H0]... }
  - inv H4.
  - inv H3.

  - inv H3.
    destruct (typ_ext_ex2 H4 H7 H2) as [Trcd' ?]. destruct_hypos.
    destruct (exposure_ext_ex2 H4 H6 H) as [Trcd'' ?].
    epose proof Tlookup_conserv H8 H0.
    destruct H9 as [Ti']. destruct_hypos.
    rewrite (ExtDefs.typ_ext_inj2 H1 H10) in *.
    apply Fsub.typing_proj with (T:=Trcd'')...
    apply Fsub.typing_sub with (S:=Trcd')...
    pose proof (Algo.typing_regular H2). destruct_hypos.
    apply Algo.exposure_sound in H...
    eapply sub_conserv;[..|apply H]...
  - inv H1. inv H0. constructor.
    apply wf_env_conserv with (E':=G)...
  - inv H2. inv H3. constructor...
    + apply rt_type_conserv in H10. tauto.
    + apply rt_expr_conserv in H12. tauto.
    + apply collectLabele_conserv in H12...
      rewrite H12...
Qed.

Theorem typing_conserv:
forall E E' e e' t t',
ExtDefs.env_ext E E' ->
ExtDefs.exp_ext e e' ->
ExtDefs.typ_ext t t' ->
typing E' e' t' -> Fsub.typing E e t.
Proof with auto.
  intros.
  destruct (minimum_typing H2) as [s' ?].
  destruct_hypos.
  destruct (typ_ext_ex2 H H0 H3) as [s ?].
  destruct_hypos.
  pose proof typing_algo_conserv H H0 H6 H3.
  eapply Fsub.typing_sub with (S:=s)...
  eapply sub_conserv;[..|apply H4]...
Qed.

End Ext2Fsub.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.rotate.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(* auxilary *)

Lemma Forall_range_uni : forall {X} {d : Inhabitant X} l P,
  Forall P l -> range_uni 0 (Zlength l) l P.
Proof.
  intros. induction H; unfold range_uni, rangei in *; intros.
  - list_solve2.
  - destruct (Z_le_lt_dec i 0).
    + list_solve2.
    + exploit (IHForall (i-1)); list_solve2.
Qed.

(* end auxilary *)

Definition rotate {X} (l : list X) k :=
  sublist k (Zlength l) l ++ sublist 0 k l.

Definition rotate_spec :=
 DECLARE _rotate
  WITH sh : share, a : val, s : list Z, n : Z, k : Z, gv : globals
  PRE [ tptr tint , tint, tint]
     PROP(writable_share sh; 0 <= n; 0 <= 4 * n <= Ptrofs.max_unsigned;
        0 < k < n
     )
     PARAMS (a; Vint (Int.repr n); Vint (Int.repr k)) GLOBALS (gv)
     SEP (mem_mgr gv; data_at sh (tarray tint n) (map Vint (map Int.repr s)) a)
  POST [ tvoid ]
     PROP()
     RETURN()
     SEP (mem_mgr gv; (data_at sh (tarray tint n) (map Vint (map Int.repr (rotate s k))) a)).

Arguments sorted {_ _}.

Definition sorted_rotate (l : list Z) k N :=
  sublist k (Zlength l) l ++ map (Z.add N) (sublist 0 k l).

Definition sorted_rotate_spec :=
 DECLARE _sorted_rotate
  WITH sh : share, a : val, s : list Z, n : Z, k : Z, N : Z, gv : globals
  PRE [ tptr tint , tint, tint, tint]
     PROP(writable_share sh; 0 <= n; 0 <= 4 * n <= Ptrofs.max_unsigned;
        0 < k < n; 0 <= N*2 < Int.max_signed;
        Forall (fun x => 0 <= x <= N) s;
        sorted Z.le s
     )
     PARAMS (a; Vint (Int.repr n); Vint (Int.repr k); Vint (Int.repr N)) GLOBALS (gv)
     SEP (mem_mgr gv; data_at sh (tarray tint n) (map Vint (map Int.repr s)) a)
  POST [ tvoid ]
     PROP(sorted Z.le (sorted_rotate s k N))
     RETURN()
     SEP (mem_mgr gv; (data_at sh (tarray tint n) (map Vint (map Int.repr (sorted_rotate s k N))) a)).

Definition Gprog : funspecs :=
        ltac:(with_library prog [rotate_spec; sorted_rotate_spec]).

Lemma rotate_body : semax_body Vprog Gprog f_rotate rotate_spec.
Proof.
  start_function.
  forward_call (tarray tint n, gv).
  simpl; split3; auto; lia.
  Intros b.
  forward_if (
    PROP ( )
    LOCAL (temp _b b; temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)); gvars gv)
    SEP (mem_mgr gv; malloc_token Ews (tarray tint n) b; data_at_ Ews (tarray tint n) b;
      data_at sh (tarray tint n) (map Vint (map Int.repr s)) a)
  ).
  { if_tac; entailer!. }
  { forward_call (-1). inv H3. }
  { forward. entailer!. if_tac; auto. congruence. }
  freeze [0; 1] FR.
  assert_PROP (n = Zlength s). { entailer!. list_solve. }
  forward_for_simple_bound (n-k) (EX i : Z,
    PROP ( )
    LOCAL (temp _b b; temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)); gvars gv)
    SEP (FRZL FR; data_at Ews (tarray tint n) (map Vint (map Int.repr (sublist k (k+i) s)) ++ Zrepeat Vundef (n-i)) b; data_at sh (tarray tint n) (map Vint (map Int.repr s)) a)
  ).
  { entailer!. rewrite data_at__tarray. list_solve. }
  { forward.
    forward.
    entailer!.
    Time list_solve2.
  }
  forward_for_simple_bound n (EX i : Z,
    PROP (n-k <= i)
    LOCAL (temp _b b; temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)); gvars gv)
    SEP (FRZL FR; data_at Ews (tarray tint n) (map Vint (map Int.repr (sublist k n s ++ sublist 0 (i-(n-k)) s)) ++ Zrepeat Vundef (n-i)) b;
      data_at sh (tarray tint n) (map Vint (map Int.repr s)) a
    )
  ).
  { forward. Exists (n-k). entailer!. list_solve2. }
  { Intros.
    forward.
    forward.
    entailer!.
    Time list_solve2.
  }
  forward_for_simple_bound n (EX i : Z,
    PROP ( )
    LOCAL (temp _b b; temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)); gvars gv)
    SEP (FRZL FR; data_at Ews (tarray tint n) (map Vint (map Int.repr (sublist k n s ++ sublist 0 k s))) b;
      data_at sh (tarray tint n) (map Vint (map Int.repr (sublist 0 i (sublist k n s ++ sublist 0 k s) ++ sublist i n s))) a
    )
  ).
  { entailer!. apply sepcon_derives; list_solve2. }
  { forward.
    forward.
    entailer!.
    Time list_solve2.
  }
  thaw FR.
  forward_call (tarray tint n, b, gv).
  { if_tac; entailer!. }
  entailer!.
  unfold rotate.
  Time list_solve2.
Time Qed.

Lemma sorted_rotate_body : semax_body Vprog Gprog f_sorted_rotate sorted_rotate_spec.
Proof.
  start_function.
  assert_PROP (Zlength s = n). { entailer!. list_solve. }
  remember (sublist 0 k s) as s1.
  remember (sublist k n s) as s2.
  assert (Zlength s1 = k) by (subst; list_solve2).
  assert (Zlength s2 = n-k) by (subst; list_solve2).
  assert (s = s1 ++ s2) by (subst; list_solve2).
  clear Heqs1 Heqs2. subst s.
  apply Forall_range_uni in H3.
  forward_call (sh, a, s1 ++ s2, n, k, gv).
  unfold rotate.
  forward_for_simple_bound n (EX i : Z,
    PROP (n-k <= i <= n)
    LOCAL (temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)); temp _N (Vint (Int.repr N)); gvars gv)
    SEP (mem_mgr gv; data_at sh (tarray tint n) (map Vint (map Int.repr (
      s2
        ++ map (fun x => x + N) (sublist 0 (i-(n-k)) s1)
        ++ sublist (i-(n-k)) k s1)
    )) a)
  ).
  { forward. Exists (n-k). entailer!. list_solve2. }
  { Intros.
    forward.
    exploit (H3 (i-(n-k))). list_solve2. intros.
    forward.
    { entailer!. autorewrite with Znth in *.
      replace (Znth _ s1) with (Znth (i - (Zlength (s1 ++ s2) - Zlength s1)) s1) by list_solve2.
      do 2 rewrite Int.signed_repr by rep_lia. rep_lia.
    }
    entailer!. Time list_solve2.
  }
  unfold sorted_rotate. entailer!.
  {
    unfold sorted. intros.
    Time list_prop_solve'.
  }
  {
    Time list_solve2'.
    (* A proof goal is remained because the base solver is incomplete. *)
    apply data_subsume_refl'. rewrite Z.add_comm. repeat f_equal. list_solve.
  }
Time Qed.