(**
This file formalizes the STS construction from the original Iris paper (POPL15).

DISCLAIMER: The definition of STSs is included in the Iris development for
historical purposes. If you plan to mechanize an Iris proof in Coq, it is
usually better to use a more direct encoding of the ghost state you need as a
resource algebra (camera). STSs are very painful to use in Coq, and they are
therefore barely used in practice.

The type [stsT] describes state-transition systems: a type of states, a type of
tokens, a step relation between states, and a token assignment function. Then
[sts_resR sts], for [sts: stsT], is the resource algebra of "STS resources",
which can be fragments ("we are in one of these states", where the set of states
needs to be closed under transitions performed without the locally owned
tokens), or authoritative ("we are exactly in this state").

The construction is performed via an intermediate internal type, [sts.car]. The
reason for this intermediate step is that composition of two STS resources is
defined only if their token sets are disjoint and the state sets are not
disjoint (i.e., they have at least one element in common). This condition is not
decidable, so we cannot use the usual approach (used e.g. in [gset_disj]) of
just composing those pairs to a dedicated "invalid" element. Instead, [sts_res]
consists of an [sts.car] element (fragment or authoritative), together with a
[Prop] defining whether this element is valid. That way we can "defer" the
validity check from composition to RA validity.
*)

From stdpp Require Export propset.
From iris.algebra Require Export cmra updates.
From iris.prelude Require Import options.
Local Arguments valid _ _ !_ /.
Local Arguments op _ _ !_ !_ /.
Local Arguments core _ _ !_ /.

(** * Definition of STSs *)
Module sts.
Structure stsT := Sts {
  state : Type;
  token : Type;
  prim_step : relation state;
  tok : state → propset token;
}.
Global Arguments Sts {_ _} _ _.
Global Arguments prim_step {_} _ _.
Global Arguments tok {_} _.
Notation states sts := (propset (state sts)).
Notation tokens sts := (propset (token sts)).

(** * Theory and definitions *)
Section sts.
Context {sts : stsT}.

(** ** Step relations *)
Inductive step : relation (state sts * tokens sts) :=
  | Step s1 s2 T1 T2 :
     prim_step s1 s2 → tok s1 ## T1 → tok s2 ## T2 →
     tok s1 ∪ T1 ≡ tok s2 ∪ T2 → step (s1,T1) (s2,T2).
Notation steps := (rtc step).
Inductive frame_step (T : tokens sts) (s1 s2 : state sts) : Prop :=
  (* Possible alternative definition: (tok s2) ## T) ∧ s \rightarrow s'.
     This is not equivalent, but it might be good enough? *)
  | Frame_step T1 T2 :
     T1 ## tok s1 ∪ T → step (s1,T1) (s2,T2) → frame_step T s1 s2.
Notation frame_steps T := (rtc (frame_step T)).

(** ** Closure under frame steps *)
Record closed (S : states sts) (T : tokens sts) : Prop := Closed {
  closed_disjoint s : s ∈ S → tok s ## T;
  closed_step s1 s2 : s1 ∈ S → frame_step T s1 s2 → s2 ∈ S
}.
Definition up (s : state sts) (T : tokens sts) : states sts :=
  {[ s' | frame_steps T s s' ]}.
Definition up_set (S : states sts) (T : tokens sts) : states sts :=
  S ≫= λ s, up s T.

(** Tactic setup *)
Local Hint Resolve Step : core.
Local Hint Extern 50 (equiv (A:=propset _) _ _) => set_solver : sts.
Local Hint Extern 50 (¬equiv (A:=propset _) _ _) => set_solver : sts.
Local Hint Extern 50 (_ ∈ _) => set_solver : sts.
Local Hint Extern 50 (_ ⊆ _) => set_solver : sts.
Local Hint Extern 50 (_ ## _) => set_solver : sts.

(** ** Setoids *)
Local Instance frame_step_mono : Proper (flip (⊆) ==> (=) ==> (=) ==> impl) frame_step.
Proof.
  intros ?? HT ?? <- ?? <-; destruct 1; econstructor;
    eauto with sts; set_solver.
Qed.
Global Instance frame_step_proper : Proper ((≡) ==> (=) ==> (=) ==> iff) frame_step.
Proof. move=> ?? /set_equiv_subseteq [??]; split; by apply frame_step_mono. Qed.
Local Instance closed_proper' : Proper ((≡) ==> (≡) ==> impl) closed.
Proof. destruct 3; constructor; intros; setoid_subst; eauto. Qed.
Global Instance closed_proper : Proper ((≡) ==> (≡) ==> iff) closed.
Proof. by split; apply closed_proper'. Qed.
Global Instance up_preserving : Proper ((=) ==> flip (⊆) ==> (⊆)) up.
Proof.
  intros s ? <- T T' HT ; apply elem_of_subseteq.
  induction 1 as [|s1 s2 s3 [T1 T2]]; [constructor|].
  eapply elem_of_PropSet, rtc_l; [eapply Frame_step with T1 T2|]; eauto with sts.
Qed.
Global Instance up_proper : Proper ((=) ==> (≡) ==> (≡)) up.
Proof.
  by move=> ??? ?? /set_equiv_subseteq [??]; split; apply up_preserving.
Qed.
Global Instance up_set_preserving : Proper ((⊆) ==> flip (⊆) ==> (⊆)) up_set.
Proof.
  intros S1 S2 HS T1 T2 HT. rewrite /up_set.
  f_equiv=> // s1 s2. by apply up_preserving.
Qed.
Global Instance up_set_proper : Proper ((≡) ==> (≡) ==> (≡)) up_set.
Proof.
  move=> S1 S2 /set_equiv_subseteq [??] T1 T2 /set_equiv_subseteq [??];
    split; by apply up_set_preserving.
Qed.

(** ** Properties of closure under frame steps *)
Lemma closed_steps S T s1 s2 :
  closed S T → s1 ∈ S → frame_steps T s1 s2 → s2 ∈ S.
Proof. induction 3; eauto using closed_step. Qed.
Lemma closed_op T1 T2 S1 S2 :
  closed S1 T1 → closed S2 T2 → closed (S1 ∩ S2) (T1 ∪ T2).
Proof.
  intros [? Hstep1] [? Hstep2]; split; [set_solver|].
  intros s3 s4; rewrite !elem_of_intersection; intros [??] [T3 T4 ?]; split.
  - apply Hstep1 with s3, Frame_step with T3 T4; auto with sts.
  - apply Hstep2 with s3, Frame_step with T3 T4; auto with sts.
Qed.
Lemma step_closed s1 s2 T1 T2 S Tf :
  step (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
  s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
Proof.
  inversion_clear 1 as [???? HR Hs1 Hs2]; intros [? Hstep]??; split_and?; auto.
  - eapply Hstep with s1, Frame_step with T1 T2; auto with sts.
  - set_solver -Hstep Hs1 Hs2.
Qed.
Lemma steps_closed s1 s2 T1 T2 S Tf :
  steps (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
  tok s1 ## T1 → s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
Proof.
  remember (s1,T1) as sT1 eqn:HsT1; remember (s2,T2) as sT2 eqn:HsT2.
  intros Hsteps; revert s1 T1 HsT1 s2 T2 HsT2.
  induction Hsteps as [?|? [s2 T2] ? Hstep Hsteps IH];
     intros s1 T1 HsT1 s2' T2' ?????; simplify_eq; first done.
  destruct (step_closed s1 s2 T1 T2 S Tf) as (?&?&?); eauto.
Qed.

(** ** Properties of the closure operators *)
Lemma elem_of_up s T : s ∈ up s T.
Proof. constructor. Qed.
Lemma subseteq_up_set S T : S ⊆ up_set S T.
Proof. intros s ?; apply elem_of_bind; eauto using elem_of_up. Qed.
Lemma elem_of_up_set S T s : s ∈ S → s ∈ up_set S T.
Proof. apply subseteq_up_set. Qed.
Lemma up_up_set s T : up s T ≡ up_set {[ s ]} T.
Proof. by rewrite /up_set set_bind_singleton. Qed.
Lemma closed_up_set S T : (∀ s, s ∈ S → tok s ## T) → closed (up_set S T) T.
Proof.
  intros HS; unfold up_set; split.
  - intros s; rewrite !elem_of_bind; intros (s'&Hstep&Hs').
    specialize (HS s' Hs'); clear Hs' S.
    induction Hstep as [s|s1 s2 s3 [T1 T2 ? Hstep] ? IH]; first done.
    inversion_clear Hstep; apply IH; clear IH; auto with sts.
  - intros s1 s2; rewrite /up; set_unfold; intros (s&?&?) ?; exists s.
    split; [eapply rtc_r|]; eauto.
Qed.
Lemma closed_up s T : tok s ## T → closed (up s T) T.
Proof.
  intros; rewrite -(set_bind_singleton (λ s, up s T) s).
  apply closed_up_set; set_solver.
Qed.
Lemma closed_up_set_empty S : closed (up_set S ∅) ∅.
Proof. eauto using closed_up_set with sts. Qed.
Lemma closed_up_empty s : closed (up s ∅) ∅.
Proof. eauto using closed_up with sts. Qed.
Lemma up_closed S T : closed S T → up_set S T ≡ S.
Proof.
  intros ?; apply set_equiv_subseteq; split; auto using subseteq_up_set.
  intros s; unfold up_set; rewrite elem_of_bind; intros (s'&Hstep&?).
  induction Hstep; eauto using closed_step.
Qed.
Lemma up_subseteq s T S : closed S T → s ∈ S → sts.up s T ⊆ S.
Proof. move=> ?? s' ?. eauto using closed_steps. Qed.
Lemma up_set_subseteq S1 T S2 : closed S2 T → S1 ⊆ S2 → sts.up_set S1 T ⊆ S2.
Proof. move=> ?? s [s' [? ?]]. eauto using closed_steps. Qed.
Lemma up_op s T1 T2 : up s (T1 ∪ T2) ⊆ up s T1 ∩ up s T2.
Proof. (* Notice that the other direction does not hold. *)
  intros x Hx. split; eapply elem_of_PropSet, rtc_subrel; try exact Hx.
  - intros; eapply frame_step_mono; last first; try done. set_solver+.
  - intros; eapply frame_step_mono; last first; try done. set_solver+.
Qed.
End sts.

Notation steps := (rtc step).
Notation frame_steps T := (rtc (frame_step T)).

(* The type of bounds we can give to the state of an STS. On paper, this is the
   type that we equip with an RA structure. In Coq we have to do some work to
   model composition only being defined under some non-computable conditions. *)
Inductive car (sts : stsT) :=
  | auth : state sts → propset (token sts) → car sts
  | frag : propset (state sts) → propset (token sts) → car sts.
Global Arguments auth {_} _ _.
Global Arguments frag {_} _ _.
End sts.

Notation stsT := sts.stsT.
Notation Sts := sts.Sts.

(** * STSs form an RA *)
Section sts_res.
Context {sts : stsT}.
Import sts.
Implicit Types S : states sts.
Implicit Types T : tokens sts.

Inductive sts_car_equiv : Equiv (car sts) :=
  | auth_equiv s T1 T2 : T1 ≡ T2 → auth s T1 ≡ auth s T2
  | frag_equiv S1 S2 T1 T2 : T1 ≡ T2 → S1 ≡ S2 → frag S1 T1 ≡ frag S2 T2.
Local Existing Instance sts_car_equiv.
Local Instance sts_car_valid_instance : Valid (car sts) := λ x,
  match x with
  | auth s T => tok s ## T
  | frag S' T => closed S' T ∧ ∃ s, s ∈ S'
  end.
Local Instance sts_car_core_instance : PCore (car sts) := λ x,
  Some match x with
  | frag S' _ => frag (up_set S' ∅ ) ∅
  | auth s _  => frag (up s ∅) ∅
  end.
Inductive sts_car_disjoint_instance : Disjoint (car sts) :=
  | frag_frag_disjoint S1 S2 T1 T2 :
     (∃ s, s ∈ S1 ∩ S2) → T1 ## T2 → frag S1 T1 ## frag S2 T2
  | auth_frag_disjoint s S T1 T2 : s ∈ S → T1 ## T2 → auth s T1 ## frag S T2
  | frag_auth_disjoint s S T1 T2 : s ∈ S → T1 ## T2 → frag S T1 ## auth s T2.
Local Existing Instance sts_car_disjoint_instance.
Local Instance sts_op_instance : Op (car sts) := λ x1 x2,
  match x1, x2 with
  | frag S1 T1, frag S2 T2 => frag (S1 ∩ S2) (T1 ∪ T2)
  | auth s T1, frag _ T2 => auth s (T1 ∪ T2)
  | frag _ T1, auth s T2 => auth s (T1 ∪ T2)
  | auth s T1, auth _ T2 => auth s (T1 ∪ T2) (* never happens *)
  end.

Local Hint Extern 50 (equiv (A:=propset _) _ _) => set_solver : sts.
Local Hint Extern 50 (∃ s : state sts, _) => set_solver : sts.
Local Hint Extern 50 (_ ∈ _) => set_solver : sts.
Local Hint Extern 50 (_ ⊆ _) => set_solver : sts.
Local Hint Extern 50 (_ ## _) => set_solver : sts.

Global Instance auth_proper s : Proper ((≡) ==> (≡)) (@auth sts s).
Proof. by constructor. Qed.
Global Instance frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@frag sts).
Proof. by constructor. Qed.

Local Instance sts_car_equivalence: Equivalence ((≡) : relation (car sts)).
Proof.
  split.
  - by intros []; constructor.
  - by destruct 1; constructor.
  - destruct 1; inversion_clear 1; constructor; etrans; eauto.
Qed.
Local Instance sts_car_op_proper : Proper ((≡@{car sts}) ==> (≡) ==> (≡)) (⋅).
Proof. by do 2 destruct 1; constructor; setoid_subst. Qed.
Local Instance sts_car_core_proper : Proper ((≡@{car sts}) ==> (≡)) core.
Proof. by destruct 1; constructor; setoid_subst. Qed.
Local Instance sts_car_valid_proper : Proper ((≡@{car sts}) ==> impl) valid.
Proof. by destruct 1; simpl; intros ?; setoid_subst. Qed.
Local Instance sts_car_valid_proper' : Proper ((≡@{car sts}) ==> iff) valid.
Proof. by split; apply: sts_car_valid_proper. Qed.
Local Instance sts_car_disjoint_proper (x : car sts) :
  Proper ((≡) ==> impl) (disjoint x).
Proof.
  by intros ? [|]; destruct 1; inversion_clear 1; econstructor; setoid_subst.
Qed.

Local Instance sts_car_disjoint_symmetric : Symmetric (@disjoint (car sts) _).
Proof. destruct 1; constructor; auto with sts. Qed.
Local Instance sts_car_disjoint_proper' :
  Proper ((≡@{car sts}) ==> (≡) ==> iff) disjoint.
Proof.
  intros x1 x2 Hx y1 y2 Hy; split.
  - by rewrite Hy (symmetry_iff (##) x1) (symmetry_iff (##) x2) Hx.
  - by rewrite -Hy (symmetry_iff (##) x2) (symmetry_iff (##) x1) -Hx.
Qed.

Local Lemma sts_car_core_valid (x : car sts) :
  ✓ x → ✓ core x.
Proof.
  destruct x; naive_solver eauto using closed_up, closed_up_set,
      elem_of_up, elem_of_up_set with sts.
Qed.
Local Lemma sts_car_op_valid (x y : car sts) :
  ✓ x → ✓ y → x ## y → ✓ (x ⋅ y).
Proof.
  destruct 3; simpl in *; destruct_and?; eauto using closed_op;
      select (closed _ _) (fun H => destruct H); set_solver.
Qed.
Local Lemma sts_car_op_assoc (x y z : car sts) :
  ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ⋅ (y ⋅ z) ≡ (x ⋅ y) ⋅ z.
Proof.
  destruct x, y, z; intros _ _ _ _ _; constructor; rewrite ?assoc; auto with sts.
Qed.
Local Lemma sts_car_op_comm (x y : car sts) :
  ✓ x → ✓ y → x ## y → x ⋅ y ≡ y ⋅ x.
Proof. destruct 3; constructor; auto with sts. Qed.

Local Lemma sts_car_disjoint_ll (x y z : car sts) :
  ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## z.
Proof.
  destruct 4; inversion_clear 1; constructor; auto with sts.
Qed.
Local Lemma sts_car_disjoint_rl (x y z : car sts) :
  ✓ x → ✓ y → ✓ z → y ## z → x ## y ⋅ z → x ## y.
Proof. intros ???. rewrite !(symmetry_iff _ x). by apply sts_car_disjoint_ll. Qed.
Local Lemma sts_car_disjoint_lr (x y z : car sts) :
  ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → y ## z.
Proof. intros ????. rewrite sts_car_op_comm //. by apply sts_car_disjoint_ll. Qed.
Local Lemma sts_car_disjoint_move_l (x y z : car sts) :
    ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## y ⋅ z.
Proof. destruct 4; inversion_clear 1; constructor; auto with sts. Qed.
Local Lemma sts_car_disjoint_move_r (a b c : car sts) :
  ✓ a → ✓ b → ✓ c → b ## c → a ## b ⋅ c → a ⋅ b ## c.
Proof.
  intros; symmetry; rewrite sts_car_op_comm; eauto using sts_car_disjoint_rl.
  apply sts_car_disjoint_move_l; auto; by rewrite sts_car_op_comm.
Qed.
Local Hint Immediate sts_car_disjoint_move_l sts_car_disjoint_move_r : core.

Local Lemma sts_car_core_disjoint_l (x : car sts) : ✓ x → core x ## x.
Proof. destruct x; constructor; eauto with sts. Qed.
Local Lemma sts_car_core_l (x : car sts) : ✓ x → core x ⋅ x ≡ x.
Proof. destruct x; constructor; eauto with sts. Qed.
Local Lemma sts_car_core_idemp (x : car sts) : ✓ x → core (core x) ≡ core x.
Proof.
  destruct x as [s T|S T]; constructor; auto with sts.
  + rewrite (up_closed (up _ _)); auto using closed_up with sts.
  + rewrite (up_closed (up_set _ _)); eauto using closed_up_set with sts.
Qed.
Local Lemma sts_car_core_mono (x y : car sts) :
  ∃ z, ✓ x → ✓ y → x ## y → core (x ⋅ y) ≡ core x ⋅ z ∧ ✓ z ∧ core x ## z.
Proof.
  exists (core (x ⋅ y))=> ?? Hxy; split_and?.
  + destruct Hxy; constructor; unfold up_set; set_solver.
  + destruct Hxy; simpl;
      eauto using closed_up_set_empty, closed_up_empty with sts.
  + destruct Hxy; econstructor;
      repeat match goal with
      | |- context [ up_set ?S ?T ] =>
         unless (S ⊆ up_set S T) by done; pose proof (subseteq_up_set S T)
      | |- context [ up ?s ?T ] =>
         unless (s ∈ up s T) by done; pose proof (elem_of_up s T)
      end; auto with sts.
Qed.

(** The resource type for [sts]. *)
Record sts_res := StsRes {
  (** The underlying STS carrier element, storing the actual data. *)
  sts_car : car sts;
  (** Defines whether this element is valid. *)
  sts_valid : Prop;
  (** Valid elements must have a valid carrier element. *)
  sts_valid_prf : sts_valid → ✓ sts_car
}.
Add Printing Constructor sts_res.
Global Arguments StsRes _ _ {_}.

(** Setoid and OFE for [sts_res]. *)
Local Instance sts_equiv : Equiv sts_res := λ x y,
  (sts_valid x ↔ sts_valid y) ∧ (sts_valid x → sts_car x ≡ sts_car y).
Local Instance sts_equivalence : Equivalence (@equiv sts_res _).
Proof.
  split; unfold equiv, sts_equiv.
  - by intros [x px ?]; simpl.
  - intros [x px ?] [y py ?]; naive_solver.
  - intros [x px ?] [y py ?] [z pz ?] [? Hxy] [? Hyz]; simpl in *.
    split; [|intros; trans y]; tauto.
Qed.
Canonical Structure sts_resO : ofe := discreteO sts_res.

(** RA for [sts_res]. *)
Local Instance sts_res_valid_instance : Valid sts_res := sts_valid.
Local Program Instance sts_res_pcore_instance : PCore sts_res := λ x,
  Some (StsRes (core (sts_car x)) (✓ x)).
Next Obligation.
  intros []; naive_solver eauto using sts_car_core_valid.
Qed.
Local Program Instance sts_res_op_instance : Op sts_res := λ x y,
  StsRes (sts_car x ⋅ sts_car y)
           (✓ x ∧ ✓ y ∧ sts_car x ## sts_car y).
Next Obligation.
  intros [] []; naive_solver eauto using sts_car_op_valid.
Qed.

Definition sts_res_ra_mixin : RAMixin sts_res.
Proof.
  apply ra_total_mixin; first eauto.
  - intros ??? [? Heq]; split; simpl; [|intros (?&?&?); by rewrite Heq].
    split; intros (?&?&?); split_and!;
      first [rewrite ?Heq; tauto|rewrite -?Heq; tauto|tauto].
  - by intros ?? [? Heq]; split; [done|]; simpl; intros ?; rewrite Heq.
  - intros ?? [??]; naive_solver.
  - intros [x px ?] [y py ?] [z pz ?]; split; simpl;
      [intuition eauto 2 using sts_car_disjoint_lr, sts_car_disjoint_rl
      |intuition eauto using sts_car_op_assoc, sts_car_disjoint_rl].
  - intros [x px ?] [y py ?]; split; naive_solver eauto using sts_car_op_comm.
  - intros [x px ?]; split;
      naive_solver eauto using sts_car_core_l, sts_car_core_disjoint_l.
  - intros [x px ?]; split; naive_solver eauto using sts_car_core_idemp.
  - intros [x px ?] [y py ?] [[z pz ?] [? Hy]]; simpl in *.
    destruct (sts_car_core_mono x z) as (z'&Hz').
    unshelve eexists (StsRes z' (px ∧ py ∧ pz)).
    { intros (?&?&?); apply Hz'; tauto. }
    split; simpl; first tauto.
    intros. rewrite Hy //. tauto.
  - by intros [x px ?] [y py ?] (?&?&?).
Qed.
Canonical Structure sts_resR : cmra :=
  discreteR sts_res sts_res_ra_mixin.

Global Instance sts_res_disrete_cmra : CmraDiscrete sts_resR.
Proof. apply discrete_cmra_discrete. Qed.
Global Instance sts_res_cmra_total : CmraTotal sts_resR.
Proof. rewrite /CmraTotal; eauto. Qed.

Local Definition to_sts_res (x : car sts) : sts_res :=
  @StsRes x (valid x) id.
Global Instance to_sts_res_proper : Proper ((≡) ==> (≡)) to_sts_res.
Proof. by intros x1 x2 Hx; split; rewrite /= Hx. Qed.

Lemma to_sts_res_op a b :
  (✓ (a ⋅ b) → ✓ a ∧ ✓ b ∧ a ## b) →
  to_sts_res (a ⋅ b) ≡ to_sts_res a ⋅ to_sts_res b.
Proof. split; naive_solver eauto using sts_car_op_valid. Qed.

End sts_res.

Global Arguments sts_resR : clear implicits.

(** Finally, the general theory of STS that should be used by users *)

Section sts_definitions.
  Context {sts : stsT}.
  Definition sts_auth (s : sts.state sts) (T : sts.tokens sts) : sts_resR sts :=
    to_sts_res (sts.auth s T).
  Definition sts_frag (S : sts.states sts) (T : sts.tokens sts) : sts_resR sts :=
    to_sts_res (sts.frag S T).
  Definition sts_frag_up (s : sts.state sts) (T : sts.tokens sts) : sts_resR sts :=
    sts_frag (sts.up s T) T.
End sts_definitions.
Global Instance: Params (@sts_auth) 2 := {}.
Global Instance: Params (@sts_frag) 1 := {}.
Global Instance: Params (@sts_frag_up) 2 := {}.

Section stsRA.
Import sts.
Context {sts : stsT}.
Implicit Types s : state sts.
Implicit Types S : states sts.
Implicit Types T : tokens sts.
Local Arguments cmra_valid _ !_/.

(** Setoids *)
Global Instance sts_auth_proper s : Proper ((≡) ==> (≡)) (sts_auth s).
Proof. solve_proper. Qed.
Global Instance sts_frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@sts_frag sts).
Proof. solve_proper. Qed.
Global Instance sts_frag_up_proper s : Proper ((≡) ==> (≡)) (sts_frag_up s).
Proof. solve_proper. Qed.

(** Validity *)
Lemma sts_auth_valid s T : ✓ sts_auth s T ↔ tok s ## T.
Proof. done. Qed.
Lemma sts_frag_valid S T : ✓ sts_frag S T ↔ closed S T ∧ ∃ s, s ∈ S.
Proof. done. Qed.
Lemma sts_frag_up_valid s T : ✓ sts_frag_up s T ↔ tok s ## T.
Proof.
  split.
  - move=>/sts_frag_valid [H _]. apply H, elem_of_up.
  - intros. apply sts_frag_valid; split.
    + by apply closed_up.
    + set_solver+.
Qed.

Lemma sts_auth_frag_valid_inv s S T1 T2 :
  ✓ (sts_auth s T1 ⋅ sts_frag S T2) → s ∈ S.
Proof. by intros (?&?&Hdisj); inversion Hdisj. Qed.

(** Op *)
Lemma sts_auth_frag_op s S T :
  s ∈ S → closed S T → sts_auth s ∅ ⋅ sts_frag S T ≡ sts_auth s T.
Proof.
  intros; split; [split|constructor; set_solver]; simpl.
  - intros (?&?&?); by apply closed_disjoint with S.
  - intros; split_and?; last constructor; set_solver.
Qed.
Lemma sts_auth_frag_up_op s T :
  sts_auth s ∅ ⋅ sts_frag_up s T ≡ sts_auth s T.
Proof.
  intros; split; [split|constructor; set_solver]; simpl.
  - intros (?&[??]&?). by apply closed_disjoint with (up s T), elem_of_up.
  - intros; split_and?.
    + set_solver+.
    + by apply closed_up.
    + exists s. set_solver.
    + constructor; last set_solver. apply elem_of_up.
Qed.

Lemma sts_frag_op S1 S2 T1 T2 :
  T1 ## T2 → sts.closed S1 T1 → sts.closed S2 T2 →
  sts_frag (S1 ∩ S2) (T1 ∪ T2) ≡ sts_frag S1 T1 ⋅ sts_frag S2 T2.
Proof.
  intros HT HS1 HS2. rewrite /sts_frag -to_sts_res_op //.
  move=>/=[?[? ?]]. split_and!; [set_solver..|constructor; set_solver].
Qed.

(* Notice that the following does *not* hold -- the composition of the
   two closures is weaker than the closure with the itnersected token
   set.  Also see up_op.
Lemma sts_frag_up_op s T1 T2 :
  T1 ## T2 → sts_frag_up s (T1 ∪ T2) ≡ sts_frag_up s T1 ⋅ sts_frag_up s T2.
*)

(** Frame preserving updates *)
Lemma sts_update_auth s1 s2 T1 T2 :
  steps (s1,T1) (s2,T2) → sts_auth s1 T1 ~~> sts_auth s2 T2.
Proof.
  intros ?. apply cmra_discrete_update.
  intros [x x_val Hx_val]; simpl. intros (Htok & Hval & Hdisj).
  specialize (Hx_val Hval).
  inversion Hdisj as [|? S ? Tf|]; simplify_eq/=; destruct_and?.
  destruct (steps_closed s1 s2 T1 T2 S Tf) as (?&?&?); auto; [].
  repeat (done || constructor).
Qed.

Lemma sts_update_frag S1 S2 T1 T2 :
  (closed S1 T1 → closed S2 T2 ∧ S1 ⊆ S2 ∧ T2 ⊆ T1) → sts_frag S1 T1 ~~> sts_frag S2 T2.
Proof.
  rewrite /sts_frag=> HC HS HT. apply cmra_discrete_update.
  intros [x x_val Hx_val]; simpl. intros (Htok & Hval & Hdisj).
  specialize (Hx_val Hval).
  inversion Hdisj as [|? S ? Tf|]; simplify_eq/=;
    (destruct HC as (? & ? & ?); first by destruct_and?).
  - split_and!; first done.
    + set_solver.
    + done.
    + constructor; set_solver.
  - split_and!; first done.
    + set_solver.
    + done.
    + constructor; set_solver.
Qed.

Lemma sts_update_frag_up s1 S2 T1 T2 :
  (tok s1 ## T1 → closed S2 T2) → s1 ∈ S2 → T2 ⊆ T1 → sts_frag_up s1 T1 ~~> sts_frag S2 T2.
Proof.
  intros HC ? HT; apply sts_update_frag. intros HC1; split; last split; eauto using closed_steps.
  - eapply HC, HC1, elem_of_up.
  - rewrite <-HT. eapply up_subseteq; last done. apply HC, HC1, elem_of_up.
Qed.

Lemma sts_up_set_intersection S1 Sf Tf :
  closed Sf Tf → S1 ∩ Sf ≡ S1 ∩ up_set (S1 ∩ Sf) Tf.
Proof.
  intros Hclf. apply (anti_symm (⊆)).
  - move=>s [HS1 HSf]. split.
    + by apply HS1.
    + by apply subseteq_up_set.
  - move=>s [HS1 [s' [/elem_of_PropSet Hsup Hs']]]. split; first done.
    eapply closed_steps, Hsup; first done. set_solver +Hs'.
Qed.

Global Instance sts_frag_core_id S : CoreId (sts_frag S ∅).
Proof.
  constructor; split=> //= [[??]].
  (* FIXME: rewriting with [sts.up_closed] for some reason fails here. *)
  f_equiv. by rewrite sts.up_closed.
Qed.

(** Inclusion *)
(* This is surprisingly different from to_validity_included. I am not sure
   whether this is because to_validity_included is non-canonical, or this
   one here is non-canonical - but I suspect both. *)
(* TODO: These have to be proven again. *)
(*
Lemma sts_frag_included S1 S2 T1 T2 :
  closed S2 T2 → S2 ≢ ∅ →
  (sts_frag S1 T1 ≼ sts_frag S2 T2) ↔
  (closed S1 T1 ∧ S1 ≢ ∅ ∧ ∃ Tf, T2 ≡ T1 ∪ Tf ∧ T1 ## Tf ∧
                                 S2 ≡ S1 ∩ up_set S2 Tf).
Proof.
  intros ??; split.
  - intros [[???] ?].
  destruct (to_validity_included (sts_dra.car sts) (sts_dra.frag S1 T1) (sts_dra.frag S2 T2)) as [Hfincl Htoincl].
  intros Hcl2 HS2ne. split.
  - intros Hincl. destruct Hfincl as ((Hcl1 & ?) & (z & EQ & Hval & Hdisj)).
    { split; last done. split; done. }
    clear Htoincl. split_and!; try done; [].
    destruct z as [sf Tf|Sf Tf].
    { exfalso. inversion_clear EQ. }
    exists Tf. inversion_clear EQ as [|? ? ? ? HT2 HS2].
    inversion_clear Hdisj as [? ? ? ? _ HTdisj | |]. split_and!; [done..|].
    rewrite HS2. apply up_set_intersection. apply Hval.
  - intros (Hcl & Hne & (Tf & HT & HTdisj & HS)). destruct Htoincl as ((Hcl' & ?) & (z & EQ)); last first.
    { exists z. exact EQ. } clear Hfincl.
    split; first (split; done). exists (sts_dra.frag (up_set S2 Tf) Tf). split_and!.
    + constructor; done.
    + simpl. split.
      * apply closed_up_set. move=>s Hs2. move:(closed_disjoint _ _ Hcl2 _ Hs2).
        set_solver +HT.
      * by apply up_set_non_empty.
    + constructor; last done. by rewrite -HS.
Qed.

Lemma sts_frag_included' S1 S2 T :
  closed S2 T → closed S1 T → S2 ≢ ∅ → S1 ≢ ∅ → S2 ≡ S1 ∩ up_set S2 ∅ →
  sts_frag S1 T ≼ sts_frag S2 T.
Proof.
  intros. apply sts_frag_included; split_and?; auto.
  exists ∅; split_and?; done || set_solver+.
Qed. *)
End stsRA.

(** STSs without tokens: Some stuff is simpler *)
Module sts_notok.
Structure stsT := Sts {
  state : Type;
  prim_step : relation state;
}.
Global Arguments Sts {_} _.
Global Arguments prim_step {_} _ _.
Notation states sts := (propset (state sts)).

Definition stsT_token := Empty_set.
Definition stsT_tok {sts : stsT} (_ : state sts) : propset stsT_token := ∅.

Canonical Structure sts_notok (sts : stsT) : sts.stsT :=
  sts.Sts (@prim_step sts) stsT_tok.
Coercion sts_notok.sts_notok : sts_notok.stsT >-> sts.stsT.

Section sts.
  Context {sts : stsT}.
  Implicit Types s : state sts.
  Implicit Types S : states sts.

  Notation prim_steps := (rtc prim_step).

  Lemma sts_step s1 s2 : prim_step s1 s2 → sts.step (s1, ∅) (s2, ∅).
  Proof. intros. split; set_solver. Qed.

  Lemma sts_steps s1 s2 : prim_steps s1 s2 → sts.steps (s1, ∅) (s2, ∅).
  Proof. induction 1; eauto using sts_step, rtc_refl, rtc_l. Qed.

  Lemma frame_prim_step T s1 s2 : sts.frame_step T s1 s2 → prim_step s1 s2.
  Proof. inversion 1 as [??? Hstep]. by inversion_clear Hstep. Qed.

  Lemma prim_frame_step T s1 s2 : prim_step s1 s2 → sts.frame_step T s1 s2.
  Proof.
    intros Hstep. apply sts.Frame_step with ∅ ∅; first set_solver.
    by apply sts_step.
  Qed.

  Lemma mk_closed S :
    (∀ s1 s2, s1 ∈ S → prim_step s1 s2 → s2 ∈ S) → sts.closed S ∅.
  Proof. intros ?. constructor; [by set_solver|eauto using frame_prim_step]. Qed.
End sts.
End sts_notok.

Notation sts_notokT := sts_notok.stsT.
Notation Sts_NoTok := sts_notok.Sts.

Section sts_notokRA.
  Context {sts : sts_notokT}.
  Import sts_notok.
  Implicit Types s : state sts.
  Implicit Types S : states sts.

  Lemma sts_notok_update_auth s1 s2 :
    rtc prim_step s1 s2 → sts_auth s1 ∅ ~~> sts_auth s2 ∅.
  Proof. intros. by apply sts_update_auth, sts_steps. Qed.
End sts_notokRA.


(*

-> Section 5.1 in paper
-> Union Types + Null + Intersection Types
-> Nominal types
-> Parametric Polymorphism

*)

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_and : typ -> typ -> typ
 | t_unit : typ
 | t_bvar  : nat -> typ
 | t_fvar  : var -> typ
 | t_all   : typ -> typ -> typ
 | t_prim  : nat -> typ.

Inductive exp : Set :=  (*r expression *)
 | e_bvar  : nat -> exp
 | e_fvar  : 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
 | e_tabs   : typ -> exp -> exp
 | e_tapp   : exp -> typ -> exp
 | e_new    : nat -> exp.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | t_top         => t_top
  | t_int         => t_int
  | t_bot         => t_bot
  | t_arrow T1 T2 => t_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | t_union T1 T2 => t_union (open_tt_rec K U T1) (open_tt_rec K U T2)
  | t_and T1 T2   => t_and (open_tt_rec K U T1) (open_tt_rec K U T2)
  | t_unit        => t_unit
  | t_bvar J      => If K = J then U else (t_bvar J)
  | t_fvar X      => t_fvar X
  | t_all T1 T2   => t_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  | t_prim i      => t_prim i
  end.

Definition open_tt T U := open_tt_rec 0 U T.

(** Opening up a type binder occuring in a term *)

Fixpoint open_te_rec (K : nat) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i    => e_bvar i
  | e_fvar x    => e_fvar x
  | e_lit i     => e_lit i
  | e_abs e1    => e_abs (open_te_rec K U e1)
  | e_app e1 e2 => e_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | e_typeof e1 T1 e2 T2 e3 => e_typeof (open_te_rec K U e1) (open_tt_rec K U T1) (open_te_rec K U e2) (open_tt_rec K U T2) (open_te_rec K U e3)
  | e_null      => e_null
  | e_tabs V e1 => e_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | e_tapp e1 V => e_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  | e_new i     => e_new i
  end.

Definition open_te t U := open_te_rec 0 U t.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_bvar nat) => If (k = nat) then e_5 else (e_bvar nat)
  | (e_fvar x) => e_fvar x
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (open_ee_rec (S k) e_5 e)
  | (e_app e1 e2) => e_app (open_ee_rec k e_5 e1) (open_ee_rec k e_5 e2)
  | (e_typeof e A e1 B e2) => e_typeof (open_ee_rec k e_5 e) A (open_ee_rec (S k) e_5 e1) B (open_ee_rec (S k) e_5 e2)
  | e_null    => e_null
  | e_tabs A e => e_tabs A (open_ee_rec k e_5 e)
  | e_tapp e A => e_tapp (open_ee_rec k e_5 e) A
  | e_new i    => e_new i
end.

Definition open_ee t u := open_ee_rec 0 u t.

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

Notation "T 'open_tt_var' X" := (open_tt T (t_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (t_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (e_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type t_top
  | type_int :
      type t_int
  | type_bot :
      type t_bot
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (t_arrow T1 T2)
  | type_union : forall T1 T2,
      type T1 ->
      type T2 ->
      type (t_union T1 T2)
  | type_and : forall T1 T2,
      type T1 ->
      type T2 ->
      type (t_and T1 T2)
  | type_var : forall X,
      type (t_fvar X)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (t_all T1 T2)
  | type_unit : type t_unit
  | type_prim : forall i,
      type (t_prim i).

(** Terms as locally closed pre-terms *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     lc_exp (e_fvar 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_ee e (e_fvar 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 ->
     type A ->
     type B ->
     ( forall x , x \notin  L -> lc_exp ( open_ee e1 (e_fvar x)) ) ->
     ( forall x , x \notin  L -> lc_exp ( open_ee e2 (e_fvar x)) ) ->
     lc_exp (e_typeof e A e1 B e2)
 | lec_e_null :
     lc_exp e_null
 | lc_e_tabs : forall L V e1,
      type V ->
      (forall X, X \notin L -> lc_exp (e1 open_te_var X)) ->
      lc_exp (e_tabs V e1)
 | lc_e_tapp : forall e1 V,
      lc_exp e1 ->
      type V ->
      lc_exp (e_tapp e1 V)
 | lc_e_new : forall i,
       lc_exp (e_new i).

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

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

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

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

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

Definition env := LibEnv.env bind.

(***************************
 *** Equality for types ****
 ***************************)

Lemma eq_dec_nat : forall (n1 n2 : nat), {n1 = n2} + {n1 <> n2}.
Proof.
  decide equality.
Defined.

Lemma eq_dec_var : forall (x y : var), {x = y} + {x <> y}.
Proof.
  intros.
  case_if_eq x y; auto.
Defined.

Lemma eq_dec : forall (x y:typ), {x = y} + {x <> y}.
Proof.
 decide equality; auto.
 apply eq_dec_nat.
 apply eq_dec_var.
 apply eq_dec_nat.
Defined.

Notation "l1 `union` l2" := (set_union eq_dec l1 l2) (at level 80).
Notation "l1 `inter` l2" := (set_inter eq_dec l1 l2) (at level 80).
Notation "l1 `dif` l2" := (set_diff eq_dec l1 l2) (at level 80).

(*******************************)
(*** Environment for P types ***)
(*******************************)

Definition envp := list (nat * typ).

(* Definition PG : envp. *)

Definition domain_envp (l : envp) : list nat := map fst l.

Definition range_envp (l : envp) : list typ := map snd l.

Require Import FunInd.

(*
issupertype returns true if A <: B
and false otherwise

It works for the transitive closure
It works for supertypes having multiple unrelated subtypes
*)

Function issupertype (l: envp) (A:typ) (B:typ) {struct l} : bool :=
    match l with
    | [] => false
    | (i, t) :: xs => match eq_dec A (t_prim i) with
                     | left _ => match eq_dec B t with
                                 | left _ => true
                                 | right _ => issupertype xs t B
                                 end
                     | right _ => issupertype xs A B
                    end
    end.

Function get_all_subtypes (l : envp) (A: typ) {struct l} : list nat :=
  match l with
  | [] => []
  | (i, t) :: xs => let flag := (issupertype l (t_prim i) A) in
                    match flag with
                      | true  => i :: (get_all_subtypes xs A)
                      | false => get_all_subtypes xs A
                      end
  end.

(* Eval compute in (issupertype [(3, (t_prim 2)); (2, (t_prim 1))]) (t_prim 1) (t_prim 2). *)

Fixpoint nats_to_types (l : list nat) {struct l} : (list typ) :=
  match l with
  | [] => []
  | a :: xs => [t_prim a] ++ (nats_to_types xs)
  end.

(* Ground Types *)

Inductive groundtype : typ -> Prop :=
  | gtype_top :
      groundtype t_top
  | gtype_int :
      groundtype t_int
  | gtype_bot :
      groundtype t_bot
  | gtype_arrow : forall T1 T2,
      groundtype (t_arrow T1 T2)
  | gtype_union : forall T1 T2,
      groundtype T1 ->
      groundtype T2 ->
      groundtype (t_union T1 T2)
  | gtype_and : forall T1 T2,
      groundtype T1 ->
      groundtype T2 ->
      groundtype (t_and T1 T2)
  | gtype_all : forall T1 T2,
      groundtype T1 ->
      groundtype (t_all T1 T2)
  | gtype_unit :
      groundtype t_unit
  | gtype_prim : forall i,
      groundtype (t_prim i).

 (** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  disjointness relation in E. This predicates implies
  that T is a type *)

Inductive wft (PG:envp) : env -> typ -> Prop :=
  | wft_top : forall E,
      wft PG E t_top
  | wft_int : forall E,
      wft PG E t_int
  | wft_bot : forall E,
      wft PG E t_bot
  | wft_arrow : forall E T1 T2,
      wft PG E T1 ->
      wft PG E T2 ->
      wft PG E (t_arrow T1 T2)
  | wft_union : forall E T1 T2,
      wft PG E T1 ->
      wft PG E T2 ->
      wft PG E (t_union T1 T2)
  | wft_and : forall E T1 T2,
      wft PG E T1 ->
      wft PG E T2 ->
      wft PG E (t_and T1 T2)
  | wft_var : forall U E X,
      (* groundtype U -> *)
      binds X (bind_disj U) E ->
      wft PG E (t_fvar X)
  | wft_all : forall L E T1 T2,
      wft PG E T1 ->
      groundtype T1 ->
      (forall X, X \notin L ->
        wft PG (E & X ~*: T1) (T2 open_tt_var X)) ->
      wft PG E (t_all T1 T2)
  | wft_unit : forall E,
      wft PG E t_unit
  | wft_prim : forall (i : nat) E,
      set_In i (domain_envp PG) ->
      wft PG E (t_prim i).

  (** A environment E is well-formed if it contains no duplicate bindings
    and if each type in it is well-formed with respect to the environment
    it is pushed on to. *)

Inductive okenvp : envp -> Prop :=
  | okenvp_empty :
      okenvp []
  | okenvp_sub : forall (PG:envp) (A:typ) (i:nat) E,
     okenvp PG ->
     wft PG E A ->
     ~( set_In i (domain_envp PG)) ->
     okenvp ((i, A) :: PG).

Inductive okt (PG : envp) : env -> Prop :=
  | okt_empty :
      okt PG empty
  | okt_typ : forall E x T,
      okt PG E ->
      wft PG E T ->
      x # E ->
      okt PG (E & x ~: T)
  | okt_disj : forall E X T,
      okt PG E ->
      wft PG E T ->
      X # E ->
      groundtype T ->
      okt PG (E & X ~*: T).

#[export]
Hint Constructors type wft okenvp groundtype : core.

(*********************************************)
(**********  FindSubtypes  (LOS)  ************)
(*********************************************)

Definition all_ord (PG : envp) := [t_int; t_arrow t_top t_bot;
  t_unit; t_all t_bot t_bot] ++ nats_to_types (domain_envp PG).

Inductive OSubtypes (PG:envp) (E:env) : typ -> list typ -> Prop :=
  | osubs_top :
      OSubtypes PG E t_top (all_ord PG)
  | osubs_bot :
      OSubtypes PG E t_bot []
  | osubs_int :
      OSubtypes PG E t_int [t_int]
  | osubs_arrow : forall A B,
      OSubtypes PG E (t_arrow A B)  [t_arrow t_top t_bot]
  | osubs_union : forall A B,
      forall l1, OSubtypes PG E A l1 ->
      forall l2, OSubtypes PG E B l2 ->
     OSubtypes PG E (t_union A B) (l1 `union` l2)
  | osubs_inter : forall A B,
      forall l1, OSubtypes PG E A l1 ->
      forall l2, OSubtypes PG E B l2 ->
      OSubtypes PG E (t_and A B) (l1 `inter` l2)
  | osubs_unit :
      OSubtypes PG E t_unit [t_unit]
  | osubs_fvar : forall X T,
      binds X (bind_disj T) E ->
      forall l,
      OSubtypes PG E T l ->
      OSubtypes PG E (t_fvar X) ((all_ord PG)  `dif` l)
  | osubs_all : forall A B,
      OSubtypes PG E (t_all A B)  [t_all t_bot t_bot]
  | osubs_prim : forall i,
      OSubtypes PG E (t_prim i) ([t_prim i] ++
      nats_to_types (get_all_subtypes PG (t_prim i))).

#[export]
Hint Constructors OSubtypes : core.

(* defns Subtyping *)
Reserved Notation "PG ; G |= A <: B" (at level 80, A at next level, B at next level).
Inductive sub (PG: envp) : env -> typ -> typ -> Prop :=    (* defn subtyping *)
 | s_top : forall G A,
     okenvp PG ->
     okt PG G ->
     wft PG G A ->
     sub PG G A t_top
 | s_int : forall G,
     okenvp PG ->
     okt PG G ->
     sub PG G t_int t_int
 | s_unit : forall G,
    okenvp PG ->
    okt PG G ->
    sub PG G t_unit t_unit
 | s_arrow : forall G (A1 A2 B1 B2:typ),
     sub PG G B1 A1 ->
     sub PG G A2 B2 ->
     sub PG G (t_arrow A1 A2) (t_arrow B1 B2)
 | s_ora : forall G (A1 A2 A:typ),
     sub PG G A1 A ->
     sub PG G A2 A ->
     sub PG G (t_union A1 A2) A
 | s_orb : forall G (A A1 A2:typ),
     wft PG G A2 ->
     sub PG G A A1 ->
     sub PG G A (t_union A1 A2)
 | s_orc : forall G (A A1 A2:typ),
     wft PG G A1 ->
     sub PG G A A2 ->
     sub PG G A (t_union A1 A2)
 | s_anda : forall G A A1 A2,
     sub PG G A A1 ->
     sub PG G A A2 ->
     sub PG G A (t_and A1 A2)
 | s_andb : forall G A1 A2 A,
     wft PG G A2 ->
     sub PG G A1 A ->
     sub PG G (t_and A1 A2) A
 | s_andc : forall G A1 A2 A,
     wft PG G A1 ->
     sub PG G A2 A ->
     sub PG G (t_and A1 A2) A
 | s_bot : forall G A,
      okenvp PG ->
      okt PG G ->
      wft PG G A ->
      sub PG G t_bot A
 | s_tvar : forall G X,
     okenvp PG ->
     okt PG G ->
     wft PG G (t_fvar X) ->
     sub PG G (t_fvar X) (t_fvar X)
 | s_all : forall L G S1 S2 T1 T2,
      sub PG G S1 T1 ->
      groundtype S1 ->
      (forall X, X \notin L ->
          PG ; (G & X ~*: T1) |=  (S2 open_tt_var X) <: (T2 open_tt_var X)) ->
      PG ; G |= (t_all S1 S2) <: (t_all T1 T2)
 | s_p_refl : forall i E,
     okenvp PG ->
     okt PG E ->
     wft PG E (t_prim i) ->
     PG ; E |= (t_prim i) <: (t_prim i)
 | s_p_sub : forall n1 n2 E,
     okenvp PG ->
     okt PG E ->
     wft PG E (t_prim n1) ->
     wft PG E (t_prim n2) ->
     set_In (t_prim n1) (nats_to_types (get_all_subtypes PG (t_prim n2))) ->
     PG ; E |= (t_prim n1) <: (t_prim n2)
where "PG ; G |= A <: B" := (sub PG G A B) : env_scope.

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

(*************************)
(***** 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
  | o_all   : forall t1 t2, Ord (t_all t1 t2)
  | o_prim  : forall i, Ord (t_prim i).

#[export]
Hint Constructors Ord : core.

(***********************************)
(****  FindSubtypes Properties  ****)
(***********************************)

Lemma list_empty_decide : forall (l : list typ), (l = []) \/ (l <> []).
Proof.
  intros. induction l. auto.
  destruct IHl. right.
  unfold not. intros. inversion H0.
  unfold not in *.
  right. intros.
  inversion H0.
Defined.

Lemma elem_append_in_list : forall (a : typ) (l : list typ), set_In a (a :: l).
Proof.
  intros. simpl. auto.
Defined.

Lemma elem_append_in_union1 : forall (a1 a2 : typ) (l1 l2 : list typ),
set_In a1 (a1 :: l1 `union` a2 :: l2).
Proof.
  intros.
  lets: elem_append_in_list a1 l1.
  apply set_union_intro1. auto.
Defined.

Lemma elem_append_in_union2 : forall (a1 : typ) (l1 : list typ),
set_In a1 ([] `union` a1 :: l1).
Proof.
  intros.
  lets: elem_append_in_list a1 l1.
  apply set_union_intro2. auto.
Defined.

Lemma sub_or (PG:envp) : forall G A B C, PG ; G |= (t_union A B) <: C ->
  PG ; G |= A <: C /\ PG ; G |= B <: C.
Proof.
intros; inductions H; try solve [split*].
inverts* H1.
specialize (IHsub A B).
forwards* : IHsub.
specialize (IHsub A B).
forwards* : IHsub.
specialize (IHsub1 A B).
specialize (IHsub2 A B).
forwards* : IHsub1.
Defined.

Lemma sub_and (PG:envp) : forall G A B C, PG ; G |= A <: (t_and B C) ->
  PG ; G |= A <: B /\ PG ; G |= A <: C.
Proof.
intros; inductions H; try solve [split*].
specialize (IHsub1 B C).
specialize (IHsub2 B C).
forwards* : IHsub1.
specialize (IHsub B C).
forwards* : IHsub.
specialize (IHsub B C).
forwards* : IHsub.
inverts* H1.
Defined.

(*
  Nominal Type Properties
*)

Lemma prim_type_in_nats_to_types : forall (A : typ) (l : list nat),
  set_In A (nats_to_types l) ->
  exists (i : nat), A = t_prim i.
Proof.
  induction l; intros. simpl in H. inverts H.
  simpl in H. destruct H. exists a. auto. auto.
Defined.

Lemma prim_in_domain : forall PG (j:nat),
  set_In j (domain_envp PG) ->
  exists (i:nat), t_prim j = t_prim i.
Proof.
  intros PG j IN. exists*.
Qed.

Lemma prim_type_in : forall PG E n l,
  OSubtypes PG E (t_prim n) l ->
  forall A, set_In A l ->
  exists (i : nat), A = t_prim i.
Proof.
  intros PG E n l H. inverts H; simpl; intros.
  destruct H. exists*.
  destruct (get_all_subtypes PG (t_prim n)); intros. simpl in H.
  inverts H.
  apply prim_type_in_nats_to_types in H. destruct H.
  exists*.
Qed.

Lemma prim_subtypes_not_empty : forall PG,
  okenvp PG ->
  forall E i, wft PG E (t_prim i) ->
  forall l, OSubtypes PG E (t_prim i) l ->
  l <> [].
Proof.
  introv OK WFT.
  unfold not. intros.
  inverts H. simpl in TEMP.
  inverts TEMP.
Qed.

Lemma i_in_nat_to_types : forall i PG,
  set_In i (domain_envp PG) ->
  set_In (t_prim i) (nats_to_types (domain_envp PG)).
Proof.
  introv IN.
  induction (domain_envp PG). inverts IN.
  simpl in IN. destruct IN.
  simpl. left. subst~.
  simpl. right. apply* IHl.
Qed.

Lemma prim_in_nat_to_types : forall i PG,
  set_In (t_prim i) (nats_to_types (domain_envp PG)) ->
  set_In i (domain_envp PG).
Proof.
  introv IN.
  induction (domain_envp PG). inverts IN.
  simpl in IN. destruct IN. inverts H.
  simpl. left. subst~.
  simpl. right. apply* IHl.
Qed.

Lemma allsubtypes_in_to_domain_nat : forall PG A,
  forall i, set_In i (get_all_subtypes PG A) ->
  set_In i (domain_envp PG).
Proof.
  induction PG; introv IN1.
  - inverts IN1.
  - destruct a as [C D].
    simpl in *. destruct (eq_dec_nat C C).
    destruct (eq_dec A D).
    + simpl in IN1.
      destruct IN1.
      * auto.
      * specialize (IHPG A i).
        forwards: IHPG H.
        auto.
    + simpl in IN1.
      destruct (issupertype PG D A).
      simpl in IN1. destruct IN1.
      auto.
      apply IHPG in H; auto.
      apply IHPG in IN1; auto.
    + contradiction.
Qed.

Lemma nat_to_types_iff : forall l1 l2,
  (nats_to_types (l1 ++ l2)) = (nats_to_types l1) ++ (nats_to_types l2).
Proof.
  induction l1; intros.
  - simpl. auto.
  - simpl. specialize (IHl1 l2).
    rewrite IHl1. auto.
Qed.

Lemma allsubtypes_in_to_domain : forall PG A,
  forall B, set_In B (nats_to_types (get_all_subtypes PG A)) ->
  set_In B (nats_to_types (domain_envp PG)).
Proof.
  induction PG; introv IN1.
  - inverts IN1.
  - simpl in *. destruct a as [C D].
    destruct (eq_dec_nat C C).
    (*assert (domain_envp ((C, D):: PG) = C :: domain_envp PG) as -> by admit.*)
    destruct (eq_dec A D); simpl in IN1.
    + destruct IN1.
      * rewrite <- H. simpl. auto.
      * apply IHPG in H. auto.
    + destruct (issupertype PG D A).
      * simpl in IN1. destruct IN1.
        simpl. auto.
        apply IHPG in H. auto.
      * apply IHPG in IN1. auto.
    + contradiction.
Qed.

(* If function is in findsubtypes then it
must be Top -> Bot *)

Lemma arrow_in_top_bot : forall PG G C l,
  OSubtypes PG G C l ->
  forall A B, set_In (t_arrow A B) l ->
  t_arrow A B = t_arrow t_top t_bot.
Proof.
  intros. inductions C; try solve [inverts H].
  - inverts H; unfold all_ord in H0;
    destruct H0 as [H | ]; inverts H.
    rewrite~ H0.
    destruct H0 as [H | [H0 | ]]; try solve [inverts H; inverts H0].
    inverts H0.
    simpl in H.
    apply prim_type_in_nats_to_types in H. destruct H as [i].
    inverts H.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H. inverts H0.
  - clear IHC1 IHC2.
    inverts H; inverts H0; auto. inverts H.
  - inverts H.
    apply set_union_elim in H0. destruct H0.
    eapply IHC1; eauto.
    eapply IHC2; eauto.
  - inverts H.
    apply set_inter_elim1 in H0.
    eapply IHC1; eauto.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H.
    apply set_diff_elim1 in H0. simpl in H0.
    destruct H0 as [H0 | [H0 | [H0 | [H0 | H0]]]]; try solve [inverts H0].
    inverts* H0.
    apply prim_type_in_nats_to_types in H0. destruct H0 as [i].
    inverts H.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H. simpl in H0. destruct H0. inverts H.
    apply prim_type_in_nats_to_types in H.
    destruct H as [i]. inverts H.
Qed.

(* If disjoint quantifier is in findsubtypes then it
must be (forall X . Bot -> Bot) *)

Lemma all_in_bot_bot : forall PG G C l,
OSubtypes PG G C l ->
forall A B, set_In (t_all A B) l ->
t_all A B = t_all t_bot t_bot.
Proof.
  intros. inductions C; try solve [inverts H].
  - inverts H; unfold all_ord in H0;
    destruct H0 as [H | ]; inverts H.
    inverts H0.
    destruct H0 as [H | [H0 | ]]; try solve [inverts H; inverts H0].
    rewrite~ H0.
    simpl in H.
    apply prim_type_in_nats_to_types in H.
    destruct H as [i]. inverts H.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H. inverts H0.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H.
    apply set_union_elim in H0. destruct H0.
    eapply IHC1; eauto.
    eapply IHC2; eauto.
  - inverts H.
    apply set_inter_elim1 in H0.
    eapply IHC1; eauto.
  - inverts H. destruct H0. inverts H. inverts H.
  - inverts H.
    apply set_diff_elim1 in H0. simpl in H0.
    destruct H0 as [H0 | [H0 | [H0 | [H0 | H0]]]]; try solve [inverts H0].
    inverts* H0.
    apply prim_type_in_nats_to_types in H0.
    destruct H0 as [i]. inverts H.
  - inverts H. destruct H0. inverts H. auto. inverts H.
  - inverts H. simpl in H0. destruct H0. inverts H.
    apply prim_type_in_nats_to_types in H.
    destruct H as [i]. inverts H.
Qed.

(* If ordinary type is a subtype of another type
then it must be in its findsubtypes *)

Lemma ord_in_findsubtypes : forall PG G A B,
  Ord A ->
  PG ; G |= A <: B ->
  forall E l, OSubtypes PG E B l ->
  set_In A l \/
  (exists t1 t2, A = t_arrow t1 t2 /\ set_In (t_arrow t_top t_bot) l) \/
  (exists t1 t2, A = t_all t1 t2 /\ set_In (t_all t_bot t_bot) l).
Proof.
  introv Ord. gen B.
  inductions Ord; intros.
  - (*case int*)
   gen l. induction B; simpl; auto; try solve [inverts H]; intros.
   + inverts* H0. left. simpl. auto.
   + inverts H0. simpl. auto.
   + inverts H0.
    inverts* H.
    * destruct (IHB1 H7 l1); auto.
      left. apply set_union_intro. left*.
      destruct H as [H | H].
      destruct H as [x1 [x2]]. destruct H. inversion H.
      destruct H as [x1 [x2]]. destruct H. inversion H.
    * destruct (IHB2 H7 l2); auto.
      left. apply set_union_intro. right*.
      destruct H as [H | H].
      destruct H as [x1 [x2]]. destruct H. inversion H.
      destruct H as [x1 [x2]]. destruct H. inversion H.
   + apply sub_and in H. destruct H.
     inverts H0.
     destruct (IHB1 H l1); auto.
    * destruct (IHB2 H1 l2); auto.
      left. apply set_inter_intro; auto.
      destruct H2 as [H2 | H2].
      destruct H2 as [x1 [x2]]. destruct H2. inversion H2.
      destruct H2 as [x1 [x2]]. destruct H2. inversion H2.
    * destruct H0 as [H0 | H0].
      destruct H0 as [x1 [x2]]. destruct H0. inversion H0.
      destruct H0 as [x1 [x2]]. destruct H0. inversion H0.
  - (*case arrow*)
   gen l. induction B; simpl; auto; try solve [inverts H]; intros.
   + right. left. inverts H0. simpl. exists* t1 t2.
   + right. left. inverts H0. simpl. exists* t1 t2.
   + inverts H0.
     inverts* H.
    * destruct (IHB1 H7 l1); auto.
      left. apply set_union_intro. left*.
      destruct H as [H | H].
      destruct H as [x1 [x2]]. destruct H.
      right. left. exists x1 x2. split*.
      apply set_union_intro. left*.
      destruct H as [x1 [x2]]. destruct H. inverts H.
    * destruct (IHB2 H7 l2); auto.
      left. apply set_union_intro. right*.
      destruct H as [H | H].
      destruct H as [x1 [x2]]. destruct H.
      right. left. exists x1 x2. split*.
      apply set_union_intro. right*.
      destruct H as [x1 [x2]]. destruct H. inverts H.
   + apply sub_and in H. destruct H.
     inverts H0.
     destruct (IHB1 H l1); auto.
    * destruct (IHB2 H1 l2); auto.
      { left. apply set_inter_intro; auto. }
      { destruct H2 as [H2 | H2].
        destruct H2 as [x1 [x2]]. destruct H2.
        lets H1': H0.
        apply (@arrow_in_top_bot PG E B1) in H1'; auto.
        rewrite <- H1' in H3.
        left. apply set_inter_intro; auto.
        destruct H2 as [x1 [x2]]. destruct H2.
        inverts H2. }
    * destruct (IHB2 H1 l2); auto.
      { destruct H0 as [H0 | H0].
        destruct H0 as [x1 [x2]]. destruct H0.
        lets H2': H2.
        apply (arrow_in_top_bot PG E B2) in H2'; auto.
        rewrite <- H2' in H3.
        left. apply set_inter_intro; auto.
        destruct H0 as [x1 [x2]]. destruct H0.
        inverts H0. }
      { destruct H0 as [H0 | H0].
        destruct H0 as [x1 [x2]]. destruct H0.
        destruct H2 as [H2 | H2].
        destruct H2 as [x3 [x4]]. destruct H2.
        right. left. exists x1 x2. split*.
        apply set_inter_intro; auto.
        destruct H2 as [x3 [x4]]. destruct H2.
        inverts H2.
        destruct H0 as [x1 [x2]]. destruct H0. inverts H0.
        }
 - (*case unit*)
   gen l. induction B; simpl; auto; try solve [inverts H]; intros.
   + inverts H0. simpl. left*.
   + inverts H0.
     inverts H.
     * destruct~ (IHB1 H7 l1).
       left. apply set_union_intro; auto.
       destruct H as [H | H].
       destruct H as [x1 [x2 [H' H'']]]. inverts H'.
       destruct H as [x1 [x2 [H' H'']]]. inverts H'.
     * destruct~ (IHB2 H7 l2).
       left. apply set_union_intro; auto.
       destruct H as [H | H].
       destruct H as [x1 [x2 [H' H'']]]. inverts H'.
       destruct H as [x1 [x2 [H' H'']]]. inverts H'.
    + apply sub_and in H. destruct H.
      inverts H0.
      destruct~ (IHB1 H l1).
     * destruct~ (IHB2 H1 l2).
       left. apply set_inter_intro; auto.
       destruct H2 as [H2 | H2].
       destruct H2 as [x1 [x2 [H2 H3]]]. inverts H2.
       destruct H2 as [x1 [x2 [H2 H3]]]. inverts H2.
     * destruct H0 as [H0 | H0].
       destruct H0 as [x1 [x2 [H0 H0']]]. inverts H0.
       destruct H0 as [x1 [x2 [H0 H0']]]. inverts H0.
    + inverts H0. simpl. left*.
  - (*case all*)
   gen l. inductions B; simpl; try solve [inverts H]; intros.
   + right. right. inverts H0. simpl. exists* t1 t2.
   + inverts H0.
     inverts H.
     * destruct~ (IHB1 H7 E l1) as [H | H].
       left. apply~ set_union_intro1.
       destruct H as [H | H].
       destruct H as [x1 [x2]]. destruct H. inverts H.
       destruct H as [x1 [x2]]. destruct H.
       right. right. exists t1 t2. split*.
       apply~ set_union_intro1.
     * destruct~ (IHB2 H7 E l2) as [H | H].
       left. apply~ set_union_intro2.
       destruct H as [H | H].
       destruct H as [x1 [x2]]. destruct H. inverts H.
       destruct H as [x1 [x2]]. destruct H.
       right. right. exists t1 t2. split*.
       apply~ set_union_intro2.
    + inverts H0.
      apply sub_and in H. destruct H.
      destruct~ (IHB1 H E l1) as [H' | H'].
      * destruct~ (IHB2 H0 E l2) as [H0' | H0'].
        left. apply~ set_inter_intro.
        destruct H0' as [H0' | H0'].
        destruct H0' as [x1 [x2]]. destruct H1.
        inverts H1.
        destruct H0' as [x1 [x2]]. destruct H1.
        right. right. exists t1 t2. split*.
        forwards* : all_in_bot_bot H'.
        rewrite H4 in H'.
        apply~ set_inter_intro.
      * destruct~ (IHB2 H0 E l2) as [H0' | H0'].
        destruct H' as [H' | H'].
        destruct H' as [x1 [x2]]. destruct H1. inverts H1.
        destruct H' as [x1 [x2]]. destruct H1.
        forwards* : all_in_bot_bot H0'.
        rewrite H4 in H0'.
        right. right. exists t_bot t_bot. split*.
        apply~ set_inter_intro.
        destruct H' as [H' | H'].
        destruct H' as [x1 [x2]]. destruct H1. inverts H1.
        destruct H' as [x1 [x2]]. destruct H1.
        destruct H0' as [H0' | H0'].
        destruct H0' as [x3 [x4]]. destruct H4.
        inverts H4.
        destruct H0' as [x3 [x4]]. destruct H4.
        right. right. exists t1 t2. split*.
        apply~ set_inter_intro.
   + right. right. inverts H0. simpl. exists* t1 t2.
  - (*case P*)
    left. gen l. inductions H; intros.
    + inverts H2. simpl. right. right.
      right. right. inverts H1.
      forwards*: i_in_nat_to_types H4.
    + inverts H1.
      apply set_union_intro.
      forwards*: IHsub H4.
    + inverts H1.
      apply set_union_intro.
      forwards*: IHsub H6.
    + inverts H1.
      apply set_inter_intro.
      forwards*: IHsub1 H4.
      forwards*: IHsub2 H6.
    + inverts H2. simpl. auto.
    + inverts H4. simpl.
      right*.
Qed.

Lemma ord_sub_findsubtypes_not_empty : forall A,
Ord A -> forall PG G B, (PG ; G |= A <: B) ->
forall E l, OSubtypes PG E B l -> l <> [].
Proof.
  unfold not. intros.
  subst.
  eapply ord_in_findsubtypes in H0; eauto; destruct H0; inverts H0.
  destruct H2 as [x1 [x2 [H2 H3]]].
  inverts H3.
  destruct H2 as [x1 [x2 [H2 H3]]].
  inverts H3.
Qed.

Lemma all_ord_in_all_ord : forall PG B,
  set_In B (all_ord PG)->
  Ord B.
Proof.
  intros; simpl in H;
  destruct H as [H | [H | [H | [H | H]]]];
   try solve [rewrite <- H; auto].
   apply prim_type_in_nats_to_types in H.
   destruct H as [i].
   inverts* H.
Defined.

Lemma demorgan : forall (P Q R S : Prop),
~ (P \/ Q \/ R \/ S) -> ~P /\ ~Q /\ ~R /\ ~S.
Proof.
  intros.
  unfold not in *.
  splits; intros; apply H; auto.
Defined.

Lemma bot_sub_all : forall PG G A,
  okenvp PG ->
  okt PG G ->
  wft PG G A ->
  PG ; G |= t_bot <: A.
Proof.
  intros.
  dependent induction A; eauto.
Qed.

(****************************************)
(**********  Dijoint Algo    ************)
(****************************************)

Definition DisjAlgo (PG:envp) (E:env) A B :=
  okenvp PG /\
  okt PG E /\
  wft PG E A /\
  wft PG E B /\
  forall l1 l2, ((OSubtypes PG E A l1) /\ (OSubtypes PG E B l2)) ->
  (l1 `inter` l2) = [].
Notation "PG ; E |= A *a B" := (DisjAlgo PG E A B) (at level 80, E at next level, A at next level).

(* Ground Type Properties *)

Lemma okt_binds_ground : forall PG E,
  okt PG E ->
  forall X T, binds X (bind_disj T) E ->
  groundtype T.
Proof.
  induction 1; intros.
  apply binds_empty_inv in H. inverts H.
  binds_cases H2. forwards*: IHokt B.
  binds_cases H3. forwards*: IHokt B.
  inverts EQ. auto.
Qed.

Lemma exists_osubtypes_ground : forall PG E A,
  groundtype A ->
  exists l, OSubtypes PG E A l.
Proof.
  introv GT. inductions GT; try solve [exists*].
  destruct~ IHGT1 as [l1].
  destruct~ IHGT2 as [l2]. exists*.
  destruct~ IHGT1 as [l1].
  destruct~ IHGT2 as [l2]. exists*.
Qed.

Lemma exists_osubtypes : forall PG E A,
  okt PG E ->
  wft PG E A ->
  exists l, OSubtypes PG E A l.
Proof.
  introv OK WFT. inductions WFT; try solve [exists*].
  destruct~ IHWFT1 as [l1].
  destruct~ IHWFT2 as [l2]. exists*.
  destruct~ IHWFT1 as [l1].
  destruct~ IHWFT2 as [l2]. exists*.
  forwards* GU: okt_binds_ground H.
  forwards* (l&osubu): exists_osubtypes_ground GU.
Qed.

(* Regularity of disjointness *)

Lemma disj_regular : forall PG E A B,
  DisjAlgo PG E A B ->
  okenvp PG /\ okt PG E /\ wft PG E A /\ wft PG E B.
Proof.
  introv Disj.
  unfold DisjAlgo in Disj.
  destructs~ Disj.
Qed.


Require Import floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import sha.general_lemmas.
Require Import sha.spec_sha.
Require Import sha.hmac_common_lemmas.
Require Import sha.spec_hmac.

Require Import sha.hkdf.
Require Import sha.spec_hkdf.
Require Import sha.hkdf_functional_prog.

Definition Done (i:Z): int := Int.repr (digest_len*i).
Definition OUTpred PrkCont InfoCont sh z r cont p: mpred:=
  data_at sh (tarray tuchar z) (sublist 0 z (map Vint (map Int.repr (HKDF_expand PrkCont InfoCont cont)))) p *
  memory_block sh r (offset_val z p).

Definition PREVcont PRK INFO (i: Z): reptype (Tarray tuchar 32 noattr) :=
     if zeq i 0 then list_repeat 32 Vundef
     else (map Vint (map Int.repr (Ti (CONT PRK) (CONT INFO) (Z.to_nat i)))).

Lemma PREV_len PRK INFO i: 0 <= i -> Zlength (PREVcont PRK INFO i) = 32.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). rewrite Zlength_list_repeat'; reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. repeat rewrite Zlength_map. apply HMAC_Zlength.
Qed.

Lemma PREV_isbyteZ PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vint (map Int.repr l) /\
                                                  Forall general_lemmas.isbyteZ l.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; split. reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. apply isbyte_hmac.
Qed.

Lemma PREVcont_Sn PRK INFO i p: 0 <= i -> PREVcont PRK INFO i = map Vint (map Int.repr p) ->
      Forall general_lemmas.isbyteZ p ->
      PREVcont PRK INFO (i+1) = if zeq i 0 then map Vint (map Int.repr (HMAC256_functional_prog.HMAC256 (CONT INFO ++ [1]) (CONT PRK)))
                                else map Vint (map Int.repr (HMAC256_functional_prog.HMAC256 (p ++ CONT INFO ++ [i + 1]) (CONT PRK))).
Proof. intros. unfold PREVcont.
destruct (zeq (i+1) 0). omega.
change (i+1) with (Zsucc i). rewrite Z2Nat.inj_succ; try omega. simpl.
unfold PREVcont in H0.
destruct (zeq i 0).
+ subst i. simpl; trivial.
+ apply map_Vint_injective in H0. apply map_IntReprOfBytes_injective in H0; trivial.
  rewrite H0, Zpos_P_of_succ_nat, Z2Nat.id; trivial.
  apply isbyteZ_Ti.
Qed.

Lemma PREV_listZ PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vint (map Int.repr l).
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; reflexivity.
Qed.

Lemma sublist_HKDF_expand4 PRK INFO i rest l (REST : 0 <= rest < 32)
      (g : 255 >= i + 1) (OLEN : 32 * i + rest + 32 <= Int.max_unsigned)
      (Hl : if zeq i 0 then l = [] else PREVcont PRK INFO i = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
      (Hi: 0 <= i):
sublist 0 rest
  (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Int.unsigned (Int.zero_ext 8 (Int.repr (i + 1)))]) (CONT PRK)) =
sublist (32 * i) (32 * i + rest) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold PREVcont in Hl. destruct (zeq i 0).
  + subst i l; simpl. rewrite Z.add_0_l. unfold HKDF_expand; simpl.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite zero_ext_inrange; try rewrite Int.unsigned_repr;
        try rewrite int_max_unsigned_eq; try omega; trivial.
  + destruct Hl as [Hl isBl].
    apply map_Vint_injective in Hl.
    apply map_IntReprOfBytes_injective in Hl; trivial.
    2: apply isbyteZ_Ti.
    unfold HKDF_expand; simpl.
    destruct (zle (32 * (i + 1)) 0); try omega.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite (Zmod_unique _ _ (i+1) 0); try omega. simpl.
    rewrite (Zdiv_unique _ _ (i+1) 0); try omega.
    replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
    simpl. rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
    rewrite Zminus_diag, Hl, <- app_assoc, Zpos_P_of_succ_nat, Z2Nat.id; try omega.
    replace ((32 * i + rest - 32 * i)%Z) with rest%Z by omega.
    replace (i + 1) with (Z.succ i) in * by trivial.
    rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; trivial; try omega.
    change (two_p 8 - 1) with 255; omega.
Qed.

Lemma sublist_HKDF_expand5 PRK INFO l i
         (Hl : if zeq i 0 then l = []
               else PREVcont PRK INFO i = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
         (Hi : 0 <= i):
      sublist 0 32 (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [i + 1]) (CONT PRK)) =
      sublist (32 * i) (32 * i + 32) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold HKDF_expand. destruct (zle (32*(i + 1)) 0); try omega. simpl.
  rewrite (Zmod_unique _ _ (i+1) 0) by omega. simpl.
  rewrite (Zdiv_unique _ _(i+1) 0) by omega.
  rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
  simpl.
  rewrite Zpos_P_of_succ_nat, Z2Nat.id; try omega.
  rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
  rewrite Zminus_diag. replace ((32 * i + 32 - 32 * i)%Z) with 32%Z by omega.
  unfold PREVcont in Hl.
  destruct (zeq i 0). { simpl in *; subst i l; simpl; trivial. }
  destruct Hl as [Hl isBTl]. apply map_Vint_injective in Hl.
  apply map_IntReprOfBytes_injective in Hl; trivial. 2: apply isbyteZ_Ti.
  rewrite Hl, <- app_assoc.
  change (i+1)%Z with (Z.succ i); trivial.
Qed.

Lemma body_hkdf_expand: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_expand HKDF_expand_spec.
Proof.
start_function. rename lvar0 into previous.
rename lvar1 into hmac. rename lvar2 into ctr.
rename H into LenPRK. rename H0 into LEN_INFO1.
destruct H1 as [LEN_INFO2 LEN_INFO3]. rename H2 into OLEN.

freeze [0;1;2;3;4;5;6] FR1.
forward. forward. forward. forward.
unfold Int.divu, Int.add, Int.sub.
assert (OLEN2: 0 <= (olen + 32 - 1) / 32 <= Int.max_unsigned).
{ split. apply Z_div_pos; omega.
  apply Zdiv_le_upper_bound; omega. }
rewrite (Int.unsigned_repr 32); [| rewrite int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr olen); [| omega].
rewrite (Int.unsigned_repr 1); [| rewrite int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr (Int.unsigned (Int.repr (olen + 32)) - 1));
  [| rewrite Int.unsigned_repr; omega].
rewrite Int.unsigned_repr; [| omega].
forward_if
  (EX v:_,
   PROP (if zlt (olen + 32) olen then v = Vint (Int.repr 1)
         else v = Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))) )
   LOCAL (temp _t'1 v;
   temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac;
   lvar _previous (tarray tuchar 64) previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)  SEP (FRZL FR1)).
{ forward. Exists (Vint (Int.repr 1)). erewrite zlt_true; try eapply H.
  entailer!. }
{ forward.
  Exists (Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32)))).
  rewrite if_false; trivial.
  entailer. unfold sem_cast; simpl.
  rewrite sem_cast_i2i_correct_range; [| apply semax_straight.is_int_of_bool]; simpl.
  apply prop_right; trivial. }
apply extract_exists_pre. intros v. Intros. rename H into HV.
unfold Int.ltu in HV.
rewrite Int.unsigned_repr in HV; [| rewrite int_max_unsigned_eq; omega].
rewrite Int.unsigned_repr in HV; [| omega].
unfold Val.of_bool in HV.
forward_if
  (PROP (v=Vint (Int.repr 0))
   LOCAL (temp _t'1 v; temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac;
   lvar _previous (tarray tuchar 64) previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)  SEP (FRZL FR1)).
{ unfold typed_true in H.
  rewrite if_false in HV; try omega.
  subst v.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); [clear H | inv H].
  forward. normalize. Exists ctr.
  Exists (expand_out_post shmd (CONT PRK) (CONT INFO) olen out) hmac previous.
  thaw FR1; entailer.
  unfold expand_out_post, digest_len; simpl.
  rewrite if_false; try omega.
  rewrite if_true; trivial. entailer!. }
{ forward. entailer. unfold typed_false in H; simpl in H; inv H.
  destruct (zlt (olen + 32) olen). inv HV; simpl in *; try discriminate.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); inv HV; simpl in *; try discriminate.
  entailer!. }
Intros. subst v. rewrite if_false in HV; try omega.
destruct (zlt 255 ((olen + 32 - 1) / 32)); [inv HV | clear HV].
drop_LOCAL 0%nat.
thaw FR1.
Time assert_PROP (isptr prk) as isPtrPrk by entailer!. (*destruct prk; try contradiction. (Vptr b i)*)

freeze [0;2;3;6] FR1.
assert_PROP (field_compatible t_struct_hmac_ctx_st [] hmac) as FC_hmac by entailer!.
replace_SEP 1 (HMAC_SPEC.EMPTY hmac).
{ entailer!. eapply HMAC_SPEC.mkEmpty; trivial. }
idtac "Timing the call to _HMAC_Init".
Time forward_call (@inr (val * Z * list Z * val) _ (hmac, spec_hmac.LEN PRK, CONT PRK, kv, prk)).
(*Finished transaction in 13.389 secs (12.203u,0.s) (successful)*)

remember ((olen + 32 - 1) / 32) as bnd.
thaw FR1.
assert_PROP (isptr previous /\ field_compatible (tarray tuchar 64) [] previous) as prevPtr by entailer!.
destruct prevPtr as [prevPtr prevFC].
(*destruct previous; try contradiction. clear prevPtr.*)

unfold data_at_ at 2. unfold field_at_.
rewrite field_at_data_at. simpl. unfold tarray.
assert (VV: exists vv :reptype (Tarray tuchar 64 noattr), vv= list_repeat 64 Vundef).
{ eexists; reflexivity. }
destruct VV as [vv VV].
assert (JMeq_1: JMeq (default_val (Tarray tuchar 64 noattr)) (sublist 0 64 vv)).
{ subst vv. rewrite sublist_list_repeat with (k:=64); try omega. simpl. apply JMeq_refl. }
erewrite  split2_data_at_Tarray with (n1:=32).
2: omega.
3: apply JMeq_refl.
3: apply JMeq_refl.
2: eassumption.
normalize. simpl.
rewrite field_address_offset by auto with field_compatible. simpl.
rewrite isptr_offset_val_zero; trivial. (* rewrite Int.add_zero.*)
rewrite field_address0_offset by auto with field_compatible. simpl.
rewrite memory_block_field_compatible_tarraytuchar by (rewrite <- initialize.max_unsigned_modulus; omega).
Intros. rename H into FCout.

freeze [1;3] FR0.
assert_PROP (isptr out) as isPTRout by entailer!.
assert (Arith: 32 > 0) by omega.
specialize (Z_div_mod_eq olen 32 Arith); intros OLEN1.
assert (REST:= Z_mod_lt olen 32 Arith). remember (olen / 32) as rounds. remember (olen mod 32) as rest.
assert (BND: bnd = if zeq rest 0 then rounds else rounds + 1).
{ subst bnd olen. clear Heqrounds Heqrest.
  destruct (zeq rest 0).
  + subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega. rewrite X; clear X.
    symmetry. eapply Zdiv.Zdiv_unique. 2: reflexivity. omega.
  + assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega. rewrite X; clear X.
    rewrite Z.div_add_l. f_equal. apply Zdiv_unique with (b:=rest -1); omega. omega. }
clear Heqbnd Heqrounds Heqrest.

forward_for_simple_bound bnd
       (EX ii:Z, PROP (0 <= olen - Int.unsigned(if zlt ii bnd then Done ii else Int.repr olen))
             LOCAL (temp _n (Vint (Int.repr bnd));
                    temp _ret (Vint (Int.repr 0));
                    temp _done (Vint (if zlt ii bnd then Done ii else Int.repr olen));
                    temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar ctr;
                    lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac; lvar _previous (tarray tuchar 64) previous;
                    temp _out_key out; temp _out_len (Vint (Int.repr olen)); temp _prk prk;
                    temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK))); temp _info info;
                    temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO))); gvar sha._K256 kv)
             SEP (FRZL FR0; K_vector kv; data_at_ Tsh tuchar ctr;
            data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO ii) previous;
            data_block Tsh (CONT INFO) info;
            if zeq ii 0 then HMAC_SPEC.REP (HMAC_SPEC.hABS (CONT PRK) []) hmac
            else HMAC_SPEC.FULL (CONT PRK) hmac;
            OUTpred (CONT PRK) (CONT INFO) shmd (Z.min (digest_len * ii) olen)
                    (olen - Z.min (digest_len * ii) olen) (ii*32) out)).
{ destruct (zeq 0 0); try solve [omega]. clear e; entailer!.
  + unfold Done; simpl.
    destruct (zeq rest 0); simpl.
    - subst rest.
      destruct (zlt 0 rounds); simpl.
      * split; trivial. rewrite Int.unsigned_repr; omega.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. split; trivial; omega.
    - rewrite if_true. 2: omega. split; trivial. rewrite Int.unsigned_repr; omega.
  + unfold OUTpred. destruct (zeq rest 0).
    - subst rest; simpl.
      destruct (zlt 0 rounds); simpl.
      * rewrite Zplus_0_r, Z.min_l, Zminus_0_r, data_at_tuchar_zero_array_eq, isptr_offset_val_zero(*, data_at__memory_block*); trivial; try omega.
        cancel.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. unfold tarray. (*cancel.*)
        rewrite isptr_offset_val_zero, data_at_tuchar_zero_array_eq; trivial. cancel.
    - rewrite Zmin_l by omega. rewrite Zminus_0_r, data_at_tuchar_zero_array_eq; trivial.
      rewrite isptr_offset_val_zero; trivial. cancel.
}

{ (*loop body*)
  rename H into Hi1. Intros. rename i into i1. rename H into olenBounded. unfold Done, digest_len in olenBounded.
   rewrite if_true in olenBounded; try omega.
   rewrite Int.unsigned_repr in olenBounded. 2: rewrite int_max_unsigned_eq; omega.

  forward. rewrite Zmin_l. 2: unfold digest_len; omega.

  forward_if (EX l:_,
  PROP ( if zeq i1 0 then l=@nil Z else PREVcont PRK INFO i1 = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
   LOCAL (temp _i (Vint (Int.repr i1)); temp _n (Vint (Int.repr bnd));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (if zlt i1 bnd then Done i1 else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac;
   lvar _previous (tarray tuchar 64) previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvar sha._K256 kv)
   SEP (FRZL FR0; K_vector kv;
   field_at Tsh tuchar []
     (Vint (cast_int_int I8 Unsigned (Int.add (Int.repr i1) (Int.repr 1)))) ctr;
   data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO i1) previous;
   data_block Tsh (CONT INFO) info;
   OUTpred (CONT PRK) (CONT INFO) shmd (digest_len * i1) (olen - digest_len * i1) (i1*32) out;
   HMAC_SPEC.REP (HMAC_SPEC.hABS (CONT PRK) l) hmac)).

   { destruct (zlt i1 bnd); try omega. rewrite if_false; trivial.
     freeze [0;2;4;6] FR1.
     idtac "Timing the call to _HMAC_Init".
     Time forward_call (@inl _ (val * Z * list Z * val * val) (hmac,0,CONT PRK,kv)).
     (*Finished transaction in 17.094 secs (16.265u,0.015s) (successful)*)
     destruct (PREV_isbyteZ PRK INFO i1) as [prev [Hprev BTprev]]. omega. rewrite Hprev.
     assert (Zlength_prev: Zlength prev = 32).
     { specialize (PREV_len PRK INFO i1). rewrite Hprev.
       do 2 rewrite Zlength_map. intros X; rewrite X; trivial. omega. }

     idtac "Timing the first call to _HMAC_Update".
     Time forward_call (CONT PRK, hmac, previous, @nil Z, prev, kv).
     (*Finished transaction in 25.358 secs (23.765u,0.s) (successful)*)
     * rewrite Zlength_prev; apply prop_right; trivial.
     * assert (Frame = [FRZL FR1]). subst Frame; reflexivity. simpl; cancel.
       unfold data_block. normalize. rewrite Zlength_prev; trivial.
     * rewrite Zlength_prev, Zlength_nil.
       split. rewrite int_max_unsigned_eq; omega.
       cbv; trivial.
     * Exists prev. rewrite if_false; trivial. entailer!. thaw FR1. cancel.
       unfold data_block. normalize. rewrite Hprev, Zlength_prev. cancel. }
   { subst i1. forward. Exists (@nil Z). rewrite ! if_true; try omega.
     entailer!. }

   apply extract_exists_pre. intros l. Intros. rename H into Hl. rewrite if_true. 2: omega.

   idtac "Timing the second call to _HMAC_Update".
   Time forward_call (CONT PRK, hmac, info, l, CONT INFO, kv).
   (*Finished transaction in 26.905 secs (25.328u,0.s) (successful)*)
   { rewrite LEN_INFO1; apply prop_right; reflexivity. }
   { split. omega.
     destruct (zeq i1 0).
     + subst i1 l. rewrite Zlength_nil, Zplus_0_r. omega.
     + assert (Arith1: 0<= i1) by omega. specialize (PREV_len PRK INFO i1 Arith1); intros HZ.
       destruct Hl.
       assert (HH: Zlength (@map int val Vint (@map Z int Int.repr l)) = @Zlength val (PREVcont PRK INFO i1))
         by (f_equal; auto).
       repeat rewrite Zlength_map in HH. rewrite HH, HZ, <- Zplus_assoc; simpl. omega. }

   simpl. freeze [1;3;5;6] FR3.
   assert_PROP (field_compatible (tarray tuchar 1) [] ctr /\ isptr ctr) as HH by entailer!.
   destruct HH as [FC_cptr isptrCtr].

   replace_SEP 3 (data_at Tsh (tarray tuchar 1) [Vint (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] ctr).
   { entailer!. apply data_at_tuchar_singleton_array. }

   assert (Forall general_lemmas.isbyteZ [Int.unsigned (Int.zero_ext 8 (Int.repr (i1+1)))]) as isBT.
      { constructor. red. rewrite zero_ext_inrange; rewrite Int.unsigned_repr. omega.
         rewrite int_max_unsigned_eq; omega.
         assert (Arith1: two_p 8 - 1 = 255) by reflexivity. rewrite Arith1; omega.
         rewrite int_max_unsigned_eq; omega. constructor. }
   assert (LEN: Zlength [Int.unsigned (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] = 1) by reflexivity.

   idtac "Timing the third call to _HMAC_Update".
   Time forward_call (CONT PRK, hmac, ctr, l++CONT INFO,
        [Int.unsigned (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))], kv).
   (*Finished transaction in 26.703 secs (25.296u,0.s) (successful)*)
   { assert (Frame = [FRZL FR3]). subst Frame; reflexivity. subst Frame. simpl. cancel.
     unfold data_block. simpl. rewrite Int.repr_unsigned, LEN. entailer!. }
   { rewrite LEN. rewrite int_max_unsigned_eq, Zlength_app. split. omega.
     destruct (zeq i1 0).
     + subst l; rewrite Zlength_nil. rewrite Z.add_0_l. omega.
     + specialize (PREV_len PRK INFO i1). destruct Hl as [Hl isbyte_l]. rewrite Hl. do 2 rewrite Zlength_map.
       intros HH; rewrite HH; omega. }

   normalize. thaw FR3. freeze [1;3;4;6] FR4.
   replace_SEP 3 (memory_block Tsh 32 previous).
   { entailer!. eapply derives_trans. apply data_at_memory_block. trivial. }
   idtac "Timing the call to _HMAC_Final".
   Time forward_call (((l ++ CONT INFO) ++ [Int.unsigned (Int.zero_ext 8 (Int.repr (i1 + 1)))]),
                 CONT PRK, hmac, previous, Tsh, kv).
   (*Finished transaction in 28.233 secs (26.187u,0.s) (successful)*)
   unfold data_block. normalize. focus_SEP 2. erewrite (extract_prop_in_SEP 0); simpl. 2: reflexivity.
   Intros. rename H into isBT_app. (*VST TODO: why does normalize/Intros need the explicit extract_prop_in_SEP???*)
   rewrite HMAC_Zlength.
   remember (HMAC256_functional_prog.HMAC256
                   ((l ++ CONT INFO) ++
                    [Int.unsigned (Int.zero_ext 8 (Int.repr (i1 + 1)))])
                   (CONT PRK)) as CONTRIB.
   forward.
   forward_if
  (PROP ( )
   LOCAL (temp _todo (if zlt olen
                             (Int.unsigned (Int.add (Done i1) (Int.repr 32)))
                      then Vint (Int.sub (Int.repr olen) (Done i1))
                      else Vint (Int.repr 32));
   temp _i (Vint (Int.repr i1));
   temp _n (Vint (Int.repr bnd)); temp _ret (Vint (Int.repr 0));
   temp _done (Vint (Done i1)); temp _digest_len (Vint (Int.repr 32));
   lvar _ctr tuchar ctr; lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac;
   lvar _previous (tarray tuchar 64) previous;
   temp _out_key out; temp _out_len (Vint (Int.repr olen));
   temp _prk prk; temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)
   SEP (data_at Tsh (tarray tuchar 32) (map Vint (map Int.repr CONTRIB)) previous;
   K_vector kv; HMAC_SPEC.FULL (CONT PRK) hmac; FRZL FR4)).
   { forward. entailer!. rewrite if_true; trivial; omega. }
   { forward. entailer!. rewrite if_false; trivial; omega. }

   thaw FR4.
   (*destruct out; try contradiction. (*out = Vptr b1 i2*) *)
   unfold OUTpred, Done, digest_len. normalize.
   freeze [0;3;4;5;6;7] FR5.

   idtac "Timing the call to _memcpy".
   Time forward_call (hkdf_compspecs.CompSpecs, (Tsh, shmd),
                 offset_val (32*i1) out, previous,
                 olen - (32* i1), 32,
             if zlt olen (32 * i1 + 32)
             then olen - 32 * i1
             else 32, map Int.repr CONTRIB).
   { destruct (zlt olen (32 * i1 + 32)); simpl; entailer!. }
   { simpl; cancel. }
   { simpl. split. apply readable_share_top. split; trivial.
     destruct (zlt olen (32 * i1 + 32)); omega. }
   forward.

   (* establish loop invariant*)
   destruct (zeq (i1 + 1) 0); try omega.
   destruct (zlt olen (32 * i1 + 32)).
   + entailer!.
     * clear - OLEN2 olenBounded OLEN Hi1 REST l0. unfold Done, digest_len in *. simpl.
       rewrite add_repr.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds); rewrite Int.unsigned_repr; omega.
       - destruct (zlt (i1 + 1) (rounds+1)). rewrite Int.unsigned_repr; omega.
         rewrite Int.unsigned_repr; try omega. split. omega. f_equal. f_equal. omega.
     * thaw FR5. destruct out; try contradiction. simpl. rewrite Zminus_diag, memory_block_zero_Vptr. cancel.
       clear H1 H2 H AC SC H4 H5.
       unfold data_block. normalize. rewrite LEN, data_at_tuchar_singleton_array_eq. cancel.
       rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; try omega. 2: change (two_p 8 - 1) with 255; omega.

         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont; simpl; trivial.
         ++ clear - Hl n0 Hi1. destruct Hl. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. omega.
       - unfold OUTpred, digest_len. simpl.
         destruct (zeq rest 0).
         ++ subst rest; simpl. rewrite Zplus_0_r in *. omega.
         ++ destruct (zlt (i1 + 1) (rounds + 1)); try solve [omega].
            assert (i1 = rounds) by omega. subst i1.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite Zmin_r; [| omega].
            rewrite Zminus_diag, memory_block_zero_Vptr; try solve [omega].
            replace (((rounds + 1)*32)%Z) with ((32 * (rounds + 1) + 0)%Z) by omega.
            rewrite (split2_data_at_Tarray_tuchar shmd (32 * rounds + rest) (32 * rounds)); simpl; trivial; try omega.

            Focus 2. rewrite Zlength_sublist; try omega.
                     rewrite 2 Zlength_map.
                     rewrite Zlength_HKDF_expand; simpl; omega.
            unfold tarray; cancel.
               rewrite field_address0_offset; simpl.
               2: eapply field_compatible0_cons_Tarray; [ reflexivity | trivial | omega].
            entailer!. rewrite sublist_sublist; try omega.
            rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite ! sublist_map.

            replace (rounds * 32)%Z with (32*rounds)%Z by omega.
            rewrite sublist_HKDF_expand4, <- sublist_HKDF_expand2; trivial; try omega.
            cancel.

   + entailer!.
     * clear H H0 H1 H2 H3 H4 H5 AC SC JMeq_1 LEN. unfold Done, digest_len in *. simpl.
       rewrite add_repr.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
       - destruct (zlt (i1 + 1) (rounds+1)).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
     * thaw FR5. cancel.
       unfold data_block, digest_len. normalize. rewrite LEN, data_at_tuchar_singleton_array_eq. cancel.
       rewrite Z.min_l by omega.
       repeat rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; try omega. 2: change (two_p 8 - 1) with 255; omega.

         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont. simpl; trivial.
         ++ clear - Hl n0 Hi1. destruct Hl. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. omega.
       - unfold OUTpred, digest_len. simpl. rewrite Z.mul_add_distr_l, Z.mul_1_r.
         rewrite zero_ext_inrange; rewrite Int.unsigned_repr; try omega.
         2: change (two_p 8 - 1) with 255; omega.
         destruct (zeq rest 0).
         ++ subst rest; simpl in *. rewrite Zplus_0_r in *.
            destruct (zlt (i1+1) rounds).
            ** replace (32 * rounds - (32 * i1 + 32)) with (32 * rounds - 32 * i1 - 32) by omega. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1+32) (32 * i1)); simpl; trivial; try omega.
               -- unfold tarray.
                  replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                  rewrite field_address0_offset; simpl.
                  Focus 2. eapply field_compatible0_cons_Tarray. reflexivity.
                           eapply field_compatible_array_smaller0. apply FCout. omega. omega.
                  rewrite sublist_sublist; try omega.
                  rewrite sublist_sublist; try omega.
                  rewrite ! sublist_map, !  Z.mul_1_l, ! Z.add_0_r, ! Z.add_0_l.
                  clear - Hl Hi1.
                  replace ((i1 + 1) * 32)%Z with (32*(i1 + 1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite <- sublist_HKDF_expand2; try omega.
                  erewrite <- sublist_HKDF_expand5; try omega; try eassumption. cancel.
              -- rewrite Zlength_sublist; try omega. rewrite ! Zlength_map.
                 replace ((i1 + 1) * 32)%Z with ((32 * (i1 + 1))+0) by omega.
                 rewrite Zlength_HKDF_expand; omega.
            ** assert (rounds = i1+1) by omega. subst rounds; simpl in *.
               replace (32 * (i1 + 1))%Z with ((32 * i1 + 32)%Z) by omega.
               replace (32 * i1 + 32 - 32 * i1 - 32)%Z with 0%Z by omega.
               rewrite Zminus_diag, memory_block_zero. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1 + 32) (32 * i1)); simpl; trivial; try omega.
               -- replace ((32 * i1 + 32 - 32 * i1)%Z) with 32%Z by omega.
                  rewrite field_address0_offset by auto with field_compatible. simpl.
                  repeat rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r, ! Z.add_0_l, ! Z.mul_1_l.
                  unfold tarray; rewrite sepcon_comm.
                  replace ((i1 + 1) * 32)%Z with (32*(i1+1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite ! sublist_map, <- (sublist_HKDF_expand5 PRK INFO l i1 Hl),
                    <- sublist_HKDF_expand2; try omega; cancel.
               -- rewrite Zlength_sublist; try omega. rewrite 2 Zlength_map.
                  replace (((i1 + 1)*32)%Z) with ((32 * (i1 + 1) + 0)%Z) by omega.
                  rewrite Zlength_HKDF_expand; omega.
          ++ replace (32 * rounds + rest - 32 * i1 - 32)%Z with (32 * rounds + rest - (32 * i1 + 32))%Z by omega.
             cancel.

             rewrite (split2_data_at_Tarray_tuchar shmd (32*i1 + 32) (32*i1)); simpl; trivial; try omega.
                ** rewrite field_address0_offset; simpl. rewrite Z.mul_1_l, Z.add_0_l.
                   rewrite ! sublist_map, ! sublist_sublist, ! Z.add_0_r; try omega.
                   replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                   replace ((i1 + 1)*32)%Z with (32*(i1+1))%Z by omega.
                   replace (i1*32)%Z with (32*i1)%Z by omega.
                   rewrite <- (sublist_HKDF_expand5 PRK INFO l i1 Hl), <- sublist_HKDF_expand2; try omega. cancel.
                   eapply field_compatible0_cons_Tarray; [ reflexivity | | omega].
                   eapply field_compatible_array_smaller0; [ apply FCout | omega].
                ** rewrite ! sublist_map, ! Zlength_map, Zlength_sublist; try omega.
                   replace ((i1 + 1) * 32)%Z with (32 * (i1+1) + 0)%Z by omega.
                   rewrite Zlength_HKDF_expand; omega. }
(*Continuation after loop*)
  normalize. rewrite if_false in H. 2: omega. clear H. (*eliminate this PROP in loop invariant entirely?*)

  forward.
    freeze [0;1;2;3;4;6] FR6.

  idtac "Timing the call to _HMAC_cleanup".
  Time forward_call (CONT PRK, hmac).
  (*Finished transaction in 25.172 secs (20.796u,0.s) (successful)*)
    { assert (Frame = [FRZL FR6]). subst Frame; reflexivity.
      subst Frame; simpl. cancel.
      destruct (zeq bnd 0); trivial. apply HMAC_SPEC.REP_FULL. }
    forward_if (
  (PROP ( )
   LOCAL (temp _ret (Vint (Int.repr 1)); temp _i (Vint (Int.repr bnd));
   temp _n (Vint (Int.repr bnd));
   temp _done (Vint (if zlt bnd bnd then Done bnd else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) hmac;
   lvar _previous (tarray tuchar 64) previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvar sha._K256 kv)
   SEP (HMAC_SPEC.EMPTY hmac; FRZL FR6))).
     { forward. entailer!. }
     { forward. entailer!. }

  forward. Exists ctr.
     Exists (expand_out_post shmd (CONT PRK) (CONT INFO) (32 * rounds + rest) out).
     Exists hmac previous.
     Time entailer.
     apply andp_right.
     + apply prop_right. unfold expand_out_post, digest_len.
       rewrite if_false. 2: omega.
       rewrite if_false. simpl; trivial.
       destruct (zeq rest 0); simpl in *.
       - subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega.
         rewrite X; clear X. erewrite <- Zdiv.Zdiv_unique. 3: reflexivity. omega. omega.
       - assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega.
         rewrite X; clear X.
         rewrite Z.div_add_l; try omega.
         erewrite Zdiv_unique with (b:=rest -1)(a:=1); omega.
     + thaw FR6. thaw FR0. cancel. unfold expand_out_post, digest_len.
        rewrite 2 sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives; [| apply HMAC_SPEC.EmptyDissolve].
        rewrite <- sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives.
        - destruct (zlt (32 * rounds + rest + 32) (32 * rounds + rest)); try omega.
          destruct (zlt (if zeq rest 0 then rounds else rounds + 1) (if zeq rest 0 then rounds else rounds + 1)); try omega.
          unfold OUTpred, data_block.
          rewrite Z.min_r by (destruct (zeq rest 0); omega).
          rewrite Zminus_diag, memory_block_zero, Zlength_HKDF_expand; try omega. normalize.
          destruct (zlt 255 ((32 * rounds + rest + 32 - 1) / 32)).
          { exfalso. destruct (zeq rest 0).
            + subst rest; simpl in *. replace (32 * rounds + 0 + 32 - 1)%Z with (rounds * 32 + 31) in l by omega.
              rewrite Z_div_plus_full_l, Zdiv_small in l; omega.
            + replace (32 * rounds + rest + 32 - 1)%Z with (rounds * 32 + (rest + 31))%Z in l by omega.
              rewrite Z_div_plus_full_l in l; try omega. erewrite (Zdiv_unique _ _ 1 ((rest + 31)-32)) in l; omega. }
          simpl.
          apply andp_right. apply prop_right; apply isbyteZ_HKDF_expand.
          apply data_at_ext_derives; trivial.
          destruct (zeq rest 0).
          * subst rest; simpl. rewrite Z.add_0_r, sublist_same, Z.mul_comm; trivial.
            rewrite ! Zlength_map. replace ((rounds*32)%Z) with ((32 * rounds + 0)%Z) by omega.
            rewrite Zlength_HKDF_expand; omega.
          * replace ((rounds + 1)*32)%Z with (32 * rounds + 32)%Z by omega.
            rewrite 2 sublist_map. f_equal. f_equal.
            apply sublist_HKDF_expand3; omega.
        - rewrite (split2_data_at__Tarray_tuchar Tsh 64 32); simpl; trivial; try omega.
          rewrite field_address0_offset. cancel.
          eapply field_compatible0_cons_Tarray; [reflexivity | trivial | omega].
Time Qed.
 (*Coq8.6:37secs*)
 (*Finished transaction in 195.171 secs (171.828u,0.031s) (successful)*)
 (* Last week: Finished transaction in 54.281 secs (49.656u,0.015s) (successful)*)


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 conj22eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (mult lv1 lv2)) (plus Zero (plus (mult lv1 lv2) lv0))).
Admitted.
QuickChick conj22eqsynthconj1.


Require Import GeoCoq.Tactics.Coinc.tactics_axioms.
Require Import GeoCoq.Tarski_dev.Annexes.inscribed_angle.

Section Tarski_is_a_Coinc_theory_for_concyclic.

Context `{TE:Tarski_euclidean}.

Definition not_col : arity Tpoint 3 := fun A B C : Tpoint => ~ Col A B C.

Lemma not_col_perm_1 : forall A X, app_1_n not_col A X -> app_n_1 not_col X A.
Proof. unfold not_col; simpl; Col. Qed.

Lemma not_col_perm_2 : forall A B (X : cartesianPower Tpoint 1),
  app_2_n not_col A B X -> app_2_n not_col B A X.
Proof. unfold not_col, app_2_n; simpl; Col. Qed.

Definition concy : arity Tpoint 4 := Concyclic_gen.

Lemma concy_perm_1 : forall (A : Tpoint) (X : cartesianPower Tpoint 3),
app_1_n concy A X -> app_n_1 concy X A.
Proof. unfold concy; simpl. intros; apply concyclic_gen_perm_1; auto. Qed.

Lemma concy_perm_2 : forall (A B : Tpoint) (X : cartesianPower Tpoint 2),
app_2_n concy A B X -> app_2_n concy B A X.
Proof.
unfold app_2_n, concy; simpl; intros; apply concyclic_gen_perm_2; auto.
Qed.

Lemma concyclic_gen_1123 : forall A B C, Concyclic_gen A A B C.
Proof.
unfold Concyclic_gen; simpl; intros A B C.
elim (col_dec A B C); intro; [right; repeat split; Col|].
left.
split; Cop.
destruct (triangle_circumscription A B C H) as [O]; spliter.
exists O, A; unfold OnCircle; repeat split; Cong.
Qed.

Lemma concy_bd : forall (A : Tpoint) (X : cartesianPower Tpoint 2),
app_2_n concy A A X.
Proof. unfold app_2_n, concy; simpl; intros; apply concyclic_gen_1123. Qed.

Lemma concy_3 :
  forall (CONCY : cartesianPower Tpoint 4) (NOT_COL : cartesianPower Tpoint 3),
  pred_conj concy CONCY NOT_COL -> app not_col NOT_COL -> app concy CONCY.
Proof.
unfold pred_conj, app_2_n, concy; simpl.
intros CONCY NOT_COL HConcy HNot_Col.
destruct HConcy as [HConcy1 [HConcy2 [HConcy3 HConcy4]]].
apply concyclic_gen_pseudo_trans with (fst NOT_COL) (fst (snd NOT_COL)) (snd (snd NOT_COL)); try apply concyclic_gen_perm_1; auto.
Qed.

Global Instance Tarski_is_a_Arity_for_concy : Arity.
Proof. exact (Build_Arity Tpoint 1). Defined.

Global Instance Tarski_is_a_Coinc_predicates_for_concy :
  (Coinc_predicates Tarski_is_a_Arity_for_concy).
Proof.
exact (Build_Coinc_predicates Tarski_is_a_Arity_for_concy not_col concy).
Defined.

Global Instance Tarski_is_a_Coinc_theory_for_concy : (Coinc_theory Tarski_is_a_Arity_for_concy Tarski_is_a_Coinc_predicates_for_concy).
Proof.
exact (Build_Coinc_theory Tarski_is_a_Arity_for_concy Tarski_is_a_Coinc_predicates_for_concy not_col_perm_1 not_col_perm_2 concy_perm_1 concy_perm_2 concy_bd concy_3).
Qed.

End Tarski_is_a_Coinc_theory_for_concyclic.


Require Import Coq.Classes.DecidableClass.

Definition decideP (P : Prop) {D : Decidable P} : {P} + {~P} :=
  match @Decidable_witness P D as X return (X = true -> P) -> (X = false -> ~P) -> {P} + {~P} with
  | true => fun pf _ => left (pf eq_refl)
  | false => fun _ pf => right (pf eq_refl)
  end (@Decidable_sound _ D) (@Decidable_complete_alt _ D).

Ltac cases_ifd Hn :=
  match goal with
    |- context[if ?d then ?tt else ?ff] =>
    let Hnt := fresh Hn "t" in
    let Hnf := fresh Hn "f" in
    destruct d as [Hnt | Hnf] end.

Lemma decide_decideP  {P:Prop }`{Decidable P} {R:Type} (a b : R) :
  (if (decide P) then  a else b) = (if (decideP P) then  a else b).
Proof.
  symmetry. unfold decide.
  destruct (decideP P).
- rewrite Decidable_complete; auto.
- rewrite Decidable_sound_alt; auto.
Qed.