(** Projet LTPF **)

(*
|-------+--------------+--------------|
|       | Bousquet Thomas | Catteau Pierrick |
|-------+--------------+--------------|
| 1.1.1 |              |             x|
| 1.1.2 |              |             x|
| 1.1.3 |              |             x|
| 1.1.4 |              |              |
| 1.2.1 |              |              |
|-------+--------------+--------------|
| 2.1.1 |              |              |
| 2.1.2 |              |              |
| 2.1.3 |              |              |
| 2.1.4 |              |              |
| 2.2.1 |              |              |
| 2.2.2 |              |              |
| 2.3.1 |              |              |
| 2.3.2 |              |              |
| 2.3.3 |              |              |
| 2.4.1 |              |              |
| 2.4.2 |              |              |
| 2.4.3 |              |              |
| 2.4.4 |              |    non traité|
|-------+--------------+--------------|
| 3.1   |              |              |
| 3.2   |              |              |
| 3.3.1 |              |              |
| 3.3.2 |              |              |
| 3.3.3 |              |              |
| 3.4   |              |              |
| 3.5   |              |              |
| 3.6   |              |              |
| 3.7.1 |              |              |
| 3.7.2 |              |              |
| 3.7.3 |              |              |
| 3.7.4 |              |              |
| 3.7.5 |              |              |
| 3.8   |              |              |
| 3.9   |              |              |
|-------+--------------+--------------|
 *)

(** 2.3.1 **)

(* On importe les bibliothèques de Coq utiles pour le TD   *)

Require Import Bool Arith List.
Import List.ListNotations.

(* ========================================================================== *)
(** * Préliminaires *)
(** ** Syntaxe des expressions arithétiques *)

Inductive aexp :=
| Aco : nat -> aexp (** constantes *)
| Ava : nat -> aexp (** variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(** ** Syntaxe des expressions booléennes *)

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp    (* test égalité de bexp *)
| Beqnat : aexp -> aexp -> bexp (* test égalité de aexp *)
.

(** ** Syntaxe du langage impératif WHILE *)

Inductive winstr :=
| Skip   : winstr
| Assign : nat -> aexp -> winstr
| Seq    : winstr -> winstr -> winstr
| If     : bexp -> winstr -> winstr -> winstr
| While  : bexp -> winstr -> winstr
.

(* -------------------------------------------------- *)
(** ** États *)

Definition state := list nat.

Fixpoint get (x:nat) (s:state) : nat :=
match x,s with
| 0   , v::_      => v
| S x1, _::l1 => get x1 l1
| _   , _         => 0
end.

Fixpoint update (s:state) (v:nat) (n:nat): state :=
match v,s with
| 0   , a :: l1 => n :: l1
| 0   , nil     => n :: nil
| S v1, a :: l1 => a :: (update l1 v1 n)
| S v1, nil     => 0 :: (update nil v1 n)
end.

(* ----------------------------------------------- *)
(** ** Sémantique fonctionnelle de aexp et de bexp *)

Fixpoint evalA (a: aexp) (s: state) : nat :=
  match a with
  | Aco n => n
  | Ava x => get x s
  | Apl a1 a2 =>  evalA a1 s + evalA a2 s
  | Amu a1 a2 =>  evalA a1 s * evalA a2 s
  | Amo a1 a2 =>  evalA a1 s - evalA a2 s
  end.

Definition eqboolb b1 b2 : bool :=
  match b1, b2  with
  | true , true  => true
  | false, false => true
  | _    , _     => false
  end.

Fixpoint eqnatb n1 n2 : bool :=
  match n1, n2 with
  | O    , O     => true
  | S n1', S n2' => eqnatb n1' n2'
  | _    , _     => false
  end.

Fixpoint evalB (b : bexp) (s : state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot b => negb (evalB b s)
  | Band e1 e2 => (evalB e1 s) && (evalB e2 s)
  | Bor e1 e2 => (evalB e1 s) || (evalB e2 s)
  | Beq e1 e2 => eqboolb (evalB e1 s) (evalB e2 s)
  | Beqnat n1 n2 => eqnatb (evalA n1 s) (evalA n2 s)
  end.

(* ========================================================================== *)

(** * SOS (Sémantique opérationnelle à petits pas) du langage While *)

Inductive config :=
| Inter : winstr -> state -> config
| Final : state -> config.

(* La relation pour un pas de SOS *)

Inductive SOS_1: winstr -> state -> config -> Prop :=
| SOS_Skip     : forall s,
                 SOS_1 Skip s (Final s)

| SOS_Assign   : forall x a s,
                 SOS_1 (Assign x a) s (Final (update s x (evalA a s)))

| SOS_Seqf     : forall i1 i2 s s1,
                 SOS_1 i1 s (Final s1) ->
                 SOS_1 (Seq i1 i2) s (Inter i2 s1)
| SOS_Seqi     : forall i1 i1' i2 s s1,
                 SOS_1 i1 s (Inter i1' s1) ->
                 SOS_1 (Seq i1 i2) s (Inter (Seq i1' i2) s1)

| SOS_If_true  : forall b i1 i2 s,
                 evalB b s = true  ->
                 SOS_1 (If b i1 i2) s (Inter i1 s)
| SOS_If_false : forall b i1 i2 s,
                 evalB b s = false ->
                 SOS_1 (If b i1 i2) s (Inter i2 s)

| SOS_While    : forall b i s,
                 SOS_1 (While b i) s (Inter (If b (Seq i (While b i)) Skip) s)
.

(** Fermeture réflexive-transitive de SOS_1 *)
(** Cette sémantique donne toutes les configurations atteignables
    par un (AST de) programme en partant d'un état initial.
 *)

Inductive SOS : config -> config -> Prop :=
| SOS_stop  : forall c, SOS c c
| SOS_again : forall i1 s1 c2 c3,
              SOS_1 i1 s1 c2 -> SOS c2 c3 ->
              SOS (Inter i1 s1) c3.

(* ========================================================================== *)

Definition N0 := Aco 0.
Definition N1 := Aco 1.
Definition N2 := Aco 2.
Definition N3 := Aco 3.
Definition N4 := Aco 4.

(** * I *)

(** *** Calcul du carré avec des additions *)
(** On code dans While un programme Pcarre correspondant à
    while not (i=n) do {i:= 1+i; x:= y+x ; y:= 2+y} *)
Definition Il := 0.
Definition Ir := Ava Il.
Definition Xl := 1.
Definition Xr := Ava Xl.
Definition Yl := 2.
Definition Yr := Ava Yl.

Definition incrI := Assign Il (Apl N1 Ir).
Definition incrX := Assign Xl (Apl Yr Xr).
Definition incrY := Assign Yl (Apl N2 Yr).
Definition corps_carre := Seq incrI (Seq incrX incrY).
Definition Pcarre_2 := While (Bnot (Beqnat Ir (Aco 2))) corps_carre.
Definition Pcarre n := While (Bnot (Beqnat Ir (Aco n))) corps_carre.
(** Nouveau : on peut jouer avec des programmes qui bouclent *)
Definition Pcarre_inf := While Btrue corps_carre.

Lemma SOS_Pcarre_2_1er_tour : SOS (Inter Pcarre_2 [0;0;1]) (Inter Pcarre_2 [1; 1; 3]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_inf_1er_tour : SOS (Inter Pcarre_inf [0;0;1]) (Inter Pcarre_inf [1; 1; 3]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_2_V0 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. reflexivity. }
  eapply SOS_again.
  {unfold corps_carre. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  cbn.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

(** Le but de la suite est d'éviter les redites, puis éventuellement
    de considérer le cas général Pcarre. *)

(** Propriété essentielle de SOS, qui a un intérêt pratique. *)
Theorem SOS_trans : forall c1 c2 c3, SOS c1 c2 -> SOS c2 c3 -> SOS c1 c3.
Proof.
  intros c1 c2 c3.
  intros h1.
  induction h1.
  - intro h2. apply h2.
  - intro h2. eapply SOS_again.
  { apply H. }
  { apply IHh1. apply h2. }
Qed.

(** Il n'est pas demandé de faire celui-ci
    (bien qu'un copié-collé d'un lemme précédent fonctionne). *)
Lemma SOS_Pcarre_2_2e_tour : SOS (Inter Pcarre_2 [1; 1; 3]) (Inter Pcarre_2 [2; 4; 5]).
Proof.
Admitted.

Theorem SOS_Pcarre_2_fini : SOS (Inter Pcarre_2 [2; 4; 5]) (Final [2; 4; 5]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. cbn. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

(** Même énoncé que SOS_Pcarre_2_V0. Utiliser SOS_trans *)
Theorem SOS_Pcarre_2_fin_V1 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  apply SOS_trans with (Inter Pcarre_2 [1; 1; 3]).
  - apply SOS_Pcarre_2_1er_tour.
  - apply SOS_trans with (Inter Pcarre_2 [2; 4; 5]).
    + apply SOS_Pcarre_2_2e_tour.
    + apply SOS_Pcarre_2_fini.
Qed.

(** Généralisation à Pcarre *)

(** On a besoin de deux lemmes arithmétiques, démontrables avec la tactique ring. *)
Lemma Sn_2 n : S n + S n = S (S (n + n)).
Proof. ring. Qed.

Lemma Sn_carre n : S n * S n = S (n + n + n * n).
Proof. ring. Qed.

Definition invar_cc n := [n; n*n; S (n+n)].
Theorem SOS_corps_carre n : SOS (Inter corps_carre (invar_cc n)) (Final (invar_cc (S n))).
Proof.
  eapply SOS_again.
  { unfold corps_carre. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { cbv[incrY]. apply SOS_Assign. }
  cbn. unfold invar_cc. rewrite Sn_2. rewrite Sn_carre. apply SOS_stop.
Qed.

(** Celui-ci est court mais difficile. Laisser Admitted au début. *)
Fixpoint SOS_seq i1 i2 s1 s2 (so : SOS (Inter i1 s1) (Final s2)) :
  SOS (Inter (Seq i1 i2) s1) (Inter i2 s2).
Proof.
Admitted.

(** Réutiliser les lemmes précédents (facile et très court). *)
Lemma SOS_corps_carre_inter n i :
  SOS (Inter (Seq corps_carre i) (invar_cc n)) (Inter i (invar_cc (S n))).
Proof.
  apply SOS_seq. apply SOS_corps_carre.
Qed.

Lemma eqnatb_refl : forall n, eqnatb n n = true.
Proof.
  intro n.
  induction n.
  - reflexivity.
  - cbn. apply IHn.
Qed.

(** Réutiliser les lemmes précédents (facile). *)
Lemma SOS_Pcarre_tour :
  forall n i, eqnatb i n = false ->
  SOS (Inter (Pcarre n) (invar_cc i)) (Inter (Pcarre n) (invar_cc (S i))).
Proof.
  intros n i.
  intros h.
  eapply SOS_again.
  { unfold Pcarre. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. rewrite h. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

(** Facile *)
Theorem SOS_Pcarre_n_fini :
  forall n, SOS (Inter (Pcarre n) (invar_cc n)) (Final (invar_cc n)).
Proof.
  intro n.
  eapply SOS_again.
  { unfold Pcarre. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. cbn. rewrite eqnatb_refl. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  apply SOS_stop.
Qed.

Theorem SOS_Pcarre_2_fin_V2 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_n_fini. }
  apply SOS_stop.
Qed.

(** On peut dire des choses sur la version qui boucle. *)
Lemma SOS_Pcarre_inf_tour :
  forall i,
  SOS (Inter Pcarre_inf (invar_cc i)) (Inter Pcarre_inf (invar_cc (S i))).
Proof.
  intro i.
  eapply SOS_again.
  {unfold Pcarre_inf. apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

Theorem SOS_Pcarre_inf_n :
  forall i,
  SOS (Inter Pcarre_inf [0; 0; 1]) (Inter Pcarre_inf (invar_cc i)).
Proof.
  (**
  intro i.
  induction i.
  -{unfold Pcarre_inf. cbv[invar_cc]. cbn. apply SOS_stop. }
  -apply SOS_trans with (Inter Pcarre_inf (invar_cc (S i))).
   {apply IHi.} *)
Admitted.


Require Export XR_eq_IZR.

Local Open Scope R_scope.

Lemma IZR_neq : forall z1 z2:Z,
  z1 <> z2 ->
  IZR z1 <> IZR z2.
Proof.
  intros x y h.
  unfold not.
  intro eq.
  unfold not in h.
  apply h.
  apply eq_IZR.
  exact eq.
Qed.


(*
 * Copyright (c) 2021 BedRock Systems, Inc.
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Import iris.bi.bi.
Require Import iris.bi.extensions.
Require Export bedrock.lang.bi.prelude.

(** * Step-indexed entailment *)
(** We axiomatize a generalization [P ⊢{n} Q] of Iris entailment that
satisfies

- [(P ⊢ Q) ↔ ∀ n, P ⊢{n} Q]

- [P ≡{n}≡ Q ↔ (P ⊢{n} Q) ∧ (Q ⊢{n} P)]

This generalization gives us a proof technique for lemmas of the form
[∃ x : A, P x ≡{n}≡ ∃ y : B, Q y] where the two sides quantify over
different types.

The cost of this generalization is that, at least for the particular
[P]s and [Q]s we care about, we have to restate the usual introduction
and elimination rules of the BI connectives in terms of [⊢{n}], prove
such connectives monotone, et cetera.

Another cost derives from the fact that the IPM is based on [⊢], so
proofs about [⊢{n}] involve more manual reasoning than IPM-based
proofs.

Note: We're defining the interface lazily. It covers only those
connectives we've needed. It could easily be fleshed out to cover
everything in Iris. *)

Reserved Notation "P '⊢{' n } Q"
  (at level 99, n at next level, Q at level 200, right associativity,
   format "'[' P  '/' '⊢{' n '}'  Q ']'").
Reserved Notation "P '⊢@{' PROP , n } Q"
  (at level 99, PROP, n at next level, Q at level 200,
   right associativity).
Reserved Notation "'(⊢{' n } )".
Reserved Notation "'(⊢@{' PROP , n } )".
Reserved Notation "P '⊣⊢{' n } Q"
  (at level 95, n at next level, no associativity,
   format "'[' P  '/' '⊣⊢{' n '}'  Q ']'").
Reserved Notation "P '⊣⊢@{' PROP , n } Q"
  (at level 95, PROP, n at next level, no associativity).

Reserved Notation "'⊢{' n } Q"
  (at level 20, n at next level, Q at level 200, format "'⊢{' n }  Q").
Reserved Notation "'⊢@{' PROP , n } Q"
  (at level 20, PROP, n at next level, Q at level 200).
(** Force left-factoring. See iris.bi.notation. *)
Reserved Notation "'(⊢@{' PROP , n } Q )".

Class EntailsN (PROP : Type) : Type := entailsN (n : nat) : relation PROP.
#[global] Instance : Params (@entailsN) 3 := {}.
#[global] Hint Mode EntailsN ! : typeclass_instances.
#[global] Arguments entailsN {_}%type_scope {_} _%nat_scope (_ _)%bi_scope : assert.

Notation "P '⊢{' n } Q" := (entailsN n P Q) : stdpp_scope.
Notation "P '⊢@{' PROP , n } Q" :=
  (@entailsN PROP _ n P Q) (only parsing) : stdpp_scope.
Notation "'(⊢{' n } )" := (entailsN n) (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP , n } )" :=
  (@entailsN PROP _ n) (only parsing) : stdpp_scope.
Notation "P '⊣⊢{' n } Q" := ((P ⊢{n} Q) ∧ (Q ⊢{n} P)) : stdpp_scope.
Notation "P '⊣⊢@{' PROP , n } Q" :=
  ((P ⊢@{PROP,n} Q) ∧ (Q ⊢@{PROP,n} P)) (only parsing) : stdpp_scope.

(** Incomplete mixin. Extend as needed, but please use additional
mixins for things like, e.g., [bi_later] and [fupd] in order to follow
the Iris mixin structure.

Notice that many primitive laws in [iris.bi.interface] follow from
[entails_entailsN], [dist_entailsN] and do not need to be axiomatized.
*)
Section mixin.
  Context (PROP : bi) `{EntailsN PROP}.
  Implicit Types P Q : PROP.

  Record BiEntailsNMixin : Prop := {
    bi_entailsN_mixin_entailsN_trans P Q R n : (P ⊢{n} Q) → (Q ⊢{n} R) → (P ⊢{n} R);
    bi_entailsN_mixin_entails_entailsN P Q : (P ⊢ Q) ↔ ∀ n, P ⊢{n} Q;
    bi_entailsN_mixin_dist_entailsN P Q n : P ≡{n}≡ Q ↔ (P ⊣⊢{n} Q);

    (** HOL: [bi_pure], [bi_and], [bi_or], [bi_impl], [bi_forall], [bi_exist] *)
    bi_entailsN_mixin_pure_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → ⌜P⌝ ⊢{n} Q;
    bi_entailsN_mixin_and_introN P Q R n : (P ⊢{n} Q) → (P ⊢{n} R) → P ⊢{n} Q ∧ R;
    bi_entailsN_mixin_impl_introN_r P Q R n : (P ∧ Q ⊢{n} R) → P ⊢{n} Q → R;
    bi_entailsN_mixin_forall_introN {A} P (Q : A → PROP) n :
      (∀ a, P ⊢{n} Q a) → (P ⊢{n} ∀ a, Q a);
    bi_entailsN_mixin_exist_elimN {A} (P : A → PROP) Q n :
      (∀ a, P a ⊢{n} Q) → (∃ a, P a) ⊢{n} Q;

    (** BI: [bi_sep], [bi_emp], [bi_wand] *)
    bi_entailsN_mixin_sep_monoN P P' Q Q' n :
      (P ⊢{n} Q) → (P' ⊢{n} Q') → (P ∗ P' ⊢{n} Q ∗ Q');
    bi_entailsN_mixin_wand_introN_r P Q R n : (P ∗ Q ⊢{n} R) → P ⊢{n} Q -∗ R;

    (** Modalities: [bi_persistently] *)
  }.
End mixin.

Class BiEntailsN (PROP : bi) : Type := {
  bi_entailsN_entailsN :> EntailsN PROP;
  bi_entailsN_mixin : BiEntailsNMixin PROP;
}.
#[global] Hint Mode BiEntailsN ! : typeclass_instances.
#[global] Arguments bi_entailsN_entailsN : simpl never.

(** Projecting properties from the mixin. *)
Section properties.
  Context `{BiEntailsN PROP}.
  Implicit Types P Q : PROP.

  Lemma entailsN_trans P Q R n : (P ⊢{n} Q) → (Q ⊢{n} R) → (P ⊢{n} R).
  Proof. apply bi_entailsN_mixin_entailsN_trans, bi_entailsN_mixin. Qed.
  Lemma entails_entailsN P Q : (P ⊢ Q) ↔ ∀ n, P ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_entails_entailsN, bi_entailsN_mixin. Qed.
  Lemma dist_entailsN P Q n : P ≡{n}≡ Q ↔ (P ⊣⊢{n} Q).
  Proof. apply bi_entailsN_mixin_dist_entailsN, bi_entailsN_mixin. Qed.

  Lemma pure_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → ⌜P⌝ ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_pure_elimN', bi_entailsN_mixin. Qed.
  Lemma and_introN P Q R n : (P ⊢{n} Q) → (P ⊢{n} R) → P ⊢{n} Q ∧ R.
  Proof. apply bi_entailsN_mixin_and_introN, bi_entailsN_mixin. Qed.
  Lemma impl_introN_r P Q R n : (P ∧ Q ⊢{n} R) → P ⊢{n} Q → R.
  Proof. apply bi_entailsN_mixin_impl_introN_r, bi_entailsN_mixin. Qed.
  Lemma forall_introN {A} P (Q : A → PROP) n : (∀ a, P ⊢{n} Q a) → (P ⊢{n} ∀ a, Q a).
  Proof. apply bi_entailsN_mixin_forall_introN, bi_entailsN_mixin. Qed.
  Lemma exist_elimN {A} (P : A → PROP) Q n : (∀ a, P a ⊢{n} Q) → (∃ a, P a) ⊢{n} Q.
  Proof. apply bi_entailsN_mixin_exist_elimN, bi_entailsN_mixin. Qed.

  Lemma sep_monoN P P' Q Q' n : (P ⊢{n} Q) → (P' ⊢{n} Q') → (P ∗ P' ⊢{n} Q ∗ Q').
  Proof. apply bi_entailsN_mixin_sep_monoN, bi_entailsN_mixin. Qed.
  Lemma wand_introN_r P Q R n : (P ∗ Q ⊢{n} R) → P ⊢{n} Q -∗ R.
  Proof. apply bi_entailsN_mixin_wand_introN_r, bi_entailsN_mixin. Qed.
End properties.

Definition emp_validN `{BiEntailsN PROP} (n : nat) (P : PROP) : Prop :=
  emp ⊢{n} P.
#[global] Arguments emp_validN {_ _} _%nat_scope _%I : simpl never, assert.
#[global] Hint Opaque emp_validN : typeclass_instances.

Notation "'⊢{' n } Q" := (emp_validN n Q) : stdpp_scope.
Notation "'⊢@{' PROP , n } Q" := (@emp_validN PROP _ n Q)
  (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP , n } Q )" := (@emp_validN PROP _ n Q)
  (only parsing) : stdpp_scope.

#[global] Instance entailsN_rewrite_relation `{BiEntailsN PROP} n :
  RewriteRelation (⊢@{PROP,n}) := {}.

(** The following theory is incomplete. Extend as needed. To use a
connective under [⊢{n}], you generally need its introduction rules,
elimination rules, and monotonicity properties. *)
Section theory.
  Context `{BiEntailsN PROP}.
  Implicit Types P Q : PROP.
  Notation "'(⊢{' n } )" := (⊢@{PROP,n}) (only parsing).

  #[global] Instance entailsN_po n : PreOrder (⊢@{PROP,n}).
  Proof.
    split.
    - intros P. by apply entails_entailsN.
    - repeat intro. by eapply entailsN_trans.
  Qed.

  (** Rewriting *)
  #[global] Instance: Params (@entailsN) 3 := {}.
  Lemma entailsN_ne n : Proper (dist n ==> dist n ==> iff) (⊢{n}).
  Proof.
    intros P1 P2 [HP1 HP2]%dist_entailsN.
    intros Q1 Q2 [HQ1 HQ2]%dist_entailsN.
    split=>?. by rewrite HP2 -HQ1. by rewrite HP1 -HQ2.
  Qed.
  #[global] Instance entailsN_proper n : Proper (equiv ==> equiv ==> iff) (⊢{n}).
  Proof. repeat intro. apply entailsN_ne; by apply equiv_dist. Qed.

  #[global] Instance: Params (@emp_validN) 3 := {}.
  #[global] Instance emp_validN_proper n :
    Proper (equiv ==> iff) (@emp_validN PROP _ n).
  Proof. exact: entailsN_proper. Qed.

  (** [bi_pure] *)
  Lemma True_introN P n : P ⊢{n} True.
  Proof. apply entails_entailsN, bi.True_intro. Qed.
  Lemma False_elimN P n : False ⊢{n} P.
  Proof. apply entails_entailsN, bi.False_elim. Qed.
  Lemma pure_introN (P : Prop) Q n : P → Q ⊢{n} ⌜P⌝.
  Proof. intros. by apply entails_entailsN, bi.pure_intro. Qed.
  Lemma pure_monoN (P Q : Prop) n : (P → Q) → (⌜P⌝ ⊢@{PROP,n} ⌜Q⌝).
  Proof. intros. by apply entails_entailsN, bi.pure_mono. Qed.
  #[global] Instance pure_monoN' n : Proper (impl ==> (⊢{n})) bi_pure.
  Proof. repeat intro. by apply pure_monoN. Qed.
  #[global] Instance pure_flip_monoN n : Proper (impl --> flip (⊢{n})) bi_pure.
  Proof. repeat intro. by apply pure_monoN. Qed.

  (** [bi_and] *)
  Lemma and_elimN_r P Q n : P ∧ Q ⊢{n} Q.
  Proof. apply entails_entailsN, bi.and_elim_r. Qed.
  Lemma and_elimN_l P Q n : P ∧ Q ⊢{n} P.
  Proof. apply entails_entailsN, bi.and_elim_l. Qed.
  Lemma and_mono P P' Q Q' n : (P ⊢{n} Q) → (P' ⊢{n} Q') → P ∧ P' ⊢{n} Q ∧ Q'.
  Proof.
    intros. apply and_introN.
    - by etrans; first apply and_elimN_l.
    - by etrans; first apply and_elimN_r.
  Qed.
  Lemma and_monoN_r P P' Q' n : (P' ⊢{n} Q') → (P ∧ P' ⊢{n} P ∧ Q').
  Proof. intros. by apply and_mono. Qed.
  Lemma and_monoN_l P P' Q n : (P ⊢{n} Q) → (P ∧ P' ⊢{n} Q ∧ P').
  Proof. intros. by apply and_mono. Qed.
  #[global] Instance and_monoN n : Proper ((⊢{n}) ==> (⊢{n}) ==> (⊢{n})) bi_and.
  Proof. repeat intro. by apply and_mono. Qed.
  #[global] Instance uPred_and_flip_monoN n :
    Proper ((⊢{n}) --> (⊢{n}) --> flip (⊢{n})) bi_and.
  Proof. repeat intro. by apply and_mono. Qed.

  (** [bi_impl] *)
  Lemma impl_introN_l P Q R n : (Q ∧ P ⊢{n} R) → (P ⊢{n} Q → R).
  Proof. rewrite comm. apply impl_introN_r. Qed.
  Lemma impl_elimN_r P Q n : (P ∧ (P → Q)) ⊢{n} Q.
  Proof. apply entails_entailsN, bi.impl_elim_r. Qed.
  Lemma impl_elimN_r' P Q R n : (Q ⊢{n} P → R) → (P ∧ Q ⊢{n} R).
  Proof. intros ->. apply impl_elimN_r. Qed.
  Lemma impl_elimN_l P Q n : ((P → Q) ∧ P) ⊢{n} Q.
  Proof. apply entails_entailsN, bi.impl_elim_l. Qed.
  Lemma impl_elimN_l' P Q R n : (P ⊢{n} Q → R) → (P ∧ Q ⊢{n} R).
  Proof. intros ->. apply impl_elimN_l. Qed.
  Lemma impl_elimN P Q R n : (P ⊢{n} Q → R) → (P ⊢{n} Q) → (P ⊢{n} R).
  Proof.
    intros HR HQ. trans (P ∧ P)%I; first by apply and_introN.
    rewrite {1}HQ HR. apply impl_elimN_r.
  Qed.
  Lemma impl_monoN P P' Q Q' n : (Q ⊢{n} P) → (P' ⊢{n} Q') → (P → P') ⊢{n} (Q → Q').
  Proof. intros HQ HP. apply impl_introN_l. rewrite HQ -HP. apply impl_elimN_r. Qed.
  #[global] Instance impl_monoN' n : Proper ((⊢{n}) --> (⊢{n}) ==> (⊢{n})) bi_impl.
  Proof. repeat intro. by apply impl_monoN. Qed.
  #[global] Instance impl_flip_monoN' n :
    Proper ((⊢{n}) ==> (⊢{n}) --> flip (⊢{n})) bi_impl.
  Proof. repeat intro. by apply impl_monoN. Qed.
  Lemma pure_implN_1 (P Q : Prop) n : ⌜P → Q⌝ ⊢@{PROP,n} ⌜P⌝ → ⌜Q⌝.
  Proof. apply entails_entailsN, bi.pure_impl_1. Qed.
  Lemma pure_implN_2 `{!BiPureForall PROP} (P Q : Prop) n :
    (⌜P⌝ → ⌜Q⌝) ⊢@{PROP,n} ⌜P → Q⌝.
  Proof. apply entails_entailsN, bi.pure_impl_2. Qed.
  Lemma entailsN_impl P Q n : (P ⊢{n} Q) → ⊢{n} P → Q.
  Proof. intros HP. apply impl_introN_r. rewrite HP. apply and_elimN_r. Qed.
  Lemma impl_entailsN P Q n `{!Affine P} : ( ⊢{n} P → Q ) → P ⊢{n} Q.
  Proof. intros. rewrite -(bi.emp_and P). by apply impl_elimN_l'. Qed.
  Lemma entailsN_impl_True P Q n : (P ⊢{n} Q) ↔ (True ⊢{n} P → Q).
  Proof.
    split.
    - intros <-. apply entails_entailsN. by rewrite -bi.entails_impl_True.
    - intros. rewrite -[P](left_id True%I bi_and). by apply impl_elimN_l'.
  Qed.
  Lemma entailsN_eq_True P Q n : (P ⊢{n} Q) ↔ ((P → Q) ⊣⊢{n} True).
  Abort.

  (** [bi_forall] *)
  Lemma forall_elimN {A} (P : A → PROP) a n : (∀ a, P a) ⊢{n} P a.
  Proof. apply entails_entailsN, bi.forall_elim. Qed.
  Lemma forall_elim {A} P (Q : A → PROP) n : (P ⊢{n} ∀ a, Q a) → ∀ a, P ⊢{n} Q a.
  Proof. intros HP a. rewrite HP. apply forall_elimN. Qed.
  Lemma forall_monoN {A} (P Q : A → PROP) n :
    (∀ a, P a ⊢{n} Q a) → (∀ a, P a) ⊢{n} (∀ a, Q a).
  Proof.
    intros HP. apply forall_introN=>a. rewrite -(HP a). apply forall_elimN.
  Qed.
  #[global] Instance forall_monoN' {A} n :
    Proper (pointwise_relation A (⊢{n}) ==> (⊢{n})) bi_forall.
  Proof. repeat intro. by apply forall_monoN. Qed.
  #[global] Instance forall_flip_monoN' {A} n :
    Proper (pointwise_relation A (flip (⊢{n})) ==> flip (⊢{n})) bi_forall.
  Proof. repeat intro. by apply forall_monoN. Qed.

  (** [bi_exist] *)
  Lemma exist_introN {A} (P : A → PROP) a n : P a ⊢{n} ∃ a, P a.
  Proof. apply entails_entailsN, bi.exist_intro. Qed.
  Lemma exist_introN' {A} P (Q : A → PROP) a n : (P ⊢{n} Q a) → P ⊢{n} ∃ a, Q a.
  Proof. etrans; eauto using exist_introN. Qed.
  Lemma exist_monoN {A} (P Q : A → PROP) n :
    (∀ a : A, P a ⊢{n} Q a) → (∃ a, P a) ⊢{n} ∃ a, Q a.
  Proof. intros. apply exist_elimN=>a. exact: exist_introN'. Qed.
  #[global] Instance exist_monoN' {A} n :
    Proper (pointwise_relation A (⊢{n}) ==> (⊢{n})) bi_exist.
  Proof. repeat intro. by apply exist_monoN. Qed.
  #[global] Instance uPred_exist_flip_monoN' {A} n :
    Proper (pointwise_relation A (flip (⊢{n})) ==> flip (⊢{n})) bi_exist.
  Proof. repeat intro. by apply exist_monoN. Qed.

  (** [bi_sep] *)
  Lemma sep_monoN_l P P' Q' n : (P' ⊢{n} Q') → P ∗ P' ⊢{n} P ∗ Q'.
  Proof. intros. by eapply sep_monoN. Qed.
  Lemma sep_monoN_r P P' Q n : (P ⊢{n} Q) → P ∗ P' ⊢{n} Q ∗ P'.
  Proof. intros. by eapply sep_monoN. Qed.
  #[global] Instance sep_monoN' n : Proper ((⊢{n}) ==> (⊢{n}) ==> (⊢{n})) bi_sep.
  Proof. repeat intro. by apply sep_monoN. Qed.
  #[global] Instance sep_flip_monoN' n :
    Proper ((⊢{n}) --> (⊢{n}) --> flip (⊢{n})) bi_sep.
  Proof. repeat intro. by apply sep_monoN. Qed.

  (** [bi_emp] *)
  Lemma emp_sep_1N P n : P ⊢{n} emp ∗ P.
  Proof. apply entails_entailsN, bi.emp_sep_1. Qed.
  Lemma emp_sep_2N P n : emp ∗ P ⊢{n} P.
  Proof. apply entails_entailsN, bi.emp_sep_2. Qed.

  (** [bi_wand] *)
  Lemma wand_elimN_l' P Q R n : (P ⊢{n} Q -∗ R) → (P ∗ Q ⊢{n} R).
  Proof. intros ->. apply entails_entailsN, bi.wand_elim_l. Qed.
  Lemma wand_elimN_r' P Q R n : (Q ⊢{n} P -∗ R) → (P ∗ Q ⊢{n} R).
  Proof. intros. rewrite comm. by apply wand_elimN_l'. Qed.
  Lemma wand_elimN_r P Q n : P ∗ (P -∗ Q) ⊢{n} Q.
  Proof. by etrans; last by apply wand_elimN_r'. Qed.
  Lemma wand_elimN_l P Q n : (P -∗ Q) ∗ P ⊢{n} Q.
  Proof. by etrans; last by apply wand_elimN_l'. Qed.
  Lemma wand_introN_l P Q R n : (Q ∗ P ⊢{n} R) → P ⊢{n} Q -∗ R.
  Proof. intros. apply wand_introN_r. by rewrite comm. Qed.
  Lemma wand_monoN P P' Q Q' n : (Q ⊢{n} P) → (P' ⊢{n} Q') → (P -∗ P') ⊢{n} (Q -∗ Q').
  Proof.
    intros HQP HPQ. apply wand_introN_r. rewrite HQP -HPQ. by apply wand_elimN_l'.
  Qed.
  #[global] Instance wand_monoN' n : Proper ((⊢{n}) --> (⊢{n}) ==> (⊢{n})) bi_wand.
  Proof. repeat intro. by apply wand_monoN. Qed.
  #[global] Instance wand_flip_monoN' n :
    Proper ((⊢{n}) ==> (⊢{n}) --> flip (⊢{n})) bi_wand.
  Proof. repeat intro. by apply wand_monoN. Qed.

  (** [bi_persitently] *)
  Lemma persistently_forall_2N `{BiPersistentlyForall PROP} {A} (P : A → PROP) n :
    (∀ a, <pers> P a) ⊢{n} <pers> (∀ a, P a).
  Proof. apply entails_entailsN, persistently_forall_2. Qed.

  (** [bi_later] *)
  Lemma later_forall_2N {A} (P : A → PROP) n : (∀ a, ▷ P a) ⊢{n} ▷ (∀ a, P a).
  Proof. apply entails_entailsN, bi.later_forall_2. Qed.

  (** [bi_affinely] *)
  Lemma affinely_monoN P Q n : (P ⊢{n} Q) → (<affine> P ⊢{n} <affine> Q).
  Proof. rewrite /bi_affinely. by intros ->. Qed.
  #[global] Instance affinely_monoN' n : Proper ((⊢{n}) ==> (⊢{n})) bi_affinely.
  Proof. repeat intro. by apply affinely_monoN. Qed.
  #[global] Instance affinely_flip_monoN' n :
    Proper ((⊢{n}) --> flip (⊢{n})) bi_affinely.
  Proof. repeat intro. by apply affinely_monoN. Qed.
  Lemma affinely_idempN P n : <affine> <affine> P ⊣⊢{n} <affine> P.
  Proof. apply dist_entailsN. by rewrite bi.affinely_idemp. Qed.
  Lemma affinely_introN' P Q n : (<affine> P ⊢{n} Q) → (<affine> P ⊢{n} <affine> Q).
  Proof. intros <-. apply affinely_idempN. Qed.
  Lemma affinely_introN P Q n `{!Affine P} : (P ⊢{n} Q) → (P ⊢{n} <affine> Q).
  Proof. intros <-. by apply entails_entailsN, bi.affinely_intro. Qed.
  Lemma affinely_elimN P n : <affine> P ⊢{n} P.
  Proof. apply entails_entailsN, bi.affinely_elim. Qed.
  Lemma afifnely_elimN_emp P n : <affine> P ⊢{n} emp.
  Proof. apply entails_entailsN, bi.affinely_elim_emp. Qed.

  (** [only_provable] *)
  #[local] Transparent only_provable.
  Lemma only_provable_introN (P : Prop) Q `{!Affine Q} n : P → Q ⊢{n} [| P |].
  Proof. intros HP. apply: affinely_introN. exact: pure_introN. Qed.
  Lemma only_provable_elimN' (P : Prop) Q n : (P → True ⊢{n} Q) → [| P |] ⊢{n} Q.
  Proof. rewrite/only_provable affinely_elimN. exact: pure_elimN'. Qed.
  Lemma only_provable_monoN (P Q : Prop) n : (P → Q) → [| P |] ⊢@{PROP,n} [| Q |].
  Proof. intros. by apply affinely_monoN, pure_monoN. Qed.
  #[global] Instance only_provable_monoN' n : Proper (impl ==> (⊢{n})) only_provable.
  Proof. repeat intro. by apply only_provable_monoN. Qed.
  #[global] Instance only_provable_flip_monoN n :
    Proper (impl --> flip (⊢{n})) only_provable.
  Proof. repeat intro. by apply only_provable_monoN. Qed.

End theory.


(*|

=============================
Example: Simple spinlock
=============================

This example is a liveness proof for the following simple C program. It encodes the program as a hand-written state machine, with states referring to labeled points.

::

  type Mutex = bool;
  const UNLOCKED = false;
  const LOCKED = true;

  void lock(Mutex *m) {
    // pc0
    for cas(m, UNLOCKED, LOCKED) {}
    // control goes directly to pc1 (see `thread`)
  }

  void unlock(Mutex *m) {
    // pc1
    *m = UNLOCKED;
    // pc2
  }

  void thread(Mutex *m) {
    lock(m);
    unlock(m);
  }

  void main() {
    Mutex *m = malloc(sizeof(Mutex));
    // these two threads are what is modeled
    spawn(thread, m);
    spawn(thread, m);
  }

What we reason about is two threads running `lock(m); unlock(m)` (assuming m starts out allocated).

|*)

From RecordUpdate Require Import RecordUpdate.
From stdpp Require Import functions.

From TLA Require Import logic.

Module spec.

  Inductive pc := pc0 | pc1 | pc2.
  Inductive Tid := tidA | tidB.

  #[global]
  Instance tid_eqdecision : EqDecision Tid.
  Proof.
    solve_decision.
  Defined.

  (* the state consists of the state of the mutex, and program counters for two
  threads, tidA and tidB *)
  Record state :=
    mkState { lock: bool; pcs: Tid → pc; }.

  #[global]
  Instance _eta : Settable _ := settable! mkState <lock; pcs>.

  Definition cas_fail (t0: Tid): action state :=
    λ s s', (s.(pcs) t0 = pc0 ∧ s.(lock) = true)
            ∧ s' = s.

  Definition cas_succ (t0: Tid): action state :=
    λ s s', s.(pcs) t0 = pc0 ∧ s.(lock) = false
            ∧ s' = s <|lock := true|>
                     <|pcs ::= <[ t0 := pc1 ]> |>.

  Definition unlock (t0: Tid): action state :=
    λ s s', s.(pcs) t0 = pc1
            ∧ s' = s <|lock := false|>
                     <|pcs ::= <[ t0 := pc2 ]> |>.

  Definition step (t0: Tid): action state :=
      λ s s', cas_fail t0 s s' ∨ cas_succ t0 s s' ∨ unlock t0 s s'.

  Definition init: state → Prop :=
    λ s, s = {| lock := false; pcs := λ _, pc0; |}.

  Definition next : action state :=
    λ s s', step tidA s s' ∨ step tidB s s' ∨ s' = s.

  (* safety is mutual exclusion *)
  Definition safe: state → Prop :=
    λ s, ¬ (s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc1).

  Definition fair: predicate state :=
    weak_fairness (step tidA) ∧ weak_fairness (step tidB).

  (* liveness means both threads terminate *)
  Definition terminated: state → Prop :=
    λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc2.

End spec.

Import spec.

Section example.

Implicit Types (s: state) (t: Tid).

Hint Unfold init next step safe fair terminated : stm.
Hint Unfold cas_fail cas_succ unlock : stm.

Lemma enabled_thread t :
  enabled (step t) = λ s, s.(pcs) t ≠ pc2.
Proof.
  apply pred_ext => s.
  unfold enabled; split.
  - autounfold with stm. intros [s' Hstep];
      (intuition subst);
      try congruence.
  - intros.
    autounfold with stm.
    destruct s as [l pcs0]; simpl in *.
    destruct (pcs0 t) eqn:?; [ | | congruence ].
    * destruct l; simpl; eexists (mkState _ _); eauto.
    * eexists (mkState _ _); eauto.
Qed.

Ltac stm_simp :=
  autounfold with stm;
  intros; (intuition (repeat deex; subst; trivial));
  rewrite ?enabled_eq ?enabled_thread;
  repeat deex;
  repeat (match goal with
        | s: state |- _ => (destruct s; cbn in * )
        | H: ?x = ?x |- _ => clear H
        | H: @eq pc _ _ |- _ => solve [ inversion H ]
        | H: @eq state (mkState _ _) (mkState _ _) |- _ =>
            invc H; cbn in *
        | H: context[@set state _ _ _ _ _] |- _ =>
            progress (unfold set in H; simpl in H)
        | H: @eq bool _ _ |- _ => solve [ inversion H ]
        | _ => progress (unfold set; simpl)
        | _ => rewrite fn_lookup_insert
        | _ => rewrite -> fn_lookup_insert_ne by congruence
        | _ => progress cbn in *
        end).

Ltac stm :=
  stm_simp;
  try solve [ intuition (repeat deex; eauto) ];
  try congruence.

Definition exclusion_inv: state → Prop :=
  λ s, (s.(pcs) tidA = pc1 → s.(lock) ∧ s.(pcs) tidB ≠ pc1) ∧
       (s.(pcs) tidB = pc1 → s.(lock) ∧ s.(pcs) tidA ≠ pc1).

Hint Unfold exclusion_inv : stm.

Lemma exclusion_inv_ok :
  ⌜init⌝ ∧ □⟨next⟩ ⊢ □⌜exclusion_inv⌝.
Proof.
  apply init_invariant.
  - stm.
  - stm.
Qed.

Theorem safety :
  ⌜init⌝ ∧ □⟨next⟩ ⊢ □ ⌜safe⌝.
Proof.
  rewrite exclusion_inv_ok.
  apply always_impl_proper.
  unseal; stm.
Qed.

Theorem wf_threads_combine :
  (weak_fairness (step tidA) ∧ weak_fairness (step tidB)) ==
  weak_fairness (λ s s', step tidA s s' ∨ step tidB s s')%type.
Proof.
  apply wf_combine.
  - rewrite /tla_enabled.
    (* rewrite ?enabled_thread. *)
    (* first, to have any hope here we'd need to make [wf_combine] internal and
    carry out this proof under the assumption of `□⟨next⟩`, but also this
    doesn't seem true at all: it's equivalent to [enabled (step tidA) → ◇
    enabled (step tidB) → ◇ (step tidA)], but this is obvious false in an
    execution which is just the initial state and then infinite stuttering *)
Abort.

(** wrapper for [exclusion_inv_ok] to "upgrade" from a semantics with [next] to
one that incorporates the invariant *)
Lemma add_safety :
  ⌜init⌝ ∧ □⟨next⟩ ⊢
  ⌜init⌝ ∧ □⟨λ s s', next s s' ∧ exclusion_inv s ∧ exclusion_inv s'⟩.
Proof.
  tla_pose (exclusion_inv_ok).
  rewrite combine_preds //.
Qed.

(*|

---------------------
Proving termination
---------------------

Why does this program terminate? The basic reasoning in this proof is fairly brute force. However, we must use the assumption of weak fairness in order to guarantee that each thread makes progress (as opposed to stuttering or starving). The main rule is wf1, which gives a `~~>` from weak fairness of an action.

The tricky part about the mutex example is getting started, because we don't know whether thread A or thread B will acquire the lock first, and thus we're not sure whether the action `step tidA` will happen or `step tidB`. The way we resolve this in the proof is to show that `step tidA` eventually runs and results in one of two possibilities: either tidA acquires the lock (and moves on to `pc1`), or it fails to acquire the lock. Now the crucial reasoning step is that if tidA doesn't acquire the lock, then tidB must hold it. In general we only know that tidB is in its critical section, but in fact because the state machine is so trivial that the entire critical section is just `pc1`.

Now we have a "diverging" leads to, which leads to one of two possibilities. TLA gives a way to construct a single leads-to from a "lattice" of leads-tos, as long as the eventually converge to some goal state. In this example, once either tidA or tidB acquire the lock, the remaining execution is sequential, so the divergence is very simple. As a result we use `leads_to_fork2`, a very special case of the lattice rule that just gives a way to diverge to `q ∨ r` and then reconverge to some goal.

|*)

Lemma init_to_terminate :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ⌜init⌝ ~~> ⌜terminated⌝.
Proof.
  unfold fair.
(*|
This manipulation (which unfortunately is messy because things are so syntactic) brings the `exclusion_inv` invariant into scope. We need this because the intermediate assertions in this proof don't all mention the lock state, and the invariant helps us infer it from the program counters of the two threads. (A more precise invariant could avoid all mention of locks.)
|*)
  rewrite <- tla_and_assoc. rewrite -> add_safety. tla_simp.

(*|
The first creative step is to lay out what two possibilities are possible from `init`. As described above, either thread A acquires the lock, or B is in its critical section and A is waiting.
|*)
  apply (leads_to_fork2
           ⌜λ s, s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc0⌝
           ⌜λ s, s.(pcs) tidA = pc0 ∧ s.(pcs) tidB = pc1⌝).
(*|
This is actually the non-obvious initial divergence where tidA runs and either succeeds or fails. Automation makes short work of it. Note that we could just as well get this result from thread B.
|*)
  - rewrite combine_or_preds.
    tla_apply (wf1 (step tidA)); stm.

  -
(*|
Next we reason through a sequence of states, connected by wf1. First A steps and releases the lock, then B steps twice to acquire and release.
|*)

    leads_to_trans ⌜λ s, s.(pcs) tidA = pc2 ∧
                         s.(pcs) tidB = pc0 ∧
                         s.(lock) = false⌝.
    { tla_apply (wf1 (step tidA)); stm. }
    leads_to_trans ⌜ λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc1⌝.
    { tla_apply (wf1 (step tidB)); stm. }
    tla_apply (wf1 (step tidB)); stm.
  -
(*|
The other branch is symmetric, with B releasing the lock and then A acquiring and releasing.
|*)
    leads_to_trans ⌜λ s, s.(pcs) tidB = pc2 ∧
                         s.(pcs) tidA = pc0 ∧
                         s.(lock) = false⌝.
    { tla_apply (wf1 (step tidB)); stm. }
    leads_to_trans ⌜ λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc1⌝.
    { tla_apply (wf1 (step tidA)); stm. }
    tla_apply (wf1 (step tidA)); stm.
Qed.

(*|
Below is an alternate proof of the same termination theorem. Instead of using the special case `leads_to_fork2`, we use the lattice rule with a lattice that fairly explicitly gives the states. Some of the paths in this lattice are actually linear chains, which can be optimized away, but maybe in some cases the lattice is easier to think about.
|*)

Inductive L := start | A1 | Afin | AfinB1 | B1 | Bfin | BfinA1 | goal.

Definition Llt (l1 l2: L) : Prop :=
  match l2, l1 with
  | start, A1 | A1, Afin | Afin, AfinB1 => True
  | start, B1 | B1, Bfin | Bfin, BfinA1 => True
  | AfinB1, goal | BfinA1, goal => True
  | _, _ => False
  end.

Theorem Llt_wf : well_founded Llt.
Proof.
  prove_wf [goal; AfinB1; Afin; A1; BfinA1; Bfin; B1; start].
Qed.

Definition h (label: L) : state → Prop :=
  match label with
  | start => init

  | A1 => λ s, s.(pcs) tidA = pc1 ∧ s.(pcs) tidB = pc0
  | Afin => λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc0 ∧ s.(lock) = false
  | AfinB1 => λ s, s.(pcs) tidA = pc2 ∧ s.(pcs) tidB = pc1

  | B1 => λ s, s.(pcs) tidB = pc1 ∧ s.(pcs) tidA = pc0
  | Bfin => λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc0 ∧ s.(lock) = false
  | BfinA1 => λ s, s.(pcs) tidB = pc2 ∧ s.(pcs) tidA = pc1

  | goal => terminated
  end.

Hint Extern 1 (Llt _ _) => exact I : core.

Lemma init_to_terminate_lattice_proof :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ⌜init⌝ ~~> ⌜terminated⌝.
Proof.
  unfold fair.
  apply (lattice_leads_to Llt_wf h start goal); [ done | done | ].
  intros l Hne.

  rewrite <- tla_and_assoc. rewrite -> add_safety. tla_simp.

  (* split the proof into one case per label *)
  destruct l; cbn [h]; try congruence.

  - (* start *)
    leads_to_trans ⌜λ s, h A1 s ∨ h B1 s⌝; swap 1 2.
    { apply pred_leads_to => s.
      intros [|]; [ exists A1 | exists B1 ]; eauto. }
    tla_apply (wf1 (step tidA)); stm.
  - (* A1 *)
    leads_to_trans ⌜h Afin⌝; swap 1 2.
    { apply pred_leads_to => s. exists Afin; eauto. }

    tla_apply (wf1 (step tidA)); stm.
  - (* Afin *)
    leads_to_trans ⌜h AfinB1⌝; swap 1 2.
    { apply pred_leads_to => s. exists AfinB1; eauto. }

    tla_apply (wf1 (step tidB)); stm.
  - (* AfinB1 *)
    leads_to_trans ⌜terminated⌝; swap 1 2.
    { apply pred_leads_to => s. exists goal; eauto. }
    tla_apply (wf1 (step tidB)); stm.

  - (* B1 *)
    leads_to_trans ⌜h Bfin⌝; swap 1 2.
    { apply pred_leads_to => s. exists Bfin; eauto. }

    tla_apply (wf1 (step tidB)); stm.
  - (* Bfin *)
    leads_to_trans ⌜h BfinA1⌝; swap 1 2.
    { apply pred_leads_to. exists BfinA1; eauto. }

    tla_apply (wf1 (step tidA)); stm.
  - (* BfinA1 *)
    leads_to_trans ⌜terminated⌝; swap 1 2.
    { apply pred_leads_to => s. exists goal; eauto. }
    tla_apply (wf1 (step tidA)); stm.
Qed.

Lemma eventually_terminate :
  ⌜init⌝ ∧ □⟨next⟩ ∧ fair ⊢ ◇ ⌜terminated⌝.
Proof.
  eapply leads_to_apply; [ | apply init_to_terminate ].
  tla_prop.
Qed.

End example.


(** a test for the derivation of new container types **)
Inductive or2 (A B : Prop) : Type :=
	or2_introl : A -> or2 A B | or2_intror : B -> or2 A B.

Load addContainer.

(* MetaCoq Run (addType or). *)
(* MetaCoq Run (addType sum). *)

(* MetaCoq Run (addType or2). *)
(* Next Obligation. *)
(*   induction H. *)

(*   induction H eqn: X. *)
(*   dependent induction H. *)
(*   induction H. *)
(*   destruct H. *)
(*   - now constructor. *)
(*   - now constructor. *)
(* Defined. *)

MetaCoq Run (addType list).
Next Obligation.
  induction X.
  - constructor.
  - constructor.
    + apply AH.
    + apply IHX.
Defined.
Print list_inst.
(* Next Obligation. *)
(* apply True. *)
(* Defined. *)
(* Next Obligation. *)
(* apply I. *)
(* Defined. *)

Print All_Forall.All.

Inductive All2 {A : Type} (P : A -> Type) : list A -> Type :=
    All2_nil : All2 P []
  | All2_cons : forall (x : A) (l : list A), P x -> All2 P l -> All2 P (x :: l).

(* MetaCoq Run (addType (@All2)). *)

Inductive t2 (A : Type) : nat -> Type :=
    nilt2 : t2 A 0
  | const2 : A -> forall n : nat, t2 A n -> t2 A (S n).

(* Obligation Tactic := idtac. *)

MetaCoq Run (addType t2).
Next Obligation.
  induction X.
  - constructor.
  - constructor.
    + apply AH.
    + apply IHX.
Defined.

Print t2_inst.
Print t2ᵗ0.
Print t2ᵗ.

(* Next Obligation. *)
(* cbn.  intros. *)
(* apply True. *)
(* Defined. *)
(* Next Oblgiation. *)


Require Import TT2BDD.TT.
Require Import BoolEq.
Require Import core.Model.
Require Import String.
Require Import List.
Require Import Utils.

Definition matchInputCell
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (cell : Cell)
    (ins: list (string*bool)):
        bool :=
    match Cell_getPort cell ttm with
    | Some (Build_Abstract_Port InputPortEClass p) =>
        existsb (fun input =>
            andb (String.eqb (fst input) (InputPort_getName p))
                (Bool.eqb (snd input) (Cell_getValue cell)))
            ins
    | _ => true
    end.

Definition matchRow
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row)
    (ins: list (string*bool)):
        bool :=
    match Row_getCells row ttm with
    | Some cells => forallb (fun cell => matchInputCell ttm cell ins) cells
    | _ => true
    end.

Definition outputCells
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row):
        list Cell :=
    match Row_getCells row ttm with
    | Some cells =>
        filter (fun cell =>
            match Cell_getPort cell ttm with
            | Some (Build_Abstract_Port OutputPortEClass _) => true
            | _ => false
            end
            ) cells
    | _ => nil
    end.

Definition cellToPair
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (cell : Cell):
        string*bool :=
    match Cell_getPort cell ttm with
        | Some (Build_Abstract_Port OutputPortEClass p) => (OutputPort_getName p,Cell_getValue cell)
        | Some (Build_Abstract_Port InputPortEClass p) => (InputPort_getName p,Cell_getValue cell)
        | _ => (""%string, Cell_getValue cell)
    end.

Definition outputOfRow
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (row : Row):
        list (string*bool) :=
    match Row_getCells row ttm with
    | Some cells =>
        map (cellToPair ttm) (outputCells ttm row)
    | _ => nil
    end.

Definition eval
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (tt : TruthTable)
    (ins: list (string*bool)):
        list (string*bool) :=
    match TruthTable_getRows tt ttm with
    | Some rows =>
        flat_map (outputOfRow ttm)  (filter (fun row => matchRow ttm row ins) rows)
    | _ => nil
    end.

Definition valueOf
    (portValues: list (string*bool))
    (portName: string)
    :=
    let values := (nodup bool_dec (map snd (filter (fun p => String.eqb (fst p) portName) portValues))) in
    match values with
    | false :: nil => Some false
    | true :: nil => Some true
    | _ => None
    end.

Definition allInputPorts
    (ttm: Model TTMetamodel_EObject TTMetamodel_ELink)
    (tt : TruthTable) :=
    filter
        (fun port => match port with
        | (Build_Abstract_Port InputPortEClass p) => true
        | _ => false
        end)
        (optionListToList (TruthTable_getPorts tt ttm)).


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv0 lv1))).
Admitted.
QuickChick conj15eqsynthconj1.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Keys for environment signature.
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibList TLC.LibLogic TLC.LibNat TLC.LibEpsilon TLC.LibReflect.
Require Export TLC.LibFset.
Require Export LibFresh.

(** * Abstract Definition of Key for an environment. *)

Module Type KeyType.

(** We leave the type of variables abstract. *)

Parameter key : Set.

(** This type is inhabited. *)

Parameter key_inhab : Inhab key.

(** This type is comparable. *)
Parameter key_comp : Comparable key.
Instance  key_comparable : Comparable key := key_comp.

(** We can build sets of variables. *)

Definition keys := fset key.

(** Finally, we have a means of generating fresh variables. *)

Parameter key_gen : keys -> key.
Parameter key_gen_spec : forall E, (key_gen E) \notin E.
Parameter key_fresh : forall (L : keys), { x : key | x \notin L }.

Axiom key_freshes : forall L n, { xs : list key | fresh key L n xs}.
End KeyType.


Set Implicit Arguments.
Require Import PeanoNat Lia List.
From Undecidability.HOU Require Import calculus.calculus concon.conservativity_constants
  unification.higher_order_unification unification.systemunification
  unification.nth_order_unification.
Import ListNotations ArsInstances.

#[export] Hint Rewrite @consts_Lam @consts_AppL @consts_AppR : simplify.

(* ** Inhabiting Types *)
Section InhabitingTypes.

  Variable (X: Const).
  Implicit Types (s t: exp X) (Gamma Delta: ctx) (sigma tau: fin -> exp X).

  Definition inhab (x: fin) (A: type) := Lambda (arity A) (@var X (arity A + x)).

  Lemma inhab_ren delta x A: ren delta (inhab x A) = inhab (delta x) A.
  Proof.
    unfold inhab. asimpl. f_equal. f_equal.
    rewrite it_up_ren_ge; simplify; eauto.
  Qed.

  Lemma inhab_typing Delta x A:
    nth Delta x = Some (target A) -> Delta ⊢(1) inhab x A : A.
  Proof.
    intros H2. unfold inhab.
    destruct (type_decompose A) as (L & beta & ->); simplify in H2; cbn in H2.
    specialize (arity_decomposed L beta) as H3.
    rewrite H3. eapply Lambda_ordertyping; trivial.
    econstructor; cbn; trivial.
    rewrite nth_error_app2; simplify; trivial; lia.
  Qed.

  Lemma inhab_typing_inv Gamma x A:
    Gamma ⊢(1) inhab x A : A -> nth Gamma x = Some (target A).
  Proof.
    intros H; unfold inhab in H.
    eapply Lambda_ordertyping_inv in H as (L & B & ? & ? & ?); subst.
    inv H. rewrite <-H1 in H3.
    rewrite nth_error_app2 in H3; simplify in *; trivial.
    destruct B; cbn in H1; try lia. now rewrite H3.
  Qed.

  Lemma inhab_app Gamma Delta x A:
      Gamma ⊢(1) inhab x A : A -> Delta ++ Gamma ⊢(1) inhab (length Delta + x) A : A.
  Proof.
    intros H % inhab_typing_inv. eapply inhab_typing.
    rewrite nth_error_app2; simplify; eauto.
  Qed.

  Lemma inhab_typing' Gamma x A:
    nth Gamma x = Some A -> target' Gamma ⊢(1) inhab x A : A.
  Proof.
    intros H; eapply inhab_typing.
    unfold target'; erewrite map_nth_error; now eauto.
  Qed.

  Lemma consts_inhab x A: consts (inhab x A) === nil.
  Proof.
    unfold inhab; rewrite consts_Lam; reflexivity.
  Qed.

  Lemma normal_inhab x A: normal (inhab x A).
  Proof.
    unfold inhab. generalize (arity A + x) as k.
    induction (arity A); cbn; eauto using normal_lam_intro.
  Qed.

End InhabitingTypes.

#[export] Hint Resolve inhab_app inhab_typing inhab_typing' ord_target' : core.

(* ** Conservativity *)
Section Conservativity.
  Variable (X: Const).

  Section DowncastLemmas.

    Implicit Types (s t: exp X) (Gamma: ctx)  (A: type).
    Variable (n: nat).
    Hypothesis (Leq: 1 <= n).

    Lemma downcast_variables Gamma s t Delta sigma:
      Delta ⊩ sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Sigma ⊩ tau : Gamma /\ tau • s ≡ tau • t /\ ord' Sigma <= 1.
    Proof.
      intros.
      pose (tau x := match nth Delta x with
                  | Some A => inhab X x A
                  | None => var x
                  end).
      exists (target' Delta). exists (sigma >> subst_exp tau). split; [|split].
      - intros ???; eapply preservation_under_substitution; [eauto|].
        unfold tau; intros ?? EQ; rewrite EQ.
        eauto using ordertyping_soundness.
      - erewrite <-compSubstSubst_exp; trivial. symmetry.
        erewrite <-compSubstSubst_exp; trivial. symmetry.
        now rewrite H0.
      - eauto.
    Qed.

    Lemma downcast_constants_ordered m Gamma s t Delta sigma:
      1 <= m -> Delta ⊩(m) sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Delta ++ Sigma ⊩(m) tau : Gamma /\ tau • s ≡ tau • t /\
      ord' Sigma <= 1 /\ (forall x c, c ∈ consts (tau x) -> c ∈ Consts [s; t]).
    Proof.
      intros L' T EQ.
      pose (C0 := Consts [s; t]).
      pose (C := Consts (map sigma (nats (length Gamma)))).
      pose (zeta c := match find c C0 with
                  | Some n => const c
                  | None =>
                    match find c C with
                    | Some x => inhab X (length Delta + x) (ctype X c)
                    | None => var 0
                    end
                  end).
      exists (target' (map (ctype X) C)). exists (sigma >> subst_consts zeta). intuition trivial.
      - intros ???. eapply ordertyping_preservation_consts.
        now eapply weakening_ordertyping_app, T.
        intros c H1. unfold zeta.
        destruct (find c C0); trivial.
        + econstructor; eapply typing_constants; eauto.
        + eapply Consts_consts
            with (S := (map sigma (nats (length Gamma)))) in H1 as H2.
          unfold C; eapply find_in in H2 as [y H2]. rewrite H2.
          eapply ordertyping_monotone, inhab_app, inhab_typing'; trivial.
          erewrite map_nth_error; trivial. now eapply find_Some.
          eapply in_map, lt_nats, nth_error_Some_lt; eauto.
      - rewrite !subst_const_comm_id. now rewrite EQ.
        all: eapply subst_consts_ident; intros x;
          rewrite Consts_consts with (S := [s; t]); intuition (auto with datatypes).
        all: now unfold zeta, C0; eapply find_in in H as [? ->].
      - eapply consts_in_subst_consts in H as [d []].
        unfold zeta in *. destruct find eqn: H1.
        + cbn in H0; intuition; subst.
          eapply find_Some, nth_error_In in H1; exact H1.
        + destruct (find d C) eqn: H2.
          all: rewrite ?consts_inhab in H0; cbn in H0; intuition trivial.
    Qed.

    Lemma downcast_constants Gamma s t Delta sigma:
      Delta ⊩ sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Delta ++ Sigma ⊩ tau : Gamma /\ tau • s ≡ tau • t /\
      ord' Sigma <= 1 /\ (forall x c, c ∈ consts (tau x) -> c ∈ Consts [s; t]).
    Proof using n Leq.
      intros [m H] % ordertypingSubst_complete EQ.
      eapply ordertypingSubst_monotone with (m := S m) in H; trivial.
      eapply downcast_constants_ordered in H as (Sigma & tau & ?); [|lia|eauto].
      exists Sigma; exists tau; intuition trivial. eapply ordertypingSubst_soundness; eauto.
    Qed.

    Lemma ordertyping_from_basetyping Sigma u B:
      (forall c, c ∈ consts u -> ord (ctype X c) <= S n) ->
      Sigma ⊢ u : B -> normal u -> ord B <= S n -> ord' Sigma <= n ->
      Sigma ⊢(n) u : B.
    Proof.
      induction 2; [eauto|eauto| |].
      - simplify; intros; econstructor; eapply IHtyping; intuition trivial.
        eauto using normal_lam_elim. cbn; simplify; intuition (auto with arith).
      - intros; enough (ord A <= n).
        + econstructor; [eapply IHtyping1 | eapply IHtyping2].
          1, 5: intros; eapply H; cbn; intuition (auto with datatypes).
          1, 4: eauto using normal_app_r, normal_app_l.
          2, 4: eauto.
          1, 2: simplify; eauto; intuition (auto with arith).
        + eapply head_atom in H0; [|easy]. cbn in H0.
          destruct (head_decompose s) as [T].
          rewrite H3 in H0_.
          eapply AppR_typing_inv in H0_ as (? & ? & ?).
          enough (ord (Arr (rev x) (A → B)) <= S n)
            as H6 by (simplify in H6; intuition (auto with arith)).
          destruct (head s); cbn in H0; eauto.
          all: inv H5.
          eapply ord'_elements in H2; eauto.
          eapply H; cbn; simplify; cbn; intuition trivial.
    Qed.

  Lemma ordertyping_weak_ordertyping Gamma Delta sigma (s t: exp X):
    (forall x A, nth Gamma x = Some A -> x ∈ vars s ++ vars t -> Delta ⊢(n) sigma x : A) ->  sigma • s ≡ sigma • t ->
    (exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ tau • s ≡ tau • t).
  Proof using Leq.
    intros T EQ.
    pose (tau x := if x el (vars s ++ vars t)
                then sigma x
                else match nth Gamma x with
                      | Some A => inhab X (length Delta + x) A
                      | None => var x
                      end).
    exists (Delta ++ target' Gamma). exists tau. split.
    - intros x B H'. unfold tau. rewrite H'; destruct dec_in.
      eapply weakening_ordertyping_app, T; trivial.
      eapply ordertyping_monotone; eauto.
    - rewrite !(subst_extensional) with (sigma := tau) (tau := sigma); trivial.
      all: intros; unfold tau; destruct dec_in; trivial; simplify in *.
      all: exfalso; eauto.
  Qed.

  Lemma unification_downcast sigma Gamma s t Delta A:
    Delta ⊩ sigma : Gamma -> Gamma ⊢(n) s : A -> Gamma ⊢(n) t : A -> sigma • s ≡ sigma • t ->
    exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ tau • s ≡ tau • t.
  Proof using Leq.
    intros T T1 T2 H.
    pose (P x := x ∈ vars s ++ vars t).
    edestruct (downcast_variables) as (Sigma' & tau' & T' & H' & O');
      [eassumption..|]; clear T H sigma Delta.
    edestruct (downcast_constants) as (Sigma'' & tau'' & T'' & H'' & O'' & C'');
      [eassumption..|]; clear T' H' tau'.
    edestruct (normalise_subst) as (tau''' & R & H & T); [eassumption|].
    eapply ordertyping_weak_ordertyping with (sigma := tau''').
    - intros. eapply ordertyping_from_basetyping.
      + intros ?; erewrite consts_subset_steps; trivial.
        intros H2 % C''; cbn in H2; simplify in H2.
        destruct H2; eapply typing_constants; [|eauto| |eauto]; eauto.
      + eauto.
      + domin H0; eauto.
      + simplify in H1; destruct H1; eapply vars_ordertyping_nth; eauto.
      + simplify; rewrite O', O''; cbn; eauto.
    - rewrite !subst_pointwise_equiv with (sigma := tau''') (tau := tau''); eauto.
  Qed.

  Lemma linearize_consts (S: list (exp X)):
    consts (linearize_terms S) === Consts S.
  Proof.
    unfold linearize_terms. cbn; simplify.
    split; unfold Consts; intros ? [x] % in_flat_map; eapply in_flat_map.
    all: intuition; try mapinj. eexists; split; [eassumption|].
    now rewrite consts_ren in H1.
    exists (ren shift x); intuition (auto with listdb). now rewrite consts_ren.
  Qed.

  Lemma unification_downcast_eqs sigma Delta (E: eqs X) Gamma L:
    (Gamma ⊢₊₊(n) E : L) ->
    (Delta ⊩ sigma : Gamma) -> (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) ->
    exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ (tau •₊ left_side E) ≡₊ (tau •₊ right_side E).
  Proof using Leq.
    intros T1 T2 H.
    pose (P x := x ∈ Vars' E). pose (s := linearize_terms (left_side E)).
    pose (t := linearize_terms (right_side E)).
    edestruct (downcast_variables) with (s := s) (t := t) as (Sigma' & tau' & T' & H' & O'); [eassumption|..].
    1: unfold s, t; now rewrite !linearize_terms_subst, linearize_terms_equiv.
    clear T2 H sigma Delta.
    edestruct (downcast_constants) with (s := s) (t := t)
      as (Sigma'' & tau'' & T'' & H'' & O'' & C''); eauto; clear T' H' tau'.
    edestruct (normalise_subst) as (tau''' & R & H & T); eauto.
    edestruct ordertyping_weak_ordertyping with (s := s) (t := t) (sigma := tau''').
    - intros. eapply ordertyping_from_basetyping.
      + intros ?; erewrite consts_subset_steps; trivial.
        intros H2 % C''. cbn [Consts flat_map] in H2.
        simplify in H2. unfold s, t in H2.
        rewrite !linearize_consts in H2.
        destruct H2; eapply typing_Consts.
        eapply left_ordertyping; [eassumption|..]. eauto.
        eapply right_ordertyping; eauto. eauto.
      + eauto.
      + domin H0; eauto.
      + simplify in H1. unfold s, t in H1; rewrite !linearize_vars in H1.
        destruct H1 as [H1|H1]; eapply Vars_listordertyping in H1.
        2, 4: eauto using left_ordertyping, right_ordertyping.
        all: destruct H1 as [? [H1 H2]]; rewrite H0 in H1;
          injection H1 as ->; eauto.
      + simplify; rewrite O', O''; cbn; eauto.
    - rewrite !subst_pointwise_equiv with (sigma := tau''') (tau := tau''); eauto.
    - destruct H0 as [tau]. exists x. exists tau. destruct H0; split; trivial.
      unfold s, t in H1; now rewrite <-linearize_terms_equiv, <-!linearize_terms_subst.
  Qed.

  End DowncastLemmas.

  Program Instance unification_monotone {n} (D: orduni n X): orduni (S n) X :=
    {  Gamma₀ := Gamma₀; s₀ := s₀ ; t₀ := t₀; A₀ := A₀; }.

  Lemma unification_monotone_forward n (I: orduni n X):
    OU n X I -> OU (S n) X (unification_monotone I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_monotone; eauto.
  Qed.

  Lemma unification_monotone_backward n (I: orduni n X):
    1 <= n -> OU (S n) X (unification_monotone I) -> OU n X I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU. eapply unification_downcast; eauto.
    intros ???; eapply ordertyping_soundness; eauto.
  Qed.

  Program Instance unification_conservative {n} (D: orduni n X): uni X :=
    {  Gammaᵤ := Gamma₀; sᵤ := s₀ ; tᵤ := t₀; Aᵤ := A₀; }.
  Next Obligation.
    eapply ordertyping_soundness; eauto.
  Qed.
  Next Obligation.
    eapply ordertyping_soundness; eauto.
  Qed.

  Lemma unification_conservative_forward n (I: orduni n X):
    OU n X I -> U X (unification_conservative I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_soundness; eauto.
  Qed.

  Lemma unification_conservative_backward n (I: orduni n X):
    1 <= n -> U X (unification_conservative I) -> OU n X I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU. eapply unification_downcast; eauto.
  Qed.

  Program Instance SU_monotone {n} (I: ordsysuni X n): ordsysuni X (S n) :=
    {  Gamma₀' := @Gamma₀' _ _ I; E₀' := @E₀' _ _ I ; L₀' := @L₀' _ _ I; }.
  Next Obligation.
    eapply eqs_ordertyping_step, @H₀'.
  Qed.

  Lemma SU_monotone_forward n (I: ordsysuni X n):
    SOU X n I -> SOU X (S n) (SU_monotone I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_monotone; eauto.
  Qed.

  Lemma SU_monotone_backward n (I: ordsysuni X n):
    1 <= n -> SOU X (S n) (SU_monotone I) -> SOU X n I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU.
    edestruct unification_downcast_eqs as (Sigma & tau & H1); eauto using equiv_pointwise_eqs, @H₀'.
    intros ???; eapply ordertyping_soundness; eauto.
    exists Sigma, tau; intuition idtac. eauto using equiv_eqs_pointwise.
  Qed.

  Program Instance SU_conservative {n} (I: ordsysuni X n): sysuni X :=
    {  Gammaᵤ' := @Gamma₀' _ _ I; Eᵤ' := @E₀' _ _ I ; Lᵤ' := @L₀' _ _ I; }.
  Next Obligation.
    eapply eqs_ordertyping_soundness, H₀'.
  Qed.

  Lemma SU_conservative_forward n (I: ordsysuni X n):
    SOU X n I -> SU X (SU_conservative I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition trivial.
    eapply ordertypingSubst_soundness; eauto.
  Qed.

  Lemma SU_conservative_backward n (I: ordsysuni X n):
    1 <= n -> SU X (SU_conservative I) -> SOU X n I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    edestruct unification_downcast_eqs as (Sigma & tau & H1); eauto using equiv_pointwise_eqs, @H₀'.
    exists Sigma, tau; intuition idtac. eauto using equiv_eqs_pointwise.
  Qed.

  Theorem unification_step n: 1 <= n -> OU n X ⪯ OU (S n) X.
  Proof.
    intros H; exists unification_monotone; split;
      eauto using unification_monotone_forward, unification_monotone_backward.
  Qed.

  Theorem unification_steps n m: 1 <= n <= m -> OU n X ⪯ OU m X.
  Proof.
    intros [H1 H2]; induction H2; eauto using unification_step, Nat.le_trans.
  Qed.

  Theorem unification_conserve n: 1 <= n -> OU n X ⪯ U X.
  Proof.
    intros H; exists unification_conservative; split;
      eauto using unification_conservative_forward, unification_conservative_backward.
  Qed.

  Theorem systemunification_step n: 1 <= n -> @SOU X n ⪯ @SOU X (S n).
  Proof.
    intros H; exists SU_monotone; split;
      eauto using SU_monotone_forward, SU_monotone_backward.
  Qed.

  Theorem systemunification_steps n m: 1 <= n <= m -> @SOU X n ⪯ @SOU X m.
  Proof.
    intros [H1 H2]; induction H2; eauto using systemunification_step, Nat.le_trans.
  Qed.

  Theorem systemunification_conserve n: 1 <= n -> @SOU X n ⪯ @SU X.
  Proof.
    intros H; exists SU_conservative; split;
      eauto using SU_conservative_forward, SU_conservative_backward.
  Qed.

End Conservativity.


(*

-> Section 3 of paper
-> Union types + Null types

*)

Require Import TLC.LibLN.
Require Import Program.Equality.
Require Import Coq.Lists.ListSet.
From Coq Require Export Lists.List.
Export ListNotations.
Require Import Coq.Strings.String.

(** syntax *)

Inductive typ : Set :=  (*r type *)
 | t_top : typ
 | t_int : typ
 | t_bot : typ
 | t_arrow : typ -> typ -> typ
 | t_union : typ -> typ -> typ
 | t_unit : typ.

Inductive exp : Set :=  (*r expression *)
 | e_var_b  : nat -> exp
 | e_var_f  : var -> exp
 | e_lit    : nat -> exp
 | e_abs    : exp -> exp
 | e_app    : exp -> exp -> exp
 | e_typeof : exp -> typ -> exp -> typ -> exp -> exp
 | e_null   : exp.

(** Binding are mapping to term variables.
 [x ~: T] is a typing assumption *)

 Inductive bind : Set :=
 | bind_typ : typ -> bind.

Notation "x ~: T" := (x ~ T)
 (at level 23, left associativity) : env_scope.

(** Environment is an associative list of bindings. *)

 Definition env := LibEnv.env typ.

Inductive okt : env -> Prop :=
| okt_empty :
     okt empty
| okt_typ : forall E x T,
     okt E-> x # E -> okt (E & x ~: T).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) => If (k = nat) then e_5 else (e_var_b nat)
  | (e_var_f x) => e_var_f x
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (open_exp_wrt_exp_rec (S k) e_5 e)
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_typeof e A e1 B e2) => e_typeof (open_exp_wrt_exp_rec k e_5 e) A (open_exp_wrt_exp_rec (S k) e_5 e1) B (open_exp_wrt_exp_rec (S k) e_5 e2)
  | (e_null) => e_null
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** Notation for opening up binders with type or term variables *)

Notation "t 'open_ee_var' x" := (open_exp_wrt_exp t (e_var_f x)) (at level 67).

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_lit : forall i5,
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (L:vars) (e:exp),
      ( forall x , x \notin  L  -> lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs e))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_typeof : forall (L:vars) (e:exp) (A:typ) (e1:exp) (B:typ) (e2:exp),
     (lc_exp e) ->
     ( forall x , x \notin  L  -> lc_exp  ( open_exp_wrt_exp e1 (e_var_f x) )  ) ->
     ( forall x , x \notin  L  -> lc_exp  ( open_exp_wrt_exp e2 (e_var_f x) )  ) ->
     (lc_exp (e_typeof e A e1 B e2))
 | lec_e_null :
     lc_exp e_null.

(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => \{}
  | (e_var_f x) => \{x}
  | (e_lit i5) => \{}
  | (e_abs e) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_typeof e A e1 B e2) => (fv_exp e) \u (fv_exp e1) \u (fv_exp e2)
  | (e_null) => \{}
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (If x = x5 then e_5 else (e_var_f x))
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (subst_exp e_5 x5 e)
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_typeof e A e1 B e2) => e_typeof (subst_exp e_5 x5 e) A (subst_exp e_5 x5 e1) B (subst_exp e_5 x5 e2)
  | (e_null) => e_null
end.

(* defns Subtyping *)
Reserved Notation "A <: B" (at level 80).
Inductive subtyping : typ -> typ -> Prop :=    (* defn subtyping *)
 | s_top : forall A,
   A <: t_top
 | s_int :
     t_int <: t_int
 | s_unit :
    t_unit <: t_unit
 | s_arrow : forall (A1 A2 B1 B2:typ),
     B1 <: A1 ->
     A2 <: B2 ->
     (t_arrow A1 A2) <: (t_arrow B1 B2)
 | s_ora : forall (A1 A2 A:typ),
     A1 <: A ->
     A2 <: A ->
     (t_union A1 A2) <: A
 | s_orb : forall (A A1 A2:typ),
     A <: A1 ->
     A <: (t_union A1 A2)
 | s_orc : forall (A A1 A2:typ),
     A <: A2 ->
     A <: (t_union A1 A2)
 | s_bot : forall A,
     t_bot <: A
where "A <: B" := (subtyping A B) : env_scope.

#[export]
Hint Constructors subtyping lc_exp ok okt : core.

Lemma sub_or : forall A B C, (t_union A B) <: C -> A <: C /\ B <: C.
Proof.
intros; inductions H; try solve [split*].
specialize (IHsubtyping A B).
forwards* : IHsubtyping.
specialize (IHsubtyping A B).
forwards* : IHsubtyping.
Defined.

(**********************************)
(*****  Subtyping Properties  *****)
(**********************************)

Lemma sub_refl : forall A, A <: A.
  induction A; eauto.
Defined.

#[export]
Hint Resolve sub_refl : core.

Lemma sub_transitivity : forall B A C, A <: B -> B <: C -> A <: C.
Proof.
induction B; intros;
generalize H0 H; clear H0; clear H; generalize A; clear A.
- intros; inductions H0; eauto.
- intros; inductions H; eauto.
- intros; inductions H; eauto.
- induction C; intros; try solve [inverts* H0].
  induction A; try solve[inverts* H].
  inverts* H0. inverts* H.
- intros. apply sub_or in H0. destruct H0.
  inductions H; eauto.
- intros; inductions H; eauto.
Defined.

Lemma bot_sub_all : forall A, t_bot <: A.
Proof.
  intros.
  dependent induction A; eauto.
Qed.

(****************************************)
(**********  Dijointness    *************)
(****************************************)

(* defns BottomLike *)
Inductive bottomlike : typ -> Prop :=    (* defn bottomlike *)
 | bl_bot :
     bottomlike t_bot
 | bl_or : forall (A B:typ),
     bottomlike A ->
     bottomlike B ->
     bottomlike (t_union A B).

(* Disjointness Specifications *)

Definition DisjSpec A B := forall C, C <: A /\ C <: B -> bottomlike C.
Notation "A *s B" := (DisjSpec A B) (at level 80).

(* Disjointness Algorithm *)

(* defns Disjointness *)
Reserved Notation "A *a B" (at level 80).
Inductive disjointness : typ -> typ -> Prop :=    (* defn disjointness *)
 | ad_btmr : forall (A:typ),
      A *a t_bot
 | ad_btml : forall (A:typ),
     t_bot *a A
 | ad_intl : forall (A B:typ),
     t_int *a (t_arrow A B)
 | ad_intr : forall (A B:typ),
     (t_arrow A B) *a t_int
 | ad_unit_intl :
      t_unit *a t_int
 | ad_unit_intr :
      t_int *a t_unit
 | ad_unit_arrowl: forall A B,
      t_unit *a (t_arrow A B)
 | ad_unit_arrowr: forall A B,
      (t_arrow A B) *a t_unit
 | ad_orl : forall (A B C:typ),
     A *a C ->
     B *a C ->
     (t_union A B) *a C
 | ad_orr : forall (C A B:typ),
     A *a C ->
     B *a C ->
     C *a (t_union A B)
where "A *a B" := (disjointness A B).

#[export]
Hint Constructors bottomlike disjointness : core.

(************************************************)
(**********  Disjointness Properties  ***********)
(************************************************)

(* Lemma 3 *)

Lemma BL_soundness : forall A, bottomlike A -> forall C, A <: C.
Proof.
intros. inductions H. auto. eauto.
Qed.

Lemma BL_completeness : forall A, (forall C, A <: C) -> bottomlike A.
Proof.
inductions A; intro; eauto.
 - specialize (H t_bot).
   inversion H.
 - specialize (H t_bot).
   inversion H.
 - specialize (H t_bot).
   inversion H.
 - constructor.
   apply IHA1. intros.
   specialize (H C).
   apply sub_or in H. destruct~ H.
   apply IHA2. intros.
   specialize (H C).
   apply sub_or in H. destruct~ H.
 - specialize (H t_bot).
   inversion H.
Qed.

Require Import Program.Equality.

(* Theorem 5 (a) *)

Lemma Disj_soundness : forall A B, A *a B -> A *s B.
intros. dependent induction H; unfold DisjSpec; intros; eauto.
- destruct H. dependent induction H0; eauto.
  apply sub_or in H. destruct H; eauto.
- destruct H. dependent induction H; eauto.
  apply sub_or in H1. destruct H1; eauto.
- destruct H. induction C; try (dependent destruction H); eauto.
  + inversion H0.
  + apply sub_or in H1. destruct H1; eauto.
- destruct H. induction C; try (dependent destruction H0); eauto.
  + inversion H.
  + apply sub_or in H. destruct H; eauto.
- destruct H. induction C; try (dependent destruction H0); eauto.
  + inversion H.
  + apply sub_or in H. destruct H; auto.
- destruct H. induction C; try (dependent destruction H); eauto.
  + inversion H0.
  + apply sub_or in H1. destruct H1; auto.
- destruct H. induction C; try (dependent destruction H0); eauto.
  + inversion H.
  + apply sub_or in H. destruct H; auto.
- destruct H. induction C; try (dependent destruction H); eauto.
  + inversion H1.
  + apply sub_or in H1. destruct H1; auto.
- destruct H1. dependent induction H1; eauto.
  apply sub_or in H2. destruct H2; eauto.
- destruct H1. dependent induction H2; eauto.
  apply sub_or in H1. destruct H1; eauto.
Qed.

Lemma BL_disj : forall A, bottomlike A -> forall B, A *a B.
  induction 1; intros; eauto.
Defined.

Lemma Disj_sym : forall A B, A *a B -> B *a A.
  induction 1; eauto.
Defined.

(* Theorem 5 (b) *)

Lemma Disj_completeness : forall A B, A *s B -> A *a B.
induction A; unfold DisjSpec; intros; eauto.
- specialize (H B). destruct H. split; eauto.
  constructor.
  apply ad_orr;
  apply BL_disj; eauto.
- induction B; eauto.
  + specialize (H t_int).
    destruct H; eauto.
    constructor;
    apply BL_disj; eauto.
  + specialize (H t_int).
    forwards*: H. inversion H0.
  + constructor; apply Disj_sym.
    apply IHB1; intros; destruct H0; apply H; eauto.
    apply IHB2; intros; destruct H0; apply H; eauto.
- induction B; eauto.
  + specialize (H (t_arrow A1 A2)).
    forwards*: H. inversion H0.
  + specialize (H (t_arrow (t_union A1 B1) t_bot)).
    forwards*: H. inversion H0.
  + constructor; apply Disj_sym.
    apply IHB1; intros; destruct H0; apply H; eauto.
    apply IHB2; intros; destruct H0; apply H; eauto.
- constructor.
  apply IHA1; unfold DisjSpec; intros; destruct H0; apply H; eauto.
  apply IHA2; unfold DisjSpec; intros; destruct H0; apply H; eauto.
- induction B; eauto.
  + specialize (H t_unit).
    forwards*: H. inverts H0.
  + constructor; apply Disj_sym.
    apply IHB1; intros; destruct H0; apply H; auto.
    apply IHB2; intros; destruct H0; apply H; auto.
  + specialize (H t_unit).
    forwards*: H. inverts H0.
Qed.

(*********************************)
(** Equivalance of Disjointness **)
(*********************************)

(*************************)
(***** Ordinary Types ****)
(*************************)

Inductive Ord : typ -> Prop :=
| o_int   : Ord t_int
| o_arrow : forall t1 t2, Ord (t_arrow t1 t2)
| o_unit  : Ord t_unit.

#[export]
Hint Constructors Ord : core.

(************************************************************)
(**********  Dijoint Specs with Ordinary types    ***********)
(************************************************************)

Definition DisjSpec1 A B := forall C, Ord C -> not (C <: A /\ C <:  B).
Notation "A *s1 B" := (DisjSpec1 A B) (at level 80).

Lemma disj_disj1 : forall A B, A *s B -> A *s1 B.
Proof.
  intros.
  unfold DisjSpec in H.
  unfold DisjSpec1. unfold not. intros.
  specialize (H C).
  forwards*: H.
  inductions H2.
  inversion H0.
  inversion H0.
Qed.

(****** Equivalence of two disjointness definitions ******)

(* Lemma 12 *)

Lemma disj1_disj : forall A B, A *s1 B -> A *s B.
Proof.
  intros.
  unfold DisjSpec1 in H.
  unfold DisjSpec. intros.
  inductions C; eauto.
  - assert (Ord t_int) by auto.
    unfold not in H.
    assert (t_int <: t_top) by auto.
    destruct H0.
    eapply sub_transitivity in H0; eauto.
    eapply sub_transitivity in H3; eauto.
    forwards*: H t_int H1.
  - specialize (H t_int).
    assert (Ord t_int) by auto.
    forwards*: H.
  - specialize (H (t_arrow C1 C2)).
    assert (Ord (t_arrow C1 C2)) by auto.
    forwards*: H.
  - destruct H0.
    apply sub_or in H0. destruct H0.
    apply sub_or in H1. destruct H1.
    constructor; auto.
  - specialize (H t_unit).
    forwards*: H.
Qed.