(** This file extends the HeapLang program logic with some derived laws (not
using the lifting lemmas) about arrays and prophecies.

For utility functions on arrays (e.g., freeing/copying an array), see
[heap_lang.lib.array].  *)

From stdpp Require Import fin_maps.
From iris.bi Require Import lib.fractional.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Export primitive_laws.
From iris.heap_lang Require Import tactics notation.
From iris Require Import options.

(** The [array] connective is a version of [mapsto] that works
with lists of values. *)

Definition array `{!heapG Σ} (l : loc) (q : Qp) (vs : list val) : iProp Σ :=
  ([∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦{q} v)%I.
Notation "l ↦∗{ q } vs" := (array l q vs)
  (at level 20, q at level 50, format "l  ↦∗{ q }  vs") : bi_scope.
Notation "l ↦∗ vs" := (array l 1 vs)
  (at level 20, format "l  ↦∗  vs") : bi_scope.

(** We have [FromSep] and [IntoSep] instances to split the fraction (via the
[AsFractional] instance below), but not for splitting the list, as that would
lead to overlapping instances. *)

Section lifting.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types vs : list val.
Implicit Types q : Qp.
Implicit Types l : loc.
Implicit Types sz off : nat.

Global Instance array_timeless l q vs : Timeless (array l q vs) := _.

Global Instance array_fractional l vs : Fractional (λ q, l ↦∗{q} vs)%I := _.
Global Instance array_as_fractional l q vs :
  AsFractional (l ↦∗{q} vs) (λ q, l ↦∗{q} vs)%I q.
Proof. split; done || apply _. Qed.

Lemma array_nil l q : l ↦∗{q} [] ⊣⊢ emp.
Proof. by rewrite /array. Qed.

Lemma array_singleton l q v : l ↦∗{q} [v] ⊣⊢ l ↦{q} v.
Proof. by rewrite /array /= right_id loc_add_0. Qed.

Lemma array_app l q vs ws :
  l ↦∗{q} (vs ++ ws) ⊣⊢ l ↦∗{q} vs ∗ (l +ₗ length vs) ↦∗{q} ws.
Proof.
  rewrite /array big_sepL_app.
  setoid_rewrite Nat2Z.inj_add.
  by setoid_rewrite loc_add_assoc.
Qed.

Lemma array_cons l q v vs : l ↦∗{q} (v :: vs) ⊣⊢ l ↦{q} v ∗ (l +ₗ 1) ↦∗{q} vs.
Proof.
  rewrite /array big_sepL_cons loc_add_0.
  setoid_rewrite loc_add_assoc.
  setoid_rewrite Nat2Z.inj_succ.
  by setoid_rewrite Z.add_1_l.
Qed.

Global Instance array_cons_frame l q v vs R Q :
  Frame false R (l ↦{q} v ∗ (l +ₗ 1) ↦∗{q} vs) Q →
  Frame false R (l ↦∗{q} (v :: vs)) Q.
Proof. by rewrite /Frame array_cons. Qed.

Lemma update_array l q vs off v :
  vs !! off = Some v →
  ⊢ l ↦∗{q} vs -∗ ((l +ₗ off) ↦{q} v ∗ ∀ v', (l +ₗ off) ↦{q} v' -∗ l ↦∗{q} <[off:=v']>vs).
Proof.
  iIntros (Hlookup) "Hl".
  rewrite -[X in (l ↦∗{_} X)%I](take_drop_middle _ off v); last done.
  iDestruct (array_app with "Hl") as "[Hl1 Hl]".
  iDestruct (array_cons with "Hl") as "[Hl2 Hl3]".
  assert (off < length vs) as H by (apply lookup_lt_is_Some; by eexists).
  rewrite take_length min_l; last by lia. iFrame "Hl2".
  iIntros (w) "Hl2".
  clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup.
  { apply list_lookup_insert. lia. }
  rewrite -[in (l ↦∗{_} <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup).
  iApply array_app. rewrite take_insert; last by lia. iFrame.
  iApply array_cons. rewrite take_length min_l; last by lia. iFrame.
  rewrite drop_insert_gt; last by lia. done.
Qed.

(** * Rules for allocation *)
Lemma mapsto_seq_array l q v n :
  ([∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦{q} v) -∗
  l ↦∗{q} replicate n v.
Proof.
  rewrite /array. iInduction n as [|n'] "IH" forall (l); simpl.
  { done. }
  iIntros "[$ Hl]". rewrite -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc. iApply "IH". done.
Qed.

Lemma twp_allocN s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN_seq; [done..|].
  iIntros (l) "Hlm". iApply "HΦ".
  iDestruct (big_sepL_sep with "Hlm") as "[Hl $]".
  by iApply mapsto_seq_array.
Qed.
Lemma wp_allocN s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_allocN_vec s E v n :
  (0 < n)%Z →
  [[{ True }]]
    AllocN #n v @ s ; E
  [[{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN; [ lia | done | .. ].
  iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
Qed.
Lemma wp_allocN_vec s E v n :
  (0 < n)%Z →
  {{{ True }}}
    AllocN #n v @ s ; E
  {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_vec; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

(** * Rules for accessing array elements *)
Lemma twp_load_offset s E l q off vs v :
  vs !! off = Some v →
  [[{ l ↦∗{q} vs }]] ! #(l +ₗ off) @ s; E [[{ RET v; l ↦∗{q} vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_load with "Hl1"). iIntros "Hl1". iApply "HΦ".
  iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
  iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_load_offset s E l q off vs v :
  vs !! off = Some v →
  {{{ ▷ l ↦∗{q} vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗{q} vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_load_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) :
  [[{ l ↦∗{q} vs }]] ! #(l +ₗ off) @ s; E [[{ RET vs !!! off; l ↦∗{q} vs }]].
Proof. apply twp_load_offset. by apply vlookup_lookup. Qed.
Lemma wp_load_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) :
  {{{ ▷ l ↦∗{q} vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗{q} vs }}}.
Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.

Lemma twp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ <[off:=v]> vs }]].
Proof.
  iIntros ([w Hlookup] Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_store with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_store_offset.
  eexists. by apply vlookup_lookup.
Qed.
Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v', #true); l ↦∗ <[off:=v2]> vs }]].
Proof.
  iIntros (Hlookup ?? Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_suc with "Hl1"); [done..|].
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. eapply twp_cmpxchg_suc_offset=> //.
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset s E l q off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  [[{ l ↦∗{q} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v0, #false); l ↦∗{q} vs }]].
Proof.
  iIntros (Hlookup HNEq Hcmp Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_fail with "Hl1"); first done.
  { destruct Hcmp; by [ left | right ]. }
  iIntros "Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
  rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_fail_offset s E l q off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  {{{ ▷ l ↦∗{q} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v0, #false); l ↦∗{q} vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗{q} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #false); l ↦∗{q} vs }]].
Proof. intros. eapply twp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
Lemma wp_cmpxchg_fail_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗{q} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #false); l ↦∗{q} vs }}}.
Proof. intros. eapply wp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.

Lemma twp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_faa with "Hl1").
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. apply twp_faa_offset=> //.
  by apply vlookup_lookup.
Qed.
Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

(** Derived prophecy laws *)

(** Lemmas for some particular expression inside the [Resolve]. *)
Lemma wp_resolve_proph s E (p : proph_id) (pvs : list (val * val)) v :
  {{{ proph p pvs }}}
    ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
  {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
Proof.
  iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
  iApply lifting.wp_pure_step_later=> //=. iApply wp_value.
  iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.

Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
  vals_compare_safe v1 v1 →
  {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
Proof.
  iIntros (Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
  iApply (wp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{q} v' }}}.
Proof.
  iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  iApply (wp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

End lifting.

Typeclasses Opaque array.


Set Implicit Arguments.
Require Import Lia.
Require Import Arith.
Require Export Coq.Program.Equality.
From Dblib Require Import DblibTactics DeBruijn Environments.

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

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.

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

(* The binding structure of terms. *)

Instance Var_term : Var term := {
  var := TVar (* avoid eta-expansion *)
}.

Fixpoint traverse_term (f : nat -> nat -> term) l t :=
  match t with
  | TVar x =>
      f l x
  | TAbs t =>
      TAbs (traverse_term f (1 + l) t)
  | TApp t1 t2 =>
      TApp (traverse_term f l t1) (traverse_term f l t2)
  end.

Instance Traverse_term : Traverse term term := {
  traverse := traverse_term
}.

Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_term : @TraverseRelative term term _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

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

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).

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

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.

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

(* The binding structure of types. *)

Instance Var_ty : Var ty := {
  var := TyVar (* avoid eta-expansion *)
}.

Fixpoint traverse_ty (f : nat -> nat -> ty) l T :=
  match T with
  | TyVar x =>
      f l x
  | TyArrow T1 T2 =>
      TyArrow (traverse_ty f l T1) (traverse_ty f l T2)
  | TyForall T =>
      TyForall (traverse_ty f (1 + l) T)
  end.

Instance Traverse_ty : Traverse ty ty := {
  traverse := traverse_ty
}.

Instance TraverseVarInjective_ty : @TraverseVarInjective ty _ ty _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_ty : @TraverseFunctorial ty _ ty _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_ty : @TraverseRelative ty ty _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_ty : @TraverseIdentifiesVar ty _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_ty : @TraverseVarIsIdentity ty _ ty _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

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

(* The tactic [introq] introduces all of the universal quantifiers that appear
   at the head of the goal. *)

Ltac introq :=
  match goal with
  | |- ?P -> ?Q =>
      idtac
  | |- forall _, _ =>
      intro; introq
  | |- _ =>
      idtac
  end.

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

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' ->
      j n E t U'.

Hint Constructors j : j.

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

(* Monotonicity of indices. *)

Lemma j_index_monotonic:
  forall n E t T,
  j n E t T ->
  forall m,
  m >= n ->
  j m E t T.
Proof.
  induction 1; eauto with j lia.
Qed.

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

(* Type preservation. *)

Lemma term_weakening:
  forall n E t T,
  j n E t T ->
  forall x U E',
  insert x U E = E' ->
  j n E' (shift x t) T.
Proof.
  induction 1; intros; subst; simpl_lift_goal; econstructor;
  eauto with lookup_insert insert_insert map_insert.
Qed.

Lemma type_weakening:
  forall n E t T,
  j n E t T ->
  forall x E' T',
  map (shift x) E = E' ->
  shift x T = T' ->
  j n E' t T'.
Proof.
  induction 1; intros; subst; simpl_lift_goal;
  econstructor;
  eauto using lookup_map_some, map_map_exchange
  with simpl_lift_goal lift_lift lift_subst map_insert.
Qed.

Lemma term_substitution:
  forall n E2 t2 T2,
  j n E2 t2 T2 ->
  forall x T1 E,
  E2 = insert x T1 E ->
  forall m t1,
  (* The derivation that is plugged in is usually canonical, i.e.,
     [m] is zero, but we do not require this. *)
  j m E t1 T1 ->
  forall k,
  (* In the worst case, the height of the new derivation is the sum
     of the heights of the original derivations, due to the way the
     derivations are plugged in at variables. *)
  k >= m + n ->
  j k E (subst t1 x t2) T2.
Proof.
  induction 1; intros; subst; simpl_subst_goal;
  try solve [
    econstructor;
    eauto using term_weakening, type_weakening with insert_insert map_insert lia
  ].
  (* JVar. *)
  unfold subst_idx. dblib_by_cases; lookup_insert_all;
  eauto using j_index_monotonic with j lia.
Qed.

Lemma type_substitution:
  forall n E t T,
  j n E t T ->
  forall U x E' T',
  map (subst U x) E = E' ->
  subst U x T = T' ->
  j n E' t T'.
Proof.
  induction 1; intros; subst; simpl_subst_goal;
  econstructor;
  eauto using lookup_map_some, map_map_exchange
  with simpl_subst_goal lift_subst subst_subst map_insert.
Qed.

Lemma inversion_JAbs:
  forall E t T1 T2,
  j 0 E (TAbs t) (TyArrow T1 T2) ->
  exists m,
  j m (insert 0 T1 E) t T2.
Proof.
  introq. intro h. dependent destruction h; try solve [ lia ].
  (* JAbs *)
  eexists. eassumption.
Qed.

Lemma inversion_JTyAbs:
  forall E t T,
  j 0 E (TAbs t) (TyForall T) ->
  (* We require a lambda-abstraction, so as to eliminate the cases where
     we have a variable or an application, which we cannot deal with. *)
  j 0 (map (shift 0) E) (TAbs t) T.
Proof.
  introq. intro h. dependent destruction h; try solve [ lia ].
  (* JTyAbs *)
  assumption.
Qed.

(* The following lemma looks like an inversion of [JTyAbs], but it
   is not truly one, because it is proved by applying weakening and
   [JTyApp], hence increasing the height of the derivation by one. *)

Goal (* phony_inversion_JTyAbs: *)
  forall n E t T,
  j n E t (TyForall T) ->
  j (S n) (map (shift 0) E) t T.
Proof.
  intros.
  generalize (pun_2 T 0). simpl. intro h. rewrite <- h. clear h.
  eapply JTyApp; [ | eauto | eauto ].
  eapply type_weakening; [ eauto | eauto | ].
  simpl_lift_goal. eauto.
Qed.

Lemma canonicalization:
  forall n E t T,
  j n E (TAbs t) T ->
  j 0 E (TAbs t) T.
Proof.
  (* Well-founded induction on [n]. *)
  intro n. pattern n. apply (well_founded_ind lt_wf). clear n. intros n ih.
  (* Analysis of the typing judgement. Inner structural induction,
     in order to go through [JTyAbs], which does not cause a decrease
     in [n]. *)
  introq. intro h. dependent induction h; eauto with j.
  (* JTyApp *)
  (* This is the reduction of a type-level beta-redex. *)
  eapply type_substitution; [ | | eauto ].
  eapply inversion_JTyAbs. eauto.
  eapply map_map_vanish. apply subst_lift.
Qed.

Lemma type_preservation:
  forall m E t1 T,
  j m E t1 T ->
  forall t2,
  red t1 t2 ->
  exists n,
  j n E t2 T.
(* A local tactic to recognize and apply the induction hypothesis. *)
Ltac tp_ih :=
  match goal with ih: forall _, red _ _ -> _, hr: red _ _ |- _ =>
    generalize (ih _ hr); intros [ ? ? ]
  end.
Proof.
  (* By induction on the type derivation. *)
  induction 1; intros ? hred.
  (* JVar *)
  dependent destruction hred.
  (* JAbs *)
  dependent destruction hred.
  tp_ih. eauto using (JAbs 0).
  (* JApp *)
  dependent destruction hred.
  (* Sub-case: beta-reduction. *)
  match goal with h: j _ _ (TAbs _) (TyArrow _ _) |- _ =>
    generalize (inversion_JAbs (canonicalization h)); intros [ ? ? ]
  end.
  solve [ eauto using term_substitution ].
  (* Sub-cases: reduction under a context. *)
  tp_ih. eauto using (JApp 0).
  tp_ih. eauto using (JApp 0).
  (* JTyAbs *)
  tp_ih. eauto with j.
  (* JTyApp *)
  tp_ih. eauto with j.
Qed.


Require Export Omega.
Require Export List.
Export ListNotations.
Require Export Setoid.
Require Export Morphisms.
Require Export Relation_Definitions.
Require Export Ring.
Require Export Basics.  (* for composition *)

Require Export SmolkaUtilities.
Require Export Utilities.
Require Export TermsUtilities.
Require Export Substitutions.

(** * Evaluating (ground) terms *)

(** When t is ground, evaluates t to T0 or to T1.
    Not complete when t is not ground *)

Fixpoint eval_ground (t: term) : term :=
  match t with
  | T0 => T0
  | T1 =>  T1
  | (V _) => t
  | A u v => match (eval_ground u) , (eval_ground  v) with
             | T0 , T0 => T0
             | T0 , T1 => T1
             | T1 , T0 => T1
             | T1 , T1 => T0
             | _ , _   => t
             end
  | M u v => match (eval_ground u) , (eval_ground v) with
             | T0 , T0 => T0
             | T0 , T1 => T0
             | T1 , T0 => T0
             | T1 , T1 => T1
             | _ , _     => t
             end
  end.

(** ** eqv is a congruence wrt eval_ground *)

Lemma eval_ground_eqv t :
  eval_ground t == t.
Proof.
  induction t as [ | | v | t1 IH1 t2 IH2| t1 IH1 t2 IH2]; simpl; auto;
    destruct (eval_ground t1); destruct (eval_ground t2);
      rewrite <- IH1;  rewrite  <- IH2; auto.
Qed.

Lemma eval_ground_compat t1 t2 :
  eqv t1 t2 -> eqv (eval_ground t1) (eval_ground t2).
Proof.
  intros H.
  assert (a1:= eval_ground_eqv t1).
  assert (a2:= eval_ground_eqv t2).
  apply eqv_trans with t1. easy.
  apply eqv_trans with t2. easy. easy.
Qed.

Add Parametric Morphism : eval_ground with
      signature eqv ==> eqv as eval_ground_mor.
  exact eval_ground_compat.
Qed.

Lemma eval_ground_complete (t: term) :
  (ground_term t = true) ->
  (eval_ground t = T0) \/ (eval_ground t = T1).
Proof.
  intros H.
  induction t as [| | v | t1 IH1 t2 IH2 |  t1 IH1 t2 IH2]; simpl; auto.
  - inversion H.
  - apply ground_term_A_elim in H; destruct H;
      assert (a:= IH1 H);
      assert (b:= IH2 H0);
      destruct a;
      destruct b;
      rewrite H1;
      rewrite H2;
      firstorder.
  - apply ground_term_M_elim in H; destruct H;
      assert (a:= IH1 H);
      assert (b:= IH2 H0);
      destruct a;
      destruct b;
      rewrite H1;
      rewrite H2;
      firstorder.
Qed.

Lemma eval_Ground_complete (t: term) :
  Ground_term t ->
  (eval_ground t = T0) \/ (eval_ground t = T1).
Proof.
  intros H.
  apply Ground_is_ground in H.
  now apply eval_ground_complete.
Qed.

Lemma Ground_T0_or_T1 (t: term) :
  Ground_term t ->
  (t == T0) \/ ( t == T1).
Proof.
  intros H.
  assert (A:= eval_Ground_complete t H).
  assert (B:=  (eval_ground_eqv t)).
  destruct A as [l | r].
  - left.
    rewrite l in B.
    now apply eqv_sym.
  - right.
    rewrite r in B.
    now apply eqv_sym.
Qed.

Lemma eval_ground_exact_T0 t :
  eval_ground t = T0 ->
  t == T0.
Proof.
  intros H0.
  rewrite <- H0.
  symmetry; apply eval_ground_eqv.
Qed.

Lemma eval_ground_exact_T1 t :
  eval_ground t = T1 ->
  t == T1.
Proof.
  intros H1.
  rewrite <- H1.
  symmetry; apply eval_ground_eqv.
Qed.

Lemma eval_ground_eqv_T0 t :
  Ground_term t ->
  t == T0 ->
  eval_ground t = T0 .
Proof.
  intros H0 H1.
  assert (H2 := Ground_is_ground t H0).
  assert (H3 := eval_ground_complete t H2).
  inversion H3.
  - easy.
  - assert (H4 := eval_ground_exact_T1 t H).
    rewrite H1 in H4.
    symmetry in H4.
    now apply T1_neqv_T0 in H4.
Qed.

Lemma eval_ground_eqv_T1 t :
  Ground_term t ->
  t == T1 ->
  eval_ground t = T1 .
Proof.
  intros H0 H1.
  assert (H2 := Ground_is_ground t H0).
  assert (H3 := eval_ground_complete t H2).
  inversion H3.
  - assert (H4 := eval_ground_exact_T0 t H).
    rewrite H1 in H4.
    symmetry in H4.
    now apply T0_neqv_T1 in H4.
  - easy.
Qed.

  Lemma ground_T0_iff t :
  Ground_term t ->
  t == T0 <-> ~ t == T1.
Proof.
  intros H1.  split.
  - intros H2 H3.
    rewrite H2 in H3. auto.
  - intros H4.
    assert (A:= eval_Ground_complete t H1).
    destruct A as [L | R].
    + now apply eval_ground_exact_T0.
    + rewrite (eval_ground_exact_T1 t R) in H4.
      assert (A:= eqv_ref T1).
      tauto.
Qed.

(** Once again: conceptually jut use ground_T0_iff for t +' 1.  But
more trouble to prove it that way than to just cut-and-paste that
proof with obvious changes *)

Lemma ground_T1_iff t :
  Ground_term t ->
  t == T1 <-> ~ t == T0.
Proof.
  intros H1.  split.
  - intros H2 H3.
    rewrite H2 in H3. auto.
  - intros H4.
    assert (A:= eval_Ground_complete t H1).
    destruct A as [L | R].
    + rewrite (eval_ground_exact_T0 t L) in H4.
      assert (A:= eqv_ref T0).
      tauto.
    + now apply eval_ground_exact_T1.
Qed.


Require Import FiatFormal.Data.List.Base.
Require Import FiatFormal.Tactics.
Require Import Coq.Program.Basics.

(********************************************************************)
(** Lemmas: map *)

Lemma map_rewind
 :  forall {A B: Type} (f: A -> B) (e: list A) x
 ,  map f e :> f x
 =  map f (e :> x).
Proof. auto. Qed.

Lemma map_snoc
 :  forall A B (f: A -> B) x xs
 ,  map f (snoc x xs) = snoc (f x) (map f xs).
Proof.
 intros.
 induction xs.
  simpl. auto.
  simpl. rewrite IHxs. auto.
Qed.
Hint Rewrite map_snoc : global.

(* Applying a function to all the elements of a list and getting
   one of the results is the same as getting the original value
   and applying the function to just that value. *)
Lemma get_map
 : forall {A B: Type} (f: A -> B) (xx: list A) x n
 ,  get n xx         = Some x
 -> get n (map f xx) = Some (f x).
Proof.
 intros. gen n.
 induction xx; intros.
  false.
  simpl. destruct n.
   simpl in H. inverts H. trivial.
   auto.
Qed.
Hint Resolve get_map.

Lemma get_map_exists
 :  forall {A B} n (f : A -> B) (xx : list A) fx
 ,  get n (map f xx) = Some fx
 -> exists x, get n xx = Some x /\ fx = f x.
Proof.
 intros. gen n.
 induction xx; intros.
 - nope.
 - destruct n.
   + simpl.
     exists a. rip.
     simpl in H. congruence.
   + simpl in H.
     simpl.
     eapply IHxx in H. auto.
Qed.
Hint Resolve get_map_exists.

Lemma map_app
 :  forall A B (f: A -> B) xx yy
 ,  map f (xx ++ yy)
 =  map f xx ++ map f yy.
Proof.
 intros.
 induction xx.
  auto.
  simpl. rewrite IHxx. auto.
Qed.
Hint Resolve map_app.
Hint Rewrite map_app : global.

(* Applying two functions to all the elements of a list one after
   the other is the same as applying their composition. *)
Lemma map_map
 :  forall {A B C: Type} (f: B -> C) (g: A -> B) xx
 ,  map f (map g xx)
 =  map (compose f g) xx.
Proof.
 induction xx.
  auto.
  simpl. rewrite IHxx. auto.
Qed.

Lemma map_impl
 :  forall {A B} (f: A -> B) {g: A -> B} xs
 ,  (forall x, f x = g x)
 -> map f xs = map g xs.
Proof.
 intros.
 induction xs.
  auto.
  repeat rewritess.
Qed.

(* Extensional equality with map.
   If two functions return equal results for all elements in a list,
   then using one or the other in a map gives the same result. *)
Lemma map_ext_in
 : forall {A B : Type}
          (f g : A -> B)
          (xs  : list A)
 , (forall x, In x xs -> f x = g x)
 -> map f xs = map g xs.
Proof.
 intros.
 induction xs.
  auto.
  simpl. rewrite IHxs. rewrite H.
   auto. simpl. auto.
   intros. apply H.
   simpl. auto.
Qed.

(* If some element is in the list resulting from a map,
   then we can find the un-transformed element in the original list. *)
Lemma map_in_exists
  :  forall (A B: Type) (f: A -> B) x ys
  ,  In x (map f ys)
  -> (exists y, f y = x /\ In y ys).
Proof.
 intros.
 induction ys.
  simpl in H. false.
  simpl in H.
   inverts H.
   simpl. exists a. eauto.
   apply IHys in H0.
   destruct H0.
   exists x0. inverts H.
   split; auto.
Qed.
Hint Resolve map_in_exists.

(* When we transform a list with a map, then we can find the element
   in the result corresponding to any element in the source. *)
Lemma map_exists_in
  :  forall (A B: Type) (f: A -> B) x ys
  ,  (exists y, f y = x /\ In y ys)
  -> In x (map f ys).
Proof.
 intros.
 induction ys.
  destruct H.
   simpl in H. inverts H. false.
   simpl in H.
   destruct H.
   inverts H.
   simpl.
   inverts H1. auto.
   right. eauto.
Qed.
Hint Resolve map_exists_in.

Lemma map_get_some_some
 :  forall {A} t1 t2 ix us (f: A -> A)
 ,  Some t1 = get ix us
 -> Some t2 = get ix (map f us)
 -> f t1 = t2.
Proof.
 intros. gen ix t1 t2.
 induction us; intros.
  false.
  destruct ix.
   simpl in H. simpl in H0.
   inverts H.  inverts H0. auto.

   simpl in H. simpl in H0; eauto.
Qed.

Lemma in_mapped
 :  forall {A B} (x : A) (xs : list A) (f : A -> B)
 ,  In x xs -> In (f x) (map f xs).
Proof.
 intros. gen x f.
 induction xs; intros.
  simpl. auto.
  simpl. simpl in H.
   inverts H.
    left.  auto.
    right. auto.
Qed.
Hint Resolve in_mapped.


Set Printing Universes.

Section Types.

  Polymorphic Definition TNat: Type := nat.

  Polymorphic Definition TMem L U: Type :=
    sigT (fun a:Type => prod (L -> a) (a -> U)).

  Polymorphic Definition TSel {L U} (t: TMem L U): Type :=
    projT1 t.

  Polymorphic Definition TTop: Type := sigT (fun a: Type => a).

  Polymorphic Definition TBot: Type := forall x: Type, x.

  Polymorphic Definition TAll (A : Type) (B: A -> Type): Type := forall x:A, (B x).

  Polymorphic Definition TAnd (A: Type) (B: Type): Type := A * B. (* TODO: not sure *)

  (* TODO: TBind, use coinduction? *)

  Check (TAll (TMem TBot TTop) (fun x => TAll (TSel x) (fun _ => (TSel x)))).

End Types.

Section Terms.

  Polymorphic Definition tzro: TNat :=
  0.

  Polymorphic Definition ttyp T: TMem T T :=
  existT (fun a => prod (T -> a) (a -> T)) T (pair (fun (a:T) => a) (fun (a:T) => a)).

  Polymorphic Definition tabs {A: Type} {B: A -> Type} (f: forall x:A, B x): TAll A B := f.

  Polymorphic Definition tapp {A: Type} {B: A -> Type} (f: TAll A B) (x: A): (B x) := f x.

  Check tabs.

  (* TODO: unpack *)

End Terms.

Section Typing.

  (* Intro & elim forms *)
  Lemma tmem_intro: forall L U (x: TMem L U) (y: L), (TSel x).
  Proof.
    intros. destruct x. destruct p. simpl. apply x0. apply y.
  Qed.

  Lemma tmem_elim: forall L U (x: TMem L U) (y: TSel x), U.
  Proof.
    intros. destruct x. destruct p. simpl. apply u. apply y.
  Qed.

End Typing.

(* Verify impredicativity via universe polymorphism *)
Definition nest T: TMem (TMem T T) (TMem T T) :=
  ttyp (TMem T T).

Check nest.

Definition unnest T: TSel (nest T) :=
ttyp T.

Check unnest.

Section Subtyping.

  (* Subtyping could be translated as coercions *)

  Polymorphic Definition sub_any {A: Type} (t: A): TTop := existT (fun a: Type => a) A t.
  Polymorphic Definition sub_bot {A: Type} (t: TBot): A := t A.

  Polymorphic Definition tmem_any {L U: Type} (t: TMem L U): TTop := sub_any t.
  Polymorphic Definition bot_tmem {L U: Type} (t: TBot): (TMem L U) := sub_bot t.

End Subtyping.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import languages_o2.

Section D_meta.
Import D.

Lemma ty_wf_weaken: forall Gamma T U, ty_wf Gamma T -> ctx_wf (U :: Gamma) -> ty_wf (U :: Gamma) T.
Proof.
  Admitted.

Lemma wf_lookup: forall Gamma x T, ctx_wf Gamma -> indexr x Gamma = Some T -> ty_wf Gamma T.
Proof.
  intros.
  induction H; inversion H0.
  inversion H0.
  destruct (beq_nat x (length Gamma)).
  - injection H2. intros. subst.
    apply ty_wf_weaken. assumption. constructor. assumption. assumption.
  - apply IHctx_wf in H2. apply ty_wf_weaken. assumption. constructor. assumption. assumption.
Qed.

Lemma hcwf: forall {Gamma e T}, has_type Gamma e T -> ctx_wf Gamma
    with
    tcwf: forall {Gamma T}, ty_wf Gamma T -> ctx_wf Gamma.
Proof.
  - intros. induction H; eauto.
  - intros. induction H; eauto.
Qed.

Lemma extract1: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T2.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma extract2: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T1.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma ty_wf_open: forall Gamma e T1 T2,
    ty_wf (T1 :: Gamma) (open (varF (length Gamma)) T2) ->
    has_type Gamma e T1 ->
    ty_wf Gamma (open' e T2)
  with
    has_type_open: forall Gamma e1 e2 T1 T2,
      has_type (T1 :: Gamma) e2 T2 ->
      has_type Gamma e1 T1 ->
      has_type Gamma (open_tm' e1 e2) (open' e1 T2).
Proof.
  -  (* ty_wf_open *)
    intros.  unfold open in *. unfold open' in *. unfold open_tm' in *.
    generalize dependent Gamma. generalize dependent e. generalize dependent T1.
    induction T2; intros.
    (* TTop *)
    -- simpl. constructor. eapply hcwf. eauto.
    (* TBot *)
    -- simpl. constructor. eapply hcwf. eauto.
    (* TAll *)
    -- simpl in H. inversion H. subst. simpl. constructor.
       --- eapply IHT2_1; eauto.
       --- unfold open in *.
         admit. (* TODO messy *)
    (* TSel *)
    -- inversion H0; subst; eauto.
    (* TMem *)
    -- inversion H. subst. simpl. constructor.
       eapply IHT2_1. eauto. auto.
       eapply IHT2_2. eauto. auto.
    (* TBind *)
    -- inversion H.
    (* TAnd *)
    -- inversion H.

  (* has_type_open *)
  - intros. unfold open in *. unfold open' in *. unfold open_tm' in *.
    generalize dependent Gamma. generalize dependent e1. generalize dependent e2.
    generalize dependent T1.
    induction T2; intros; eauto.
Admitted. (*TODO: most of the cases are wrong, try avoiding eauto *)

Lemma htwf: forall {Gamma e T}, has_type Gamma e T -> ty_wf Gamma T.
Proof.
  intros. induction H; auto.
  - eapply wf_lookup; eauto.
  - apply wf_sel with (T1 := T1) (T2 := TTop); auto. constructor. eapply tcwf. eauto.
  - apply (extract1 _ _ _ IHhas_type2).
  - constructor; auto.
  - inversion IHhas_type1. subst. eapply ty_wf_open; eauto.
  - constructor; auto.
Qed.

End D_meta.

Section Term_Reflect.

  (* "term T" is the type of coq terms having type T, where T ranges over the shallow embedded types above.  *)
  Polymorphic Inductive term: Type -> Type :=
  | term_tnat: TNat -> term TNat (* TODO remove later *)
  | term_ttop: TTop -> term TTop
  | term_tbot: TTop -> term TBot
  | term_tmem: forall T, TMem T T -> term (TMem T T)
  | term_tsel: forall L U (t: TMem L U), @TSel L U t -> term (@TSel L U t)
  | term_tall: forall T U, TAll T U -> term (TAll T U)
  | term_tand: forall T U, TAnd T U -> term (TAnd T U)
  .

  (* ∃T.term T*)
  Polymorphic Definition TERM: Type := sigT (fun T: Type => term T).

  (* pack a term T into TERM *)
  Polymorphic Definition TERM_of {T} (t: term T): TERM :=
    existT term T t.

End Term_Reflect.

  (* The context encoding is somewhat inspired by
       "System F in Agda for Fun and Profit",
     by Chapman, Kireev, Nester, and Wadler (MPC'19). *)

  (* Translated typing contexts *)
  Polymorphic Inductive ty_env: Type :=
  | ty_nil: ty_env
  | ty_cons: Type -> ty_env -> ty_env
  .

  (* \lang \rang *)
  Notation "⟪ x ; .. ; y ⟫" := (ty_cons x .. (ty_cons y ty_nil) ..).
  Notation "⟪⟫" := ty_nil.
  Notation "T ;;⋆ Gamma" := (ty_cons T Gamma) (at level 70, right associativity).

  Local Definition ty_env_ex1: ty_env := ty_cons Type (ty_cons Prop (ty_cons Set (ty_cons TERM ty_nil))).
  Local Definition ty_env_ex2: ty_env := ⟪ Type ; Prop ; Set; TERM; ty_env ⟫.

  (* Morally, ty_env is a list of Coq types with heterogeneous universe
   levels However, we cannot just resolve to the standard list type,
   e.g.,

     Polymorphic Definition ty_env: Type = list Type.

   which results in an odd proof obligation

     Type@{coq.1760} = list Type@{coq.1762}.

   It seems doubtful that we can proceed here. *)

  Fixpoint ty_env_length (Gamma: ty_env): nat :=
    match Gamma with
    | ⟪⟫ => 0
    | _ ;;⋆ Gamma' => 1 + (ty_env_length Gamma')
    end.

  (* Term contexts are indexed by the typing context. *)
  Polymorphic Inductive tm_env: ty_env -> Type :=
  | tm_nil:  tm_env ⟪⟫
  | tm_cons: forall T Gamma, T -> tm_env Gamma -> tm_env (T ;;⋆ Gamma)
  .

  (* \lAngle \rAngle*)
  Notation "⟨ x ; .. ; y ⟩" := (tm_cons _ _ x .. (tm_cons _ _ y tm_nil) ..).
  Notation "⟨⟩" := tm_nil.
  Notation "v ;⋆ gamma" := (tm_cons _ _ v gamma) (at level 65, right associativity).

  Local Definition tm_env_ex1 := ⟨ 1; 2; False ⟩.
  Check tm_env_ex1.

  Polymorphic Definition tm_env_destruct {T Gamma} (c: tm_env (T ;;⋆ Gamma)): (T * (tm_env Gamma)) :=
    match c with
    | x ;⋆ xs => (x,xs)
    end.

  Polymorphic Definition tm_env_hd {T Gamma} (c: tm_env (T ;;⋆ Gamma)) := fst (tm_env_destruct c).
  Polymorphic Definition tm_env_tl {T Gamma} (c: tm_env (T ;;⋆ Gamma)) := snd (tm_env_destruct c).

  Fixpoint tm_env_length {Gamma} (gamma: tm_env Gamma): nat :=
    match gamma with
    | ⟨⟩ => 0
    | _ ;⋆ vs => 1 + (tm_env_length vs)
    end.

  Lemma env_length_eq: forall Gamma (gamma: tm_env Gamma), ty_env_length Gamma = tm_env_length gamma.
  Proof.
    intros.
    induction gamma; simpl; auto.
  Qed.

(*

how should this stuff behave?

t_all translation case:
  {{ Gamma }} = list of *terms* having *translated* types as prescribed by Gamma

  ty_wf Gamma T1     ⤳ T1' : {{ Gamma }} -> Type
  ty_wf T1::Gamma T2 ⤳ T2' : {{ T1::Gamma }} -> Type
  ty_wf Gamma (D.Tall T1 T2)

  ⤳ {{ Gamma }} ->  TAll (T1' {{ Gamma }},  λx:T1' {{ Gamma }}.  T2' (x :: {{ Gamma }}))

structural properties:

  ctx_cons [[T1]] {{ Gamma }} = {{ T1 :: Gamma }}

*)

Section Interp.

  Polymorphic Variable DUMMY_TERM: { U: Type & { Gamma': ty_env & tm_env Gamma' -> term U } }.
  Polymorphic Variable DUMMY_TYPE: { Gamma': ty_env & tm_env Gamma' -> Type }.

  Polymorphic Fixpoint tctx {Gamma} (wf: D.ctx_wf Gamma): ty_env :=
    match wf with
    | D.wf_empty => ⟪⟫
    | D.wf_cons Gamma T wf_Gamma_T wf_Gamma => (ttp wf_Gamma_T) ;;⋆ (tctx wf_Gamma)
    end
  with ttp {Gamma} {T} (ty_wf: D.ty_wf Gamma T): { Gamma : ty_env & tm_env Gamma -> Type}  :=
      match ty_wf with
        | _ => DUMMY_TYPE
    (* | D.wf_top _ => *)
    (*   TTop *)
    (* | D.wf_bot _ => *)
    (*   TBot *)
    (* | D.wf_all _ _ _ ty_wf_T1 ty_wf_T2 => *)
    (*   TBot (*TODO: requires denotation as context-dependent functions *) *)
    (* | D.wf_mem _ _ _ ty_wf_T1 ty_wf_T2 => *)
    (*   TMem (ttp ty_wf_T1) (ttp ty_wf_T2) *)
    (* | D.wf_sel _ _ _ _ _ _ has_type_e => *)
    (*   match ttm has_type_e with *)
    (*   | existT _ _ (term_tmem T t) => @TSel T T t *)
    (*   | _ => False *)
    (*   end *)
    end
  (*
    Problem: we cannot mention ttp in the return type of ttm! The idea is to
    construct a TERM = term U for some U s.t. U = ttp (htwf typing).
    reify is supposed to turn this intermediate term representation into a proper
    coq term having the type U.
   *)
  with ttm {Gamma} {t} {T} (typing: D.has_type Gamma t T): { U: Type & { Gamma': ty_env & tm_env Gamma' -> term U } } :=
      match typing with
      | _ => DUMMY_TERM
    (* | D.t_var v _ _ _ _ => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_typ _ _ ty_wf_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_seli _ _ _ _ has_type_a_T1 has_type_e_TM_T1_Top => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_sele _ _ _ _ has_type_a_TSel_e has_type_e_TM_Bot_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_app _ _ _ _ _ has_type_f_TAll_T1_T2 has_type_x_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_abs _ _ _ _ ty_wf_T1 has_type_y_T2 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    end.

  (* Certifies that term U indeed gives a U. *)
  Polymorphic Variable reify: forall U, term U -> U. (* TODO: define *)

  (* TODO: use type classes to make more readable *)
  Polymorphic Lemma ttm_yields_ttp: forall Gamma t T (typing: D.has_type Gamma t T), (projT1 (ttm typing)) = (ttp (htwf typing)).
  Proof.
  Admitted.

  Unset Printing Universes.
  (* type preservation  *)
  Polymorphic Theorem type_preservation: forall Gamma t T (typing: D.has_type Gamma t T), (ttp (htwf typing)).
  Proof.
    intros.
    rewrite <- ttm_yields_ttp.
    destruct (ttm typing).
    simpl.
    apply reify.
    assumption.
  Qed.

(* TODO: how to relate evaluation in D and in Coq?

   - State as axiom that "Coq terms normalize" (does Coq coq correct paper help here?)
   - Seems reasonable to prove: If a well-typed source term never yields a result for any
     amount of fuel, then the coq translation does not normalize => contradiction of axiom

*)

End Interp.


(*! Tutorial: Verifying a small combinational circuit !*)
Require Import Koika.Frontend.

(*|
============================================================
 A simple combinational module and its proof of correctness
============================================================

In this file we model a simple combinational block:

  input ---(the module)--> output

Unlike in ``combinational_proof_tutorial.v``, we are not concerned here with properties related to timing, and for maximum simplicity we consider a single-cycle, non-combinational proof design.

We will start by verifying a Kôika function, and then show how to extend the proof to a single-rule design.

All that follows is parameterized on a register size ``sz``, set here to 16 bits.
|*)

Definition sz := 16.

(*|
Model
=====

We start by defining our functional model.  We have a type of "instructions", which select the mode of operation of our module:
|*)

Inductive operation :=
| quadruple (** Quadruple the input **)
| rotate_half. (** Rotate the input left by half of its width **)

(*|
Note that this model does not specify the bit pattern to encode those two instructions.
And we have a model of each of these operations:
|*)

Definition model (op: operation) (input: bits sz) : bits sz :=
  match op with
  | quadruple => Bits.slice 0 sz (Bits.mul (Bits.of_nat sz 4) input)
  | rotate_half => Bits.rotate_l (sz / 2) input
  end.

(*|
We chose a relatively low-level model: an alternative would have been to phrase the model in terms on integers, not bitvectors.  For the purposes of this demo, however, a simple bitvector-based model is enough.

We can check that this model behaves as expected:
|*)

Compute Bits.to_nat (model quadruple (Bits.of_nat sz 7)). (* .unfold *)
Compute model rotate_half Ob~1~1~1~1~0~0~0~0~1~0~1~0~1~0~1~0. (* .unfold *)

(*|
Combinational implementation
============================

We then define the Kôika implementation.
Let's consider a machine working with 8-bits instruction words. The machine should identify which
of the two instructions to perform based on a subset of the 8-bits of being high.
So we start by fixing a bit pattern to recognize for each operation :
|*)

Definition ops :=
  {| enum_name := "operations";
     enum_members :=
       vect_of_list ["quadruple"; "rotate_half"];
     enum_bitpatterns :=
       vect_of_list [Ob~0~0~0~0~0~1~1~0; Ob~0~0~0~1~0~0~0~1] |}.

(*|
… and then we implement the design itself.  While the functional model was written for legibility, the design is written for performance.
For example here we replace the multiply-by-4 operation with bitvector operations (slice and append).

Since we are writing a combinational function, the design is parametric on the set of registers `reg_t`:
|*)

  Definition design reg_t : UInternalFunction reg_t empty_ext_fn_t := {{
    fun design (op: bits_t 8) (input: bits_t sz): bits_t sz =>
      match unpack(enum_t ops, op) with
      | enum ops { quadruple } => input[|4`d0|:+14] ++ Ob~0~0
      | enum ops { rotate_half } => input[|4`d0|:+8] ++ input[|4`d8|:+8]
      return default: |16`d0|
      end
  }}.

(*|
The program above is *untyped*; we want to typecheck it; again, since we do not look at registers, we leave `reg_t` and `R` as parameters:
|*)

  Definition tc_design reg_t R :=
    tc_function R empty_Sigma (design reg_t).

(*|
.. note::

   The result of typechecking a term is a bit gnarly.  For cases like this, where we are going to verify properties of a program and hence spend a lot of time looking at its code, Kôika has an experimental *typed* language, found on the `cpitclaudel_typed_parsing`.

Correctness proof
=================

To prove the correctness of our design, we first need to phrase a correctness property; and for that, we need to relate `operations` in the sense of the model and `ops` in the sense of the design:
|*)

  Definition encode_operation op :=
    match op with
    | quadruple => vect_hd ops.(enum_bitpatterns)
    | rotate_half => vect_hd (vect_tl ops.(enum_bitpatterns))
    end.

  Compute encode_operation quadruple. (* .unfold *)
  Compute encode_operation rotate_half. (* .unfold *)

(*|
This is all that's needed to state a theorem.  We'll use Coq's “section” mechanism to parameterize the theorem about all the stateful parts of Kôika's semantics:
|*)

  Section Correctness.
    Context {reg_t: Type} {reg_t_eq_dec: EqDec reg_t}.
    Context {R: reg_t -> type} {REnv: Env reg_t} (r: REnv.(env_t) R).
    Context (L l: CompactLogs.Log R REnv).

(*|
For readability, let's define an abbreviation of the `interp_action` function.
|*)

    Definition run_design op input :=
      let design_inputs :=
          #{ ("op", bits_t 8) => op;
             ("input", bits_t 16) => input }# in
      CompactSemantics.interp_action
        r empty_sigma design_inputs L l (tc_design reg_t R).

(*|
(This is a good point to run a quick sanity check to make sure that our design passes simple smoke tests:)
|*)

    Definition design_result op input :=
      match run_design op input with
      | Some (_, r, _) => Some r
      | None => None
      end.

    Compute Bits.to_nat (must (design_result Ob~0~0~0~0~0~1~1~0 (Bits.of_nat sz 7))). (* .unfold *)
    Compute must (design_result Ob~0~0~0~1~0~0~0~1 Ob~1~1~1~1~0~0~0~0~1~0~1~0~1~0~1~0) : bits_t _. (* .unfold *)

(*|
All good.  Now for the theorem:
|*)

    Theorem design_correct:
      forall op input, exists ctx',
          run_design (encode_operation op) input =
          Some (l, model op input, ctx').
    Proof.
(*|
There are four components to this equality:

- `Some …` means that the Kôika design did not reach a conflict or a dynamic failure.
- `l` is unchanged in `Some (l, …)`: the model does not perform reads nor writes.
- The design produces the right value, as indicated by the `Some (…, model op input, …)` part of the output.
- `ctx'` records the reads and writes made to local variables; that's an implementation detail, so we don't say anything about it.

We are now ready for the proof, which is structured in two parts — one per operator.
|*)

      destruct op; cbv zeta; intros; eexists. (* .unfold *)

(*|
We can use abstract interpretation to compute the results that the design produces.  Ideally we'd prefer to run `simpl`, but `simpl` in Coq is extremely slow; so we use `cbv` instead, carefully passing it a list of things to not simplify:
|*)

      { unfold run_design; rewrite <- interp_action_cps_correct.
        cbv -[Vect.Bits.slice Bits.slice Bits.mul]. (* .unfold *)

(*|
Hence abstract interpretation shows that the design does not fail (we see `Some` on both sides).  Now we need to show that the two ways of doing this computation (the model's way and the design's way) do match up:
|*)

        repeat f_equal; clear. (* .unfold *)

(*|
This a property of multiplication: multiplying by 4 is the same as shifting left by two places, and the moduli line up properly.  We leave it to the reader — it's not entirely trivial!  THe most efficient way to proceed would probably be to use existing theorems on `N.testbit` along with `Bits.to_N`.
|*)

        admit. }

      { unfold run_design; rewrite <- interp_action_cps_correct.
        cbv -[Vect.Bits.slice Bits.slice Bits.mul vect_app Bits.rotate_l]. (* .unfold *)

        apply f_equal.

(*|
No math involved in this property: it's just a rephrasing of rotation as a slice and an append.  We could prove a general theorem for all bitwidths, but because of the way Kôika's definitions are written this property actually simplifies:
|*)

        cbv; reflexivity.
    Admitted.
  End Correctness.

(*|
Now that we have a verified function, we can incorporate it into a rule and then into a design:
|*)

Inductive reg_t := input_op | input_data | output_data.

Definition R r :=
  match r with
  | input_op    => bits_t 8
  | input_data  => bits_t sz
  | output_data => bits_t sz
  end.

Definition _runDesign : uaction _ _ :=
  {{
     let op := read0(input_op) in
     let input := read0(input_data) in
     write0(output_data, {design reg_t}(op, input))
  }}.

Inductive rule_name_t := runDesign.

Definition rules : rule_name_t -> rule R empty_Sigma :=
  tc_rules R empty_Sigma
           (fun rl => match rl with
                   | runDesign => _runDesign
                   end).

Definition system : scheduler :=
  runDesign |> done.

(*|
Extracting to Verilog and C++
=============================
|*)

Definition r : ContextEnv.(env_t) R :=
  #{ input_op => Ob~0~0~0~0~0~1~1~0;
     input_data => Bits.of_nat 16 7;
     output_data => Bits.of_nat 16 0 }#.

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init reg := r.[reg];
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external _ := false;
                   koika_scheduler := system;
                   koika_module_name := "combinational_proof_tutorial" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

(*|
This last bit registers our program, which allows the build system to locate it:
|*)

Definition prog := Interop.Backends.register package.
Extraction "combinational_proof_tutorial.ml" prog.


(** * Stlc: The Simply Typed Lambda-Calculus *)

Require Import SF.Maps.
Require Import SF.Smallstep.
Require Import SF.Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core
    calculus embodying the key concept of _functional abstraction_,
    which shows up in pretty much every real-world programming
    language in some form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous chapter
    when formalizing this calculus (syntax, small-step semantics,
    typing rules) and its main properties (progress and preservation).
    The new technical challenges arise from the mechanisms of
    _variable binding_ and _substitution_.  It which will take some
    work to deal with these. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_:
    booleans, numbers, strings, etc.  The exact choice of base types
    doesn't matter much -- the construction of the language and its
    theoretical properties work out the same no matter what we
    choose -- so for the sake of brevity let's take just [Bool] for
    the moment.  At the end of the chapter we'll see how to add more
    base types, and in later chapters we'll enrich the pure STLC with
    other useful constructs like pairs, records, subtyping, and
    mutable state.

    Starting from boolean constants and conditionals, we add three
    things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out first in informal BNF notation -- we'll
    formalize it below). *)
(**

       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional

*)

(** The [\] symbol in a function abstraction [\x:T1.t2] is generally
    written as a Greek letter "lambda" (hence the name of the
    calculus).  The variable [x] is called the _parameter_ to the
    function; the term [t2] is its _body_.  The annotation [:T1]
    specifies the type of arguments that the function can be applied
    to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (As in Coq, a two-argument function is really
        a one-argument function whose body is also a one-argument
        function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        As in Coq, application associates to the left -- i.e., this
        expression is parsed as [((\x:Bool. \y:Bool. x) false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    The STLC doesn't provide any primitive syntax for defining _named_
    functions -- all functions are "anonymous."  We'll see in chapter
    [MoreStlc] that it is easy to add named functions to what we've
    got -- indeed, the fundamental naming and binding mechanisms are
    exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**

      T ::= Bool
          | T1 -> T2

    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool]
                              (i.e., [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool] *)

(* ###################################################################### *)
(** ** Syntax *)

(** We begin by formalizing the syntax of the STLC. *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin,
    as always, by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T. t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T. t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq, in its built-in functional programming langauge Gallina,
    makes the first choice -- for example,

         Compute (fun x:bool => 3 + 4)

    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

    Intuitively, a "complete program" must not refer to any undefined
    variables.  We'll see shortly how to define the _free_ variables
    in a STLC term.  A complete program is _closed_ -- that is, it
    contains no free variables.

    Having made the choice not to reduce under abstractions, we don't
    need to worry about whether variables are values, since we'll
    always be reducing programs "from the outside in," and that means
    the [step] relation will always be working with closed terms.  *)

(* ###################################################################### *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.  This
    operation is used below to define the operational semantics of
    function application, where we will need to substitute the
    argument term for the function parameter in the function's body.
    For example, we reduce

       (\x:Bool. if x then true else x) false

    to

       if false then true else false

    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given term [s]
    for occurrences of some variable [x] in another term [t].  In
    informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)]
           yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)]
           yields [\y:Bool. if y then true else false]

      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...

       [x:=s]x               = s
       [x:=s]y               = y                      if x <> y
       [x:=s](\x:T11. t12)   = \x:T11. t12
       [x:=s](\y:T11. t12)   = \y:T11. [x:=s]t12      if x <> y
       [x:=s](t1 t2)         = ([x:=s]t1) ([x:=s]t2)
       [x:=s]true            = true
       [x:=s]false           = false
       [x:=s](if t1 then t2 else t3) =
                       if [x:=s]t1 then [x:=s]t2 else [x:=s]t3

*)

(** ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x] that include
    binders for all of the variables they mention), we can avoid this
    extra complexity here, but it must be dealt with when formalizing
    richer languages. *)

(** **** Exercise: 3 stars (substi)  *)
(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors and prove that the relation you've defined coincides
    with the function given above. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  (* FILL IN HERE *)
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the
    same pattern as the ones we have seen before.  Intuitively, to
    reduce a function application, we first reduce its left-hand
    side (the function) until it becomes an abstraction; then we
    reduce its right-hand side (the argument) until it is also a
    value; and finally we substitute the argument for the bound
    variable in the body of the abstraction.  This last rule, written
    informally as

      (\x:T.t12) v2 ==> [x:=v2]t12

    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'

*)
(** ... plus the usual rules for booleans:

                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)

*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* ##################################### *)
(** *** Examples *)

(** Example:

      ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)

    i.e.,

      (idBB idB) ==>* idB

*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:

      ((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
            ==>* (\x:Bool. x)

    i.e.,

      (idBB (idBB idB)) ==>* idB.

*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:

      ((\x:Bool->Bool. x) (\x:Bool. if x then false
                                    else true)) true)
            ==>* false

    i.e.,

       ((idBB notB) ttrue) ==>* tfalse.

*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:

((\x:Bool -> Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false

i.e.,

  (idBB (notB ttrue)) ==>* tfalse.

*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** We can use the [normalize] tactic defined in the [Types] chapter
    to simplify these proofs. *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof. normalize. Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(** **** Exercise: 2 stars (step_example3)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma step_example5_with_normalize :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(** Next we consider the typing relation of the STLC. *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place _typing judgment_, informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                      Gamma , x:T11 |- t12 \in T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "to the term [t] we can assign the type [T] using as types for
    the free variables of [t] the ones specified in the context
    [Gamma]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:

       empty |- \x:A. \y:A->A. y (y x))
             \in A -> (A->A) -> A.

*)

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply] (or [...]). *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
       empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
                   y (x z)
             \in T.

*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,

    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y : T.

*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1.  Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:

    ~ (exists S, exists T,
          empty |- \x:S. x x \in T).

*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End STLC.

(** $Date: 2016-05-26 17:51:14 -0400 (Thu, 26 May 2016) $ *)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)

Require Import Raux Defs Generic_fmt Float_prop Digits Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_div.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real quotient of the
    input floating-point numbers.

The algorithm performs the following steps:
- Shift dividend mantissa so that it has at least p2 + p digits.
- Perform the Euclidean division.
- Compute the position according to the division remainder.

Complexity is fine as long as p1 <= 2p and p2 <= p.
*)

Lemma mag_div_F2R :
  forall m1 e1 m2 e2,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z.
Proof.
intros m1 e1 m2 e2 Hm1 Hm2.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq.
apply mag_div.
now apply F2R_neq_0, Zgt_not_eq.
now apply F2R_neq_0, Zgt_not_eq.
Qed.

Definition Fdiv_core m1 e1 m2 e2 e :=
  let (m1', m2') :=
    if Zle_bool e (e1 - e2)%Z
    then (m1 * Zpower beta (e1 - e2 - e), m2)%Z
    else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in
  let '(q, r) :=  Z.div_eucl m1' m2' in
  (q, new_location m2' r loc_Exact).

Theorem Fdiv_core_correct :
  forall m1 e1 m2 e2 e,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l.
Proof.
intros m1 e1 m2 e2 e Hm1 Hm2.
unfold Fdiv_core.
match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end.
case_eq m12 ; intros m1' m2' Hm.
assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2'].
{ unfold F2R, Zminus ; simpl.
  destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst.
  - split ; try easy.
    apply Zle_bool_imp_le in He'.
    rewrite mult_IZR, IZR_Zpower by omega.
    unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq.
  - apply Z.leb_gt in He'.
    split ; cycle 1.
    { apply Z.mul_pos_pos with (1 := Hm2).
      apply Zpower_gt_0 ; omega. }
    rewrite mult_IZR, IZR_Zpower by omega.
    unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq. }
clearbody m12 ; clear Hm Hm1 Hm2.
generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')).
destruct (Z.div_eucl m1' m2') as (q, r).
intros (Hq, Hr).
rewrite Hf.
unfold inbetween_float, F2R. simpl.
rewrite Hq, 2!plus_IZR, mult_IZR.
apply inbetween_mult_compat.
  apply bpow_gt_0.
destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2''].
- replace 1%R with (IZR m2' * /IZR m2')%R.
  apply new_location_correct ; try easy.
  apply Rinv_0_lt_compat.
  now apply IZR_lt.
  constructor.
  field.
  now apply IZR_neq, Zgt_not_eq.
  field.
  now apply IZR_neq, Zgt_not_eq.
- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega).
  unfold Rdiv.
  rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r.
  now constructor.
Qed.

Definition Fdiv (x y : float beta) :=
  let (m1, e1) := x in
  let (m2, e2) := y in
  let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  (m, e, l).

Theorem Fdiv_correct :
  forall x y,
  (0 < F2R x)%R -> (0 < F2R y)%R ->
  let '(m, e, l) := Fdiv x y in
  (e <= cexp beta fexp (F2R x / F2R y))%Z /\
  inbetween_float beta m e (F2R x / F2R y) l.
Proof.
intros [m1 e1] [m2 e2] Hm1 Hm2.
apply gt_0_F2R in Hm1.
apply gt_0_F2R in Hm2.
unfold Fdiv.
generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2).
set (e := Zminus _ _).
set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)).
intros [H1 H2].
generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2).
destruct Fdiv_core as [m' l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
destruct (Zle_lt_or_eq _ _ H1) as [H|H].
- replace (fexp (mag _ _)) with (fexp (e + 1)).
  apply Z.le_min_r.
  clear -H1 H2 H ; apply f_equal ; omega.
- replace (fexp (mag _ _)) with (fexp e).
  apply Z.le_min_l.
  clear -H1 H2 H ; apply f_equal ; omega.
Qed.

End Fcalc_div.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Definition Falign (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = F2R (Float beta m1 e) /\ F2R f2 = F2R (Float beta m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float beta (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  Float beta (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite Z2R_mult, bpow_plus.
ring.
Qed.

End Float_ops.


(*|
######################################################
Matching expression context under ``forall`` with Ltac
######################################################

:Link: https://stackoverflow.com/q/45389615
|*)

(*|
Question
********

Say I have the following definitions in Coq:
|*)

Inductive Compare := Lt | Eq | Gt.

Fixpoint compare (x y : nat) : Compare :=
  match x, y with
  | 0, 0   => Eq
  | 0, S _ => Lt
  | S _, 0 => Gt
  | S x', S y' => compare x' y'
  end.

(*| Now consider this lemma: |*)

Lemma foo : forall (x : nat),
    (forall z, match compare x z with
               | Lt => False
               | Eq => False
               | Gt => False
               end) -> nat -> False.
Proof.
  intros x H y.

(*| At this point proof state looks like this: |*)

  Show. (* .unfold .messages *)

(*|
I'd like to write Ltac ``match goal`` that will detect that:

a) there is a hypothesis ``x : nat`` that is used as an argument to
   ``compare`` somewhere inside a quantified hypothesis ``H``
b) and there is some other hypothesis of type ``nat`` - namely ``y`` -
   that can be used to specialize the quantified hypothesis.
c) and once we have those two things specialize ``H`` to ``y``

I tried doing it like this:

.. code-block:: coq

    match goal with
    | [ X : nat, Y : nat, H : forall (z : nat), context[compare X z] |- _ ] =>
        specialize (H Y)
    end.

But there are at least two things that are wrong with this code:

1. Using ``context`` under a ``forall`` seems disallowed.
2. I can't figure out a correct way to pass ``X`` as argument to
   ``compare`` in a way that it is recognized as something that exists
   as a hypothesis.
|*)

(*|
Answer (Yves)
*************

If you want to check that ``X`` occurs in the quantified hypothesis
``H``, it suffices to check that it occurs in ``H`` after it is
instantiated with any value that does not contain ``X``. For instance,
you can instantiate ``H`` with ``Y`` by simply writing the application
of ``H`` as a function to ``Y``. Here is my proposal:
|*)

  match goal with
  | X : nat, H : _, Y : nat |- _ =>
      match type of (H Y) with
      | context[X] => specialize (H Y)
      end
  end.

(*|
This Ltac text really checks that ``H`` is a function. If you want to
be more precise and state that ``H`` should really be a universal
quantification (or a product type), then you can check that the type
of ``(H Y)`` also contains ``Y``, as in the following fragment:
|*)

  Undo. (* .none *)
  match goal with
  | X : nat, H : _, Y : nat |- _ =>
      match type of (H Y) with
      | context[X] =>
          match type of (H Y) with
          | context[Y] => specialize (H Y)
          end
      end
  end.

(*|
----

**Q:** Can you explain the meaning of ``match type``? Is this
documented anywhere in Coq manual?

**A:** Here you have the combination of two constructs of the Ltac
language. ``match ... with`` and ``type of``. If you write ``match H
with`` you only look at the symbol ``H``, on the other hand, if you
want to observe the hypothesis statement, you have to look at its
type. This is documented in section 9 of the manual.
|*)

(*|
Answer (Daniel Schoepe)
***********************

This doesn't quite do what you are asking for, but it's somewhat
close:
|*)

  Undo. (* .none *)
  match goal with
  | [ X : nat, Y : nat, H : context[compare ?a _] |- _ ] =>
      match type of H with
      | forall (z : nat), _ =>
          match a with
          | X => specialize (H Y)
          end
      end
  end.

(*|
However, this does not check that the second argument to ``compare``
matches the ``z`` that is bound by the ``forall``.
|*)