(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 14: Separation Logic
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap Setoid Classes.Morphisms SepCancel.

Set Implicit Arguments.
Set Asymmetric Patterns.

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

Definition heap := fmap nat nat.

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

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

(** * Encore of last mixed-embedding language from last time *)

(* Let's work with a variant of the imperative language from last time. *)

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

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

(* But let's also add memory allocation and deallocation. *)
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit.

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

(* These helper functions respectively initialize a new span of memory and
 * remove a span of memory that the program is done with. *)

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

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

(* Let's do the semantics a bit differently this time, falling back on classic
 * small-step operational semantics. *)
Inductive step : forall A, heap * cmd A -> heap * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h h',
  step (h, c1) (h', c1')
  -> step (h, Bind c1 c2) (h', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h,
  step (h, Bind (Return v) c2) (h, c2 v)

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

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

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

(* Now let's get into the first distinctive feature of separation logic: an
 * assertion language that takes advantage of *pariality* of heaps.  We give our
 * definitions inside a module, which will shortly be used as a parameter to
 * another module (from the book library), to get some free automation for
 * implications between these assertions. *)
Module Import S <: SEP.
  Definition hprop := heap -> Prop.
  (* A [hprop] is a regular old assertion over heaps. *)

  (* Implication *)
  Definition himp (p q : hprop) := forall h, p h -> q h.

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

  (* Lifting a pure proposition: it must hold, and the heap must be empty. *)
  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  (* Separating conjunction, one of the two big ideas of separation logic.
   * When does [star p q] apply to [h]?  When [h] can be partitioned into two
   * subheaps [h1] and [h2], respectively compatible with [p] and [q].  See book
   * module [Map] for definitions of [split] and [disjoint]. *)
  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

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

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

  Local Open Scope sep_scope.

  (* And now we prove some key algebraic properties, whose details aren't so
   * important.  The library automation uses these properties. *)

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

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

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

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

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

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

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

  Hint Resolve split_empty_bwd'.

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

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

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

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

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

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

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

Export S.
(* Instantiate our big automation engine to these definitions. *)
Module Import Se := SepCancel.Make(S).

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

(* Capturing single-mapping heaps *)
Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

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

(* For describing a "struct" in memory at consecutive addresses *)
Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

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

(* We'll use this one to describe the struct returned by [Alloc]. *)
Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

(* For recording merely that a range of cells is mapped into our memory space *)
Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

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

(** * Finally, the Hoare logic *)

Inductive hoare_triple : forall {result}, hprop -> cmd result -> (result -> hprop) -> Prop :=
(* First, four basic rules that look exactly the same as before *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple P c1 Q
    -> (forall r, hoare_triple (Q r) (c2 r) R)
    -> hoare_triple P (Bind c1 c2) R
| HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
    (forall acc, hoare_triple (I (Again acc)) (body acc) I)
    -> hoare_triple (I (Again init)) (Loop init body) (fun r => I (Done r))
| HtFail : forall {result},
    hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False)

(* Now the new rules for primitive heap operations: *)

| HtRead : forall a R,
    hoare_triple (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
(* To read from an address, it must be mapped into the address space with some
 * value.  Afterward, that address is known to point to the result value [r].
 * An additional *frame* predicate [R] is along for the ride. *)

| HtWrite : forall a v',
    hoare_triple (exists v, a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
(* To write to an address, just show that it's mapped into the address space.
 * Afterward, that address points to the value we've written.  Note that this
 * rule is in the *small-footprint* style, with no frame predicate baked in. *)

| HtAlloc : forall numWords,
    hoare_triple emp%sep (Alloc numWords) (fun r => r |--> zeroes numWords)%sep
(* Allocation works in any memory, transitioning to a state where the result
 * value points to a sequence of zeroes. *)

| HtFree : forall a numWords,
    hoare_triple (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep
(* Deallocation requires an argument pointing to the appropriate number of
 * words, taking us to a state where those addresses are unmapped. *)

| HtConsequence : forall {result} (c : cmd result) P Q (P' : hprop) (Q' : _ -> hprop),
    hoare_triple P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P' c Q'
(* This is essentially the same rule of consequence from before. *)

| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple P c Q
    -> hoare_triple (P * R)%sep c (fun r => Q r * R)%sep.
(* The *frame rule* is the other big idea of separation.  We can extend any
 * Hoare triple by starring an arbitrary assertion [R] into both precondition
 * and postcondition.  Note that rule [HtRead] built in a variant of the frame
 * rule, where the frame predicate [R] may depend on the value [v] being read.
 * The other operations can use this generic frame rule instead. *)

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

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

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

(* Now, we carry out a moderately laborious soundness proof!  It's safe to skip
 * ahead to the text "Examples", but a few representative lemma highlights
 * include [invert_Read], [preservation], [progress], and the main theorem
 * [hoare_triple_sound]. *)

Lemma invert_Return : forall {result : Set} (r : result) P Q,
  hoare_triple P (Return r) Q
  -> forall h, P h -> Q r h.
Proof.
  induct 1; propositional; eauto.

  exists h, $0; propositional; eauto.
  unfold lift; propositional.

  unfold himp in *; eauto.

  unfold star, himp in *; simp; eauto 7.
Qed.

Hint Constructors hoare_triple.

Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
  hoare_triple P (Bind c1 c2) Q
  -> exists R, hoare_triple P c1 R
               /\ forall r, hoare_triple (R r) (c2 r) Q.
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  eexists; propositional.
  eapply HtWeaken.
  eassumption.
  auto.
  eapply HtStrengthen.
  apply H4.
  auto.

  simp.
  exists (fun r => x r * R)%sep.
  propositional.
  eapply HtFrame; eauto.
  eapply HtFrame; eauto.
Qed.

Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
    hoare_triple P (Loop init body) Q
    -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                 /\ (forall h, P h -> I (Again init) h)
                 /\ (forall r h, I (Done r) h -> Q r h).
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  exists x; propositional; eauto.
  unfold himp in *; eauto.

  simp.
  exists (fun o => x o * R)%sep; propositional; eauto.
  unfold star in *; simp; eauto 7.
  unfold star in *; simp; eauto 7.
Qed.

Lemma invert_Fail : forall result P Q,
  hoare_triple P (Fail (result := result)) Q
  -> forall h, P h -> False.
Proof.
  induct 1; propositional; eauto.

  unfold star in *; simp; eauto.
Qed.

(* Now that we proved enough basic facts, let's hide the definitions of all
 * these predicates, so that we reason about them only through automation. *)
Opaque heq himp lift star exis ptsto.

Lemma unit_not_nat : unit = nat -> False.
Proof.
  simplify.
  assert (exists x : unit, forall y : unit, x = y).
  exists tt; simplify.
  cases y; reflexivity.
  rewrite H in H0.
  invert H0.
  specialize (H1 (S x)).
  linear_arithmetic.
Qed.

Lemma invert_Read : forall a P Q,
  hoare_triple P (Read a) Q
  -> exists R, (P ===> exists v, a |-> v * R v)%sep
               /\ forall r, a |-> r * R r ===> Q r.
Proof.
  induct 1; simp; eauto.

  exists R; simp.
  cancel; auto.
  cancel; auto.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (fun n => x n * R)%sep; simp.
  rewrite H1.
  cancel.

  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Write : forall a v' P Q,
  hoare_triple P (Write a v') Q
  -> exists R, (P ===> (exists v, a |-> v) * R)%sep
               /\ a |-> v' * R ===> Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  exists emp; simp.
  cancel; auto.
  cancel; auto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (x * R)%sep; simp.
  rewrite H1.
  cancel.

  cancel.
  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Alloc : forall numWords P Q,
  hoare_triple P (Alloc numWords) Q
  -> forall r, P * r |--> zeroes numWords ===> Q r.
Proof.
  induct 1; simp; eauto.

  apply unit_not_nat in x0; simp.

  cancel.

  apply unit_not_nat in x0; simp.

  rewrite H0.
  eauto using himp_trans.

  rewrite <- IHhoare_triple.
  cancel.
Qed.

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma zeroes_initialize' : forall h a v,
    h $? a = None
    -> (fun h' : heap => h' = h $+ (a, v)) ===> (fun h' => h' = h) * a |-> v.
Proof.
  unfold himp, star, split, ptsto, disjoint; simp.
  exists h, (heap1 a v).
  propositional.
  maps_equal.
  unfold heap1.
  rewrite lookup_join2.
  simp.
  simp.
  apply lookup_None_dom in H.
  propositional.
  cases (h $? k).
  rewrite lookup_join1; auto.
  eauto using lookup_Some_dom.
  rewrite lookup_join2; auto.
  unfold heap1; simp.
  eauto using lookup_None_dom.
  unfold heap1 in *.
  cases (a ==n a0); simp.
Qed.

(* Opaque again! *)
Opaque heq himp lift star exis ptsto.

Lemma multi_ptsto_app : forall ls2 ls1 a,
     a |--> ls1 * (a + length ls1) |--> ls2 ===> a |--> (ls1 ++ ls2).
Proof.
  induct ls1; simp; cancel; auto.

  replace (a + 0) with a by linear_arithmetic.
  cancel.

  rewrite <- IHls1.
  cancel.
  replace (a0 + 1 + length ls1) with (a0 + S (length ls1)) by linear_arithmetic.
  cancel.
Qed.

Lemma length_zeroes : forall n,
    length (zeroes n) = n.
Proof.
  induct n; simplify; auto.
  rewrite app_length; simplify.
  linear_arithmetic.
Qed.

Lemma initialize_fresh : forall a' h a numWords,
    a' >= a + numWords
    -> initialize h a numWords $? a' = h $? a'.
Proof.
  induct numWords; simp; auto.
Qed.

Lemma zeroes_initialize : forall numWords a h,
    (forall i, i < numWords -> h $? (a + i) = None)
    -> (fun h' => h' = initialize h a numWords) ===> (fun h' => h' = h) * a |--> zeroes numWords.
Proof.
  induct numWords; simp.

  cancel; auto.
  rewrite <- multi_ptsto_app.
  rewrite zeroes_initialize'.
  erewrite IHnumWords.
  simp.
  rewrite length_zeroes.
  cancel; auto.
  auto.
  rewrite initialize_fresh; auto.
Qed.

Lemma invert_Free : forall a numWords P Q,
  hoare_triple P (Free a numWords) Q
  -> P ===> a |->? numWords * Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  cancel; auto.

  rewrite H0.
  rewrite IHhoare_triple.
  cancel; auto.

  rewrite IHhoare_triple.
  cancel; auto.
Qed.

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma do_deallocate' : forall a Q h,
    ((exists v, a |-> v) * Q)%sep h
    -> Q (h $- a).
Proof.
  unfold ptsto, star, split, heap1; simp.
  invert H1.
  replace ($0 $+ (a, x1) $++ x0 $- a) with x0; auto.
  maps_equal.
  cases (k ==n a); simp.
  specialize (H a).
  simp.
  cases (x0 $? a); auto.
  exfalso; apply H; equality.
  rewrite lookup_join2; auto.
  apply lookup_None_dom.
  simp.
Qed.

Lemma do_deallocate : forall Q numWords a h,
    (a |->? numWords * Q)%sep h
    -> Q (deallocate h a numWords).
Proof.
  induct numWords; simp.

  unfold star, exis, lift in H; simp.
  apply split_empty_fwd' in H0; simp.

  apply IHnumWords.
  clear IHnumWords.

  apply do_deallocate'.
  Opaque heq himp lift star exis ptsto.
  match goal with
  | [ H : ?P h |- ?Q h ] => assert (P ===> Q) by cancel
  end.
  Transparent himp.
  apply H0; auto.
  Opaque himp.
Qed.

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

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma preservation : forall {result} (c : cmd result) h c' h',
    step (h, c) (h', c')
    -> forall Q, hoare_triple (fun h' => h' = h) c Q
                 -> hoare_triple (fun h'' => h'' = h') c' Q.
Proof.
  induct 1; simplify.

  apply invert_Bind in H0; simp.
  eauto.

  apply invert_Bind in H; simp.
  specialize (invert_Return H); eauto using HtWeaken.

  apply invert_Loop in H; simp.
  econstructor.
  eapply HtWeaken.
  eauto.
  assumption.
  simp.
  cases r.
  apply HtReturn'.
  unfold himp; simp; eauto.
  eapply HtStrengthen.
  eauto.
  unfold himp; simp; eauto.

  apply invert_Read in H0; simp.
  apply HtReturn'.
  assert ((exists v, a |-> v * x v)%sep h') by auto.
  unfold exis, star in H1; simp.
  unfold ptsto in H4; subst.
  unfold split in H1; subst.
  unfold heap1 in H.
  rewrite lookup_join1 in H by (simp; sets).
  unfold himp; simp.
  invert H.
  apply H2.
  unfold star.
  exists (heap1 a v), x2; propositional.
  unfold split; reflexivity.
  unfold ptsto; reflexivity.

  apply invert_Write in H0; simp.
  apply HtReturn'.
  simp.
  assert (((exists v : nat, a |-> v) * x)%sep h) by auto.
  unfold star in H1; simp.
  invert H4.
  unfold ptsto in H5; subst.
  unfold split in H3; subst.
  unfold heap1 in H.
  rewrite lookup_join1 in H by (simp; sets).
  unfold himp; simp.
  invert H.
  apply H2.
  unfold star.
  exists ($0 $+ (a, v')), x1; propositional.
  unfold split.
  unfold heap1.
  maps_equal.
  rewrite lookup_join1 by (simp; sets).
  simp.
  repeat rewrite lookup_join2 by (simp; sets); reflexivity.
  unfold disjoint in *; simp.
  cases (a0 ==n a); simp.
  apply H1 with (a0 := a).
  unfold heap1; simp.
  equality.
  assumption.
  unfold ptsto; reflexivity.

  apply invert_Alloc with (r := a) in H0.
  apply HtReturn'.
  unfold himp; simp.
  eapply himp_trans in H0; try apply zeroes_initialize.
  auto.
  assumption.

  apply invert_Free in H.
  assert ((a |->? numWords * Q tt)%sep h) by auto.
  apply HtReturn'.
  unfold himp; simp.
  eapply do_deallocate.
  eauto.
Qed.

Lemma deallocate_None : forall a' numWords h a,
    h $? a' = None
    -> deallocate h a numWords $? a' = None.
Proof.
  induct numWords; simp.
  rewrite IHnumWords; simp.
  cases (a ==n a'); simp.
Qed.

Lemma preservation_finite : forall {result} (c : cmd result) h c' h' bound,
    step (h, c) (h', c')
    -> (forall a, a >= bound -> h $? a = None)
    -> exists bound', forall a, a >= bound' -> h' $? a = None.
Proof.
  induct 1; simplify; eauto.

  exists bound; simp.
  cases (a ==n a0); simp.
  rewrite H0 in H; equality.
  auto.

  exists (max bound (a + numWords)); simp.
  rewrite initialize_fresh; auto.

  exists bound; simp.
  eauto using deallocate_None.
Qed.

Hint Constructors step.

Lemma progress : forall {result} (c : cmd result) P Q,
    hoare_triple P c Q
    -> forall h h1 h2, split h h1 h2
                       -> disjoint h1 h2
                       -> P h1
                       -> (exists bound, forall a, a >= bound -> h $? a = None)
                       -> (exists r, c = Return r)
                          \/ (exists h' c', step (h, c) (h', c')).
Proof.
  induct 1; simp;
  repeat match goal with
           | [ H : forall _ h1 _, _ -> _ -> ?P h1 -> _, H' : ?P _ |- _ ] => eapply H in H'; clear H; try eassumption; simp
         end; eauto.

  invert H1.
  right; exists h, (Return x0).
  constructor.
  unfold split, ptsto, heap1 in *; simp.
  unfold star in H2; simp.
  unfold split in H; simp.
  rewrite lookup_join1; simp.
  rewrite lookup_join1; simp.
  sets.
  eapply lookup_Some_dom.
  rewrite lookup_join1; simp.
  sets.

  right; exists (h $+ (a, v')), (Return tt).
  unfold split, exis, ptsto, heap1 in *; simp.
  econstructor.
  rewrite lookup_join1; simp.
  sets.

  unfold lift in H1; simp.
  apply split_empty_fwd' in H; simp.
  right; exists (initialize h2 x numWords), (Return x).
  constructor.
  simp; auto.

  unfold star in H2; simp.
  apply IHhoare_triple with (h := h) (h1 := x0) (h2 := h2 $++ x1); eauto.
  unfold split in *; simp.
  rewrite (@join_comm _ _ h2 x1).
  apply join_assoc.
  sets.
  cases (h2 $? x2).
  cases (x1 $? x2).
  specialize (H2 x2).
  specialize (H1 x2).
  rewrite lookup_join2 in H1.
  apply H1; equality.
  unfold not.
  simplify.
  cases (x0 $? x2).
  exfalso; apply H2; equality.
  apply lookup_None_dom in Heq1; propositional.
  apply lookup_None_dom in Heq0; propositional.
  apply lookup_None_dom in Heq; propositional.

  unfold split, disjoint in *; simp.
  cases (h2 $? a).
  rewrite lookup_join1 in H8.
  apply H1 with (a := a); auto.
  rewrite lookup_join1; auto.
  cases (x0 $? a); try equality.
  eauto using lookup_Some_dom.
  eauto using lookup_Some_dom.
  rewrite lookup_join2 in H8.
  eapply H2; eassumption.
  eauto using lookup_None_dom.
Qed.

Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
    hoare_triple P c Q
    -> P $0
    -> invariantFor (trsys_of $0 c)
                    (fun p =>
                       (exists bound, forall a, a >= bound -> fst p $? a = None)
                       /\ hoare_triple (fun h' => h' = fst p)
                                       (snd p)
                                       Q).
Proof.
  simplify.

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  exists 0; simp.
  eapply HtWeaken; eauto.
  unfold himp; simplify; equality.

  cases s.
  cases s'.
  simp.
  eauto using preservation_finite.
  eauto using preservation.
Qed.

Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
    hoare_triple P c Q
    -> P $0
    -> invariantFor (trsys_of $0 c)
                    (fun p => (exists r, snd p = Return r)
                              \/ (exists p', step p p')).
Proof.
  simplify.

  eapply invariant_weaken.
  eapply hoare_triple_sound'; eauto.
  simp.
  specialize (progress H3); simplify.
  specialize (H2 (fst s) (fst s) $0).
  assert (split (fst s) (fst s) $0) by auto.
  assert (disjoint (fst s) $0) by auto.
  assert (exists bound, forall a, a >= bound -> fst s $? a = None) by eauto.
  cases s; simp; eauto.
Qed.

(* Fancy theorem to help us rewrite within preconditions and postconditions *)
Instance hoare_triple_morphism : forall A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

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

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

(** * Examples *)

Opaque heq himp lift star exis ptsto.

(* Here comes some automation that we won't explain in detail, instead opting to
 * use examples. *)

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

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

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

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree.

Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel; auto ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel; auto ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel; auto ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                      || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
Ltac loop_inv Inv := loop_inv0 Inv; ht.
Ltac use H := (eapply use_lemma; [ eapply H | cancel; auto ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel; auto ] | ]).

Ltac heq := intros; apply himp_heq; split.

(* That's the end of the largely unexplained automation.  Let's prove some
 * programs! *)

(** ** Swapping with two pointers *)

Definition swap p q :=
  tmpp <- Read p;
  tmpq <- Read q;
  _ <- Write p tmpq;
  Write q tmpp.

(* Looking at the precondition here, note how we no longer work with explicit
 * functions over heaps.  All that is hidden within the assertion language.
 * Also note that the definition of [*] gives us nonaliasing of [p] and [q] for
 * free! *)
Theorem swap_ok : forall p q a b,
  {{p |-> a * q |-> b}}
    swap p q
  {{_ ~> p |-> b * q |-> a}}.
Proof.
  unfold swap.
  (* [simp] is our generic simplifier for this file. *)
  simp.
  (* We generally just keep calling [step] to advance forward by one atomic
   * statement. *)
  step.
  step.
  (* We do often want to use [simp] to clean up the goal after [step] infers an
   * intermediate assertion. *)
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  (* The [cancel] procedure repeatedly finds matching subformulas on the two
   * sides of [===>], removing them and recurring, possibly learning the values
   * of some unification variables each time. *)
  cancel.
  subst.
  cancel.
Qed.

Opaque swap.
(* This command prevents later proofs from peeking inside the implementation of
 * [swap].  Instead, we only reason about it through [swap_ok]. *)

(* Two swaps in a row provide a kind of rotation across three addresses. *)
Definition rotate p q r :=
  _ <- swap p q;
  swap q r.

Theorem rotate_ok : forall p q r a b c,
  {{p |-> a * q |-> b * r |-> c}}
    rotate p q r
  {{_ ~> p |-> b * q |-> c * r |-> a}}.
Proof.
  unfold rotate.
  simp.
  step.
  (* Now we invoke our earlier theorem by name.  Note that its precondition only
   * matches a subset of our current precondition.  The rest of state is left
   * alone, which we can prove "for free" by the frame rule. *)
  use swap_ok.
  simp.
  use swap_ok.
  simp.
  cancel.
Qed.

Opaque rotate.

(** ** Initializing a fresh object *)

Definition init :=
  p <- Alloc 2;
  _ <- Write p 7;
  _ <- Write (p+1) 8;
  Return p.

Theorem init_ok :
  {{emp}}
    init
  {{p ~> p |--> [7; 8]}}.
Proof.
  unfold init.
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  cancel.
Qed.

Opaque init.

Theorem the_circle_of_life_ok :
  {{emp}}
    p <- init;
    Free p 2
  {{_ ~> emp}}.
Proof.
  step.
  use init_ok.
  simp.
  step.
  cancel.
Qed.

Theorem ultra_combo_ok :
  {{emp}}
    p <- init;
    _ <- swap p (p+1);
    Return p
  {{p ~> p |--> [8; 7]}}.
Proof.
  step.
  use init_ok.
  simp.
  step.
  use swap_ok.
  simp.
  step.
  cancel.
Qed.

(** ** In-place reversal of a singly linked list *)

(* Let's give a recursive definition of how a linked list should be laid out in
 * memory. *)
Fixpoint linkedList (p : nat) (ls : list nat) :=
  match ls with
    | nil => [| p = 0 |]
      (* An empty list is associated with a null pointer and no memory
       * contents. *)
    | x :: ls' => [| p <> 0 |]
                  * exists p', p |--> [x; p'] * linkedList p' ls'
      (* A nonempty list is associated with a nonnull pointer and a two-cell
       * struct, which points to a further list. *)
  end%sep.

(* The definition of [linkedList] is recursive in the list.  Let's also prove
 * lemmas for simplifying [linkedList] invocations based on values of [p]. *)

Theorem linkedList_null : forall ls,
  linkedList 0 ls === [| ls = nil |].
Proof.
  (* Tactic [heq] breaks an equivalence into two implications. *)
  heq; cases ls; cancel.
Qed.

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

Hint Rewrite <- rev_alt.
Hint Rewrite rev_involutive.

(* Let's hide the definition of [linkedList], so that we *only* reason about it
 * via the two lemmas we just proved. *)
Opaque linkedList.

(* In-place linked-list reverse, the "hello world" of separation logic! *)
Definition reverse p :=
  pr <- for pr := (p, 0) loop
    let (p, r) := pr in
    if p ==n 0 then
      Return (Done pr)
    else
      tmp <- Read (p + 1);
      _ <- Write (p+1) r;
      Return (Again (tmp, p))
  done;
  Return (snd pr).

(* Helper function to peel away the [Done]/[Again] status of a [loop_outcome] *)
Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Theorem reverse_ok : forall p ls,
  {{linkedList p ls}}
    reverse p
  {{r ~> linkedList r (rev ls)}}.
Proof.
  unfold reverse.
  simp.
  step.
  (* When we reach a loop, we give the invariant with a special tactic. *)
  loop_inv (fun o => exists ls1 ls2, [| ls = rev_append ls1 ls2 |]
                                     * linkedList (fst (valueOf o)) ls2
                                     * linkedList (snd (valueOf o)) ls1
                                     * [| match o with
                                          | Done (p, _) => p = 0
                                          | _ => True
                                          end |])%sep.
  cases (a ==n 0); simp.
  step.
  cancel.
  step.
  (* We use [setoid_rewrite] for rewriting under binders ([exists], in this
   * case).  Note that we also specify hypothesis [n] explicitly, since
   * [setoid_rewrite] isn't smart enough to infer parameters otherwise. *)
  setoid_rewrite (linkedList_nonnull _ n).
  step.
  simp.
  step.
  step.
  simp.
  step.
  setoid_rewrite (linkedList_nonnull _ n).
  cancel.
  simp.
  setoid_rewrite linkedList_null.
  cancel.
  equality.
  simp.
  step.
  cancel.
  simp.
  setoid_rewrite linkedList_null.
  cancel.
  simp.
  cancel.
Qed.

Opaque reverse.

(* ** Calling [reverse] twice, to illustrate the *frame rule* *)

Theorem reverse_two_ok : forall p1 ls1 p2 ls2,
  {{linkedList p1 ls1 * linkedList p2 ls2}}
    p1 <- reverse p1;
    p2 <- reverse p2;
    Return (p1, p2)
  {{ps ~> linkedList (fst ps) (rev ls1) * linkedList (snd ps) (rev ls2)}}.
Proof.
  simp.
  step.
  use reverse_ok.
  simp.
  step.
  use reverse_ok.
  simp.
  step.
  cancel.
Qed.
(* Note that the intuitive correctness theorem would be *false* for lists
 * sharing any cells in common!  The inherent disjointness of [*] saves us from
 * worrying about those cases. *)

(* ** Computing the length of a linked list *)

(* To state a good loop invariant, it will be helpful to define
 * *list segments* that end with some pointer beside null. *)
Fixpoint linkedListSegment (p : nat) (ls : list nat) (q : nat) :=
  match ls with
    | nil => [| p = q |]
    | x :: ls' => [| p <> 0 |] * exists p', p |-> x * (p+1) |-> p' * linkedListSegment p' ls' q
  end%sep.

(* Next, two [linkedListSegment] lemmas analogous to those for [linkedList]
 * above *)

Lemma linkedListSegment_empty : forall p ls,
  linkedList p ls ===> linkedList p ls * linkedListSegment p nil p.
Proof.
  cancel.
Qed.

Lemma linkedListSegment_append : forall q r x ls p,
  q <> 0
  -> linkedListSegment p ls q * q |-> x * (q+1) |-> r ===> linkedListSegment p (ls ++ x :: nil) r.
Proof.
  induct ls; cancel; auto.
  subst; cancel.
  rewrite <- IHls; cancel; auto.
Qed.

(* One more [linkedList] lemma will be helpful.  We'll re-reveal the predicate's
 * definition to prove the lemma. *)

Transparent linkedList.

Lemma linkedListSegment_null : forall ls p,
  linkedListSegment p ls 0 ===> linkedList p ls.
Proof.
  induct ls; cancel; auto.
Qed.

Opaque linkedList linkedListSegment.

(* A few algebraic properties of list operations: *)
Hint Rewrite <- app_assoc.
Hint Rewrite app_length app_nil_r.

(* We tie a few of them together into this lemma. *)
Lemma move_along : forall A (ls : list A) x2 x1 x0 x,
  ls = x2 ++ x1
  -> x1 = x0 :: x
  -> ls = (x2 ++ [x0]) ++ x.
Proof.
  simp.
Qed.

Hint Resolve move_along.

Theorem length_ok : forall p ls,
  {{linkedList p ls}}
    q_len <- for q_len := (p, 0) loop
      let (q, len) := q_len in
      if q ==n 0 then
        Return (Done q_len)
      else
        tmp <- Read (q + 1);
        Return (Again (tmp, len+1))
    done;
    Return (snd q_len)
  {{len ~> linkedList p ls * [| len = length ls |]}}.
Proof.
  simp.
  step.
  loop_inv (fun o => exists ls1 ls2, [| ls = ls1 ++ ls2 |]
                                     * linkedListSegment p ls1 (fst (valueOf o))
                                     * linkedList (fst (valueOf o)) ls2
                                     * [| snd (valueOf o) = length ls1 |]
                                     * [| match o with
                                          | Done (q, _) => q = 0 /\ ls2 = nil
                                          | _ => True
                                          end |])%sep.
  cases (a ==n 0); simp.
  step.
  setoid_rewrite linkedList_null.
  cancel.
  simp.
  step.
  setoid_rewrite (linkedList_nonnull _ n).
  step.
  simp.
  step.
  cancel.
  eauto.
  simp.
  setoid_rewrite <- linkedListSegment_append.
  cancel.
  auto.
  simp.
  simp.
  rewrite linkedListSegment_empty.
  cancel.
  simp.
  step.
  cancel.
  simp.
  simp.
  rewrite linkedListSegment_null.
  rewrite linkedList_null.
  cancel.
  simp.
Qed.


Require Export CatSem.CAT.category.

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

Section DISCRETE_CAT.

Variable T : Type.

(* Definition Discrete_hom (a b:T) := a = b.
*)
Lemma Discrete_hom_equiv (a b : T) : @Equivalence (a = b)
       (fun p q => True).
Proof.
  intros a b;
  constructor; simpl; auto.
Qed.

Instance Discrete_hom_oid a b : Setoid (a = b) :=
     Build_Setoid (Discrete_hom_equiv a b).
(*
Obligation Tactic := intuition; auto.
*)
Program Instance DISCRETE_struct : Cat_struct (obj:=T) (fun a b => a = b).
Next Obligation.
  apply (Discrete_hom_oid).
Defined.
Next Obligation.
Proof.
  unfold Proper; repeat red.
  auto.
Qed.

Definition DISCRETE := Build_Cat DISCRETE_struct.

End DISCRETE_CAT.


(**
  Ciro Iván García López
  Tesis de Maestría
  Session Type Systems Verification
  Unam - 2021

  This file contains the basic facts concerning names.
*)
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Bool.Bool.
From Coq Require Import Lia.
From Coq Require Import Sets.Constructive_sets.

From Papercod Require Import Defs_Tactics.
From Papercod Require Import Defs_GeneralGrammar.

(**
  Inverse for the beq_nat_false lemma.
*)
Lemma beq_nat_false_inv :
forall ( x y : nat),
x <> y ->
(x =? y) = false.
Proof.
  intros.
  apply not_true_iff_false.
  unfold not.
  intros.
  apply beq_nat_true in H0.
  contradiction.
Qed.
#[global]
Hint Resolve beq_nat_false_inv : Piull.

(**
  Inverse for the beq_nat_true lemma.
*)
Lemma beq_nat_true_inv :
forall ( x y : nat),
x = y ->
(x =? y) = true.
Proof.
  intros.
  rewrite H.
  apply eq_sym.
  apply beq_nat_refl.
Qed.
#[global]
Hint Resolve beq_nat_true_inv : Piull.

(**
*)
Ltac DecidEq :=
  match goal with
    | Gt : ?num0 = ?num1 |- _ =>  apply beq_nat_true_inv in Gt; rewrite Gt
  end;
  auto with Piull.

(**
*)
Lemma Open_Name_BName_Eq :
forall (k i x : nat),
k = i ->
Open_Name k x (BName i) = FName x.
Proof.
  intros.
  simpl.
  DecidEq.
Qed.
#[global]
Hint Resolve Open_Name_BName_Eq : Piull.

(**
*)
Lemma Open_Name_BName_Gt :
forall (k i x : nat),
k < i ->
Open_Name k x (BName i) = BName i.
Proof.
  intros.
  simpl.
  DecidSimple k i.
Qed.
#[global]
Hint Resolve Open_Name_BName_Gt : Piull.

(* (**
Siempre que se hace una sustitución sobre nombres solo se pueden obtener dos resultados, se remplaza o queda igual.
*)
Lemma Subst_Name_Output :
forall ( x y : nat )( z : Name ),
lcName z -> ((Subst_Name x y z = (FName y)) \/ (Subst_Name x y z = z)).
Proof.
  intros.
  inversions H.
  simpl.
  DecidSimple x0 x.
Qed.
#[global]
Hint Resolve Subst_Name_Output : Piull. *)

(**
Análogamente, al cerrar un nombre solo hay dos opciones, se remplazar o queda igual.
*)
Lemma Close_Name_Output :
forall ( i x : nat) ( y : Name),
lcName y -> ( (Close_Name i x y = y) \/ (Close_Name i x y = BName i) ).
Proof.
  intros.
  inversion H.
  simpl.
  DecidSimple x0 x.
Qed.
#[global]
Hint Resolve Close_Name_Output : Piull.

(**
*)
Lemma Open_BName_Output :
forall ( k x p : nat),
Open_Name k x (BName p) = BName p \/ Open_Name k x (BName p) = FName x.
Proof.
  intros.
  simpl.
  DecidSimple k p.
Qed.
#[global]
Hint Resolve Open_BName_Output : Piull.

(**
*)
Lemma Output_LCName_Output :
forall ( p : Name )( k x : nat ),
lcName p -> Open_Name k x p = p.
Proof.
  intros.
  inversions H.
  auto.
Qed.
#[global]
Hint Resolve Output_LCName_Output : Piull.

(**
*)
Lemma Open_BName_IsFName_Eq :
forall ( k x p : nat),
Open_Name k x (BName p) = FName x -> k = p.
Proof.
  intros.
  simpl.
  DecidSimple k p.
  simpl in H.
  rewrite n in H.
  discriminate.
Qed.
#[global]
Hint Resolve Open_BName_IsFName_Eq : Piull.

(**
*)
Lemma Open_BName_IsBName_Eq :
forall ( k x p : nat),
Open_Name k x (BName p) = BName p -> k <> p.
Proof.
  intros.
  DecidSimple k p.
  simpl in H.
  rewrite e in H.
  discriminate.
Qed.
#[global]
Hint Resolve Open_BName_IsBName_Eq : Piull.

(**
*)
Lemma Eq_Open_Name :
forall ( i y k x p : nat),
i <> k ->
Open_Name i y (Open_Name k x (BName p)) = Open_Name k x (Open_Name i y (BName p)).
Proof.
  intros.
  specialize ( Open_BName_Output k x p) as HA.
  specialize ( Open_BName_Output i y p) as HB.
  destruct HA.
  + destruct HB.
    - congruence.
    - rewrite ?H0; rewrite ?H1.
      auto.
 + destruct HB.
  - rewrite H1; rewrite H0.
    auto.
  - apply Open_BName_IsFName_Eq in H0.
    apply Open_BName_IsFName_Eq in H1.
    lia.
Qed.
#[global]
Hint Resolve Eq_Open_Name : Piull.

(* (**
*)
Lemma Subst_BName_Output :
forall ( x y i : nat ),
Subst_Name x y (BName i) = BName i.
Proof.
  auto.
Qed.
#[global]
Hint Resolve Subst_BName_Output : Piull. *)

(* (**
*)
Lemma Subst_Name_Open_Name_Ex :
forall ( x : Name )( x0 y0 z w k: nat ),
FName w = Subst_Name x0 y0 (FName z) ->
Subst_Name x0 y0 (Open_Name k z x) = Open_Name k w (Subst_Name x0 y0 x).
Proof.
  intros.
  destruct x.
  + simpl.
    DecidSimple x x0.
  + specialize ( Open_BName_Output k z i ) as HA.
    destruct HA.
    - rewrite Subst_BName_Output.
      rewrite H0.
      specialize ( Open_BName_Output k w i ) as HB.
      destruct HB.
      * rewrite H1; auto.
      * apply Open_BName_IsFName_Eq in H1.
        apply Open_BName_IsBName_Eq in H0.
        contradiction.
    - rewrite Subst_BName_Output.
      rewrite H0.
      specialize ( Open_BName_Output k w i ) as HB.
      destruct HB.
      * apply Open_BName_IsFName_Eq in H0.
        apply Open_BName_IsBName_Eq in H1.
        contradiction.
      * rewrite H1.
        rewrite H.
        auto.
Qed.
#[global]
Hint Resolve Subst_Name_Open_Name_Ex : Piull. *)

(**
*)
Lemma Open_Close_FName :
forall ( x y : nat ),
(Open_Name 0 x (Close_Name 0 y (FName y))) = (FName x).
Proof.
  intros.
  simpl.
  DecidSimple y y.
Qed.
#[global]
Hint Resolve Open_Close_FName : Piull.

(* (**
*)
Lemma Subst_Name_By_Equal :
forall ( x0 : nat )( x : Name ),
Subst_Name x0 x0 x = x.
Proof.
  intros.
  destruct x; auto.
  simpl.
  DecidSimple x x0.
Qed.
#[global]
Hint Resolve Subst_Name_By_Equal : Piull. *)

(**
------------------------------------------------------------------------------
------------------------------------------------------------------------------
------------------------------------------------------------------------------
lca names results
------------------------------------------------------------------------------
------------------------------------------------------------------------------
------------------------------------------------------------------------------
*)

(**
*)
Lemma Lc_Lca_Zero_Name :
forall ( x : Name ),
lcName x -> lcaName 0 x.
Proof.
  intros.
  inversions H.
  Piauto.
Qed.
#[global]
Hint Resolve Lc_Lca_Zero_Name : Piull.

(**
*)
Lemma Lca_Zero_Lc_Name :
forall ( x : Name ),
lcaName 0 x -> lcName x.
Proof.
  intros.
  destruct x; Piauto.
  inversions H.
  lia.
Qed.
#[global]
Hint Resolve Lca_Zero_Lc_Name : Piull.

(**
*)
Lemma Lca_Name_Open :
forall (x : Name)(i : nat),
(forall (x0 : nat), lcaName i (Open_Name i x0 x)) -> lcaName (S i) x.
Proof.
  intros.
  destruct x; Piauto.
  simpl in H.
  destruct (bool_dec (i =? i0) true).
  rewrite e in H.
  * constructor.
    apply beq_nat_true in e.
    lia.
  * apply not_true_iff_false in n.
    rewrite n in H.
    specialize (H i).
    inversions H.
    constructor.
    auto.
Qed.
#[global]
Hint Resolve Lca_Name_Open : Piull.

(**
*)
Lemma Lca_Name_Rd :
forall ( x : Name )( k y : nat ),
lcaName (S k) x -> lcaName k (Open_Name k y x).
Proof.
  intros.
  inversions H.
  - simpl. constructor.
  - assert ( HI : k = i \/ i < k ). { lia. }
    destruct HI; simpl;
    DecidSimple k i.
Qed.
#[global]
Hint Resolve Lca_Name_Rd : Piull.

(**
*)
Lemma Lca_Name_Close :
forall ( x : Name )( k y : nat ),
lcaName k x -> lcaName (S k) (Close_Name k y x).
Proof.
  intros.
  inversions H; simpl; Piauto.
  DecidSimple x0 y.
Qed.
#[global]
Hint Resolve Lca_Name_Close : Piull.

(* (**
*)
Lemma Subst_Lca_Name :
forall ( x : Name )( k x0 y0 : nat),
lca_name k x -> lca_name k (Subst_Name x0 y0 x).
Proof.
  intros.
  inversions H; Piauto.
  specialize ( Subst_Name_Output x0 y0 (FName x1)) as HS.
  destruct HS; try rewrite H0; constructor.
Qed.
#[global]
Hint Resolve Subst_Lca_Name : Piull. *)

(* (**
*)
Lemma Subst_Name_Gen_Output :
forall (u x0 : nat)(x : Name),
u <> x0 ->
u ∈ FVars_Name (Subst_Name u x0 x) -> False.
Proof.
  intros.
  destruct x; simpl in H0; try inversions H0.
  unfold not in *.
  apply H.
  destruct (bool_dec (x =? u) true).
  + rewrite e in H0.
    apply Singleton_inv in H0.
    auto.
  + apply not_true_iff_false in n.
    rewrite n in H0.
    simpl in H0.
    apply Singleton_inv in H0.
    apply beq_nat_false in n.
    contradiction.
Qed.
#[global]
Hint Resolve Subst_Name_Gen_Output : Piull. *)


Require Export Iron.Language.SimpleData.Ty.

(* Data Constructors *)
Inductive datacon : Type :=
 | DataCon    : nat -> datacon.
Hint Constructors datacon.

Fixpoint datacon_beq t1 t2 :=
  match t1, t2 with
  | DataCon n1, DataCon n2 => beq_nat n1 n2
  end.

(* Definitions.
   Carries meta information about type and data constructors. *)
Inductive def  : Type :=
 (* Definition of a data type constructor *)
 | DefDataType
   :  tycon        (* Name of data type constructor *)
   -> list datacon (* Data constructors that belong to this type *)
   -> def

 (* Definition of a data constructor *)
 | DefData
   :  datacon      (* Name of data constructor *)
   -> list ty      (* Types of arguments *)
   -> ty           (* Type  of constructed data *)
   -> def.
Hint Constructors def.

(* Definition environment.
   Holds the definitions of all current type and data constructors. *)
Definition defs  := list def.

(* Lookup the def of a given type constructor.
   Returns None if it's not in the list. *)
Fixpoint getTypeDef (tc: tycon) (ds: defs) : option def :=
 match ds with
 | ds' :> DefDataType tc' _ as d
 => if tycon_beq tc tc'
     then  Some d
     else  getTypeDef tc ds'

 | ds' :> _ => getTypeDef tc ds'
 | Empty    => None
 end.

(* Lookup the def of a given data constructor.
   Returns None if it's not in the list. *)
Fixpoint getDataDef (dc: datacon) (ds: defs) : option def :=
 match ds with
 | ds' :> DefData dc' _ _ as d
 => if datacon_beq dc dc'
     then  Some d
     else  getDataDef dc ds'

 | ds' :> _ => getDataDef dc ds'
 | Empty    => None
 end.

(* Boolean equality for data constructors. *)
Lemma datacon_beq_eq
 :  forall dc dc'
 ,  true = datacon_beq dc dc'
 -> dc = dc'.
Proof.
 intros.
 destruct dc.
 destruct dc'.
 simpl in H.
 apply beq_nat_eq in H.
 auto.
Qed.

(* Boolean negation for data constructors. *)
Lemma datacon_beq_false
 :  forall dc
 ,  false = datacon_beq dc dc
 -> False.
Proof.
 intro.
 destruct dc.
 simpl.
 intros.
  induction n.
  simpl in H. false.
  simpl in H. auto.
Qed.


(*
FSub (F<:)
T ::= Top | X | T -> T | Forall Z <: T. T^Z
t ::= x | lambda x:T.t | Lambda X<:T.t | t t | t [T]
*)

(* semantic equality big-step / small-step *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.

(* ### Syntax ### *)

Definition id := nat.

Inductive ty : Type :=
| TTop : ty
| TFun : ty -> ty -> ty
| TAll : ty -> ty -> ty
| TVarF : id -> ty (* free type variable, in concrete environment *)
| TVarH : id -> ty (* free type variable, in abstract environment  *)
| TVarB : id -> ty (* locally-bound type variable *)
.

Inductive tm : Type :=
| tvar : id -> tm
| tabs : ty -> tm -> tm
| tapp : tm -> tm -> tm
| ttabs : ty -> tm -> tm
| ttapp : tm -> ty -> tm
| tty: ty -> tm
.

Inductive binding {X: Type} :=
| bind_tm : X -> binding
| bind_ty : X -> binding
.

Inductive vl : Type :=
(* a closure for a term abstraction *)
| vabs : venv (*H*) -> ty -> tm -> vl
(* a closure for a type abstraction *)
| vtabs : venv (*H*) -> ty -> tm -> vl
(* a closure over a type *)
| vty : venv (*H*) -> ty -> vl
with venv : Type := (* need to recurse structurally, hence don't use built-in list *)
| vnil: venv
| vcons: vl -> venv -> venv
.

Definition tenv := list (@binding ty). (* Gamma environment: static *)
(*Definition venv := list vl. (* H environment: run-time *) *)
Definition aenv := list (venv*ty). (* J environment: abstract at run-time *)

(* ### Representation of Bindings ### *)

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint lengthr (l : venv) : nat :=
  match l with
    | vnil => 0
    | vcons a  l' =>
      S (lengthr l')
  end.

Fixpoint indexr (n : id) (l : venv) : option vl :=
  match l with
    | vnil => None
    | vcons a  l' =>
      if (beq_nat n (lengthr l')) then Some a else indexr n l'
  end.

Inductive closed: nat(*B*) -> nat(*H*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall i j k,
    closed i j k TTop
| cl_fun: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TFun T1 T2)
| cl_all: forall i j k T1 T2,
    closed i j k T1 ->
    closed (S i) j k T2 ->
    closed i j k (TAll T1 T2)
| cl_sel: forall i j k x,
    k > x ->
    closed i j k (TVarF x)
| cl_selh: forall i j k x,
    j > x ->
    closed i j k (TVarH x)
| cl_selb: forall i j k x,
    i > x ->
    closed i j k (TVarB x)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute type u for all occurrences of (TVarB k) *)
Fixpoint open_rec (k: nat) (u: ty) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TFun T1 T2  => TFun (open_rec k u T1) (open_rec k u T2)
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TVarF x => TVarF x
    | TVarH i => TVarH i
    | TVarB i => if beq_nat k i then u else TVarB i
  end.

Definition open u T := open_rec 0 u T.

(* Locally-nameless encoding with respect to varH variables. *)
Fixpoint subst (U : ty) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TFun T1 T2   => TFun (subst U T1) (subst U T2)
    | TAll T1 T2   => TAll (subst U T1) (subst U T2)
    | TVarB i      => TVarB i
    | TVarF i      => TVarF i
    | TVarH i      => if beq_nat i 0 then U else TVarH (i-1)
  end.

Definition liftb (f: ty -> ty) b :=
  match b with
    | bind_tm T => bind_tm (f T)
    | bind_ty T => bind_ty (f T)
  end.

Definition substb (U: ty) := liftb (subst U).

Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TFun T1 T2   => nosubst T1 /\ nosubst T2
    | TAll T1 T2   => nosubst T1 /\ nosubst T2
    | TVarB i      => True
    | TVarF i      => True
    | TVarH i      => i <> 0
  end.

(* ### Evaluation (Big-Step Semantics) ### *)

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

(* Environment-based evaluator *)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tty T        => Some (Some (vty env T))
        | tvar x       => Some (indexr x env)
        | tabs T y     => Some (Some (vabs env T y))
        | ttabs T y    => Some (Some (vtabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vtabs _ _ _)) => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vcons vx env2) ey
              end
          end
        | ttapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vabs _ _ _)) => Some None
            | Some (Some (vty _ _)) => Some None
            | Some (Some (vtabs env2 T ey)) =>
              teval n (vcons (vty env ex) env2) ey
          end
      end
  end.

(* Substitution-based evaluator *)

Fixpoint shift_ty (u:nat) (T : ty) {struct T} : ty :=
  match T with
    | TTop        => TTop
    | TFun T1 T2  => TFun (shift_ty u T1) (shift_ty u T2)
    | TAll T1 T2  => TAll (shift_ty u T1) (shift_ty u T2)
    | TVarF i     => TVarF i
    | TVarH i     => TVarH (i+u)
    | TVarB i     => TVarB i
  end.

Fixpoint shift_tm (u:nat) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => tvar (i + u)
    | tabs T1 t   => tabs (shift_ty u T1) (shift_tm u t)
    | tapp t1 t2  => tapp (shift_tm u t1) (shift_tm u t2)
    | ttabs T1 t  => ttabs (shift_ty u T1) (shift_tm u t)
    | ttapp t1 T2 => ttapp (shift_tm u t1) (shift_ty u T2)
    | tty T       => tty (shift_ty u T)
  end.

Definition et t := match t with
                     | tty T => T
                     | _ => TTop
                   end.

Fixpoint subst_tm (u:tm) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => if beq_nat i 0 then u else tvar (i-1)
    | tabs T1 t   => tabs (subst (et u) T1) (subst_tm (shift_tm 1 u) t)
    | tapp t1 t2  => tapp (subst_tm u t1) (subst_tm u t2)
    | ttabs T1 t  => ttabs (subst (et u) T1) (subst_tm (shift_tm 1 u) t)
    | ttapp t1 T2 => ttapp (subst_tm u t1) (subst (et u) T2)
    | tty T       => tty (subst (et u) T)
  end.

Fixpoint subst_ty (u:ty) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => if beq_nat i 0 then (tty u) else tvar (i-1)
    | tabs T1 t   => tabs (subst u T1) (subst_ty (shift_ty 1 u) t)
    | tapp t1 t2  => tapp (subst_ty u t1) (subst_ty u t2)
    | ttabs T1 t  => ttabs (subst u T1) (subst_ty (shift_ty 1 u) t)
    | ttapp t1 T2 => ttapp (subst_ty u t1) (subst u T2)
    | tty T       => tty (subst u T)
  end.

Fixpoint tevals(n: nat)(t: tm){struct n}: option (option tm) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tty T        => Some (Some (tty T))
        | tvar x       => Some None
        | tabs T y     => Some (Some (tabs T y))
        | ttabs T y    => Some (Some (ttabs T y))
        | tapp ef ex   =>
          match tevals n ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match tevals n ef with
                | None => None
                | Some None => Some None
                | Some (Some (tty T)) => Some None
                | Some (Some (tvar _)) => Some None
                | Some (Some (tapp _ _)) => Some None
                | Some (Some (ttapp _ _)) => Some None
                | Some (Some (ttabs _ _)) => Some None
                | Some (Some (tabs _ ey)) =>
                  tevals n (subst_tm vx ey)
              end
          end
        | ttapp ef ex   =>
          match tevals n ef with
            | None => None
            | Some None => Some None
            | Some (Some (tty T)) => Some None
            | Some (Some (tvar _)) => Some None
            | Some (Some (tapp _ _)) => Some None
            | Some (Some (ttapp _ _)) => Some None
            | Some (Some (tabs _ _)) => Some None
            | Some (Some (ttabs T ey)) =>
              tevals n (subst_ty ex ey)
          end
      end
  end.

(* ### Evaluation (Small-Step Semantics) ### *)

Inductive value : tm -> Prop :=
| V_Abs : forall T t,
    value (tabs T t)
| V_TAbs : forall T t,
    value (ttabs T t)
| V_Ty : forall T,
    value (tty T)
.

Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall v T1 t12,
    value v ->
    step (tapp (tabs T1 t12) v) (subst_tm v t12)
| ST_App1 : forall t1 t1' t2,
    step t1 t1' ->
    step (tapp t1 t2) (tapp t1' t2)
| ST_App2 : forall f t2 t2',
    value f ->
    step t2 t2' ->
    step (tapp f t2) (tapp f t2')
| ST_TAppAbs : forall T1 t12 T2,
    step (ttapp (ttabs T1 t12) T2) (subst_ty T2 t12)
| ST_TApp1 : forall t1 t1' t2,
    step t1 t1' ->
    step (ttapp t1 t2) (ttapp t1' t2)
.

Inductive mstep : nat -> tm -> tm -> Prop :=
| MST_Z : forall t,
    mstep 0 t t
| MST_S: forall n t1 t2 t3,
    step t1 t2 ->
    mstep n t2 t3 ->
    mstep (S n) t1 t3
.

(* automation *)

Hint Constructors venv.
Hint Unfold tenv.

Hint Unfold open.
Hint Unfold indexr.
Hint Unfold length.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors closed.

Hint Constructors option.
Hint Constructors list.

Hint Resolve ex_intro.

(* ### Euivalence big-step env <-> big-step subst ### *)

Fixpoint subst_ty_all n venv t {struct venv} :=
  match venv with
    | vnil                       => t
    | vcons (vabs venv0 T y) tl  => subst TTop (subst_ty_all (S n) tl t) (* use TTop as placeholder *)
    | vcons (vtabs venv0 T y) tl => subst TTop (subst_ty_all (S n) tl t) (* use TTop as placeholder *)
    | vcons (vty venv0 T) tl     =>
      subst (shift_ty n (subst_ty_all 0 venv0 T)) (subst_ty_all (S n) tl t)
  end.

Fixpoint subst_tm_all n venv t {struct venv} :=
  match venv with
    | vnil => t
    | vcons (vabs venv0 T y) tl =>
      subst_tm (shift_tm n (tabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))) (subst_tm_all (S n) tl t)
    | vcons (vtabs venv0 T y) tl =>
      subst_tm (shift_tm n (ttabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))) (subst_tm_all (S n) tl t)
    | vcons (vty venv0 T) tl =>
      subst_ty (shift_ty n (subst_ty_all 0 venv0 T)) (subst_tm_all (S n) tl t)
  end.

Definition subst_tm_res t :=
  match t with
    | None => None
    | Some None => Some None
    | Some (Some (vabs venv0 T y)) => Some (Some ((tabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))))
    | Some (Some (vtabs venv0 T y)) => Some (Some ((ttabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))))
    | Some (Some (vty venv0 T)) => Some (Some (tty (subst_ty_all 0 venv0 T)))
  end.

Lemma idx_miss: forall env i l,
  i >= lengthr env ->
  indexr i env = None /\ subst_tm_all l env (tvar i) = (tvar (i-(lengthr env))).
Proof.
  intros env. induction env.
  - intros. simpl in H. simpl.
    assert (i-0=i). omega. rewrite H0. eauto.
  - intros. simpl in H. simpl.
    destruct (IHenv i (S l)) as [A B]. omega.
    rewrite B. simpl.
    assert (beq_nat (i - lengthr env) 0 = false). eapply beq_nat_false_iff. omega.
    assert (beq_nat i (lengthr env) = false). eapply beq_nat_false_iff. omega.
    rewrite H0. rewrite H1.
    assert (i - lengthr env - 1 = i - S (lengthr env)). omega.
    rewrite H2.

    destruct v; try destruct v; eauto.
Qed.

Lemma idx_miss1: forall env i l,
  i >= lengthr env ->
  subst_tm_all l env (tvar i) = (tvar (i-(lengthr env))).
Proof.
  intros env. eapply idx_miss; eauto.
Qed.

Lemma shiftz_id_ty: forall t,
  shift_ty 0 t = t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto.
Qed.

Lemma shiftz_id: forall t,
  shift_tm 0 t = t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto; try rewrite shiftz_id_ty; eauto.
Qed.

Lemma shift_add_ty: forall t l1 l2,
  shift_ty l1 (shift_ty l2 t) = shift_ty (l2+l1) t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto.
  rewrite plus_assoc. eauto.
Qed.

Lemma shift_add: forall t l1 l2,
  shift_tm l1 (shift_tm l2 t) = shift_tm (l2+l1) t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto; try rewrite shift_add_ty; eauto.
  rewrite plus_assoc. eauto.
Qed.

Lemma subst_shift_id_ty: forall t u l,
  subst u (shift_ty (S l) t) = shift_ty l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
Qed.

Lemma subst_shift_id_ty1: forall t u l,
  subst_ty u (shift_tm (S l) t) = shift_tm l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite subst_shift_id_ty. eauto.
Qed.

Lemma subst_shift_id: forall t u l,
  subst_tm u (shift_tm (S l) t) = shift_tm l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite subst_shift_id_ty. eauto.
Qed.

Lemma subst_ty_tm: forall t u,
  subst_tm (tty u) t = subst_ty u t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - rewrite IHt. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. eauto.
  - rewrite IHt. eauto.
Qed.

Lemma idx_miss2: forall env i v l,
  i < lengthr env ->
  subst_tm_all l (vcons v env) (tvar i) = subst_tm_all l env (tvar i).
Proof.
  intros env. induction env.
  - intros. inversion H.
  - intros. simpl in H.
    case_eq (beq_nat i (lengthr env)); intros E.
    +
      assert (beq_nat (i - lengthr env) 0 = true) as E1.
      eapply beq_nat_true_iff. eapply beq_nat_true_iff in E. omega.

      simpl. rewrite idx_miss1. rewrite idx_miss1. simpl. rewrite E1.

      destruct v0; destruct v; eauto.

      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.

      simpl. rewrite subst_shift_id_ty. eauto. rewrite shift_add_ty. rewrite plus_comm.
      rewrite subst_shift_id_ty1. eauto.
      simpl. rewrite subst_shift_id_ty. eauto. rewrite shift_add_ty. rewrite plus_comm.
      rewrite subst_shift_id_ty1. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.

      eapply beq_nat_true_iff in E. omega.
      eapply beq_nat_true_iff in E. omega.

    + assert (i < lengthr env). rewrite beq_nat_false_iff in E. omega.
      remember (vcons v env) as env1. simpl.
      subst env1. rewrite IHenv. rewrite IHenv.

      destruct v0.
      eapply (IHenv i (vabs v0 t t0)). eauto.
      eapply (IHenv i (vtabs v0 t t0)). eauto.
      eapply (IHenv i (vty v0 t)). eauto.
      eauto.
      eauto.
Qed.

Lemma idx_hit: forall env i,
  i < lengthr env ->
  subst_tm_res (Some (indexr i env)) = Some (Some (subst_tm_all 0 env (tvar i))).
Proof.
  intros env. induction env.
  - intros. inversion H.
  - intros.
    simpl in H. simpl.
    case_eq (beq_nat i (lengthr env)); intros E.
    + eapply beq_nat_true_iff in E.
      rewrite idx_miss1. subst i. simpl.
      assert (beq_nat (lengthr env - lengthr env) 0 = true). eapply beq_nat_true_iff. omega.
      rewrite H0.
      assert (beq_nat (lengthr env) (lengthr env) = true). eapply beq_nat_true_iff. omega.
      destruct v.
      rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
      rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
      rewrite shiftz_id_ty. eauto.
      omega.
    + assert (i <> lengthr env). eapply beq_nat_false_iff. eauto.
      assert (i < lengthr env). omega.

      specialize (IHenv _ H1).
      rewrite <-(idx_miss2 env _ v) in IHenv . simpl in IHenv. eauto. eauto.
Qed.

(* proof of equivalence *)

Theorem big_env_subst: forall n env e1 e2,
  subst_tm_all 0 env e1 = e2 ->
  subst_tm_res (teval n env e1) = (tevals n e2).
Proof.
  intros n. induction n.
  (* z *) intros. simpl. eauto.
  (* S n *) intros.
  destruct e1; simpl; eauto.
  - (* var *)
    assert (i < lengthr env \/ i >= lengthr env) as L. omega.
    destruct L as [L|L].
    + (* hit *)
      simpl in H.
      specialize (idx_hit env i L). intros IX. rewrite H in IX.
      remember (indexr i env). destruct o.
      * simpl in IX. rewrite IX. destruct v; inversion IX; eauto.
      * inversion IX.
    +
      specialize (idx_miss env i 0 L). intros IX. rewrite H in IX.
      destruct IX as [A B]. rewrite A. rewrite B. eauto.

  - (* tabs *)
    assert (forall env l,
              subst_tm_all l env (tabs t e1) =
              (tabs (subst_ty_all l env t) (subst_tm_all (S l) env e1))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto;
    try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
  - (* tapp *)
    assert (forall env l,
              subst_tm_all l env (tapp e1_1 e1_2) =
              (tapp (subst_tm_all l env e1_1) (subst_tm_all l env e1_2))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto. }

    rewrite REC in H. subst e2.

    assert (subst_tm_res (teval n env e1_2) = tevals n (subst_tm_all 0 env e1_2)) as HF. eapply IHn; eauto.
    assert (subst_tm_res (teval n env e1_1) = tevals n (subst_tm_all 0 env e1_1)) as HX. eapply IHn; eauto.
    rewrite <-HF. rewrite <-HX. simpl.

    remember ((teval n env e1_2)) as A.
    destruct A as [[|]|]; simpl.
    * remember ((teval n env e1_1)) as B.
      destruct B as [[|]|]; simpl.
      { destruct v0; destruct v; simpl; eauto.
        eapply IHn. simpl. rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
        eapply IHn. simpl. rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
        eapply IHn. simpl. rewrite subst_ty_tm. rewrite shiftz_id_ty. eauto.
      }
      destruct v; eauto.
      destruct v; eauto.
    * eauto.
    * eauto.
  - (* ttabs *)
    assert (forall env l,
              subst_tm_all l env (ttabs t e1) =
              (ttabs (subst_ty_all l env t) (subst_tm_all (S l) env e1))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto;
    try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
  - (* ttapp *)
    assert (forall env l,
              subst_tm_all l env (ttapp e1 t) =
              (ttapp (subst_tm_all l env e1) (subst_ty_all l env t))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto. }

    rewrite REC in H. subst e2.

    assert (subst_tm_res (teval n env e1) = tevals n (subst_tm_all 0 env e1)) as HX. eapply IHn; eauto.
    rewrite <-HX. simpl.

    remember ((teval n env e1)) as B.
    destruct B as [[?|]|]; simpl.
    { destruct v; simpl; eauto.
      eapply IHn. simpl. rewrite shiftz_id_ty. eauto. }
    eauto. eauto.
  - (* dummy *)
    assert (forall env l T,
              subst_tm_all l env (tty T) =
              (tty (subst_ty_all l env T))) as REC. {
      intros env0. induction env0; intros.
      simpl. eauto.
      simpl. destruct v; rewrite IHenv0; simpl; eauto;
             try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
Qed.

(* ### Equivalence big-step subst <-> small-step subst ### *)

Lemma app_inv: forall nu t1 t2 t3,
  tevals nu (tapp t1 t2) = Some (Some t3) ->
  exists T ty v2 nv, nu = S nv /\
                     tevals nv t1 = Some (Some (tabs T ty)) /\
                     tevals nv t2 = Some (Some v2) /\
                     tevals nv (subst_tm v2 ty) = Some (Some t3).
Proof.
  intros. destruct nu. inversion H.
  simpl in H.
  remember (tevals nu t2) as rx.
  destruct rx. destruct o.
  remember (tevals nu t1) as rf.
  destruct rf. destruct o.

  destruct t0; inversion H; repeat eexists; eauto.
  inversion H. inversion H. inversion H. inversion H.
Qed.

Lemma tapp_inv: forall nu t1 t2 t3,
  tevals nu (ttapp t1 t2) = Some (Some t3) ->
  exists T ty nv, nu = S nv /\
                     tevals nv t1 = Some (Some (ttabs T ty)) /\
                     tevals nv (subst_ty t2 ty) = Some (Some t3).
Proof.
  intros. destruct nu. inversion H.
  simpl in H.
  remember (tevals nu t1) as rf.
  destruct rf. destruct o.

  destruct t; inversion H; repeat eexists; eauto.
  inversion H. inversion H.
Qed.

Lemma eval_stable: forall n t1 v j,
  tevals n t1 = Some v ->
  j >= n ->
  tevals j t1 = Some v.
Proof.
  intros n. induction n; intros. inversion H.
  destruct j. inversion H0.
  destruct t1; eauto.
  - simpl in H. simpl.
    remember (tevals n t1_2) as rx.
      destruct rx. destruct o.
      rewrite (IHn _ (Some t)).
      remember (tevals n t1_1) as rf.
      destruct rf. destruct o.
      rewrite (IHn _ (Some t0)).
      destruct t0; eauto; eapply IHn; eauto; omega.
      destruct t0; eauto; eapply IHn; eauto; omega.
      omega.
      rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.

      eauto. omega.
      inversion H. rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.
 - simpl in H. simpl.
    remember (tevals n t1) as rf.
      destruct rf. destruct o.
      rewrite (IHn _ (Some t0)).
      destruct t0; eauto; eapply IHn; eauto; omega.
      destruct t0; eauto; eapply IHn; eauto; omega.
      omega.
      rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.
Qed.

Lemma value_eval: forall t1,
   value t1 ->
   forall nu, nu >= 1 -> tevals nu t1 = Some (Some t1).
Proof.
  intros. destruct nu. inversion H0. inversion H; eauto.
Qed.

Lemma step_eval: forall t1 t2,
  step t1 t2 ->
  forall t3 nu, tevals nu t2 = Some (Some t3) ->
  tevals (S nu) t1 = Some (Some t3).
Proof.
  intros ? ? ?. induction H; intros.
  - (* AppAbs *)
    simpl.
    assert (nu >= 1). destruct nu. inversion H0. omega.
    rewrite (value_eval v).
    rewrite (value_eval (tabs T1 t12)).
    eapply H0; omega. constructor.
    eauto. eauto. eauto.
  - (* App1 *)
    simpl. eapply app_inv in H0.
    repeat destruct H0 as [? H0].
    destruct H0 as [N [E1 [E2 E3]]].
    subst nu. eapply IHstep in E1.
    eapply eval_stable in E2.
    rewrite E1. rewrite E2. eapply eval_stable. eapply E3. eauto. eauto.
  - (* App2 *)
    simpl. eapply app_inv in H1.
    repeat destruct H1 as [? H1].
    destruct H1 as [N [E1 [E2 E3]]].
    subst nu. eapply IHstep in E2.
    eapply eval_stable in E1.
    rewrite E1. rewrite E2. eapply eval_stable. eapply E3. eauto. eauto.
  - (* TAppAbs *)
    simpl.
    assert (nu >= 1). destruct nu. inversion H. omega.
    rewrite (value_eval (ttabs T1 t12)).
    eapply H; omega. constructor.
    eauto.
  - (* App1 *)
    simpl. eapply tapp_inv in H0.
    repeat destruct H0 as [? H0].
    destruct H0 as [N [E1 E2]].
    subst nu. eapply IHstep in E1.
    eapply eval_stable in E2.
    rewrite E1. rewrite E2. eauto. eauto.
Qed.

(* proof of equivalence: small-step implies big-step *)

Theorem small_to_big: forall n t1 t2,
   mstep n t1 t2 -> value t2 ->
   exists ns, tevals ns t1 = Some (Some t2).
Proof.
  intros n. induction n.
  (* z *)
  intros. inversion H; subst.
  exists 1. eapply value_eval; eauto.
  (* S n *)
  intros. inversion H; subst.
  eapply IHn in H3. destruct H3.
  exists (S x). eapply step_eval; eauto.
  eauto.
Qed.

(* proof of equivalence: big-step implies small-step *)

Lemma ms_app1 : forall n t1 t1' t2,
     mstep n t1 t1' ->
     mstep n (tapp t1 t2) (tapp t1' t2).
Proof.
  intros. induction H. constructor.
  econstructor. eapply ST_App1; eauto. eauto.
Qed.

Lemma ms_app2 : forall n t1 t2 t2',
     value t1 ->
     mstep n t2 t2' ->
     mstep n (tapp t1 t2) (tapp t1 t2').
Proof.
  intros. induction H0. constructor.
  econstructor. apply ST_App2; eauto. eauto.
Qed.

Lemma ms_tapp1 : forall n t1 t1' t2,
     mstep n t1 t1' ->
     mstep n (ttapp t1 t2) (ttapp t1' t2).
Proof.
  intros. induction H. constructor.
  econstructor. eapply ST_TApp1; eauto. eauto.
Qed.

Lemma ms_trans : forall n1 n2 t1 t2 t3,
     mstep n1 t1 t2 ->
     mstep n2 t2 t3 ->
     mstep (n1+n2) t1 t3.
Proof.
  intros. induction H. eauto.
  econstructor. eauto. eauto.
Qed.

Theorem big_to_small: forall n t1 t2,
   tevals n t1 = Some (Some t2) ->
   exists ns, value t2 /\ mstep ns t1 t2.
Proof.
  intros n. induction n; intros. inversion H. destruct t1.
  - simpl in H. inversion H.
  - simpl in H. inversion H. eexists. split; constructor.
  - eapply app_inv in H. repeat destruct H as [? H].
    destruct H as [N [E1 [E2 E3]]]. inversion N. subst x2.
    eapply IHn in E1. eapply IHn in E2. eapply IHn in E3.
    destruct E1 as [? [? E1]]. destruct E2 as [? [? E2]]. destruct E3 as [? [? E3]].
    eexists. split. eauto.
    eapply ms_app1 in E1. eapply ms_app2 in E2.
    eapply ms_trans. eapply E1.
    eapply ms_trans. eapply E2. econstructor. econstructor.
    eauto. eauto. eauto.
  - simpl in H. inversion H. eexists. split; constructor.
  - eapply tapp_inv in H. repeat destruct H as [? H].
    destruct H as [N [E1 E2]]. inversion N. subst x1.
    eapply IHn in E1. eapply IHn in E2.
    destruct E1 as [? [? E1]]. destruct E2 as [? [? E2]].
    eexists. split. eauto.
    eapply ms_tapp1 in E1.
    eapply ms_trans. eapply E1.  econstructor. econstructor.
    eauto.
  - simpl in H. inversion H. eexists. split; constructor.
Qed.


Require Import Tapl.Stlc.Base.
Require Import Tapl.Stlc.Exp.
Require Import Tapl.Data.List.

(* Typing *)
Reserved Notation "G '⊢' t '∈' T" (at level 40).
Inductive has_type : context -> term -> type -> Prop :=
  | Ty_Var : forall G i T,
      get i G = Some T ->
      G ⊢ tm_var i ∈ T
  | Ty_Abs : forall G t T1 T2,
      (T1 :: G) ⊢ t ∈ T2 ->
      G ⊢ tm_abs T1 t ∈ ty_arrow T1 T2
  | Ty_App : forall G t1 t2 T1 T2,
      G ⊢ t1 ∈ ty_arrow T1 T2 ->
      G ⊢ t2 ∈ T1 ->
      G ⊢ tm_app t1 t2 ∈ T2
  | Ty_Unit : forall G,
      G ⊢ tm_unit ∈ ty_unit
where "G '⊢' t '∈' T" := (has_type G t T).
Global Hint Constructors has_type : core.

Example ex_ty1 : nil ⊢ tm_abs ty_unit 0 ∈ ty_arrow ty_unit ty_unit.
Proof. auto. Qed.
Example ex_ty2 : (ty_arrow ty_unit ty_unit :: nil) ⊢ tm_app (tm_var 0) tm_unit ∈ ty_unit.
Proof with auto.
  eapply Ty_App... auto. Qed.

(* Typing implies well-formedness. *)
Lemma typing_implies_wf : forall Γ t T,
  Γ ⊢ t ∈ T →
  wf Γ t.
Proof.
  intros.
  induction H; auto.
  - apply wf_var. exists T; assumption.
Qed.
Global Hint Resolve typing_implies_wf : core.

(* Typing of terms is unique. *)
Lemma typing_unique : forall t G T1 T2,
    G ⊢ t ∈ T1 ->
    G ⊢ t ∈ T2 ->
    T1 = T2.
Proof with auto.
  intros t.
  induction t; intros; inversion H0; subst; inversion H; subst; simpl...
  - rewrite -> H3 in H4.
    inversion H4; auto.
  - assert (T2 = T3). apply IHt with (t :: G)... subst; auto.
  - assert (T0 = T3). apply IHt2 with G... subst.
    assert (ty_arrow T3 T2 = ty_arrow T3 T1). apply IHt1 with G... inversion H1; subst...
Qed.

(* Canonical forms *)
Lemma canonical_forms_unit : forall v,
  nil ⊢ v ∈ ty_unit ->
  value v ->
  v = tm_unit.
Proof.
  intros.
  destruct H0.
  destruct H0.
  - inversion H.
  - reflexivity.
Qed.

Lemma canonical_forms_arrow : forall v T1 T2,
  nil ⊢ v ∈ ty_arrow T1 T2 ->
  value v ->
  exists t, v = tm_abs T1 t.
Proof.
  intros.
  destruct H0; destruct H0; inversion H; subst.
  - exists t. reflexivity.
Qed.


Set Implicit Arguments.

Require Import compcert.lib.Coqlib.
Require Import Coq.Program.Basics. (* for function composition: ∘ *)
Require Import List. Import ListNotations.
Require Import compcert.lib.Integers.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.HMAC_common_defs.
Require Import Lia.

Local Open Scope program_scope.

Section HMAC.
  Variable c:nat.
  Variable p:nat.
  Definition b := (c+p)%nat.
  Variable B: (0<b)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.

  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.

  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : Blist) :=
    hash_blocks_bits b B h k m.

  (* The composition of the keyed hash function with the IV. *)
  Definition hash_words := h_star iv.

  Variable splitAndPad : Blist -> Blist.

  Definition hash_words_padded : Blist -> Blist :=
    hash_words ∘ splitAndPad.

  (* constant-length padding. *)
  Variable fpad : Blist.

  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad.
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in (* concat earlier, then split *)
      let h_in := (hash_words_padded (k_In ++ m)) in
        hash_words_padded (k_Out ++ h_in).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    (* GHMAC_2K k (splitAndPad m). *)
    GHMAC_2K k m.

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Blist.

  Definition HMAC (k : Blist) :=
    HMAC_2K (BLxor k opad ++ BLxor k ipad).

  (*The following hypotheses and constructions from the abstract spec
    do not need to be enforced/repeated here

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 -> b1 = b2.

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (h_star_pad k_In m).

  Definition GHMAC (k : Blist) :=
    GHMAC_2K (BLxor k opad ++ BLxor k ipad).
  *)
End HMAC.

Definition convert (l : list int) : list bool :=
  bytesToBits (intlist_to_bytelist l).

(* Front/back equivalence theorems *)

Lemma front_equiv b d (DB32: (d*32)%nat = b):
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = b ->
    (length FRONT)%nat = d ->
    front ++ back = convert (FRONT ++ BACK) ->
    front = convert FRONT.
Proof.
  intros back BACK front FRONT f_len F_len concat_eq.
  unfold convert in *.
  rewrite -> intlist_to_bytelist_app in concat_eq.
  rewrite -> bytesToBits_app in concat_eq.

  assert (back = skipn b (front ++ back)).
    rewrite skipn_exact; trivial.
  assert (bytesToBits (intlist_to_bytelist BACK) = skipn b (front ++ back)).
    rewrite concat_eq; clear concat_eq.
    rewrite skipn_exact; trivial.
    rewrite bytesToBits_len, length_intlist_to_bytelist, F_len. lia.
  rewrite H, H0 in concat_eq; clear H H0.
  eapply app_inv_tail. eassumption.
Qed.

Lemma back_equiv b d (DB32: (d*32)%nat = b):
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = b ->
    (length FRONT)%nat = d ->
    front ++ back = convert (FRONT ++ BACK) ->
    back = convert BACK.
Proof.
  intros back BACK front FRONT f_len F_len concat_eq.
  assert (front ++ back = convert (FRONT ++ BACK)) as concat_eq'. apply concat_eq.
  unfold convert in *.
  rewrite -> intlist_to_bytelist_app in concat_eq.
  rewrite -> bytesToBits_app in concat_eq.

  assert (front_eq : front = convert FRONT).
    pose proof front_equiv DB32 back BACK front FRONT.
    apply H.
    * assumption.
    * assumption.
    * apply concat_eq'.
    * rewrite -> front_eq in concat_eq.
      unfold convert in *.
      eapply app_inv_head. eassumption.
Qed.

Module Type INST.
Parameter shah : Blist -> Blist ->  Blist.
Parameter hashblock : list int -> list int -> list int.
Parameter HHB : shah =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).

Parameter hashblocks: list int -> list int -> list int.
Parameter d:nat.

Parameter HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | [] => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end.
End INST.

Require Import sha.HMAC_functional_prog. (*Just for HMAC_FUN*)

Module HMAC_Pad (HF:HP.HASH_FUNCTION) (I:INST).
(*Module HMAC_Pad.Declare Module HF:HP.HASH_FUNCTION.*)
Module HM:= HP.HMAC_FUN HF.

(*Module PadConcrete (HF:HP.HASH_FUNCTION).*)

(*From hmac_common_lemmas TODO: Isolate*)
(*Lemma SF_ByteRepr x: isbyteZ x ->
                     HM.sixtyfour x =
                     map Byte.unsigned (HM.sixtyfour (Byte.repr x)).
Proof. intros. unfold HM.sixtyfour.
 rewrite map_repeat.
 rewrite Byte.unsigned_repr; trivial. destruct H.
 assert (BMU: Byte.max_unsigned = 255). reflexivity. lia.
Qed.
*)
(*From hmac_common_lemmas TODO: Isolate*)
(*Lemma length_SF {A} (a:A) :length (HM.sixtyfour a) = HF.BlockSize.
Proof. apply repeat_length. Qed.
*)
(*From SHaInstantiation -- TODO: Isolate*)
Lemma xor_equiv_byte: forall xpad XPAD k K,
                          bytes_bits_lists xpad (HM.sixtyfour XPAD) ->
                          length K= HF.BlockSize ->
                          bytes_bits_lists k K ->
bytes_bits_lists (BLxor k xpad) (HM.mkArg K XPAD).
Proof. intros. apply inner_general_mapByte; try assumption.
Qed.
(*
Lemma isbyte_hmaccore ipad opad m k:
   Forall isbyteZ (HM.HmacCore (Byte.repr ipad) (Byte.repr opad) m k).
Proof. apply HF.Hash_isbyteZ. Qed. *)

(*Parameter *)
Lemma hash_block_equiv:
  forall (bits : Blist) (bytes : list byte)
         (regs : Blist) REGS,
    regs = bytesToBits (intlist_to_bytelist REGS) ->
    bits = bytesToBits bytes ->
    I.shah regs bits =
    bytesToBits (intlist_to_bytelist
                   (I.hashblock REGS (bytelist_to_intlist bytes))).
Proof.
  intros bits bytes regs REGS regs_eq input_eq.
  rewrite I.HHB. unfold intsToBits.
  apply f_equal.
  apply f_equal.
  rewrite -> regs_eq; clear regs_eq.
  rewrite -> input_eq; clear input_eq.
  unfold bitsToInts.
  rewrite bytes_bits_bytes_id.
  rewrite -> bytes_bits_bytes_id.
  rewrite -> intlist_to_bytelist_to_intlist.
  reflexivity.
Qed.

Lemma fold_equiv_blocks b (B:(0<b)%nat) (DB32: (I.d*32)%nat=b):
  forall (l : Blist) (acc : Blist)
         (L : list int) (ACC : list int),
      InBlocks b l ->
      InBlocks I.d L ->
      l = convert L ->
      acc = convert ACC ->
      hash_blocks_bits b B I.shah acc l = convert (I.hashblocks ACC L).
Proof.
  intros l acc L ACC bit_blocks bytes_blocks inputs_eq acc_eq.

  revert acc ACC L inputs_eq acc_eq bytes_blocks.
  induction bit_blocks; intros.
  *
    revert acc ACC inputs_eq acc_eq.
    induction bytes_blocks; intros.

    - rewrite I.HBS_eq.
      rewrite -> hash_blocks_bits_equation.
      apply acc_eq.
    - rewrite -> H0 in *.
      unfold convert in inputs_eq.
      destruct front.
      { simpl in H. rewrite <- H in *; lia. }
      { simpl in inputs_eq. inversion inputs_eq. }

  *
    revert front back full H H0 bit_blocks IHbit_blocks acc ACC
           inputs_eq acc_eq.
    induction bytes_blocks; intros.

    -
      simpl in inputs_eq.
      rewrite -> H0 in inputs_eq.
      unfold convert in inputs_eq.
      destruct front.
      { simpl in H. subst b. lia. }
      { simpl in inputs_eq. inversion inputs_eq. }

    - clear IHbytes_blocks. intros. rewrite I.HBS_eq.
      rewrite -> hash_blocks_bits_equation.
      repeat rewrite -> length_not_emp.
      rewrite -> H0.
      rewrite -> H2.
      rewrite firstn_exact; trivial.
      rewrite firstn_exact; trivial.
      rewrite skipn_exact; trivial.
      rewrite skipn_exact; trivial.
      apply IHbit_blocks; auto; clear  IHbit_blocks.
      + rewrite -> H0 in inputs_eq.
        rewrite -> H2 in inputs_eq.
        eapply (back_equiv DB32); eassumption.
      + rewrite (@hash_block_equiv front0 (intlist_to_bytelist front) acc ACC); auto.
        rewrite -> intlist_to_bytelist_to_intlist.
        reflexivity.
        { rewrite -> H0 in inputs_eq.
          rewrite -> H2 in inputs_eq.
          apply (front_equiv DB32 back0 back front0 front H1 H inputs_eq). }
     + rewrite -> H0. rewrite -> app_length. rewrite -> H. lia.
     + rewrite -> H2. rewrite -> app_length. rewrite -> H1. lia.
Qed.

Lemma equiv_pad shaiv shasplitandpad c p (B: (0< b c p)%nat) (DB32: (I.d*32 =b c p)%nat)
     ir (IVIR: shaiv = convert ir)
       gap (GAP: forall bits, NPeano.Nat.divide I.d (length (gap (bitsToBytes bits))))
       (sap_gap: forall bits, shasplitandpad bits = bytesToBits (intlist_to_bytelist (gap (bitsToBytes bits))))
       HASH
       (HSH: forall (m:list byte), HASH m = intlist_to_bytelist (I.hashblocks ir (gap m))):
       forall (bits : Blist) (bytes : list byte),
                    bytes_bits_lists bits bytes ->
                    bytes_bits_lists
                      (hash_words_padded c p B I.shah shaiv shasplitandpad bits)
                      (HASH bytes).
Proof.
  intros bits bytes input_eq.
  unfold hash_words_padded.
  change ((hash_words c p B I.shah shaiv ∘ shasplitandpad) bits) with
  (hash_words c p B I.shah shaiv (shasplitandpad bits)).
    unfold hash_words.
    unfold h_star. rewrite HSH; clear HSH.
    apply bytes_bits_comp_ind.
    { apply bytes_bits_ind_comp in input_eq.
        { subst bytes. rewrite sap_gap; clear sap_gap.
          eapply (fold_equiv_blocks B DB32).
          3: reflexivity.
          3: assumption.
          apply InBlocks_len. rewrite bytesToBits_len, length_intlist_to_bytelist.
             rewrite <- DB32. destruct (GAP bits). rewrite H. exists x.
             rewrite Nat.mul_comm, Nat.mul_assoc.
             assert ((8*4= 32)%nat) by lia. rewrite H0. rewrite Nat.mul_comm, <- Nat.mul_assoc. trivial.
          apply InBlocks_len. apply GAP.
        }
    }
Qed.

Theorem HMAC_pad_concrete splitandpad c p (B: (0< b c p)%nat) (BS: (HF.BlockSize * 8)%nat = b c p)
        (DB32: (I.d*32 =b c p)%nat)
         ir (*ie initial_regs*) gap (*ie generate_and_pad*)
         (GAP: forall bits, NPeano.Nat.divide I.d (length (gap (bitsToBytes bits))))
         (sap_gap: forall bits, splitandpad bits = bytesToBits (intlist_to_bytelist (gap (bitsToBytes bits))))
         (HSH: forall (m:list byte), HF.Hash m = intlist_to_bytelist (I.hashblocks ir (gap m)))
         (K : list byte) (M H : list byte) (OP IP : byte)
                          (k m h : Blist) (op ip : Blist):
  length K = HF.BlockSize ->
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HM.sixtyfour OP) ->
  bytes_bits_lists ip (HM.sixtyfour IP) ->
  HMAC c p B I.shah (convert ir) splitandpad op ip k m = h ->
  HM.HmacCore IP OP M K = H ->
  bytes_bits_lists h H.
Proof.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq HMAC_abstract HMAC_concrete.
  rewrite <- HMAC_abstract. rewrite <- HMAC_concrete.
  unfold HMAC. unfold HM.HmacCore. unfold HM.OUTER. unfold HM.INNER.
  unfold HM.outerArg. unfold HM.innerArg.

  unfold HMAC_2K. unfold GHMAC_2K. rewrite -> split_append_id.

  { eapply equiv_pad.
    apply DB32. reflexivity. apply GAP. assumption. assumption.
    apply bytes_bits_lists_append.
    apply xor_equiv_byte; trivial.

    eapply equiv_pad.
    apply DB32. reflexivity. apply GAP. assumption. assumption.
    apply bytes_bits_lists_append.
    - apply xor_equiv_byte; trivial.
    - assumption. }

  { apply BLxor_length; erewrite bytes_bits_length; try eassumption.
         rewrite padded_key_len. apply BS.
         rewrite HM.length_SF. apply BS. }

  { apply BLxor_length; erewrite bytes_bits_length; try eassumption.
         rewrite padded_key_len. apply BS.
         rewrite HM.length_SF. apply BS. }
Qed.

Theorem HMAC_pad_concrete' splitandpad c p (B: (0< b c p)%nat) (BS: (HF.BlockSize * 8)%nat =b c p)
        (DB32: (I.d*32 =b c p)%nat)
         ir (*ie initial_regs*) gap (*ie generate_and_pad*)
         (GAP: forall bits, NPeano.Nat.divide I.d (length (gap (bitsToBytes bits))))
         (sap_gap: splitandpad = fun bits => bytesToBits (intlist_to_bytelist (gap (bitsToBytes bits))))
         (HSH: forall (m:list byte), HF.Hash m = intlist_to_bytelist (I.hashblocks ir (gap m)))
         (K : list byte) (M : list byte) (OP IP : byte)
                          (k m : Blist) (op ip : Blist):
  length K = HF.BlockSize ->
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HM.sixtyfour OP) ->
  bytes_bits_lists ip (HM.sixtyfour IP) ->
  bytes_bits_lists
     (HMAC c p B I.shah (convert ir) splitandpad op ip k m)
     (HM.HmacCore IP OP M K).
Proof.
  intros. eapply HMAC_pad_concrete; try reflexivity.
  eassumption. eassumption. eassumption. eassumption. eassumption. eassumption.
  eassumption. eassumption. eassumption.  rewrite sap_gap. trivial.
Qed.

End HMAC_Pad.
(*
Lemma equiv_pad_SHA256 HASH c p B sap h iv: forall (bits : Blist) (bytes : list Z),
                    bytes_bits_lists bits bytes ->
                    bytes_bits_lists
                      (HMAC_Pad.hash_words_padded c p B h iv sap bits)
                      (HASH bytes).
Proof. intros.
  eapply HMAC_Pad.equiv_pad (*with (gap:=generate_and_pad')*).
  2: reflexivity.
  2: apply hash_blocks_equation.
  reflexivity. reflexivity.
  apply gap_divide16.
  intros. unfold sha_splitandpad. f_equal.
    apply bytes_bits_ind_comp in H.
    { subst bytes. unfold generate_and_pad'.
      rewrite pure_lemmas.Zlist_to_intlist_to_Zlist; trivial.
        destruct (pad_len_64_nat (bitsToBytes bits0)). rewrite H.
          exists ((x*16)%nat). rewrite Nat.mul_comm, <- Nat.mul_assoc. reflexivity.
        apply pad_isbyteZ. eapply bitsToBytes_isbyteZ. reflexivity. }
    apply (bytesBitsLists_isbyteZ _ _ H).
  intros; unfold HP.SHA256.Hash.
    rewrite -> functional_prog.SHA_256'_eq. unfold SHA256.SHA_256.
    rewrite <- pad_compose_equal; reflexivity.
  assumption.
Qed.
*)


From cgraphs.locks.lambdalock Require Export langdef.

Fixpoint expr_refs e :=
  match e with
  | Val v => val_refs v
  | Var x => ∅
  | Fun x e => expr_refs e
  | App e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Unit => ∅
  | Pair e1 e2 => expr_refs e1 ∪ expr_refs e2
  | LetPair e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Sum i e => expr_refs e
  | MatchSum n e es => expr_refs e ∪ fin_union n (expr_refs ∘ es)
  | ForkBarrier e => expr_refs e
  | NewLock e => expr_refs e
  | ForkLock e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Acquire e => expr_refs e
  | Release e1 e2 => expr_refs e1 ∪ expr_refs e2
  | Wait e => expr_refs e
  | Drop e => expr_refs e
  end
with val_refs v :=
  match v with
  | FunV x e => expr_refs e
  | UnitV => ∅
  | PairV v1 v2 => val_refs v1 ∪ val_refs v2
  | SumV i v => val_refs v
  | BarrierV i => {[ i ]}
  | LockV i => {[ i ]}
  end.

Definition obj_refs x :=
  match x with
  | Thread e => expr_refs e
  | Barrier => ∅
  | Lock refcnt o =>
      match o with
      | Some v => val_refs v
      | None => ∅
      end
  end.

Inductive expr_head_waiting : expr -> nat -> Prop :=
  | Barrier_waiting j v :
    expr_head_waiting (App (Val $ BarrierV j) (Val v)) j
  | ForkLock_waiting j v :
    expr_head_waiting (ForkLock (Val $ LockV j) (Val v)) j
  | Acquire_waiting j :
    expr_head_waiting (Acquire (Val $ LockV j)) j
  | Release_waiting j v :
    expr_head_waiting (Release (Val $ LockV j) (Val v)) j
  | Wait_waiting j :
    expr_head_waiting (Wait (Val $ LockV j)) j
  | Drop_waiting j :
    expr_head_waiting (Drop (Val $ LockV j)) j.

Definition expr_waiting e j :=
  ∃ k e', ctx k ∧ e = k e' ∧ expr_head_waiting e' j.

Definition waiting (ρ : cfg) (i j : nat) :=
  (∃ e, ρ !! i = Some (Thread e) ∧ expr_waiting e j) ∨
  (∃ y, ρ !! j = Some y ∧ i ∈ obj_refs y ∧ ∀ e, y = Thread e -> ¬ expr_waiting e i).

Definition can_step (ρ : cfg) (i : nat) := ∃ ρ', step i ρ ρ'.
Definition inactive (ρ : cfg) (i : nat) := ρ !! i = None.

Record deadlock (ρ : cfg) (s : nat -> Prop) := {
  dl_nostep i : s i -> ¬ can_step ρ i;
  dl_waiting i j : waiting ρ i j -> s i -> s j;
}.

Definition deadlock_free (ρ : cfg) :=
  ∀ s, deadlock ρ s -> ∀ i, s i -> inactive ρ i.

Inductive reachable (ρ : cfg) : nat -> Prop :=
  | Can_step_reachable i :
      can_step ρ i -> reachable ρ i
  | Waiting_reachable i j :
      waiting ρ i j -> reachable ρ j -> reachable ρ i.

Definition fully_reachable (ρ : cfg) :=
  ∀ i, inactive ρ i ∨ reachable ρ i.

Definition global_progress (ρ : cfg) :=
  (∀ i, inactive ρ i) ∨ (∃ i, can_step ρ i).

Definition type_safety (ρ : cfg) :=
  ∀ i, inactive ρ i ∨ can_step ρ i ∨ ∃ j, waiting ρ i j.


Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true : bool
  | false : bool.

(** continue here https://www.cis.upenn.edu/~bcpierce/sf/current/Basics.html#next_weekday **)


Load "include/ops_header.v".

Require annotated_recs_z annotated_recs_s.

(* Shorter name space for elements in annotated_recs_[z|s] *)
Module z.
Include annotated_recs_z.
End z.

Module s.
Include annotated_recs_s.
End s.

Section AnnOfU.

Variable z : int -> rat.
Variable s : int -> int -> rat.

Variable z_ann : z.Ann z.
Let z_Sn2 := z.Sn2_ z_ann.

Variable s_ann : s.Ann s.
Let s_Sn2 := s.Sn2_ s_ann.
Let s_SnSk := s.SnSk_ s_ann.
Let s_Sk2 := s.Sk2_ s_ann.

Let u n k := z n + s n k.

Lemma u_Sk2 : s.Sk2 u.
Proof.
(* Hack to force the lemma to depend on unused parameter. *)
have ? := z_ann.
rewrite /s.Sk2 /s.precond.Sk2.
move => n k ?.
rewrite /u.
rewrite s_Sk2 //.
set s1 := s _ _.
set s2 := s _ _.
set z1 := z _.
rewrite /s.Sk2_cf0_0 /s.Sk2_cf0_1.
by field; ring_lia.
Qed.

Lemma u_SnSk : s.SnSk u.
Proof.
(* Hack to force the lemma to depend on unused parameter. *)
have ? := z_ann.
rewrite /s.SnSk /s.precond.SnSk.
move => n k ?.
rewrite /u.
rewrite s_SnSk //.
set s1 := s _ _.
set s2 := s _ _.
set s3 := s _ _.
set z1 := z _.
set z2 := z _.
rewrite /s.SnSk_cf0_0 /s.SnSk_cf1_0 /s.SnSk_cf0_1.
by field; ring_lia.
Qed.

Lemma u_Sn2 : s.Sn2 u.
Proof.
rewrite /s.Sn2 /s.precond.Sn2.
move => n k ?.
rewrite /u.
rewrite z_Sn2; last by rewrite /z.precond.Sn2; lia.
rewrite s_Sn2 //.
set s1 := s _ _.
set s2 := s _ _.
set s3 := s _ _.
set z1 := z _.
set z2 := z _.
rewrite /z.Sn2_cf0 /z.Sn2_cf1
  /s.Sn2_cf0_0 /s.Sn2_cf1_0 /s.Sn2_cf0_1.
by field; ring_lia.
Qed.

End AnnOfU.