Require Import VST.floyd.base2.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.computable_theorems.
Open Scope nat.

Inductive ListType: list Type -> Type :=
  | Nil: ListType nil
  | Cons: forall {A B} (a: A) (b: ListType B), ListType (A :: B).

Fixpoint ListTypeGen {A} (F: A -> Type) (f: forall A, F A) (l: list A) : ListType (map F l) :=
  match l with
  | nil => Nil
  | cons h t => Cons (f h) (ListTypeGen F f t)
  end.

Lemma ListTypeGen_preserve: forall A F f1 f2 (l: list A),
  (forall a, In a l -> f1 a = f2 a) ->
  ListTypeGen F f1 l = ListTypeGen F f2 l.
Proof.
  intros.
  induction l.
  + reflexivity.
  + simpl.
    rewrite H, IHl.
    - reflexivity.
    - intros; apply H; simpl; tauto.
    - simpl; left; auto.
Defined.

Definition decay' {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F.
  remember (map (fun _ : X => F) l) eqn:E.
  revert l E.
  induction v; intros.
  + exact nil.
  + destruct l; inversion E.
    specialize (IHv l H1).
    rewrite H0 in a.
    exact (a :: IHv).
Defined.

Fixpoint decay'' {X} {F: Type} (l0 : list Type) (v: ListType l0) :
  forall (l: list X), l0 = map (fun _ => F) l -> list F :=
  match v in ListType l1
    return forall l2, l1 = map (fun _ => F) l2 -> list F
  with
  | Nil => fun _ _ => nil
  | Cons A B a b =>
    fun (l1 : list X) (E0 : A :: B = map (fun _ : X => F) l1) =>
    match l1 as l2 return (A :: B = map (fun _ : X => F) l2 -> list F) with
    | nil => fun _ => nil (* impossible case *)
    | x :: l2 =>
       fun E1 : A :: B = map (fun _ : X => F) (x :: l2) =>
       (fun
          X0 : map (fun _ : X => F) (x :: l2) =
               map (fun _ : X => F) (x :: l2) -> list F =>
        X0 eq_refl)
         match
           E1 in (_ = y)
           return (y = map (fun _ : X => F) (x :: l2) -> list F)
         with
         | eq_refl =>
             fun H0 : A :: B = map (fun _ : X => F) (x :: l2) =>
              (fun (H3 : A = F) (H4 : B = map (fun _ : X => F) l2) =>
                  (eq_rect A (fun A0 : Type => A0) a F H3) :: (decay'' B b l2 H4))
                 (f_equal
                    (fun e : list Type =>
                     match e with
                     | nil => A
                     | T :: _ => T
                     end) H0)
                (f_equal
                   (fun e : list Type =>
                    match e with
                    | nil => B
                    | _ :: l3 => l3
                    end) H0)
         end
    end E0
  end.

Definition decay {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F :=
  let l0 := map (fun _ => F) l in
  let E := @eq_refl _ (map (fun _ => F) l) : l0 = map (fun _ => F) l in
  decay'' l0 v l E.

Lemma decay_spec: forall A F f l,
  decay (ListTypeGen (fun _: A => F) f l) = map f l.
Proof.
  intros.
  unfold decay.
  induction l.
  + simpl.
    reflexivity.
  + simpl.
    f_equal.
    auto.
Defined.

Section COMPOSITE_ENV.
Context {cs: compspecs}.

Lemma type_ind: forall P : type -> Prop,
  (forall t,
  match t with
  | Tarray t0 _ _ => P t0
  | Tstruct id _ => let m := co_members (get_co id) in Forall (fun it => P (field_type (fst it) m)) m
  | Tunion id _ => let m := co_members (get_co id) in Forall (fun it => P (field_type (fst it) m)) m
  | _ => True
  end -> P t) ->
  forall t, P t.
Proof.
  intros P IH_TYPE.
  intros.
  remember (rank_type cenv_cs t) as n eqn: RANK'.
  assert (rank_type cenv_cs t <= n)%nat as RANK.
  subst. apply le_n.
  clear RANK'.
  revert t RANK.
  induction n;
  intros;
  specialize (IH_TYPE t); destruct t;
  try solve [specialize (IH_TYPE I); auto].
  + (* Tarray level 0 *)
    simpl in RANK. inv RANK.
  + (* Tstruct level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (cenv_cs ! i); [inv RANK | apply IH_TYPE; simpl; constructor].
  + (* Tunion level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (cenv_cs ! i); [inv RANK | apply IH_TYPE].
    simpl; constructor.
  + (* Tarray level positive *)
    simpl in RANK.
    specialize (IHn t).
    apply IH_TYPE, IHn.
    apply le_S_n; auto.
  + (* Tstruct level positive *)
    simpl in RANK.
    pose proof get_co_members_no_replicate i.
    unfold get_co in *.
    destruct (cenv_cs ! i) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros [i0 t0] ?; simpl.
    apply IHn.
    pose proof In_field_type _ _ H H0.
    simpl in H1; rewrite H1.
    apply rank_type_members with (ce := cenv_cs) in H0.
    rewrite <- co_consistent_rank in H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    exact (cenv_consistent i co CO).
  + (* Tunion level positive *)
    simpl in RANK.
    pose proof get_co_members_no_replicate i.
    unfold get_co in *.
    destruct (cenv_cs ! i) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros [i0 t0] ?; simpl.
    apply IHn.
    pose proof In_field_type _ _ H H0.
    simpl in H1; rewrite H1.
    apply rank_type_members with (ce := cenv_cs) in H0.
    rewrite <- co_consistent_rank in H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    exact (cenv_consistent i co CO).
Defined.

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    let a := fresh "a" in
    destruct t as [| | | | | | | id a | id a]
  end.

Variable A: type -> Type.

Definition FT_aux id :=
    let m := co_members (get_co id) in
    ListType (map (fun it => A (field_type (fst it) m)) m).

Variable F_ByValue: forall t: type, A t.
Variable F_Tarray: forall t n a, A t -> A (Tarray t n a).
Variable F_Tstruct: forall id a, FT_aux id -> A (Tstruct id a).
Variable F_Tunion: forall id a, FT_aux id -> A (Tunion id a).

Fixpoint type_func_rec (n: nat) (t: type): A t :=
  match n with
  | 0 =>
    match t as t0 return A t0 with
    | Tstruct id a =>
       match cenv_cs ! id with
       | None => let m := co_members (get_co id) in
                       F_Tstruct id a (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => F_ByValue (field_type (fst it) m)) m)
       | _ => F_ByValue (Tstruct id a)
       end
    | Tunion id a =>
       match cenv_cs ! id with
       | None => let m := co_members (get_co id) in
                      F_Tunion id a (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => F_ByValue (field_type (fst it) m)) m)
       | _ => F_ByValue (Tunion id a)
       end
    | t' => F_ByValue t'
    end
  | S n' =>
    match t as t0 return A t0 with
    | Tarray t0 n a => F_Tarray t0 n a (type_func_rec n' t0)
    | Tstruct id a =>  let m := co_members (get_co id) in
                            F_Tstruct id a (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => type_func_rec n' (field_type (fst it) m)) m)
    | Tunion id a =>  let m := co_members (get_co id) in
                            F_Tunion id a (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => type_func_rec n' (field_type (fst it) m)) m)
    | t' => F_ByValue t'
    end
  end.

Definition type_func t := type_func_rec (rank_type cenv_cs t) t.

Lemma rank_type_Tstruct: forall id a co, cenv_cs ! id = Some co ->
  rank_type cenv_cs (Tstruct id a) = S (co_rank (get_co id)).
Proof.
  intros.
  unfold get_co; simpl.
  destruct (cenv_cs ! id); auto; congruence.
Defined.

Lemma rank_type_Tunion: forall id a co, cenv_cs ! id = Some co ->
  rank_type cenv_cs (Tunion id a) = S (co_rank (get_co id)).
Proof.
  intros.
  unfold get_co; simpl.
  destruct (cenv_cs ! id); auto; congruence.
Defined.

Lemma type_func_rec_rank_irrelevent: forall t n n0,
  n >= rank_type cenv_cs t ->
  n0 >= rank_type cenv_cs t ->
  type_func_rec n t = type_func_rec n0 t.
Proof.
 (* DON'T USE omega IN THIS PROOF!
   We want the proof to compute reasonably efficiently.
*)
  intros t.
  type_induction t;
  intros;
  try solve [destruct n; simpl; auto; destruct n0; simpl; auto].
  + (* Tarray *)
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
    simpl. f_equal.
    apply IH; apply le_S_n; auto.
  + (* Tstruct *)
    destruct (cenv_cs ! id) as [co |] eqn: CO.
    - erewrite rank_type_Tstruct in H by eauto.
      erewrite rank_type_Tstruct in H0 by eauto.
      clear co CO.
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      apply ListTypeGen_preserve.
      intros [i t] Hin.
      simpl in IH.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH (i, t) Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs i t _ Hin).
      pose proof get_co_members_no_replicate id.
      pose proof In_field_type (i, t) _ H1 Hin.
      rewrite <- (co_consistent_rank cenv_cs (get_co id) (get_co_consistent _)) in H3.
      unfold field_type in H2.
      apply IH;
       (eapply le_trans; [ | eassumption]; rewrite H2; auto).
    - destruct n, n0; simpl;  unfold FT_aux in *;
      generalize (F_Tstruct id a) as FF; unfold get_co;
      rewrite CO; intros; auto.
  + (* Tunion *)
    destruct (cenv_cs ! id) as [co |] eqn: CO.
    - erewrite rank_type_Tunion in H by eauto.
      erewrite rank_type_Tunion in H0 by eauto.
      clear co CO.
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      apply ListTypeGen_preserve.
      intros [i t] Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH (i, t) Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs i t _ Hin).
      pose proof get_co_members_no_replicate id.
      pose proof In_field_type (i, t) _ H1 Hin.
      rewrite <- (co_consistent_rank cenv_cs (get_co id) (get_co_consistent _)) in H3.
      apply IH;
       (eapply le_trans; [ | eassumption]; rewrite H2; auto).
    - destruct n, n0; simpl;  unfold FT_aux in *;
      generalize (F_Tunion id a) as FF; unfold get_co;
      rewrite CO; intros; auto.
Defined.

Definition FTI_aux id :=
    let m := co_members (get_co id) in
    (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => type_func (field_type (fst it) m)) m).

Lemma type_func_eq: forall t,
  type_func t =
  match t as t0 return A t0 with
  | Tarray t0 n a => F_Tarray t0 n a (type_func t0)
  | Tstruct id a => F_Tstruct id a (FTI_aux id)
  | Tunion id a => F_Tunion id a (FTI_aux id)
  | t' => F_ByValue t'
  end.
Proof.
  intros.
  type_induction t; try reflexivity.
  + (* Tstruct *)
    unfold type_func in *.
    simpl type_func_rec.
    destruct (cenv_cs ! id) as [co |] eqn:CO; simpl.
    - f_equal.
      apply ListTypeGen_preserve; intros [i t].
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply type_func_rec_rank_irrelevent.
      * assert (H0 := get_co_members_no_replicate id).
        unfold get_co in H0; rewrite CO in H0.
        rewrite (In_field_type _ _ H0 Hin).
        rewrite (co_consistent_rank cenv_cs _
                           (cenv_consistent id co CO)).
        eapply rank_type_members; eauto.
      * apply le_n.
    - rewrite CO.
      f_equal.
      unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
  + (* Tunion *)
    unfold type_func in *.
    simpl type_func_rec.
    destruct (cenv_cs ! id) as [co |] eqn:CO; simpl.
    - f_equal.
      apply ListTypeGen_preserve; intros [i t].
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply type_func_rec_rank_irrelevent.
      * assert (H0 := get_co_members_no_replicate id).
        unfold get_co in H0; rewrite CO in H0.
        rewrite (In_field_type _ _ H0 Hin).
        rewrite (co_consistent_rank cenv_cs _
                           (cenv_consistent id co CO)).
        eapply rank_type_members; eauto.
      * apply le_n.
    - rewrite CO.
      f_equal.
      unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
Defined.

End COMPOSITE_ENV.

Arguments type_func {cs} A F_ByValue F_Tarray F_Tstruct F_Tunion t / .

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    let a := fresh "a" in
    destruct t as [| | | | | | | id a | id a]
  end.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Option data-structure
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibReflect.
Generalizable Variables A.

(** Fixing implicit arguments *)

Implicit Arguments Some [[A]].
Implicit Arguments None [[A]].

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Instance option_inhab : forall A, Inhab (option A).
Proof using. intros. apply (prove_Inhab None). Qed.

Definition option_compare `{Comparable A} (o1 o2 : option A) :=
  match o1, o2 with
  | None, None => true
  | Some v1, Some v2 => decide (v1 = v2)
  | _, _ => false
  end.

Global Instance option_comparable : forall `{Comparable A},
  Comparable (option A).
Proof using.
  intros.
  applys (comparable_beq option_compare).
  destruct x; destruct y; simpl; rew_refl; iff; auto_false*; congruence.
Qed.

(* ********************************************************************** *)
(** * Operations and their properties *)

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

(** [is_some o] holds when [o] is of the form [Some x] *)

Definition is_some A (o:option A) :=
  match o with
  | None => false
  | Some _ => true
  end.

(** [unsome_default d o] returns the content of the option, and returns [d]
    in case the option in [None]. *)

Definition unsome_default A d (o:option A) :=
  match o with
  | None => d
  | Some x => x
  end.

(** [unsome o] returns the content of the option, and returns an arbitrary
    value in case the option in [None]. *)

Definition unsome `{Inhab A} :=
  unsome_default arbitrary.

(** [map f o] takes an option and returns an option, and maps the function
    [f] to the content of the option if it has one. *)

Definition map A B (f : A -> B) o :=
  match o with
  | None => None
  | Some x => Some (f x)
  end.

(** [map_on o f] is the same as [map f o], only the arguments are swapped. *)

Definition map_on A B o (f : A -> B) :=
  map f o.

(** [apply f o] optionnaly applies a function of type [A -> option B] *)
(* --todo: find a more explicit name *)

Definition apply A B (f : A -> option B) o :=
  match o with
  | None => None
  | Some x => f x
  end.

(** [apply_on o f] is the same as [apply f o] *)

Definition apply_on A B o (f : A -> option B) :=
  apply f o.

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

Lemma apply_on_inv : forall A B (f : A->option B) x y,
  apply_on x f = Some y ->
  exists z, x = Some z /\ f z = Some y.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Implicit Arguments apply_on_inv [A B f x y].

Lemma map_inv : forall A B (f : A->B) x y,
  map f x = Some y ->
  exists z, x = Some z /\ y = f z.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Implicit Arguments map_inv [A B f x y].

Lemma map_on_inv : forall A B (f : A->B) x y,
  map_on x f = Some y ->
  exists z, x = Some z /\ y = f z.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Implicit Arguments map_on_inv [A B f x y].


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A1prime A2prime B1 B2 A1 I B3 A3 : Universe, ((wd_ B1 B2 /\ (wd_ A1prime A2prime /\ (wd_ A2prime B1 /\ (wd_ A1prime B1 /\ (wd_ B1 A1 /\ (wd_ B1 I /\ (wd_ B1 B3 /\ (wd_ B3 I /\ (wd_ B3 A3 /\ (col_ A1prime A2prime A1 /\ (col_ I A1prime A2prime /\ (col_ I B1 B2 /\ (col_ A1prime A2prime A3 /\ col_ B3 B1 I))))))))))))) -> col_ B1 B2 B3)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O B C Bprime Cprime X Y : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ X C /\ (wd_ B Bprime /\ (wd_ C Bprime /\ (wd_ B Cprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y B /\ col_ X Y C)))))))))))))))) -> col_ C X O)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D P Cprime Dprime : Universe, ((wd_ A B /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (wd_ C D /\ (wd_ A Cprime /\ (wd_ A Dprime /\ (wd_ Cprime P /\ (wd_ Dprime P /\ (wd_ A P /\ (wd_ B P /\ (wd_ D Dprime /\ (wd_ C Cprime /\ (col_ P A B /\ (col_ A B Cprime /\ (col_ A B Dprime /\ col_ C P D))))))))))))))))) -> col_ P A Dprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import PromiseConsistent.

Require Import AMemory.
Require Import ALocal.
Require Import ATView.
Require Import AThread.

Require Import PFCommon.
Require Import PFStep.
Require Import PFCertify.

Set Implicit Arguments.

Definition ThreadsProp :=
  forall (tid:Ident.t)
    (lang:language)
    (st:(Language.state lang)),
    Prop.

Definition MemoryProp :=
  forall (assign: LocFun.t Const.t),
    Prop.

Module Logic.
  Section Logic.
    Variable
      (S: ThreadsProp)
      (J: MemoryProp)
      (program: Threads.syntax).

    Structure t: Type := mk {
      INIT:
        <<ST_INIT:
          forall tid lang syn
            (FIND: IdentMap.find tid program = Some (existT _ lang syn)),
            S tid lang ((Language.init lang) syn)>> /\
        <<ASSIGN_INIT: J (LocFun.init 0)>>;
      SILENT:
        forall tid lang st1 st2
          (ST1: S tid lang st1)
          (STEP: (Language.step lang) ProgramEvent.silent st1 st2),
          S tid lang st2;
      READ:
        forall tid lang st1 st2
          loc val ord
          assign
          (ST1: S tid lang st1)
          (ASSIGN1: J assign /\ LocFun.find loc assign = val)
          (STEP: (Language.step lang) (ProgramEvent.read loc val ord) st1 st2),
          S tid lang st2;
      WRITE:
        forall tid lang st1 st2
          loc val ord
          (ST1: S tid lang st1)
          (STEP: (Language.step lang) (ProgramEvent.write loc val ord) st1 st2),
          <<ST2: S tid lang st2>> /\
          <<ASSIGN2: forall assign, J assign -> J (LocFun.add loc val assign)>>;
      UPDATE:
        forall tid lang st1 st2
          loc valr valw ordr ordw
          assign
          (ST1: S tid lang st1)
          (ASSIGN1: J assign /\ LocFun.find loc assign = valr)
          (STEP: (Language.step lang) (ProgramEvent.update loc valr valw ordr ordw) st1 st2),
          <<ST2: S tid lang st2>> /\
          <<ASSIGN2: forall assign, J assign -> J (LocFun.add loc valw assign)>>;
      FENCE:
        forall tid lang st1 st2
          ordr ordw
          (ST1: S tid lang st1)
          (STEP: (Language.step lang) (ProgramEvent.fence ordr ordw) st1 st2),
          S tid lang st2;
      SYSCALL:
        forall tid lang st1 st2
          e
          (ST1: S tid lang st1)
          (STEP: (Language.step lang) (ProgramEvent.syscall e) st1 st2),
          S tid lang st2;
      FAILURE:
        forall tid lang st1 st2
          (ST1: S tid lang st1)
          (STEP: (Language.step lang) ProgramEvent.failure st1 st2),
          <<ST2: forall tid lang st, S tid lang st>> /\
          <<ASSIGN2: forall assign, J assign>>;
    }.
  End Logic.
End Logic.

Section Invariant.
  Variable
    (S:ThreadsProp)
    (J:MemoryProp)
    (program: IdentMap.t {lang:language & (Language.syntax lang)}).

  Context `{LOGIC: Logic.t S J program}.

  Definition sem_threads (ths:Threads.t): Prop :=
    forall tid lang st lc
      (FIND: IdentMap.find tid ths = Some (existT _ lang st, lc)),
      S tid lang st.

  Definition memory_assign (m:Memory.t) (assign:Loc.t -> Const.t) :=
    forall loc,
    exists from to released,
      Memory.get loc to m =
      Some (from, Message.full (LocFun.find loc assign) released).

  Definition sem_memory (m:Memory.t): Prop :=
    memory_assign m <1= J.

  Inductive sem (c:Configuration.t): Prop :=
  | sem_configuration_intro
      (TH: sem_threads (Configuration.threads c))
      (MEM: sem_memory (Configuration.memory c))
  .

  Lemma vals_incl_sem_memory
        mem1 mem2
        (VALS: PFCommon.vals_incl mem1 mem2)
        (MEM2: sem_memory mem2):
    sem_memory mem1.
  Proof.
    ii. apply MEM2. ii. specialize (PR loc). des.
    exploit VALS; eauto.
  Qed.

  (* sem_memory_step *)

  Lemma sem_memory_read_step
        lc1 mem1 loc to val released ord lc2
        (INHABITED: Memory.inhabited mem1)
        (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
        (SEM: sem_memory mem1):
    exists assign,
      J assign /\ LocFun.find loc assign = val.
  Proof.
    exists (LocFun.add loc val (LocFun.init 0)).
    splits.
    - apply SEM. ii.
      destruct (Loc.eq_dec loc loc0).
      + subst. rewrite LocFun.add_spec_eq.
        inv STEP. esplits; eauto.
      + rewrite LocFun.add_spec_neq, LocFun.init_spec.
        specialize (INHABITED loc0).
        esplits; eauto. congr.
    - apply LocFun.add_spec_eq.
  Qed.

  Lemma sem_memory_write_step_eq
        lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
        assign
        (INHABITED: Memory.inhabited mem1)
        (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (SEM: memory_assign mem2 assign)
        (LOC: LocFun.find loc assign = val):
    exists assign0,
      memory_assign mem1 assign0 /\
      assign = LocFun.add loc val assign0.
  Proof.
    exists (LocFun.add loc 0 assign). splits; cycle 1.
    - rewrite LocFun.add_add_eq. apply LocFun.ext. i.
      rewrite LocFun.add_spec. condtac; subst; ss.
    - ii. rewrite LocFun.add_spec. condtac.
      { specialize (INHABITED loc0). esplits; eauto. }
      specialize (SEM loc0). des. revert SEM.
      inv STEP. inv WRITE. inv PROMISE; ss.
      + erewrite Memory.add_o; eauto. condtac; ss.
        * i. des. inv SEM. congr.
        * i. esplits; eauto.
      + erewrite Memory.split_o; eauto. condtac; ss.
        { i. des. inv SEM. congr. }
        condtac; ss.
        { guardH o. des. subst. congr. }
        i. esplits; eauto.
      + erewrite Memory.lower_o; eauto. condtac; ss.
        * i. des. inv SEM. congr.
        * i. esplits; eauto.
  Qed.

  Lemma sem_memory_write_step_neq
        lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
        assign
        (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (SEM: memory_assign mem2 assign)
        (LOC: LocFun.find loc assign <> val):
    memory_assign mem1 assign.
  Proof.
    ii. specialize (SEM loc0). des. revert SEM.
    inv STEP. inv WRITE. inv PROMISE; ss.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + i. des. inv SEM. congr.
      + i. esplits; eauto.
    - erewrite Memory.split_o; eauto. condtac; ss.
      { i. des. inv SEM. congr. }
      condtac; ss.
      { guardH o. i. des. inv SEM.
        exploit Memory.split_get0; try exact MEM; eauto. i. des.
        esplits; eauto.
      }
      i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + i. des. inv SEM. congr.
      + i. esplits; eauto.
  Qed.

  Lemma program_step_sem
        tid lang e
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (TH1: S tid lang st1)
        (MEM1: sem_memory mem1)
        (INHABITED1: Memory.inhabited mem1)
        (STEP: Thread.program_step e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
    <<TH2: S tid lang st2>> /\
    <<MEM2: sem_memory mem2>>.
  Proof.
    inv LOGIC. inv STEP. inv LOCAL.
    - esplits; eauto.
    - exploit sem_memory_read_step; eauto. i. des.
      exploit READ; eauto.
    - exploit WRITE; eauto. i. des.
      esplits; eauto. ii.
      destruct (Const.eq_dec (LocFun.find loc x0) val).
      { subst. hexploit sem_memory_write_step_eq; eauto. i. des.
        rewrite H0. eauto.
      }
      { hexploit sem_memory_write_step_neq; eauto. }
    - exploit sem_memory_read_step; eauto. i. des.
      exploit UPDATE; eauto. i. des.
      esplits; eauto. ii.
      destruct (Const.eq_dec (LocFun.find loc x2) valw).
      { subst. hexploit sem_memory_write_step_eq; eauto. i. des.
        rewrite H0. eauto.
      }
      { hexploit sem_memory_write_step_neq; eauto. }
    - exploit FENCE; eauto.
    - exploit SYSCALL; eauto.
    - exploit FAILURE; eauto. i. des.
      esplits; eauto.
  Qed.

  Lemma rtc_all_program_step_sem
        tid lang
        th1 th2
        (TH1: S tid lang (Thread.state th1))
        (MEM1: sem_memory (Thread.memory th1))
        (INHABITED1: Memory.inhabited (Thread.memory th1))
        (STEP: rtc (union (@Thread.program_step lang)) th1 th2):
    <<TH2: S tid lang (Thread.state th2)>> /\
    <<MEM2: sem_memory (Thread.memory th2)>>.
  Proof.
    move STEP after TH1. revert_until STEP. induction STEP; ss.
    i. inv H.
    destruct x, y. ss.
    exploit program_step_sem; eauto. i. des.
    eapply IHSTEP; eauto.
    hexploit Thread.program_step_inhabited; eauto.
  Qed.

  Lemma rtc_tau_program_step_sem
        tid lang
        th1 th2
        (TH1: S tid lang (Thread.state th1))
        (MEM1: sem_memory (Thread.memory th1))
        (INHABITED1: Memory.inhabited (Thread.memory th1))
        (STEP: rtc (tau (@Thread.program_step lang)) th1 th2):
    <<TH2: S tid lang (Thread.state th2)>> /\
    <<MEM2: sem_memory (Thread.memory th2)>>.
  Proof.
    move STEP after TH1. revert_until STEP. induction STEP; ss.
    i. inv H.
    destruct x, y. ss.
    exploit program_step_sem; eauto. i. des.
    eapply IHSTEP; eauto.
    hexploit Thread.program_step_inhabited; eauto.
  Qed.

  (* sem_memory_astep *)

  Lemma sem_memory_awrite_step_eq
        lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
        assign
        (INHABITED: Memory.inhabited mem1)
        (STEP: ALocal.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (SEM: memory_assign mem2 assign)
        (LOC: LocFun.find loc assign = val):
    exists assign0,
      memory_assign mem1 assign0 /\
      assign = LocFun.add loc val assign0.
  Proof.
    exists (LocFun.add loc 0 assign). splits; cycle 1.
    - rewrite LocFun.add_add_eq. apply LocFun.ext. i.
      rewrite LocFun.add_spec. condtac; subst; ss.
    - ii. rewrite LocFun.add_spec. condtac.
      { specialize (INHABITED loc0). esplits; eauto. }
      specialize (SEM loc0). des. revert SEM.
      inv STEP. inv WRITE. inv PROMISE; ss.
      + erewrite Memory.add_o; eauto. condtac; ss.
        * i. des. inv SEM. congr.
        * i. esplits; eauto.
      + erewrite Memory.split_o; eauto. condtac; ss.
        { i. des. inv SEM. congr. }
        condtac; ss.
        { guardH o. des. subst. congr. }
        i. esplits; eauto.
      + erewrite Memory.lower_o; eauto. condtac; ss.
        * i. des. inv SEM. congr.
        * i. esplits; eauto.
  Qed.

  Lemma sem_memory_awrite_step_neq
        lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
        assign
        (STEP: ALocal.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (SEM: memory_assign mem2 assign)
        (LOC: LocFun.find loc assign <> val):
    memory_assign mem1 assign.
  Proof.
    ii. specialize (SEM loc0). des. revert SEM.
    inv STEP. inv WRITE. inv PROMISE; ss.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + i. des. inv SEM. congr.
      + i. esplits; eauto.
    - erewrite Memory.split_o; eauto. condtac; ss.
      { i. des. inv SEM. congr. }
      condtac; ss.
      { guardH o. i. des. inv SEM.
        exploit Memory.split_get0; try exact MEM; eauto. i. des.
        esplits; eauto.
      }
      i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + i. des. inv SEM. congr.
      + i. esplits; eauto.
  Qed.

  Lemma aprogram_step_sem
        tid lang e
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (TH1: S tid lang st1)
        (MEM1: sem_memory mem1)
        (INHABITED1: Memory.inhabited mem1)
        (STEP: AThread.program_step e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
    <<TH2: S tid lang st2>> /\
    <<MEM2: sem_memory mem2>>.
  Proof.
    inv LOGIC. inv STEP. inv LOCAL.
    - esplits; eauto.
    - exploit sem_memory_read_step; eauto. i. des.
      exploit READ; eauto.
    - exploit WRITE; eauto. i. des.
      esplits; eauto. ii.
      destruct (Const.eq_dec (LocFun.find loc x0) val).
      { subst. hexploit sem_memory_awrite_step_eq; eauto. i. des.
        rewrite H0. eauto.
      }
      { hexploit sem_memory_awrite_step_neq; eauto. }
    - exploit sem_memory_read_step; eauto. i. des.
      exploit UPDATE; eauto. i. des.
      esplits; eauto. ii.
      destruct (Const.eq_dec (LocFun.find loc x2) valw).
      { subst. hexploit sem_memory_awrite_step_eq; eauto. i. des.
        rewrite H0. eauto.
      }
      { hexploit sem_memory_awrite_step_neq; eauto. }
    - exploit FENCE; eauto.
    - exploit SYSCALL; eauto.
    - exploit FAILURE; eauto. i. des.
      esplits; eauto.
  Qed.

  Lemma rtc_all_aprogram_step_sem
        tid lang
        th1 th2
        (TH1: S tid lang (Thread.state th1))
        (MEM1: sem_memory (Thread.memory th1))
        (INHABITED1: Memory.inhabited (Thread.memory th1))
        (STEP: rtc (union (@AThread.program_step lang)) th1 th2):
    <<TH2: S tid lang (Thread.state th2)>> /\
    <<MEM2: sem_memory (Thread.memory th2)>>.
  Proof.
    move STEP after TH1. revert_until STEP. induction STEP; ss.
    i. inv H.
    destruct x, y. ss.
    exploit aprogram_step_sem; eauto. i. des.
    eapply IHSTEP; eauto.
    hexploit AThread.program_step_inhabited; eauto.
  Qed.

  Lemma rtc_tau_aprogram_step_sem
        tid lang
        th1 th2
        (TH1: S tid lang (Thread.state th1))
        (MEM1: sem_memory (Thread.memory th1))
        (INHABITED1: Memory.inhabited (Thread.memory th1))
        (STEP: rtc (tau (@AThread.program_step lang)) th1 th2):
    <<TH2: S tid lang (Thread.state th2)>> /\
    <<MEM2: sem_memory (Thread.memory th2)>>.
  Proof.
    move STEP after TH1. revert_until STEP. induction STEP; ss.
    i. inv H.
    destruct x, y. ss.
    exploit aprogram_step_sem; eauto. i. des.
    eapply IHSTEP; eauto.
    hexploit AThread.program_step_inhabited; eauto.
  Qed.

  Lemma pf_step_sem
        tid lang caps e
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (TH1: S tid lang st1)
        (MEM1: sem_memory mem1)
        (INHABITED1: Memory.inhabited mem1)
        (STEP: PFCertify.pf_step caps e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
    <<TH2: S tid lang st2>> /\
    <<MEM2: sem_memory mem2>>.
  Proof.
    inv STEP.
    exploit aprogram_step_sem; try exact STEP0; eauto. i. des.
    split; auto.
    hexploit PFCertify.add_cap_vals_incl; eauto. i.
    eapply vals_incl_sem_memory; eauto.
  Qed.

  Lemma rtc_pf_step_sem
        tid lang caps
        th1 th2
        (TH1: S tid lang (Thread.state th1))
        (MEM1: sem_memory (Thread.memory th1))
        (INHABITED1: Memory.inhabited (Thread.memory th1))
        (STEP: rtc (union (PFCertify.pf_step caps)) th1 th2):
    <<TH2: S tid lang (Thread.state th2)>> /\
    <<MEM2: sem_memory (Thread.memory th2)>>.
  Proof.
    move STEP after TH1. revert_until STEP.
    induction STEP; ss.
    i. inv H.
    hexploit PFCertify.pf_step_inhabited; eauto. i. des.
    destruct x, y. ss.
    exploit pf_step_sem; eauto. i. des.
    eapply IHSTEP; eauto.
  Qed.

  (* future_sem_memory *)

  Lemma future_sem_memory
        m1 m2
        (FUTURE: Memory.future m1 m2)
        (SEM: sem_memory m2):
    sem_memory m1.
  Proof.
    ii. apply SEM. ii. specialize (PR loc). des.
    exploit Memory.future_get1; eauto. i. des.
    inv MSG_LE. esplits; eauto.
  Qed.

  Lemma future_weak_sem_memory
        m1 m2
        (FUTURE: Memory.future_weak m1 m2)
        (SEM: sem_memory m2):
    sem_memory m1.
  Proof.
    ii. apply SEM. ii. specialize (PR loc). des.
    exploit Memory.future_weak_get1; eauto. i. des.
    inv MSG_LE. esplits; eauto.
  Qed.

  Lemma consistent_sem
        tid lang e_src e_tgt
        (TH: S tid lang (Thread.state e_src))
        (MEM: sem_memory (Thread.memory e_src))
        (SIM: @PFStep.sim_thread lang e_src e_tgt)
        (CONSISTENT: Thread.consistent e_tgt)
        (WF: Local.wf (Thread.local e_tgt) (Thread.memory e_tgt))
        (SC: Memory.closed_timemap (Thread.sc e_tgt) (Thread.memory e_tgt))
        (CLOSED: Memory.closed (Thread.memory e_tgt)):
    sem_memory (Thread.memory e_tgt).
  Proof.
    exploit Memory.cap_exists; try apply CLOSED. i. des.
    exploit Memory.cap_closed; eauto. intro CLOSED_CAP.
    exploit Memory.max_full_timemap_exists; try apply CLOSED_CAP. intro MAX. des.
    hexploit Memory.max_full_timemap_closed; eauto. intro SC_CAP.
    exploit Local.cap_wf; eauto. intro WF_CAP.
    exploit PFCertify.sim_thread_exists; eauto. i. des.
    hexploit PFCertify.sim_memory_inhabited; try apply SIM0; try apply WF_CAP; try apply CLOSED_CAP. s. i. des.
    apply vals_incl_sem_memory in VALS; auto.
    exploit CONSISTENT; eauto. i. des.
    - unfold Thread.steps_failure in *. des.
      exploit Thread.rtc_tau_step_future; try exact STEPS; eauto. s. i. des.
      inv FAILURE0; try by inv STEP.
      exploit PFCertify.thread_rtc_tau_step; eauto.
      { inv STEP. inv LOCAL. inv LOCAL0. ss. }
      i. des.
      exploit PFCertify.thread_program_step; try exact STEP; eauto.
      { inv STEP. inv LOCAL. inv LOCAL0. ss. }
      i. des.
      exploit rtc_pf_step_sem; try exact STEPS_SRC; eauto. i. des.
      inv STEP_SRC. inv STEP0. inv LOGIC.
      exploit FAILURE; try exact STATE; eauto. i. des.
      ii. eauto.
    - exploit Thread.rtc_tau_step_future; eauto. s. i. des.
      exploit PFCertify.thread_rtc_tau_step; eauto.
      { eapply Local.bot_promise_consistent; ss. }
      i. des.
      exploit rtc_pf_step_sem; try exact STEPS_SRC; eauto. i. des.
      exploit PFCertify.sim_memory_bot; try apply SIM2; eauto. i.
      rewrite x0 in *.
      exploit Memory.cap_future_weak; eauto. i.
      eapply future_weak_sem_memory; eauto.
      eapply future_sem_memory; eauto.
  Qed.

  Lemma configuration_failure_step_sem
        tid c1 c2
        (WF: Configuration.wf c1)
        (SEM: sem c1)
        (STEP: Configuration.step MachineEvent.failure tid c1 c2):
    sem c2.
  Proof.
    inv SEM. inv STEP; try by (destruct e; ss).
    inv STEP0; try by inv STEP.
    exploit TH; eauto. intro TH1.
    inv WF. inv WF0. clear DISJOINT.
    exploit THREADS; eauto. intro WF. clear THREADS.
    exploit Thread.rtc_tau_step_future; eauto. s. i. des.
    exploit (@PFStep.sim_thread_exists
               _ (Thread.mk lang st1 lc1 (Configuration.sc c1) (Configuration.memory c1))); ss.
    i. des.
    hexploit PFStep.sim_memory_vals_incl; try eapply SIM; eauto. s. i.
    apply vals_incl_sem_memory in H; auto.
    hexploit PFStep.sim_memory_inhabited; try apply SIM; try apply WF; try apply MEM0. i. des.
    exploit PFStep.thread_rtc_tau_step; try exact SIM; try eapply STEPS; eauto.
    { inv STEP. inv LOCAL. inv LOCAL0. ss. }
    i. des.
    exploit PFStep.thread_program_step; try exact SIM2; try eapply STEP; eauto.
    { inv STEP. inv LOCAL. inv LOCAL0. ss. }
    i. des.
    exploit rtc_tau_aprogram_step_sem; try exact STEPS_SRC; eauto.
    { inv SIM. ss. rewrite STATE. eauto. }
    i. des.
    inv STEP_SRC. inv LOGIC. ss.
    exploit FAILURE; try exact STATE; eauto. i. des.
    econs; ss; ii; eauto.
  Qed.

  Lemma configuration_normal_step_sem
        tid e c1 c2
        (WF: Configuration.wf c1)
        (SEM: sem c1)
        (STEP: Configuration.step e tid c1 c2)
        (EVENT: e <> MachineEvent.failure):
    sem c2.
  Proof.
    inv SEM. inv STEP; ss.
    eapply rtc_implies in STEPS; [|by apply tau_union].
    exploit rtc_n1; eauto.
    { econs. econs. eauto. }
    clear EVENT EVENT0 STEPS STEP0. intro STEPS.
    inv WF. inv WF0. clear DISJOINT.
    exploit THREADS; eauto. intro WF. clear THREADS.
    exploit Thread.rtc_all_step_future; eauto. s. i. des.
    exploit (@PFStep.sim_thread_exists
               _ (Thread.mk lang st1 lc1 (Configuration.sc c1) (Configuration.memory c1))); ss.
    i. des.
    hexploit PFStep.sim_memory_vals_incl; try eapply SIM; eauto. s. i.
    apply vals_incl_sem_memory in H; auto.
    hexploit PFStep.sim_memory_inhabited; try apply SIM; try apply WF; try apply MEM0. i. des.
    exploit PFStep.thread_rtc_all_step; try exact SIM; try eapply STEPS; eauto.
    { eapply consistent_promise_consistent; eauto. }
    i. des.
    exploit rtc_all_aprogram_step_sem; try exact STEPS_SRC; eauto.
    { inv SIM. ss. rewrite STATE. eauto. }
    i. des.
    econs; s.
    - ii. revert FIND.
      rewrite IdentMap.gsspec. condtac; ss; [|by apply TH]. subst.
      i. inv FIND. apply inj_pair2 in H3. subst.
      inv SIM2. ss. rewrite <- STATE. ss.
    - hexploit consistent_sem; eauto.
  Qed.

  Lemma configuration_step_sem
        e tid c1 c2
        (WF: Configuration.wf c1)
        (SEM: sem c1)
        (STEP: Configuration.step e tid c1 c2):
    sem c2.
  Proof.
    destruct e.
    - eapply configuration_normal_step_sem; eauto. ss.
    - eapply configuration_normal_step_sem; eauto. ss.
    - eapply configuration_failure_step_sem; eauto.
  Qed.

  Inductive Configuration_step_evt (c1 c2:Configuration.t): Prop :=
  | Configuration_step_evt_intro
      e tid
      (STEP: Configuration.step e tid c1 c2)
  .

  Lemma init_sem: sem (Configuration.init program).
  Proof.
    inv LOGIC. des. econs.
    - ii. unfold Configuration.init in FIND. ss.
      unfold Threads.init in FIND. rewrite IdentMap.Facts.map_o in FIND.
      destruct (@UsualFMapPositive.UsualPositiveMap'.find
                  (@sigT _ (@Language.syntax ProgramEvent.t)) tid program) eqn:X; inv FIND.
      apply inj_pair2 in H1. subst. destruct s. ss.
      eapply ST_INIT; eauto.
    - ii. cut (x0 = LocFun.init 0); [by i; subst|].
      apply LocFun.ext. i. rewrite LocFun.init_spec.
      specialize (PR i). des. ss.
      unfold Memory.get, Memory.init in PR. unfold Cell.get, Cell.init in PR. ss.
      apply DOMap.singleton_find_inv in PR. des. inv PR0. auto.
  Qed.

  Lemma sound
        c
        (STEPS: rtc Configuration_step_evt (Configuration.init program) c):
    sem c.
  Proof.
    cut (forall c1 c2
           (WF: Configuration.wf c1)
           (SEM: sem c1)
           (STEPS: rtc Configuration_step_evt c1 c2),
            sem c2).
    { i. eapply H; eauto.
      - apply Configuration.init_wf.
      - apply init_sem; auto.
    }
    i. revert WF SEM. induction STEPS0; ss. i.
    inv H. exploit Configuration.step_future; eauto. i. des.
    apply IHSTEPS0; ss. eapply configuration_step_sem; try exact STEP; eauto.
  Qed.
End Invariant.


(** Coq coding by choukh, May 2022 **)

From ZF Require Import Basic.

(*** 内模型 ***)
Section InnerModel.

(* 𝓜 ⊨ ZF *)
Context {𝓜 : ZF}.

(* 𝓜上的类 *)
Variable P : 𝓜 → Prop.

Hypothesis P为封闭类 : 封闭类 P.

(* 类的类型化 *)
Definition ℙ : Type := Σ x, x ∈ₚ P.

(* 类P中关系R到𝓜的嵌入 *)
Definition 嵌入 (R : ℙ → ℙ → Prop) : 𝓜 → 𝓜 → Prop :=
  λ x y, ∃ (xP : x ∈ₚ P) (yP : y ∈ₚ P), R (exist P x xP) (exist P y yP).
Notation "⌜ R ⌝" := (嵌入 R) (format "⌜ R ⌝").

(* 𝓜中关系R到类P的投影 *)
Definition 投影 (R : 𝓜 → 𝓜 → Prop) : ℙ → ℙ → Prop :=
  λ X Y : (Σ x, x ∈ₚ P), R (proj1_sig X) (proj1_sig Y).

Lemma 嵌入的函数性 R : 函数性 R → 函数性 ⌜R⌝.
Proof.
  intros FR x y z [xP [yP RXY]] [xP'[Pz RXZ]].
  eapply eq_sig_fst. eapply FR. apply RXY.
  erewrite subset_eq_compat. apply RXZ. easy.
Qed.

Lemma 函数性投影 R : 函数性 R → 函数性 (投影 R).
Proof.
  intros FR [x xP] [y yP] [z zP] RXY RYZ.
  unfold 投影 in *; simpl in *.
  apply subset_eq_compat. eapply FR; eauto.
Qed.

(* ⋃ {x ∊ { ⌜R⌝ @ A } | 函数性 R} *)
Definition 替代嵌入 R A := ⋃ ({⌜R⌝ @ A,} ∩ₚ (λ _, 函数性 R)).
Notation "R ⌜@⌝ A" := (替代嵌入 R A) (at level 70).

Lemma 替代嵌入_函数性 R A : 函数性 R → R ⌜@⌝ A = ⌜R⌝ @ A.
Proof. intros FR. unfold 替代嵌入. now rewrite 全分离, 并单. Qed.

Lemma 替代嵌入_非函数性 R A : ¬ 函数性 R → R ⌜@⌝ A = ∅.
Proof. intros nFR. unfold 替代嵌入. now rewrite 未分离, 并空. Qed.

Definition 子结构 : ZF结构.
  apply (Build_ZF结构) with (集 := ℙ).
  - intros [x _] [y _]. apply (x ∈ y).
  - exists ∅. apply 空集封闭类.
  - intros [x xP]. exists (⋃ x). now apply 并集封闭类.
  - intros [x xP]. exists (𝒫 x). now apply 幂集封闭类.
  - intros R [A AP]. exists (R ⌜@⌝ A). 排中 (函数性 R).
    + rewrite 替代嵌入_函数性; auto.
      apply 替代封闭类; auto. apply 嵌入的函数性; auto.
      now intros x y [_ [yP _]] _.
    + rewrite 替代嵌入_非函数性; auto. now apply 空集封闭类.
Defined.

(* 内模型 ⊨ ZF *)
Definition 内模型 : ZF.
Proof.
  apply (Build_ZF) with (结构 := 子结构).
  - intros [x xP] [y yP] XY YX.
    enough (x = y). subst y. erewrite subset_eq_compat; reflexivity.
    apply 外延.
    + intros z zx. exact (XY (exist P z (成员封闭类 zx xP)) zx).
    + intros z zy. exact (YX (exist P z (成员封闭类 zy yP)) zy).
  - intros [x xP] X0. eapply 空集. apply X0.
  - intros [x xP] [a aP]. split; intros H.
    + apply (并集 x a) in H as [y [xy ya]]. now exists (exist P y (成员封闭类 ya aP)).
    + apply (并集 x a). destruct H as [[y yP] XYA]. now exists y.
  - intros [x xP] [a aP]. split; intros H.
    + apply (幂集 x a) in H. intros [y yP] YX. apply H, YX.
    + apply (幂集 x a). intros y yx. exact (H (exist P y (成员封闭类 yx xP)) yx).
  - intros R [a aP] FR [y yP]. split; intros H.
    + apply 并集 in H. rewrite 全分离 in H; auto.
      apply 并集 in H. rewrite 并单 in H.
      apply 替代 in H as [x[xa[xP[yP' RXY]]]]. 2:now apply 嵌入的函数性.
      exists (exist P x (成员封闭类 xa aP)).
      replace (成员封闭类 xa aP) with xP. replace yP with yP'. now split.
      apply proof_irrelevance. apply proof_irrelevance.
    + apply 并集. rewrite 全分离; auto.
      apply 并集. rewrite 并单. destruct H as [[x xP][XA RXY]].
      apply 替代. now apply 嵌入的函数性. exists x.
      split. apply XA. exists xP, yP. apply RXY.
  - intros [x xP]. induction (正则 x) as [x _ IH].
    constructor. intros [y yP] Y. apply IH. apply Y.
Defined.

End InnerModel.

Notation "R ⌜@⌝ A" := (替代嵌入 R A) (at level 70) : zf_scope.


Require Export CatSem.ORDER.pcf_order_rep.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Lemma eq_Rep_equiv (P R: PCFPO_rep) :
     Equivalence (A:=PCFPO_rep_Hom P R)
         (fun a c => forall r, a r == c r).
Proof.
 intros P R.
 constructor;
 simpl in *.
 unfold Reflexive; intros. auto.
 unfold Symmetric; simpl; intros r s.
 intros.
 auto.

 unfold Transitive; intros.
 transitivity (y r t z0); auto.
Qed.

Definition eq_Rep_oid (P R : PCFPO_rep) := Build_Setoid (eq_Rep_equiv P R).

(** Identity Representation *)

Lemma Rep_id_struct (P : PCFPO_rep) :
         PCFPO_rep_Hom_struct (RMonad_Hom_id P).
Proof.
  intro P;
  unfold Monad_Hom_id.
  simpl.
  constructor;
  simpl;
  intros;
  try rewrite <- surjective_pairing;
  auto.
Qed.

Definition Rep_id (P: PCFPO_rep) := Build_PCFPO_rep_Hom (Rep_id_struct P).

(** Composition of Representations *)
Section Rep_comp.
Variables P Q R: PCFPO_rep.
Variable M: PCFPO_rep_Hom P Q.
Variable N: PCFPO_rep_Hom Q R.

Program Instance Rep_comp_struct :
      PCFPO_rep_Hom_struct (Monad_Hom_comp M N).
Next Obligation.
Proof.
  set (HM:=App_Hom (Sig := M)).
  set (HN:=App_Hom (Sig := N)).
  simpl in *.
  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Abs_Hom (Sig := M)).
  set (HN:=Abs_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Rec_Hom (Sig := M)).
  set (HN:=Rec_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=ttt_Hom (Sig := M)).
  set (HN:=ttt_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=fff_Hom (Sig := M)).
  set (HN:=fff_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=nats_Hom (Sig := M)).
  set (HN:=nats_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=succ_Hom (Sig := M)).
  set (HN:=succ_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=zero_Hom (Sig := M)).
  set (HN:=zero_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=condN_Hom (Sig := M)).
  set (HN:=condN_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=condB_Hom (Sig := M)).
  set (HN:=condB_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Bottom_Hom (Sig := M)).
  set (HN:=Bottom_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.

Definition Rep_comp := Build_PCFPO_rep_Hom Rep_comp_struct.

End Rep_comp.

(** category of representations *)

Program Instance PCFPO_REP_struct : Cat (fun a c => PCFPO_rep_Hom a c) := {
  mor_oid a c := eq_Rep_oid a c;
  id a := Rep_id a;
  comp P Q R f g := Rep_comp f g
}.
Next Obligation.
Proof.
  unfold Proper in *; do 2 red.
  simpl.
  intros y z h y' z' h' e r t.
  rewrite h.
  rewrite h'.
  auto.
Qed.

Definition PCFPO_REP := Build_Category PCFPO_REP_struct.

End PCFPO_representation.

Existing Instance pcfpo_rep_struct.


From fae_gtlc_mu.backtranslation.implication_consistencies.help_lemmas Require Import listset_ext closed_rec_types.
From fae_gtlc_mu.cast_calculus Require Export types types_lemmas.
From stdpp Require Import base listset.
From iris Require Import base.

Definition combinations (τ τ' : type) : listset (type * type) := (* we count more then actually possible but no biggie *)
  listset_prod (closed_rec_types τ) {[TRec TUnknown]} ∪
  listset_prod (closed_rec_types τ') {[TRec TUnknown]} ∪
  listset_prod {[TRec TUnknown]} (closed_rec_types τ) ∪
  listset_prod {[TRec TUnknown]} (closed_rec_types τ') ∪
  listset_prod (closed_rec_types τ) (closed_rec_types τ') ∪
  listset_prod (closed_rec_types τ') (closed_rec_types τ).

Notation "{{ l }}" := (Listset l) (at level 20).

Definition upper_bound (A : list (type * type)) τ τ' : nat :=
  size (combinations τ τ' ∖ {{A}}).

Notation "#" := upper_bound.

Lemma subseteq_comp_normal {X1 X1' X2 X2' X3 X3' X4 X4' X5 X5' X6 X6' : listset (type * type)}
      (H1 : X1 ⊆ X1') (H2 : X2 ⊆ X2') (H3 : X3 ⊆ X3') (H4 : X4 ⊆ X4') (H5 : X5 ⊆ X5') (H6 : X6 ⊆ X6') :
  X1 ∪ X2 ∪ X3 ∪ X4 ∪ X5 ∪ X6 ⊆ X1' ∪ X2' ∪ X3' ∪ X4' ∪ X5' ∪ X6'.
Proof. set_solver. Qed.

Lemma subseteq_comp_contravariant {X1 X1' X2 X2' X3 X3' X4 X4' X5 X5' X6 X6' : listset (type * type)}
      (H1 : X1 ⊆ X2') (H2 : X2 ⊆ X1') (H3 : X3 ⊆ X4') (H4 : X4 ⊆ X3') (H5 : X5 ⊆ X6') (H6 : X6 ⊆ X5') :
  X1 ∪ X2 ∪ X3 ∪ X4 ∪ X5 ∪ X6 ⊆ X1' ∪ X2' ∪ X3' ∪ X4' ∪ X5' ∪ X6'.
Proof. set_solver. Qed.

Lemma size_elem_difference_suc {A : Type} {_ : EqDecision A} (l : listset A) (k : list A) (a : A) : a ∈ l → a ∉ k →
  size (l ∖ {{k}}) = S (size (l ∖ {{a :: k}})).
Proof.
  intros.
  assert (triv : l ≡ l ∖ {[a]} ∪ {[a]}).
  { apply set_subseteq_antisymm; try set_solver.
    intros τ pin; destruct (decide (τ = a)); set_solver. } rewrite{1} triv. clear triv.
  rewrite difference_union_distr_l.
  rewrite size_union_alt.
  assert (triv : {[a]} ≡ {[a]} ∖ {{k}} ∖ (l ∖ {[a]} ∖ {{k}})). set_solver. rewrite -triv. clear triv.
  assert (triv : l ∖ {[a]} ∖ {{k}} ≡ l ∖ {{a :: k}}).
  { assert (triv : {{a :: k}} = {[a]} ∪ {{k}}). set_solver. rewrite triv. clear triv. set_solver. } rewrite triv. clear triv.
  rewrite size_singleton. lia.
Qed.

Lemma upper_bound_symmetric A τ τ' :
  # A τ τ' = # A τ' τ.
Proof.
  rewrite /upper_bound.
  assert (triv : combinations τ τ' ≡ combinations τ' τ).
  { apply set_subseteq_antisymm; apply subseteq_comp_contravariant; apply listset_prod_subseteq; set_solver. }
  by rewrite triv.
Qed.

(** if types are structurally smaller, then upper_bound is smaller or equal *)

Lemma upper_bound_le_arrow_r A τ1 τ2 τ1' τ2' :
  # A τ2 τ2' ≤ # A (TArrow τ1 τ2) (TArrow τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_arrow_l A τ1 τ2 τ1' τ2' :
  # A τ1' τ1 ≤ # A (TArrow τ1 τ2) (TArrow τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  rewrite /combinations.
  apply subseteq_comp_contravariant; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_sum2 A τ1 τ2 τ1' τ2' :
  # A τ2 τ2' ≤ # A (TSum τ1 τ2) (TSum τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_sum1 A τ1 τ2 τ1' τ2' :
  # A τ1 τ1' ≤ # A (TSum τ1 τ2) (TSum τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  rewrite /combinations.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_prod2 A τ1 τ2 τ1' τ2' :
  # A τ2 τ2' ≤ # A (TProd τ1 τ2) (TProd τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_prod1 A τ1 τ2 τ1' τ2' :
  # A τ1 τ1' ≤ # A (TProd τ1 τ2) (TProd τ1' τ2').
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  rewrite /combinations.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_sum_unknown1 A τ1 τ2 :
  # A τ1 TUnknown ≤ # A (TSum τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_sum_unknown2 A τ1 τ2 :
  # A τ2 TUnknown ≤ # A (TSum τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_prod_unknown1 A τ1 τ2 :
  # A τ1 TUnknown ≤ # A (TProd τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_prod_unknown2 A τ1 τ2 :
  # A τ2 TUnknown ≤ # A (TProd τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_prod1 A τ1 τ2 :
  # A TUnknown τ1 ≤ # A TUnknown (TProd τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_prod2 A τ1 τ2 :
  # A TUnknown τ2 ≤ # A TUnknown (TProd τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_sum1 A τ1 τ2 :
  # A TUnknown τ1 ≤ # A TUnknown (TSum τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_sum2 A τ1 τ2 :
  # A TUnknown τ2 ≤ # A TUnknown (TSum τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_arrow_unknown_cov A τ1 τ2 :
  # A τ2 TUnknown ≤ # A (TArrow τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_arrow_cov A τ1 τ2 :
  # A TUnknown τ2 ≤ # A TUnknown (TArrow τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_normal; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_unknown_arrow_con A τ1 τ2 :
  # A τ1 TUnknown ≤ # A TUnknown (TArrow τ1 τ2).
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_contravariant; apply listset_prod_subseteq; set_solver.
Qed.

Lemma upper_bound_le_arrow_unknown_con A τ1 τ2 :
  # A TUnknown τ1 ≤ # A (TArrow τ1 τ2) TUnknown.
Proof.
  rewrite /upper_bound.
  apply subseteq_size.
  apply difference_mono_r.
  apply subseteq_comp_contravariant; apply listset_prod_subseteq; set_solver.
Qed.

(** if types is structurally larger, i.e. from i.e. τb.[μ.τb/] > μ.τ,
    then upper_bound is smaller *)

Lemma upper_bound_lt_rec_star A τb (pμτb : Closed (TRec τb)) (pn : (TRec τb, TRec TUnknown) ∉ A) :
  # ((TRec τb, TRec TUnknown) :: A) τb.[TRec τb/] TUnknown < # A (TRec τb) TUnknown.
Proof.
  rewrite /upper_bound.
  rewrite (size_elem_difference_suc _ A (TRec τb, TRec TUnknown)); try auto.
  + apply le_lt_n_Sm. apply subseteq_size. apply difference_mono_r.
    apply subseteq_comp_normal; apply listset_prod_subseteq; (apply (closed_rec_types_unfold_subset τb pμτb) || set_solver).
  + rewrite /combinations.
    cut ((TRec τb, TRec TUnknown) ∈ listset_prod (closed_rec_types (TRec τb)) {[TRec TUnknown]}). set_solver.
    apply in_listset_prod_iff; set_solver.
Qed.

Lemma upper_bound_lt_star_rec A τb (pμτb : Closed (TRec τb)) (pn : (TRec TUnknown, TRec τb) ∉ A) :
  # ((TRec TUnknown, TRec τb) :: A) TUnknown τb.[TRec τb/] < # A TUnknown (TRec τb).
Proof.
  rewrite /upper_bound.
  rewrite (size_elem_difference_suc _ A (TRec TUnknown, TRec τb)); try auto.
  + apply le_lt_n_Sm. apply subseteq_size. apply difference_mono_r.
    (* apply closed_rec_types_unfold_subset. *)
    apply subseteq_comp_normal; apply listset_prod_subseteq; (apply (closed_rec_types_unfold_subset τb pμτb) || set_solver).
  + rewrite /combinations.
    cut ((TRec TUnknown, TRec τb) ∈ listset_prod {[TRec TUnknown]} (closed_rec_types (TRec τb))). set_solver.
    apply in_listset_prod_iff; set_solver.
Qed.

Lemma upper_bound_lt_rec_rec A τb (pμτb : Closed (TRec τb)) τb' (pμτb' : Closed (TRec τb')) (pn : (TRec τb, TRec τb') ∉ A) :
  # ((TRec τb, TRec τb') :: A) τb.[TRec τb/] τb'.[TRec τb'/] < # A (TRec τb) (TRec τb').
Proof.
  rewrite /upper_bound.
  rewrite (size_elem_difference_suc _ A (TRec τb, TRec τb')); try auto.
  + apply le_lt_n_Sm. apply subseteq_size. apply difference_mono_r.
    apply subseteq_comp_normal; apply listset_prod_subseteq; (by eapply (closed_rec_types_unfold_subset) || set_solver).
  + rewrite /combinations.
    cut ((TRec τb, TRec τb') ∈ listset_prod (closed_rec_types (TRec τb)) (closed_rec_types (TRec τb'))). set_solver.
    apply in_listset_prod_iff; set_solver.
Qed.


Require Import Thread0 SharedList Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := (heapSize + 50) * 4.
  Definition globalList : W := globalSched ^+ $4.
End M'.

Import M'.

Module E := SharedList.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 2.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalList =?> 1 * globalSched =?> 1 * mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract (unfold globalSched, localsInvariantMain, M'.globalList, M'.globalSched; genesis).
  Qed.

  Definition m1 := link boot E.T.m.
  Definition m := link E.m m1.

  Lemma ok1 : moduleOk m1.
    link ok0 E.T.ok.
  Qed.

  Theorem ok : moduleOk m.
    link E.ok ok1.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $(size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


From stdpp Require Import prelude.
From sets Require Import Ensemble.
From AML Require Import Signature.
From AML.Syntax Require Import Pattern.
From AML.Proofs Require Import ProofSystem Theorems.
From AML.Semantics Require Import GlobalSemanticConsequence.
From AML.Soundness Require Import LocalSoundness.

Section sec_global_soundness.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  .

Lemma global_soundness (Γ : PatternSet) (ϕ : Pattern) :
  Γ ⊢ ϕ -> Γ ⊧ ϕ.
Proof.
  induction 1 as [| | | | ? ? Hpremise].
  - apply set_local_semantic_consequence_global, local_soundness.
    by apply ml_thm_assumption.
  - apply set_local_semantic_consequence_global, local_soundness.
    by apply ml_thm_tautology.
  - apply set_local_semantic_consequence_global, local_soundness.
    by apply ml_thm_axiom.
  - inversion X; subst.
    by apply set_global_mp with ϕ.
  - inversion Hpremise as [? ? Hsingle| | ]; subst.
    + inversion Hsingle as [| | ? ? ? Hfree Hsub].
      * by subst; apply set_global_semantic_consequence_impl_app_elim_l.
      * by subst; apply set_global_semantic_consequence_impl_app_elim_r.
      * by subst; apply set_global_semantic_consequence_knaster_tarski.
    + by apply set_global_impl_ex_elim.
    + by apply set_global_semantic_consequence_svar_sub0.
Qed.

End sec_global_soundness.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D Bprimeprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ col_ O Eprime Bprimeprime))))))))))))) -> col_ O C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Misc.
Require Import Limits.Graph.
Require Import Limits.Product.
Require Import Limits.Terminal.
Require Import Limits.Pullback.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Module Slice.
  Section Slice.
    Context {C : PreCategory}.
    Context {z : object C}.

    Definition s : object (C/z) -> object C := fun x => x.(CommaCategory.a).
    Definition f (ob : object (C/z)) : morphism C (s ob) z := ob.(CommaCategory.f).
    Definition m {x y : object (C/z)} : morphism (C/z) x y -> morphism C (s x) (s y) :=
      fun mph => mph.(CommaCategory.g).
  End Slice.
End Slice.

Section SliceUtilities.
  Context {C : PreCategory}.
  Import Slice.

  Definition Build_SliceObject {x y : object C} (h : morphism C x y) : object (C/y) :=
        CommaCategory.Build_object (Functor.Identity.identity C) (!y) x tt h.
  Definition Build_SliceMorphism {z : object C} (x y : object (C/z)) (h : morphism C (s x) (s y)) :
    (f y) o h = (f x) -> morphism (C/z) x y.
  Proof.
    intro H. srapply CommaCategory.Build_morphism.
    - exact h.
    - rewrite <- (contr (CommaCategory.b x)). rewrite <- (contr (CommaCategory.b y)). apply identity.
    - simpl. rewrite left_identity. rewrite H. reflexivity.
  Defined.
  Definition Build_SliceMorphism' {z : object C} (x y : object (C/z)) (h : morphism C (s x) (s y)) :
    (f y) o h = (f x) -> Core.CommaCategory.morphism x y :=
    fun H => Build_SliceMorphism x y h H.

  Lemma path_SliceObject {x y : object C} (h1 h2 : morphism C x y) :
    h1 = h2 -> Build_SliceObject h1 = Build_SliceObject h2.
  Proof.
    intro H. simple refine (CommaCategory.path_object' _ _ _ _ _); [ reflexivity | reflexivity | ].
    simpl. exact H.
  Qed.
  Lemma slice_f_injective {z : object C} (x y : object (C/z)) (H : Slice.s x = Slice.s y) :
    transport (fun s => morphism C s z) H (f x) = f y -> x = y.
  Proof.
    destruct x; destruct y; simpl in *. destruct H; simpl.
    intro Heq. rewrite Heq. clear Heq.
    destruct b; destruct b0. reflexivity.
  Qed.
  Lemma slice_f_inv_r {y : object C} (x : object (C/y)) :
    Build_SliceObject (Slice.f x) = x.
  Proof.
    simple refine (slice_f_injective _ _ _ _); [ reflexivity | reflexivity ].
  Qed.
  Lemma slice_f_inv_l {x y : object C} (m : morphism C x y) :
    Slice.f (Build_SliceObject m) = m.
  Proof. reflexivity. Qed.

  Lemma path_SliceMorphism {z : object C} (x y : object (C/z)) (h1 h2 : morphism C (s x) (s y))
        (H1 : (f y) o h1 = f x) (H2 : (f y) o h2 = f x) :
    h1 = h2 -> Build_SliceMorphism x y h1 H1 = Build_SliceMorphism x y h2 H2.
  Proof.
    intro H. apply CommaCategory.path_morphism; [ | reflexivity ]. exact H.
  Qed.
  Lemma slice_m_injective {z : object C} (x y : object (C/z)) (h1 h2 : morphism (C/z) x y) :
    m h1 = m h2 -> h1 = h2.
  Proof.
    destruct h1; simpl. intro H.
    generalize dependent p. generalize dependent p_sym. rewrite H. clear H.
    intros p_sym p. destruct h2; simpl. destruct h; destruct h0; simpl.
    assert (p = p0) as Heq by apply (center _). rewrite Heq. clear Heq.
    assert (p_sym = p_sym0) as Heq by apply (center _). rewrite Heq. clear Heq.
    reflexivity.
  Qed.
  Lemma slice_m_comm {z : object C} (x y : object (C/z)) (h : morphism (C/z) x y) :
    f y o m h = f x.
  Proof. destruct h; simpl. simpl in p_sym. rewrite left_identity in p_sym. exact p_sym. Qed.
  Lemma slice_m_comp {z : object C} (a b c : object (C/z))
        (h1 : morphism (C/z) a b) (h2 : morphism (C/z) b c) :
    m (h2 o h1) = m h2 o m h1.
  Proof. reflexivity. Qed.
  Lemma slice_m_id {z : object C} (a : object (C/z)) :
    m (identity a) = identity (s a).
  Proof. reflexivity. Qed.
End SliceUtilities.


From stdpp Require Import prelude.
From sets Require Import Ensemble.
From ARL.ARS Require Import TransitionSystem.

Definition Valuation `{TransitionSystem} (Name : Type) : Type := Name -> idomain.

Section sec_rule_based_transition_system.

Context
  `{TransitionSystem}
  (NameSet : Type)
  `{FinSet Name NameSet}.

Definition quantified_pattern : Type := Valuation Name -> Ensemble idomain.

Definition quantified_term : Type := Valuation Name -> idomain.

Definition quantified_term_to_pattern (t : quantified_term) : quantified_pattern :=
  fun v => {[ t v ]}.

#[global] Coercion quantified_term_to_pattern : quantified_term >-> quantified_pattern.

Definition arl_predicate `(p : quantified_pattern) : Prop :=
  forall v : Valuation Name, p v ≡ top idomain \/ p v ≡ ∅.

Definition quantified_variable (x : Name) : quantified_term :=
  fun v => v x.

Record ARLVarsEq (vars : NameSet) (v1 v2 : Valuation Name) :=
{
  arl_vars_eq : forall x, x ∈ vars -> v1 x = v2 x
}.

Lemma ARLVarsEqProper_subseteq : Proper ((⊆) --> (=) ==> (=) ==> (impl)) ARLVarsEq.
Proof.
  intros vars1 vars2 Hvars _v1 v1 -> _v2 v2 -> Hvars1.
  constructor; intros x Hx.
  by apply Hvars1, Hvars.
Qed.

#[global] Instance ARLVarsEqProper : Proper ((≡) --> (=) ==> (=) ==> (iff)) ARLVarsEq.
Proof.
  intros vars1 vars2 Hvars _v1 v1 -> _v2 v2 ->.
  apply set_equiv_subseteq in Hvars as [].
  by split; apply ARLVarsEqProper_subseteq.
Qed.

Definition pattern_dependent_vars (p : quantified_pattern) (dependent_vars : NameSet) : Prop :=
  forall (v1 v2 : Valuation Name), ARLVarsEq dependent_vars v1 v2 -> p v1 ≡ p v2.

Record RewriteRule : Type :=
{
  lhs : quantified_term;
  requires : quantified_pattern;
  rhs : quantified_term;
  ensures : quantified_pattern;
  vars : NameSet;
  vars_lhs : NameSet;
  vars_lhs_prop : vars_lhs ⊆ vars;
  lhs_vars : pattern_dependent_vars lhs vars_lhs;
  rhs_vars : pattern_dependent_vars rhs vars;
  requires_vars : pattern_dependent_vars requires vars_lhs;
  ensures_vars : pattern_dependent_vars ensures vars;
  requires_predicate : arl_predicate requires;
  ensures_predicate : arl_predicate ensures;
}.

Record TransitionFromRuleInstance (r : RewriteRule) (v : Valuation Name) (a b : idomain) : Prop :=
{
  a_is_lhs : a = lhs r v;
  b_is_rhs : b = rhs r v;
  requires_holds : a ∈ requires r v;
  ensure_holds : b ∈ ensures r v;
}.

Definition transition_closed_to_rule_instance (r : RewriteRule) (v : Valuation Name) : Prop :=
  forall a b, TransitionFromRuleInstance r v a b -> transition a b.

Inductive TransitionFromRule (r : RewriteRule) (a b : idomain) : Prop :=
| tfr : forall v : Valuation Name, TransitionFromRuleInstance r v a b ->
  TransitionFromRule r a b.

Definition transition_rule_consistency (r : RewriteRule) : Prop :=
  forall v, lhs r v ∈ requires r v ->
    exists b, TransitionFromRule r (lhs r v) b.

Definition transition_closed_to_rule (r : RewriteRule) : Prop :=
  forall a b, TransitionFromRule r a b -> transition a b.

Context
  `{Set_ RewriteRule RewriteRuleSet}.

Definition transition_from_rule_set (rs : RewriteRuleSet) (a b : idomain) : Prop :=
  set_Exists (fun r : RewriteRule => TransitionFromRule r a b) rs.

Definition transition_closed_to_rule_set (rs : RewriteRuleSet) : Prop :=
  forall a b, transition_from_rule_set rs a b -> transition a b.

Definition transition_included_in_rule_set (rs : RewriteRuleSet) : Prop :=
  forall a b, transition a b -> transition_from_rule_set rs a b.

End sec_rule_based_transition_system.

Class RuleBasedTransitionSystem
  `{TransitionSystem} (NameSet : Type) `{FinSet Name NameSet}
  `{Set_ (RewriteRule NameSet) RewriteRuleSet}
  (rs : RewriteRuleSet) :=
{
  rules_sound : transition_closed_to_rule_set NameSet rs;
  rules_complete : transition_included_in_rule_set NameSet rs;
  rules_consistent : set_Forall (transition_rule_consistency NameSet) rs;
}.

#[global] Hint Mode RuleBasedTransitionSystem - - - - - - - - - - - - - - - - - - - - - ! : typeclass_instances.

Arguments vars {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r : assert.

Arguments vars_lhs {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r : assert.

Arguments lhs {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r _ : assert.

Arguments rhs {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r _ : assert.

Arguments requires {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r _ _ : assert.

Arguments ensures {idomain}%type_scope {H} {NameSet}%type_scope
  {Name}%type_scope {H0} r _ _ : assert.

Arguments TransitionFromRuleInstance {idomain}%type_scope
  {H} {NameSet}%type_scope {Name}%type_scope {H0} r v a b : assert.

Arguments TransitionFromRule {idomain}%type_scope
  {H} {NameSet}%type_scope {Name}%type_scope {H0} r
  a b.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  See if I can correctly hand craft the inductive hypothesis that I
 need.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.

Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export MoreTacticals.

Require Export AlphaConversion.

(* A mini K to work out context destructing induction. *)

Inductive K : Delta -> Tau -> Kappa -> Prop :=
 | K_int   : forall (d : Delta),
                  K d cint B

 | K_B     : forall (d : Delta) (alpha : TV.T),
               D.map d alpha = Some B ->
               K d (tv_t alpha) B

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (cross t0 t1) A

 | K_utype  : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
                   D.map d alpha = None ->
                   K  (D.ctxt alpha k d) tau A ->
                   K d (utype alpha k tau) A.

(* Put in the context destructuring dependent term and drop AK so I use
  the mini K. *)
Lemma A_6_Substitution_1:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      D.nodup d = true ->
      K d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        D.nodup (D.ctxt alpha k d) = true ->
        K (D.ctxt alpha k d) tau' k' ->
        K d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k nodupd Kderd alpha k' tau' nodupd' Kderctxt.
  induction Kderctxt; intros.
  Case "K_int".
   assert (Z: d0 = (D.ctxt alpha k d)).
   admit.
   subst.
   (* K d (subst_Tau cint tau alpha) B *)

   simpl.
   apply K_int.
  Case "K_B".
   assert (Z: d0 = (D.ctxt alpha k d)).
   admit.
   subst.
   (*
      D.map (D.ctxt alpha k d) alpha0 = Some B
      K d (subst_Tau (tv_t alpha0) tau alpha) B
   *)
   unfold D.ctxt in H.
   unfold D.map in H.
   fold D.map in H.
   case_eq(D.K_eq alpha0 alpha); intros; rewrite H0 in H; inversion H; subst.
   unfold D.K_eq in H0.
   apply D.K.beq_t_eq in H0.
   subst.
   simpl.
   rewrite TV.beq_t_refl.
   assumption.
   unfold subst_Tau.
   autounfold in H0.
   rewrite D.K.beq_t_sym in H0.
   rewrite H0.
   constructor; try assumption.
  Case "K_cross".
   assert (Z: d0 = (D.ctxt alpha k d)).
   admit.
   subst.
   (* IH D.nodup d0 = true -> K d (subst_Tau t0 tau alpha) A *)
   (*
      K (D.ctxt alpha k d) t0 A ->
      K d (subst_Tau (cross t0 t1) tau alpha) A
    *)
   unfold subst_Tau.
   fold subst_Tau.
   pose proof nodupd' as nodupd''.
   apply IHKderctxt1 in nodupd''; try assumption.
   apply IHKderctxt2 in nodupd'; try assumption.
   apply K_cross; try assumption.
  Case "K_utype".
   assert (Z: d0 = (D.ctxt alpha k d)).
   admit.
   subst.
   unfold subst_Tau.
   fold subst_Tau.
   case_eq(TV.beq_t alpha alpha0); intros.
   apply TV.beq_t_eq in H0.
   subst.
   inversion H.
   unfold D.K_eq in H1.
   rewrite D.K.beq_t_refl in H1.
   inversion H1.
   assert (Z: D.nodup (D.ctxt alpha0 k0 (D.ctxt alpha k d)) = true).
   apply D.nodup_r_str; try assumption.
   apply IHKderctxt in Z.
   constructor; try assumption.
   admit. (* apply D.map_none_r_weak. *)
   admit. (* K_r_weakening, which won't apply due to smaller K. *)
Qed.

Definition K_ind2 :=
fun (P : Delta -> Tau -> Kappa -> Prop) (f : forall d : Delta, P d cint B)
  (f0 : forall (d : Delta) (alpha : TV.T),
        D.map d alpha = Some B -> P d (tv_t alpha) B)
  (f1 : forall (d : Delta) (t0 t1 : Tau),
        K d t0 A -> P d t0 A -> K d t1 A -> P d t1 A -> P d (cross t0 t1) A)
  (f2 : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        K (D.ctxt alpha k d) tau A ->
        P (D.ctxt alpha k d) tau A -> P d (utype alpha k tau) A) =>
fix F (d : Delta) (t : Tau) (k : Kappa) (k0 : K d t k) {struct k0} :
  P d t k :=
  match k0 in (K d0 t0 k1) return (P d0 t0 k1) with
  | K_int d0 => f d0
  | K_B d0 alpha e => f0 d0 alpha e
  | K_cross d0 t0 t1 k1 k2 => f1 d0 t0 t1 k1 (F d0 t0 A k1) k2 (F d0 t1 A k2)
  | K_utype d0 alpha k1 tau e k2 =>
      f2 d0 alpha k1 tau e k2 (F (D.ctxt alpha k1 d0) tau A k2)
  end.

Check K_ind2
     : forall P : Delta -> Tau -> Kappa -> Prop,
       (forall d : Delta, P d cint B) ->
       (forall (d : Delta) (alpha : TV.T),
        D.map d alpha = Some B -> P d (tv_t alpha) B) ->
       (forall (d : Delta) (t0 t1 : Tau),
        K d t0 A -> P d t0 A -> K d t1 A -> P d t1 A -> P d (cross t0 t1) A) ->
       (forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        K (D.ctxt alpha k d) tau A ->
        P (D.ctxt alpha k d) tau A -> P d (utype alpha k tau) A) ->
       forall (d : Delta) (t : Tau) (k : Kappa), K d t k -> P d t k.

Definition K_ind_dep :=
fun (P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop)
  (f : forall d : Delta,
       forall alpha0 : TV.T,
         forall k': Kappa,
         P alpha0 k' d cint B)
  (f0 : forall (d : Delta) (alpha : TV.T),
        forall alpha0 : TV.T,
        forall k' : Kappa,
          D.map d alpha = Some B -> P alpha0 k' d (tv_t alpha) B)
  (f1 : forall (d : Delta) (t0 t1 : Tau),
        forall alpha0 : TV.T,
        forall k' : Kappa,
          K d t0 A ->
          P alpha0 k' d t0 A ->
          K d t1 A ->
          P alpha0 k' d t1 A ->
          P alpha0 k' d (cross t0 t1) A)
  (f2 : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        forall alpha0 : TV.T,
        forall k' : Kappa,
          K (D.ctxt alpha k d) tau A ->
          P alpha0 k' (D.ctxt alpha k d) tau A ->
          P alpha0 k' d (utype alpha k tau) A) =>
fix F (alpha0 : TV.T) (k' : Kappa)
    (d : Delta) (t : Tau) (k : Kappa)
    (k0 : K d t k) {struct k0} :
  P alpha0 k' d t k :=
  match k0 in (K d0 t0 k1) return (P alpha0 k' d0 t0 k1) with
  | K_int d0 => f d0 alpha0 k'
  | K_B d0 alpha e => f0 d0 alpha alpha0 k' e
  | K_cross d0 t0 t1 k1 k2 =>
    f1 d0 t0 t1 alpha0 k' k1 (F alpha0 k' d0 t0 A k1) k2 (F alpha0 k' d0 t1 A k2)
  | K_utype d0 alpha k1 tau e k2 =>
      f2 d0 alpha k1 tau e alpha0 k' k2
         (F alpha0 k' (D.ctxt alpha k1 d0) tau A k2)
  end.

Check K_ind_dep
     : forall P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop,
       (forall (d : Delta) (alpha0 : TV.T) (k' : Kappa), P alpha0 k' d cint B) ->
       (forall (d : Delta) (alpha alpha0 : TV.T) (k' : Kappa),
        D.map d alpha = Some B -> P alpha0 k' d (tv_t alpha) B) ->
       (forall (d : Delta) (t0 t1 : Tau) (alpha0 : TV.T) (k' : Kappa),
        K d t0 A ->
        P alpha0 k' d t0 A ->
        K d t1 A -> P alpha0 k' d t1 A -> P alpha0 k' d (cross t0 t1) A) ->
       (forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        forall (alpha0 : TV.T) (k' : Kappa),
        K (D.ctxt alpha k d) tau A ->
        P alpha0 k' (D.ctxt alpha k d) tau A ->
        P alpha0 k' d (utype alpha k tau) A) ->
       forall (alpha0 : TV.T) (k' : Kappa) (d : Delta) (t : Tau) (k : Kappa),
       K d t k -> P alpha0 k' d t k.

Lemma A_6_Substitution_1_apply_no_dep_ind:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      D.nodup d = true ->
      K d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K (D.ctxt alpha k d) tau' k' ->
        D.nodup (D.ctxt alpha k d) = true ->
        K d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k nodupd Kderd alpha k' tau' nodupd' Kderctxt.
  apply (K_ind
           (fun (d : Delta) (tau : Tau) (k : Kappa) =>
              K (D.ctxt alpha k d) tau' k' ->
              D.nodup (D.ctxt alpha k d) = true ->
              K d (subst_Tau tau' tau alpha) k'))
        with (k:= k); intros.
  admit.
  (* broken. *)
Admitted.

Lemma A_6_Substitution_1_apply_dep_ind:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K (D.ctxt alpha k d) tau' k' ->
        K d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
  apply (K_ind_dep
           (fun (alpha0 : TV.T) (k' : Kappa) (d0 : Delta) (tau : Tau) (k : Kappa) =>
              K (D.ctxt alpha0 k' d) tau' k' ->
              K d (subst_Tau tau' tau alpha) k'))
        with (k:= k) (alpha0:=alpha) (d0:=d).
  intros.
  admit.  (* Might be right but it's ugly. *)
  intros. (* Wrong. *)
Admitted.

Inductive K1 : Delta -> Tau -> Kappa -> Prop :=
 | K1_int   : forall (d : Delta), K1 d cint B.

Print K1_ind.

Definition K1_ind2 :=
fun (P : Delta -> Tau -> Kappa -> Prop)
    (f : forall d : Delta, P d cint B)
    (d : Delta) (t : Tau) (k : Kappa) (k0 : K1 d t k) =>
match k0 in (K1 d0 t0 k1) return (P d0 t0 k1) with
| K1_int x => f x
end.

Definition K1_ind_dep :=
fun (P : Tau -> Kappa -> Prop)
    (f : P cint B)
    (d : Delta) (t : Tau) (k : Kappa) (k0 : K1 d t k) =>
match k0 in (K1 d0 t0 k1) return (P t0 k1) with
| K1_int x => f
end.

Lemma A_6_Substitution_1_K1_dep:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K1 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K1 (D.ctxt alpha k d) tau' k' ->
        K1 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
  apply (K1_ind_dep
           (fun (tau : Tau) (k : Kappa) =>
              K1 (D.ctxt alpha k d) tau' k' ->
              K1 d (subst_Tau tau' tau alpha) k'))
        with (d0:= d) (k:= k); intros.
  admit. (* Looks OK, can't really tell. *)
  assumption.
  assumption.
Qed.
(* Perhaps. *)

Inductive K2 : Delta -> Tau -> Kappa -> Prop :=
 | K2_int   : forall (d : Delta),
                  K2 d cint B

 | K2_B     : forall (d : Delta) (alpha : TV.T),
               D.map d alpha = Some B ->
               K2 d (tv_t alpha) B.
Print K2_ind.

(*
Definition K2_ind_dep :=
fun (P : Tau -> Kappa -> Prop)
    (d : Delta) (t : Tau) (k : Kappa) (k0 : K2 d t k)
    (f : P cint B)
    (f0 : forall (alpha : TV.T),
             D.map (D.ctxt alpha k d) alpha = Some B -> P (tv_t alpha) B)
=>
  match k0 in (K2 d0 t0 k1) return (P t0 k1) with
    | K2_int x => f
    | K2_B x x0 x1 => f0 x0 x1
  end.
*)

(*
Lemma A_6_Substitution_1_K2_dep:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K2 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K2 (D.ctxt alpha k d) tau' k' ->
        K2 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
  apply (K2_ind_dep
           (fun (tau : Tau) (k : Kappa) =>
              K2 (D.ctxt alpha k d) tau' k' ->
              K2 d (subst_Tau tau' tau alpha) k'))
        with (d0:= d) (k:= k); intros.
  admit. (* Looks OK, can't really tell. *)
  assumption.
  assumption.
Qed.
*)

(* Try and write d0 = (D.ctxt alpha k d)) through. *)
Definition J := (fun a0 k2 x x0 => D.map (D.ctxt a0 k2 x) x0 = Some B).
Lemma transform:
  forall c k a0,
    D.map c k = Some B ->
    D.map (D.ctxt a0 B c) k = Some B.
Proof.
  induction c; crush.
  case_eq(D.K_eq k0 k); intros; rewrite H0 in *.
  admit.
Admitted.

Check K2_B.
(*

Definition K2_ind_dep2 :=
fun
  (P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop)
  (f : forall a0 k2 d, P a0 k2 d cint B)
  (f0 : forall a0 k2 (d : Delta) (alpha : TV.T),
        D.map (D.ctxt a0 k2 d) alpha = Some B -> P a0 k2 d (tv_t alpha) B)
  (a0 : TV.T) (k2 : Kappa) (d : Delta) (t : Tau) (k : Kappa) (k0 : K2 d t k) =>
match k0 in (K2 d0 t0 k1) return (P a0 k2 d0 t0 k1) with
| K2_int x => f a0 k2 x
(* | K2_B x x0 (= d0 (D.ctxt a0 k2 d)) => f0 a0 k2 x x0 (D.ctxt a0 k2 d) *)
| K2_B x x0 x2 => f0 a0 k2 x x0 x2
end.

(* (D.map (D.ctxt a0 k2 x) x0 = Some B) *)

Check (fun (x1 : (forall a0 k2 x x0, D.map (D.ctxt a0 k2 x) x0 = Some B))
       => x1).

(* map x1 to the right type. *)

Lemma A_6_Substitution_1_apply_dep_ind2:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K2 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K2 (D.ctxt alpha k d) tau' k' ->
        K2 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
  apply (K2_ind_dep2
           (fun (alpha : TV.T) (k' : Kappa) (d : Delta) (tau : Tau) (k : Kappa) =>
              K2 (D.ctxt alpha k d) tau' k' ->
              K2 d (subst_Tau tau' tau alpha) k'))
        with (k:= k); intros.
  admit. (* right *)
  admit. (* Wrong. *)
  admit. (* Unsolvable. *)
  assumption.
Admitted.
*)

(* Quit attempting to fix their induction and just write the right induction
hypothesis case by case. *)

Check K2.
Check K2_ind.

(* Can't unify. Why ?
Lemma K2_induction_dependent:
  forall P : Delta -> Tau -> Kappa -> Prop,
    (forall alpha k d, P (D.ctxt alpha k d) cint B) ->
    (forall (alpha : TV.T) (k : Kappa) (d : Delta) (tau : Tau) (k' : Kappa),
        D.map (D.ctxt alpha k d) alpha = Some B ->
        P (D.ctxt alpha k d) (tv_t alpha) B) ->
    (forall (alpha : TV.T) (k : Kappa) (d : Delta) (tau : Tau) (k' : Kappa),
      P (D.ctxt alpha k d) tau k').
Admitted.

Lemma A_6_Substitution_1_apply_K2_induction_dependent:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K2 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K2 (D.ctxt alpha k d) tau' k' ->
        K2 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
  apply (K2_induction_dependent
           (fun (d : Delta) (tau : Tau) (k : Kappa) =>
              K2 (D.ctxt alpha k d) tau' k' ->
              K2 d (subst_Tau tau' tau alpha) k')).

  admit. (* right *)
  admit. (* Wrong. *)
  admit. (* Unsolvable. *)
  assumption.
Admitted.
*)

Lemma K2_induction_dependent_2:
  forall P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop,
    (forall alpha k d, P alpha k d cint B) ->
    (forall (alpha a': TV.T) (k k': Kappa) (d : Delta) (tau : Tau),
        D.map (D.ctxt alpha k d) a' = Some B ->
        P alpha k d (tv_t a') B) ->
    (forall (alpha : TV.T) (k : Kappa) (d : Delta) (tau : Tau) (k' : Kappa),
      P alpha k d tau k').
Proof.
  intros.
Admitted.

Lemma A_6_Substitution_1_apply_K2_induction_dependent_2:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K2 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K2 (D.ctxt alpha k d) tau' k' ->
        K2 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
(* tau' vs tau ? yep breaking the first case. *)
  apply (K2_induction_dependent_2
           (fun (alpha : TV.T) (k : Kappa) (d : Delta) (tau' : Tau) (k' : Kappa) =>
              K2 d tau k ->
              K2 (D.ctxt alpha k d) tau' k' ->
              K2 d (subst_Tau tau' tau alpha) k'))
        with (k:= k).
  intros.
  simpl.
  apply K2_int.

  intros.
(* Want.
  Kderd : K d tau k
  H : D.map (D.ctxt alpha k d) alpha0 = Some B
  ============================
   K d (subst_Tau (tv_t alpha0) tau alpha) B
*)
  (* Have it by lifting the K2 d tau K into the induction hypothesis. *)
(*
  H : D.map (D.ctxt alpha0 k0 d0) a' = Some B
  H0 : K2 d0 tau k0
  H1 : K2 (D.ctxt alpha0 k0 d0) (tv_t a') B
 And they are disconntexted from extra d terms so they can't be used to
 foul the proof.
*)
  admit. (* Looks OK. *)
  assumption.
  assumption.
(* May work. *)
Admitted.

(* Now with a binding type constructor. *)

Inductive K3 : Delta -> Tau -> Kappa -> Prop :=
 | K3_int   : forall (d : Delta),
                  K3 d cint B

 | K3_B     : forall (d : Delta) (alpha : TV.T),
               D.map d alpha = Some B ->
               K3 d (tv_t alpha) B

 | K3_utype  : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
                   D.map d alpha = None ->
                   K3  (D.ctxt alpha k d) tau A ->
                   K3 d (utype alpha k tau) A.

Print K3_ind.
Definition K3_ind_7 :=
fun (P : Delta -> Tau -> Kappa -> Prop) (f : forall d : Delta, P d cint B)
  (f0 : forall (d : Delta) (alpha : TV.T),
        D.map d alpha = Some B ->
        P d (tv_t alpha) B)
  (f1 : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        K3 (D.ctxt alpha k d) tau A ->
        P (D.ctxt alpha k d) tau A -> P d (utype alpha k tau) A) =>
fix F (d : Delta) (t : Tau) (k : Kappa) (k0 : K3 d t k) {struct k0} :
  P d t k :=
  match k0 in (K3 d0 t0 k1) return (P d0 t0 k1) with
  | K3_int d0 => f d0
  | K3_B d0 alpha e => f0 d0 alpha e
  | K3_utype d0 alpha k1 tau e k2 =>
      f1 d0 alpha k1 tau e k2 (F (D.ctxt alpha k1 d0) tau A k2)
end.

Lemma K3_induction_dependent:
  forall P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop,
    (forall alpha k d, P alpha k d cint B) ->
    (forall (alpha a': TV.T) (k k': Kappa) (d : Delta) (tau : Tau),
        D.map (D.ctxt alpha k d) a' = Some B ->
        P alpha k d (tv_t a') B) ->
    (forall (d : Delta) (alpha a' : TV.T) (k k': Kappa) (tau : Tau),
        D.map d alpha = None ->
        K3 (D.ctxt alpha k d) tau A ->
        P alpha k d tau A ->
        P alpha k d (utype a' k tau) A) ->
    (forall (alpha : TV.T) (k : Kappa) (d : Delta) (tau : Tau) (k' : Kappa),
      P alpha k d tau k').
Proof.
  intros.
Admitted.

Lemma A_6_Substitution_1_apply_K3_induction_dependent:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K3 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K3 (D.ctxt alpha k d) tau' k' ->
        K3 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
(* tau' vs tau ? yep breaking the first case. *)
  apply (K3_induction_dependent
           (fun (alpha : TV.T) (k : Kappa) (d : Delta) (tau' : Tau) (k' : Kappa) =>
              K3 d tau k ->
              K3 (D.ctxt alpha k d) tau' k' ->
              K3 d (subst_Tau tau' tau alpha) k'))
        with (k:= k); try assumption.
  intros.
  simpl.
  apply K3_int.

  intros.
(* Want.
  Kderd : K d tau k
  H : D.map (D.ctxt alpha k d) alpha0 = Some B
  ============================
   K d (subst_Tau (tv_t alpha0) tau alpha) B
*)
  (* Have it by lifting the K3 d tau K into the induction hypothesis. *)
(*
  H : D.map (D.ctxt alpha0 k0 d0) a' = Some B
  H0 : K3 d0 tau k0
  H1 : K3 (D.ctxt alpha0 k0 d0) (tv_t a') B
 And they are disconntexted from extra d terms so they can't be used to
 foul the proof.
*)
  admit. (* Looks OK. *)
 (* Want.
  Kderctxt1 : K d0 t0 A
  Kderctxt2 : K d0 t1 A
  IHKderctxt1 : D.nodup d0 = true -> K d (subst_Tau t0 tau alpha) A
  IHKderctxt2 : D.nodup d0 = true -> K d (subst_Tau t1 tau alpha) A
  Z : d0 = D.ctxt alpha k d
  ============================
   K d (subst_Tau (cross t0 t1) tau alpha) A
*)
  intros.
(*  Want and I have it!!!!!
  nodupd' : D.nodup (D.ctxt alpha k d) = true
  H : D.map (D.ctxt alpha k d) alpha0 = None
  Kderctxt : K (D.ctxt alpha0 k0 (D.ctxt alpha k d)) tau0 A
  IHKderctxt : D.nodup (D.ctxt alpha0 k0 (D.ctxt alpha k d)) = true ->
               K d (subst_Tau tau0 tau alpha) A
  ============================
   K d (subst_Tau (utype alpha0 k0 tau0) tau alpha) A
*)

  admit.
(* May work. *)
Admitted.

Inductive K4 : Delta -> Tau -> Kappa -> Prop :=
 | K4_int   : forall (d : Delta),
                  K4 d cint B

 | K4_B     : forall (d : Delta) (alpha : TV.T),
               D.map d alpha = Some B ->
               K4 d (tv_t alpha) B

 | K4_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K4 d t0 A ->
                    K4 d t1 A ->
                    K4 d (cross t0 t1) A

 | K4_utype  : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
                   D.map d alpha = None ->
                   K4  (D.ctxt alpha k d) tau A ->
                   K4 d (utype alpha k tau) A.

Print K4_ind.
Definition K4_ind_7 :=
fun (P : Delta -> Tau -> Kappa -> Prop) (f : forall d : Delta, P d cint B)
  (f0 : forall (d : Delta) (alpha : TV.T),
        D.map d alpha = Some B -> P d (tv_t alpha) B)
  (f1 : forall (d : Delta) (t0 t1 : Tau),
        K4 d t0 A -> P d t0 A -> K4 d t1 A -> P d t1 A -> P d (cross t0 t1) A)
  (f2 : forall (d : Delta) (alpha : TV.T) (k : Kappa) (tau : Tau),
        D.map d alpha = None ->
        K4 (D.ctxt alpha k d) tau A ->
        P (D.ctxt alpha k d) tau A -> P d (utype alpha k tau) A) =>
fix F (d : Delta) (t : Tau) (k : Kappa) (k0 : K4 d t k) {struct k0} :
  P d t k :=
  match k0 in (K4 d0 t0 k1) return (P d0 t0 k1) with
  | K4_int d0 => f d0
  | K4_B d0 alpha e => f0 d0 alpha e
  | K4_cross d0 t0 t1 k1 k2 =>
      f1 d0 t0 t1 k1 (F d0 t0 A k1) k2 (F d0 t1 A k2)
  | K4_utype d0 alpha k1 tau e k2 =>
      f2 d0 alpha k1 tau e k2 (F (D.ctxt alpha k1 d0) tau A k2)
  end.

Lemma K4_induction_dependent:
  forall P : TV.T -> Kappa -> Delta -> Tau -> Kappa -> Prop,
    (forall alpha k d, P alpha k d cint B) ->
    (forall (alpha a': TV.T) (k k': Kappa) (d : Delta) (tau : Tau),
        D.map (D.ctxt alpha k d) a' = Some B ->
        P alpha k d (tv_t a') B) ->
  (forall (alpha : TV.T) (k : Kappa) (d : Delta) (t0 t1 : Tau),
        K4 (D.ctxt alpha k d) t0 A ->
        P alpha k d t0 A ->
        K4 (D.ctxt alpha k d) t1 A ->
        P alpha k d t1 A ->
        P alpha k d (cross t0 t1) A) ->
    (forall (d : Delta) (alpha a' : TV.T) (k k': Kappa) (tau : Tau),
        D.map d alpha = None ->
        K4 (D.ctxt alpha k d) tau A ->
        P alpha k d tau A ->
        P alpha k d (utype a' k tau) A) ->
    (forall (alpha : TV.T) (k : Kappa) (d : Delta) (tau : Tau) (k' : Kappa),
      P alpha k d tau k').
Proof.
  intros.
Admitted.

Lemma A_6_Substitution_1_apply_K4_induction_dependent:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      K4 d tau k ->
      forall (alpha : TV.T) (k' : Kappa) (tau' : Tau),
        K4 (D.ctxt alpha k d) tau' k' ->
        K4 d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k Kderd alpha k' tau' Kderctxt.
(* tau' vs tau ? yep breaking the first case. *)
  apply (K4_induction_dependent
           (fun (alpha : TV.T) (k : Kappa) (d : Delta) (tau' : Tau) (k' : Kappa) =>
              K4 d tau k ->
              K4 (D.ctxt alpha k d) tau' k' ->
              K4 d (subst_Tau tau' tau alpha) k'))
        with (k:= k); try assumption.
  intros.
  simpl.
  apply K4_int.

  intros.
(* Want.
  Kderd : K d tau k
  H : D.map (D.ctxt alpha k d) alpha0 = Some B
  ============================
   K d (subst_Tau (tv_t alpha0) tau alpha) B
*)
  (* Have it by lifting the K4 d tau K into the induction hypothesis. *)
(*
  H : D.map (D.ctxt alpha0 k0 d0) a' = Some B
  H0 : K4 d0 tau k0
  H1 : K4 (D.ctxt alpha0 k0 d0) (tv_t a') B
 And they are disconntexted from extra d terms so they can't be used to
 foul the proof.
*)
  admit. (* Looks OK. *)
(* Want
  nodupd : D.nodup d = true
  Kderd : K d tau k
  nodupd' : D.nodup (D.ctxt alpha k d) = true
  Kderctxt1 : K (D.ctxt alpha k d) t0 A
  Kderctxt2 : K (D.ctxt alpha k d) t1 A
  IHKderctxt1 : D.nodup (D.ctxt alpha k d) = true ->
                K d (subst_Tau t0 tau alpha) A
  IHKderctxt2 : D.nodup (D.ctxt alpha k d) = true ->
                K d (subst_Tau t1 tau alpha) A
  ============================
   K d (subst_Tau (cross t0 t1) tau alpha) A
*)
  intros.

  admit.
 (* Want.
  Kderctxt1 : K d0 t0 A
  Kderctxt2 : K d0 t1 A
  IHKderctxt1 : D.nodup d0 = true -> K d (subst_Tau t0 tau alpha) A
  IHKderctxt2 : D.nodup d0 = true -> K d (subst_Tau t1 tau alpha) A
  Z : d0 = D.ctxt alpha k d
  ============================
   K d (subst_Tau (cross t0 t1) tau alpha) A
*)
  Looks good!

  intros.
(*  Want and I have it!!!!!
  nodupd' : D.nodup (D.ctxt alpha k d) = true
  H : D.map (D.ctxt alpha k d) alpha0 = None
  Kderctxt : K (D.ctxt alpha0 k0 (D.ctxt alpha k d)) tau0 A
  IHKderctxt : D.nodup (D.ctxt alpha0 k0 (D.ctxt alpha k d)) = true ->
               K d (subst_Tau tau0 tau alpha) A
  ============================
   K d (subst_Tau (utype alpha0 k0 tau0) tau alpha) A
*)

  admit.
(* May work. *)
Admitted.


(** Correctness of in-place list reversal *)
From iris.proofmode Require Export tactics.
From iris.program_logic Require Export total_weakestpre weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Unset Mangle Names.

Section list_reverse.
Context `{!heapGS Σ}.
Implicit Types l : loc.

Fixpoint is_list (hd : val) (xs : list val) : iProp Σ :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_list hd' xs
  end%I.

Definition rev : val :=
  rec: "rev" "hd" "acc" :=
    match: "hd" with
      NONE => "acc"
    | SOME "l" =>
       let: "tmp1" := Fst !"l" in
       let: "tmp2" := Snd !"l" in
       "l" <- ("tmp1", "acc");;
       "rev" "tmp2" "hd"
    end.

Lemma rev_acc_wp hd acc xs ys :
  [[{ is_list hd xs ∗ is_list acc ys }]]
    rev hd acc
  [[{ w, RET w; is_list w (reverse xs ++ ys) }]].
Proof.
  iIntros (Φ) "[Hxs Hys] HΦ". Show.
  iInduction xs as [|x xs] "IH" forall (hd acc ys Φ);
    iSimplifyEq; wp_rec; wp_let.
  - Show. wp_match. by iApply "HΦ".
  - iDestruct "Hxs" as (l hd' ->) "[Hx Hxs]".
    wp_load. wp_load. wp_store.
    iApply ("IH" $! hd' (SOMEV #l) (x :: ys) with "Hxs [Hx Hys]"); simpl.
    { iExists l, acc; by iFrame. }
    iIntros (w). rewrite cons_middle assoc -reverse_cons. iApply "HΦ".
Qed.

Lemma rev_wp hd xs :
  [[{ is_list hd xs }]] rev hd NONEV [[{ w, RET w; is_list w (reverse xs) }]].
Proof.
  iIntros (Φ) "Hxs HΦ".
  iApply (rev_acc_wp hd NONEV xs [] with "[$Hxs //]").
  iIntros (w). rewrite right_id_L. iApply "HΦ".
Qed.
End list_reverse.