Require Export Unicode.Utf8_core.
(* Add LoadPath "." as Casts. *)

Require Import Cast DecidableExtns Showable List Ascii String.

Local Open Scope string_scope.

Extract Inductive bool => "Data.Bool.Bool" [ "Data.Bool.True" "Data.Bool.False" ].

Extract Inductive ascii => "Data.Char.Char"
[
"{- If this appears, you're using Ascii internals. Please don't -}
 (\ b0 b1 b2 b3 b4 b5 b6 b7 ->
  let f b i = if b then 1 Data.Bits.shiftL i else 0 :: Prelude.Int in
  Data.Char.chr (f b0 0 Prelude.+ f b1 1 Prelude.+ f b2 2 Prelude.+ f b3 3 Prelude.+ f b4 4 Prelude.+ f b5 5 Prelude.+ f b6 6 Prelude.+ f b7 7))"
].

Extract Constant zero => "'\000'".
Extract Constant one => "'\001'".
Extract Constant shift =>
 "\ b c -> Data.Char.chr (((Data.Char.ord c) Data.Bits.shiftL 1) land 255 Prelude.+ if b then 1 else 0)".

Extract Inlined Constant ascii_dec => "(==)".

Extract Inductive string => "[Data.Char.Char]" [ "[]" "(:)" ].

Definition x_not_ok := 1.

Definition x_good : {n:nat | n < 10} := ? 5.

Eval compute in x_good.

Eval compute in x_good.1.

Definition x_bad : {n:nat | n < 10} := ? 15.

Eval compute in x_bad.

Eval compute in x_bad.1.

Definition g (x: {n:nat | n > 0}) := 1.

Eval compute in g (? 0).

Definition client (x: nat) := g (? x).

Extraction Language Haskell.
Extract Constant failed_cast =>
     "\ a s -> Prelude.error (""Cast has failed with "" Prelude.++ s)".
Extraction "test.hs" client.

(** ** A more involved example: casting lists *)

Definition cast_list (A: Type) `{Show A} (P : A -> Prop)
  (dec : forall a, Decidable (P a)):
    list A -> list {a : A | P a} := map (fun a => ? a).

Notation "?::" := (cast_list _ _ _).

Definition list_of_3: list {n:nat | n = 3} := ?:: (3 :: 2 :: 1 :: nil).

Eval compute in list_of_3.

Definition top_succ : nat -> {n:nat | n < 10} := ?> S.

Eval compute in top_succ 6.

Eval compute in top_succ 9.

Definition foo (x: {n:nat | n > 0 }) := x.1.

Extraction foo.

Definition gee := <? foo.
Extraction gee.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export usquash.
Require Export per_props_psquash.

Lemma member_iff_inhabited_mkc_apply2_mkc_usquash_per {o} :
  forall lib (t1 t2 T : @CTerm o),
    inhabited_type lib (mkc_apply2 (mkc_usquash_per nvarx nvary T) t1 t2)
    <=> inhabited_type lib T.
Proof.
  introv.

  split; introv inh.

  - eapply inhabited_type_respects_cequivc in inh;
    [|apply cequivc_beta2].
    rw @mkcv_lam_substc in inh; try (complete (intro xx; ginv)).

    eapply inhabited_type_respects_cequivc in inh;
      [|apply cequivc_beta].

    autorewrite with slow in *; auto.

  - eapply inhabited_type_respects_cequivc;
    [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply inhabited_type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.
Qed.

Lemma implies_tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    type lib t1
    -> type lib t2
    -> (inhabited_type lib t1 <=> inhabited_type lib t2)
    -> tequality lib (mkc_usquash t1) (mkc_usquash t2).
Proof.
  introv tt1 tt2 tiff.
  unfold mkc_usquash.
  rw @tequality_mkc_pertype.
  dands.

  - (* type 1 *)
    introv.
    unfold mkc_usquash_per.

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.

  - (* type 2 *)
    introv.
    unfold mkc_psquash_per.

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.

  - (* extensional eq *)
    introv.
    allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.

  - (* PER *)
    unfold is_per_type; dands.

    (* symmetry *)
    + introv inh.
      allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

    (* transitivity *)
    + introv inh1 inh2.
      allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.
Qed.

Lemma tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    tequality lib (mkc_usquash t1) (mkc_usquash t2)
    <=> (type lib t1
         # type lib t2
         # (inhabited_type lib t1 <=> inhabited_type lib t2)).
Proof.
  introv; split; intro k; try (apply implies_tequality_mkc_usquash; tcsp);[].

  unfold mkc_usquash in k.
  rw @tequality_mkc_pertype in k; repnd.

  (* let's get that t1 is a type *)
  pose proof (k0 mkc_axiom mkc_axiom) as tt1.
  unfold mkc_usquash_per in tt1.

  eapply type_respects_cequivc in tt1;[|apply cequivc_beta2].
  rw @mkcv_lam_substc in tt1; try (complete (intro xx; ginv)).
  eapply type_respects_cequivc in tt1;[|apply cequivc_beta].
  autorewrite with slow in *.

  (* let's get that t2 is a type *)
  pose proof (k1 mkc_axiom mkc_axiom) as tt2.
  unfold mkc_usquash_per in tt2.

  eapply type_respects_cequivc in tt2;[|apply cequivc_beta2].
  rw @mkcv_lam_substc in tt2; try (complete (intro xx; ginv)).
  eapply type_respects_cequivc in tt2;[|apply cequivc_beta].
  autorewrite with slow in *.

  dands; auto;[].

  pose proof (k2 mkc_axiom mkc_axiom) as k2.
  allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.
Qed.

Lemma sp_implies_tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    tequality lib t1 t2
    -> tequality lib (mkc_usquash t1) (mkc_usquash t2).
Proof.
  introv teq.
  apply tequality_mkc_usquash.
  dands; eauto 3 with slow.

  - apply tequality_refl in teq; auto.

  - apply tequality_sym in teq; apply tequality_refl in teq; auto.

  - introv; split; intro mem; eapply inhabited_type_tequality; eauto.
    apply tequality_sym; auto.
Qed.

Lemma implies_equality_in_mkc_usquash {o} :
  forall lib (a b T : @CTerm o),
    inhabited_type lib T
    -> equality lib a b (mkc_usquash T).
Proof.
  introv inh.
  unfold mkc_usquash.

  apply equality_in_mkc_pertype2; dands.

  - apply member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

  - apply sp_implies_tequality_mkc_usquash.
    unfold inhabited_type in inh; exrepnd.
    apply inhabited_implies_tequality in inh0; auto.
Qed.

Lemma equality_in_mkc_usquash {o} :
  forall lib (a b T : @CTerm o),
    equality lib a b (mkc_usquash T)
    <=> inhabited_type lib T.
Proof.
  introv; split; introv k; try (apply implies_equality_in_mkc_usquash; sp);[].
  unfold mkc_usquash in k.

  apply equality_in_mkc_pertype2 in k; repnd.
  apply member_iff_inhabited_mkc_apply2_mkc_usquash_per in k0; sp.
Qed.

Lemma equality_mkc_usquash_in_uni {o} :
  forall lib (t1 t2 : @CTerm o) i,
    equality lib (mkc_usquash t1) (mkc_usquash t2) (mkc_uni i)
    <=> (member lib t1 (mkc_uni i)
         # member lib t2 (mkc_uni i)
         # (inhabited_type lib t1 <=> inhabited_type lib t2)).
Proof.
  introv.
  sp_iff Case; introv h; repnd.

  - Case "->".
    apply mkc_pertype_equality_in_uni in h; repnd.

    pose proof (h0 mkc_axiom mkc_axiom) as h0.
    eapply member_respects_cequivc in h0;[|apply cequivc_beta2].
    repeat (rw @mkcv_lam_substc in h0; try (complete (intro xx; ginv));[]).
    eapply member_respects_cequivc in h0;[|apply cequivc_beta].
    autorewrite with slow in *.

    pose proof (h1 mkc_axiom mkc_axiom) as h1.
    eapply member_respects_cequivc in h1;[|apply cequivc_beta2].
    repeat (rw @mkcv_lam_substc in h1; try (complete (intro xx; ginv));[]).
    eapply member_respects_cequivc in h1;[|apply cequivc_beta].
    autorewrite with slow in *.

    dands; auto.

    pose proof (h2 mkc_axiom mkc_axiom) as h2.
    allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.

  - unfold mkc_usquash.
    apply mkc_pertype_equality_in_uni.
    dands; introv;
      [| | |].

    { eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta2|].
      repeat (rw @mkcv_lam_substc; try (complete (intro xx; ginv));[]).
      eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta|].
      autorewrite with slow in *; auto. }

    { eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta2|].
      repeat (rw @mkcv_lam_substc; try (complete (intro xx; ginv));[]).
      eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta|].
      autorewrite with slow in *; auto. }

    { repeat rw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp. }

    { unfold is_per_type; dands.

      + introv inh.
        allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

      + introv inh1 inh2.
        allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp. }
Qed.


From F_mu_ref_conc_sub Require Export lang.

Inductive type :=
  | Top : type
  | TUnit : type
  | TNat : type
  | TBool : type
  | TProd : type → type → type
  | TSum : type → type → type
  | TArrow : type → type → type
  | TRec (τ : {bind 1 of type})
  | TVar (x : var)
  | TForall (σ : type) (τ : {bind 1 of type})
  | Tref (τ : type).

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.
Instance SubstLemmas_typer : SubstLemmas type. derive. Qed.

Inductive subtype : list type → type → type → Prop :=
| sbt_var Ξ x τ : Ξ !! x = Some τ → subtype Ξ (TVar x) τ
| sbt_refl Ξ τ : subtype Ξ τ τ
| sbt_trans Ξ τ1 τ2 τ3 : subtype Ξ τ1 τ2 → subtype Ξ τ2 τ3 → subtype Ξ τ1 τ3
| sbt_top Ξ τ : subtype Ξ τ Top
| sbt_arrow Ξ σ σ' τ τ' : subtype Ξ σ' σ → subtype Ξ τ τ' →
                        subtype Ξ (TArrow σ τ) (TArrow σ' τ')
| sbt_forall Ξ σ τ1 τ2 : subtype (σ.[ren (+1)] :: (subst (ren (+1)) <$> Ξ)) τ1 τ2 →
                         subtype Ξ (TForall σ τ1) (TForall σ τ2)
| sbt_rec Ξ σ τ :
    subtype ((TVar 1) :: (TVar 1) :: (subst (ren (+2)) <$> Ξ))
            σ.[up (ren (+1))] τ.[ren (+1)] →
    subtype Ξ (TRec σ) (TRec τ).

Fixpoint binop_res_type (op : binop) : type :=
  match op with
  | Add => TNat | Sub => TNat | Mult => TNat
  | Eq => TBool | Le => TBool | Lt => TBool
  end.

Inductive EqType : type → Prop :=
  | EqTUnit : EqType TUnit
  | EqTNat : EqType TNat
  | EqTBool : EqType TBool
  | EQRef τ : EqType (Tref τ).

Reserved Notation "Ξ |ₜ Γ ⊢ₜ e : τ" (at level 74, e, τ at next level).

Inductive typed (Ξ Γ : list type) : expr → type → Prop :=
  | Var_typed x τ : Γ !! x = Some τ → Ξ |ₜ Γ ⊢ₜ Var x : τ
  | Unit_typed : Ξ |ₜ Γ ⊢ₜ Unit : TUnit
  | Nat_typed n : Ξ |ₜ Γ ⊢ₜ #n n : TNat
  | Bool_typed b : Ξ |ₜ Γ ⊢ₜ #♭ b : TBool
  | BinOp_typed op e1 e2 :
     Ξ |ₜ Γ ⊢ₜ e1 : TNat → Ξ |ₜ Γ ⊢ₜ e2 : TNat →
     Ξ |ₜ Γ ⊢ₜ BinOp op e1 e2 : binop_res_type op
  | Pair_typed e1 e2 τ1 τ2 :
      Ξ |ₜ Γ ⊢ₜ e1 : τ1 → Ξ |ₜ Γ ⊢ₜ e2 : τ2 → Ξ |ₜ Γ ⊢ₜ Pair e1 e2 : TProd τ1 τ2
  | Fst_typed e τ1 τ2 :
      Ξ |ₜ Γ ⊢ₜ e : TProd τ1 τ2 → Ξ |ₜ Γ ⊢ₜ Fst e : τ1
  | Snd_typed e τ1 τ2 : Ξ |ₜ Γ ⊢ₜ e : TProd τ1 τ2 → Ξ |ₜ Γ ⊢ₜ Snd e : τ2
  | InjL_typed e τ1 τ2 : Ξ |ₜ Γ ⊢ₜ e : τ1 → Ξ |ₜ Γ ⊢ₜ InjL e : TSum τ1 τ2
  | InjR_typed e τ1 τ2 : Ξ |ₜ Γ ⊢ₜ e : τ2 → Ξ |ₜ Γ ⊢ₜ InjR e : TSum τ1 τ2
  | Case_typed e0 e1 e2 τ1 τ2 τ3 :
     Ξ |ₜ Γ ⊢ₜ e0 : TSum τ1 τ2 → Ξ |ₜ τ1 :: Γ ⊢ₜ e1 : τ3 →
     Ξ |ₜ τ2 :: Γ ⊢ₜ e2 : τ3 → Ξ |ₜ Γ ⊢ₜ Case e0 e1 e2 : τ3
  | If_typed e0 e1 e2 τ :
     Ξ |ₜ Γ ⊢ₜ e0 : TBool → Ξ |ₜ Γ ⊢ₜ e1 : τ → Ξ |ₜ Γ ⊢ₜ e2 : τ →
     Ξ |ₜ Γ ⊢ₜ If e0 e1 e2 : τ
  | Rec_typed e τ1 τ2 :
     Ξ |ₜ TArrow τ1 τ2 :: τ1 :: Γ ⊢ₜ e : τ2 → Ξ |ₜ Γ ⊢ₜ Rec e : TArrow τ1 τ2
  | Lam_typed e τ1 τ2 :
      Ξ |ₜ τ1 :: Γ ⊢ₜ e : τ2 → Ξ |ₜ Γ ⊢ₜ Lam e : TArrow τ1 τ2
  | LetIn_typed e1 e2 τ1 τ2 :
      Ξ |ₜ Γ ⊢ₜ e1 : τ1 → Ξ |ₜ τ1 :: Γ ⊢ₜ e2 : τ2 → Ξ |ₜ Γ ⊢ₜ LetIn e1 e2 : τ2
  | Seq_typed e1 e2 τ1 τ2 :
      Ξ |ₜ Γ ⊢ₜ e1 : τ1 → Ξ |ₜ Γ ⊢ₜ e2 : τ2 → Ξ |ₜ Γ ⊢ₜ Seq e1 e2 : τ2
  | App_typed e1 e2 τ1 τ2 :
     Ξ |ₜ Γ ⊢ₜ e1 : TArrow τ1 τ2 → Ξ |ₜ Γ ⊢ₜ e2 : τ1 → Ξ |ₜ Γ ⊢ₜ App e1 e2 : τ2
  | TLam_typed e σ τ :
     σ.[ren (+1)] :: (subst (ren (+1)) <$> Ξ) |ₜ subst (ren (+1)) <$> Γ ⊢ₜ e : τ →
     Ξ |ₜ Γ ⊢ₜ TLam e : TForall σ τ
  | TApp_typed e σ τ τ' : Ξ |ₜ Γ ⊢ₜ e : TForall σ τ → subtype Ξ τ' σ →
      Ξ |ₜ Γ ⊢ₜ TApp e : τ.[τ'/]
  | TFold e τ : Ξ |ₜ Γ ⊢ₜ e : τ.[TRec τ/] → Ξ |ₜ Γ ⊢ₜ Fold e : TRec τ
  | TUnfold e τ : Ξ |ₜ Γ ⊢ₜ e : TRec τ → Ξ |ₜ Γ ⊢ₜ Unfold e : τ.[TRec τ/]
  | TFork e : Ξ |ₜ Γ ⊢ₜ e : TUnit → Ξ |ₜ Γ ⊢ₜ Fork e : TUnit
  | TAlloc e τ : Ξ |ₜ Γ ⊢ₜ e : τ → Ξ |ₜ Γ ⊢ₜ Alloc e : Tref τ
  | TLoad e τ : Ξ |ₜ Γ ⊢ₜ e : Tref τ → Ξ |ₜ Γ ⊢ₜ Load e : τ
  | TStore e e' τ : Ξ |ₜ Γ ⊢ₜ e : Tref τ → Ξ |ₜ Γ ⊢ₜ e' : τ →
      Ξ |ₜ Γ ⊢ₜ Store e e' : TUnit
  | TCAS e1 e2 e3 τ :
     EqType τ → Ξ |ₜ Γ ⊢ₜ e1 : Tref τ → Ξ |ₜ Γ ⊢ₜ e2 : τ → Ξ |ₜ Γ ⊢ₜ e3 : τ →
     Ξ |ₜ Γ ⊢ₜ CAS e1 e2 e3 : TBool
  | TSub e τ τ' : Ξ |ₜ Γ ⊢ₜ e : τ → subtype Ξ τ τ' → Ξ |ₜ Γ ⊢ₜ e : τ'
where "Ξ |ₜ Γ ⊢ₜ e : τ" := (typed Ξ Γ e τ).

(* Lemma typed_subst_invariant Ξ Γ e τ s1 s2 : *)
(*   Ξ |ₜ Γ ⊢ₜ e : τ → (∀ x, x < length Γ → s1 x = s2 x) → e.[s1] = e.[s2]. *)
(* Proof. *)
(*   intros Htyped; revert s1 s2. *)
(*   assert (∀ x Γ, x < length (subst (ren (+1)) <$> Γ) → x < length Γ). *)
(*   { intros ??. by rewrite fmap_length. } *)
(*   assert (∀ {A} `{Ids A} `{Rename A} (s1 s2 : nat → A) x, *)
(*     (x ≠ 0 → s1 (pred x) = s2 (pred x)) → up s1 x = up s2 x). *)
(*   { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal lia. } *)
(*   induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with lia. *)
(* Qed. *)
(* Lemma n_closed_invariant n (e : expr) s1 s2 : *)
(*   (∀ f, e.[upn n f] = e) → (∀ x, x < n → s1 x = s2 x) → e.[s1] = e.[s2]. *)
(* Proof. *)
(*   intros Hnc. specialize (Hnc (ren (+1))). *)
(*   revert n Hnc s1 s2. *)
(*   induction e => m Hmc s1 s2 H1; asimpl in *; try f_equal; *)
(*     try (match goal with H : _ |- _ => eapply H end; eauto; *)
(*          try inversion Hmc; try match goal with H : _ |- _ => by rewrite H end; *)
(*          fail). *)
(*   - apply H1. rewrite iter_up in Hmc. destruct lt_dec; try lia. *)
(*     asimpl in *. injection Hmc as Hmc. unfold var in *. omega. *)
(*   - unfold upn in *. *)
(*     change (e.[up (up (upn m (ren (+1))))]) with *)
(*     (e.[iter (S (S m)) up (ren (+1))]) in *. *)
(*     apply (IHe (S (S m))). *)
(*     + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
(*     + intros [|[|x]] H2; [by cbv|by cbv |]. *)
(*       asimpl; rewrite H1; auto with lia. *)
(*   - apply (IHe (S m)). *)
(*     + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
(*     + intros [|x] H2; [by cbv |]. *)
(*       asimpl; rewrite H1; auto with lia. *)
(*   - apply (IHe0 (S m)). *)
(*     + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
(*     + intros [|x] H2; [by cbv |]. *)
(*       asimpl; rewrite H1; auto with lia. *)
(*   - change (e1.[up (upn m (ren (+1)))]) with *)
(*     (e1.[iter (S m) up (ren (+1))]) in *. *)
(*     apply (IHe0 (S m)). *)
(*     + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
(*     + intros [|x] H2; [by cbv |]. *)
(*       asimpl; rewrite H1; auto with lia. *)
(*   - change (e2.[up (upn m (ren (+1)))]) with *)
(*     (e2.[upn (S m) (ren (+1))]) in *. *)
(*     apply (IHe1 (S m)). *)
(*     + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
(*     + intros [|x] H2; [by cbv |]. *)
(*       asimpl; rewrite H1; auto with lia. *)
(* Qed. *)

Fixpoint env_subst (vs : list val) : var → expr :=
  match vs with
  | [] => ids
  | v :: vs' => (of_val v) .: env_subst vs'
  end.

Lemma env_subst_lookup vs x v :
  vs !! x = Some v → env_subst vs x = of_val v.
Proof.
  revert vs; induction x => vs.
  - by destruct vs; inversion 1.
  - destruct vs as [|w vs]; first by inversion 1.
    rewrite -lookup_tail /=.
    apply IHx.
Qed.

(* Lemma typed_n_closed Γ τ e : Γ ⊢ₜ e : τ → (∀ f, e.[upn (length Γ) f] = e). *)
(* Proof. *)
(*   intros H. induction H => f; asimpl; simpl in *; auto with f_equal. *)
(*   - apply lookup_lt_Some in H. rewrite iter_up. destruct lt_dec; auto with lia. *)
(*   - f_equal. apply IHtyped. *)
(*   - by f_equal; rewrite map_length in IHtyped. *)
(* Qed. *)

(** Weakening *)
(* Lemma context_gen_weakening ξ Γ' Γ e τ : *)
(*   Γ' ++ Γ ⊢ₜ e : τ → *)
(*   Γ' ++ ξ ++ Γ ⊢ₜ e.[upn (length Γ') (ren (+ (length ξ)))] : τ. *)
(* Proof. *)
(*   intros H1. *)
(*   remember (Γ' ++ Γ) as Ξ. revert Γ' Γ ξ HeqΞ. *)
(*   induction H1 => Γ1 Γ2 ξ HeqΞ; subst; asimpl in *; eauto using typed. *)
(*   - rewrite iter_up; destruct lt_dec as [Hl | Hl]. *)
(*     + constructor. rewrite lookup_app_l; trivial. by rewrite lookup_app_l in H. *)
(*     + asimpl. constructor. rewrite lookup_app_r; auto with lia. *)
(*       rewrite lookup_app_r; auto with lia. *)
(*       rewrite lookup_app_r in H; auto with lia. *)
(*       match goal with *)
(*         |- _ !! ?A = _ => by replace A with (x - length Γ1) by lia *)
(*       end. *)
(*   - econstructor; eauto. by apply (IHtyped2 (_::_)). by apply (IHtyped3 (_::_)). *)
(*   - constructor. by apply (IHtyped (_ :: _ :: _)). *)
(*   - constructor. by apply (IHtyped (_ :: _)). *)
(*   - econstructor; eauto. by apply (IHtyped2 (_::_)). *)
(*   - constructor. *)
(*     specialize (IHtyped *)
(*       (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2) (subst (ren (+1)) <$> ξ)). *)
(*     asimpl in *. rewrite ?map_length in IHtyped. *)
(*     repeat rewrite fmap_app. apply IHtyped. *)
(*     by repeat rewrite fmap_app. *)
(* Qed. *)

(* Lemma context_weakening ξ Γ e τ : *)
(*   Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e.[(ren (+ (length ξ)))] : τ. *)
(* Proof. eapply (context_gen_weakening _ []). Qed. *)

(* Lemma closed_context_weakening ξ Γ e τ : *)
(*   (∀ f, e.[f] = e) → Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e : τ. *)
(* Proof. intros H1 H2. erewrite <- H1. by eapply context_weakening. Qed. *)


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

Require Import sha.spec_sha.
Require Import sha.hmac_common_lemmas.

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

Lemma body_hkdf_extract: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_extract HKDF_extract_spec.
Proof.
start_function.
rename H into LenSalt. rename H0 into LenSecret.
freeze [0;2;3;4] FR1.
assert_PROP (isptr salt) as Ptr_salt.
{ unfold data_block. normalize. rewrite data_at_isptr. entailer!. }
apply vst_lemmas.isptrD in Ptr_salt. destruct Ptr_salt as [sb [si SLT]]. subst salt.
thaw FR1.
idtac "Timing the call to HMAC".
Time forward_call (out, SALT, secret, SECRET, kv, shmd, sb, si).
apply extract_exists_pre. intros Hmac.
idtac "Timing the normalize". Time normalize. (*Coq8.6: 2secs*)
(*yields
H: ByteBitRelations.bytesToBits
      (HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)) =
    verif_hmac_crypto.bitspec SALT SECRET
H0 : forall
       (A : Comp.OracleComp
              (HMAC_spec_abstract.HMAC_Abstract.Message
                 HMAC256_isPRF.PARS256.P)
              (Bvector.Bvector ShaInstantiation.c) bool)
       (Awf : DistSem.well_formed_oc A), verif_hmac_crypto.CRYPTO A Awf
 and substitutes Hmac. *)
rename H into HypHmacBits. rename H0 into HmacCrypto.
remember (HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)) as Hmac. rename HeqHmac into HypHmac.

(*idtac "Timing the Intros". Time Intros. (*Coq8.6: 146s*) (*Coq8.5: 77.468 secs (77.25u,0.015s)*)
(*yields
H : Hmac = HMAC256_functional_prog.HMAC256 (CONT SECRET) (CONT SALT)
H0 : ByteBitRelations.bytesToBits Hmac =
     verif_hmac_crypto.bitspec SALT SECRET
H1 : forall
       (A : Comp.OracleComp
              (HMAC_spec_abstract.HMAC_Abstract.Message
                 HMAC256_isPRF.PARS256.P)
              (Bvector.Bvector ShaInstantiation.c) bool)
       (Awf : DistSem.well_formed_oc A), verif_hmac_crypto.CRYPTO A Awf,
so the same except for the substitution*)
(*rename H into HypHmac. rename H0 into HypHmacBits. Intros. rename H1 into HmacCrypto.*)*)

assert_PROP (isptr out) as Ptr_out.
{ unfold data_block. normalize. rewrite data_at_isptr. entailer!. }
forward_if (PROP ( )
   LOCAL (temp _t'1 out; temp _out_key out;
   temp _out_len olen; temp _salt (Vptr sb si); temp _salt_len (Vint (Int.repr (LEN SALT)));
   temp _secret secret; temp _secret_len (Vint (Int.repr (LEN SECRET)));
   gvar sha._K256 kv)
   SEP (K_vector kv; data_block shmd Hmac out; initPostKey (Vptr sb si) (CONT SALT);
   data_block Tsh (CONT SECRET) secret; data_at_ Tsh tuint olen)).
{ apply denote_tc_test_eq_split.
  + unfold data_block. normalize.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer1.
    apply sepcon_valid_pointer2. apply data_at_valid_ptr.
    apply readable_nonidentity. apply writable_readable; trivial.
    rewrite HMAC_Zlength; simpl; omega.
  + apply valid_pointer_zero. }
{ subst out; contradiction. }
{ clear H; forward. entailer!. }

forward. forward.
unfold HKDF_extract. cancel.
Time Qed.
(*Coq 8.6: 2.5 secs*)
(*Feb 23rd 2017 (Coq8.5pl2): Finished transaction in 24.859 secs (17.937u,0.s) (successful)*)
 (*earlier: Finished transaction in 5.781 secs (4.89u,0.s) (successful)*)


From iris.proofmode Require Import
  proofmode.

From caml5 Require Import
  prelude.
From caml5 Require Export
  base.
From caml5.algebra Require Import
  lib.auth_nat_max.

Class AuthNatMaxG Σ := {
  auth_nat_max_G_inG : inG Σ auth_nat_max_R ;
}.
#[local] Existing Instance auth_nat_max_G_inG.

Definition auth_nat_max_Σ := #[
  GFunctor auth_nat_max_R
].
#[global] Instance subG_auth_nat_max_Σ Σ :
  subG auth_nat_max_Σ Σ →
  AuthNatMaxG Σ.
Proof.
  solve_inG.
Qed.

Section auth_nat_max_G.
  Context `{!AuthNatMaxG Σ}.
  Implicit Types n m p : nat.

  Definition auth_nat_max_auth γ dq n :=
    own γ (auth_nat_max_auth dq n).
  Definition auth_nat_max_frag γ n :=
    own γ (auth_nat_max_frag n).

  #[global] Instance auth_nat_max_auth_timeless γ dq n :
    Timeless (auth_nat_max_auth γ dq n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_nat_max_auth_persistent γ n :
    Persistent (auth_nat_max_auth γ DfracDiscarded n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_nat_max_frag_timeless γ n :
    Timeless (auth_nat_max_frag γ n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_nat_max_frag_persistent γ n :
    Persistent (auth_nat_max_frag γ n).
  Proof.
    apply _.
  Qed.

  #[global] Instance auth_nat_max_auth_fractional γ n :
    Fractional (λ q, auth_nat_max_auth γ (DfracOwn q) n).
  Proof.
    intros ?*. rewrite -own_op -auth_nat_max_auth_dfrac_op //.
  Qed.
  #[global] Instance auth_nat_max_auth_as_fractional γ q n :
    AsFractional (auth_nat_max_auth γ (DfracOwn q) n) (λ q, auth_nat_max_auth γ (DfracOwn q) n) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma auth_nat_max_auth_persist γ dq n :
    auth_nat_max_auth γ dq n ==∗
    auth_nat_max_auth γ DfracDiscarded n.
  Proof.
    iApply own_update. apply auth_nat_max_auth_persist.
  Qed.

  Lemma auth_nat_max_alloc n :
    ⊢ |==> ∃ γ,
      auth_nat_max_auth γ (DfracOwn 1) n.
  Proof.
    iMod (own_alloc (auth_nat_max.auth_nat_max_auth (DfracOwn 1) n)) as "(% & ?)".
    { apply auth_nat_max_auth_valid. }
    naive_solver.
  Qed.

  Lemma auth_nat_max_auth_valid γ dq a :
    auth_nat_max_auth γ dq a -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros. iDestruct (own_valid with "[$]") as %?%auth_nat_max_auth_dfrac_valid. done.
  Qed.
  Lemma auth_nat_max_auth_combine γ dq1 n1 dq2 n2 :
    auth_nat_max_auth γ dq1 n1 -∗
    auth_nat_max_auth γ dq2 n2 -∗
      auth_nat_max_auth γ (dq1 ⋅ dq2) n1 ∗
      ⌜n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2". iCombine "H●1 H●2" as "H●".
    iDestruct (own_valid with "H●") as %(? & <-)%auth_nat_max_auth_dfrac_op_valid.
    rewrite -auth_nat_max_auth_dfrac_op. naive_solver.
  Qed.
  Lemma auth_nat_max_auth_valid_2 γ dq1 n1 dq2 n2 :
    auth_nat_max_auth γ dq1 n1 -∗
    auth_nat_max_auth γ dq2 n2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_nat_max_auth_combine with "H●1 H●2") as "(H● & %)".
    iDestruct (auth_nat_max_auth_valid with "H●") as %?.
    done.
  Qed.
  Lemma auth_nat_max_auth_agree γ dq1 n1 dq2 n2 :
    auth_nat_max_auth γ dq1 n1 -∗
    auth_nat_max_auth γ dq2 n2 -∗
    ⌜n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_nat_max_auth_valid_2 with "H●1 H●2") as %?. naive_solver.
  Qed.
  Lemma auth_nat_max_auth_exclusive γ n1 n2 :
    auth_nat_max_auth γ (DfracOwn 1) n1 -∗
    auth_nat_max_auth γ (DfracOwn 1) n2 -∗
    False.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_nat_max_auth_valid_2 with "H●1 H●2") as %(? & _). done.
  Qed.

  Lemma auth_nat_max_frag_0 γ :
    ⊢ |==> auth_nat_max_frag γ 0.
  Proof.
    iApply own_unit.
  Qed.
  Lemma auth_nat_max_frag_get γ q n :
    auth_nat_max_auth γ q n -∗
    auth_nat_max_frag γ n.
  Proof.
    apply own_mono, auth_nat_max_included.
  Qed.
  Lemma auth_nat_max_frag_le {γ n} n' :
    n' ≤ n →
    auth_nat_max_frag γ n -∗
    auth_nat_max_frag γ n'.
  Proof.
    intros. apply own_mono, auth_nat_max_frag_mono. done.
  Qed.

  Lemma auth_nat_max_valid γ dq n m :
    auth_nat_max_auth γ dq n -∗
    auth_nat_max_frag γ m -∗
    ⌜m ≤ n⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (own_valid_2 with "H●1 H●2") as %?%auth_nat_max_both_dfrac_valid.
    naive_solver.
  Qed.

  Lemma auth_nat_max_update {γ n} n' :
    n ≤ n' →
    auth_nat_max_auth γ (DfracOwn 1) n ==∗
    auth_nat_max_auth γ (DfracOwn 1) n'.
  Proof.
    iIntros "% H●".
    iMod (own_update with "H●"); first apply auth_nat_max_auth_update; done.
  Qed.
End auth_nat_max_G.

#[global] Opaque auth_nat_max_auth.
#[global] Opaque auth_nat_max_frag.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Structure.BiCCC.
Require Export Category.Structure.Constant.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Program Instance Coq : Category := {
  obj     := Type;
  hom     := fun A B : Type => A -> B;
  homset  := fun _ _ => {| equiv := fun f g => forall x, f x = g x |};
  id      := fun _ x => x;
  compose := fun _ _ _ g f x => g (f x)
}.
Next Obligation. equivalence; congruence. Qed.
Next Obligation. proper; congruence. Qed.

Program Instance Coq_Terminal : @Terminal Coq := {
  terminal_obj := unit : Type;
  one := fun _ a => tt
}.
Next Obligation. destruct (f x0), (g x0); reflexivity. Qed.

Program Instance Coq_Cartesian : @Cartesian Coq := {
  product_obj := prod;
  fork := fun _ _ _ f g x => (f x, g x);
  exl  := fun _ _ p => fst p;
  exr  := fun _ _ p => snd p
}.
Next Obligation. proper; congruence. Qed.
Next Obligation.
  intros; simplify; intros.
  - rewrite H; reflexivity.
  - rewrite H; reflexivity.
  - intros; simplify.
    rewrite <- H, <- H0.
    rewrite <- surjective_pairing; reflexivity.
Qed.

Program Instance Coq_Closed : @Closed Coq _ := {
  exponent_obj := Basics.arrow;
  exp_iso := fun _ _ _ =>
    {| to   := {| morphism := fun f a b => f (a, b) |}
     ; from := {| morphism := fun f p => f (fst p) (snd p) |} |}
}.
Next Obligation. proper; extensionality X0; congruence. Qed.
Next Obligation. proper; congruence. Qed.

Program Instance Coq_Initial : Initial Coq := {
  terminal_obj := False;
  one := fun _ _ => False_rect _ _
}.
Next Obligation. contradiction. Qed.

Program Instance Coq_Cocartesian : @Cocartesian Coq := {
  product_obj := sum;
  fork := fun _ _ _ f g x =>
            match x with
            | Datatypes.inl v => f v
            | Datatypes.inr v => g v
            end;
  exl  := fun _ _ p => Datatypes.inl p;
  exr  := fun _ _ p => Datatypes.inr p
}.
Next Obligation.
  split; intros.
    split; intros;
    rewrite H; reflexivity.
  destruct x0; firstorder.
Qed.

Lemma injectivity_is_monic `(f : x ~> y) :
  (∀ x y, f x = f y → x = y) ↔ Monic f.
Proof.
  split.
  - intros HA.
    constructor.
    autounfold in *; intros ??? HB.
    simpl in *; intros.
    apply HA, HB.
  - intros HA ?? HB.
    pose (fun (_ : unit) => x0) as const_x.
    pose (fun (_ : unit) => y0) as const_y.
    destruct HA.
    specialize (monic unit const_x const_y).
    unfold const_x in monic.
    unfold const_y in monic.
    eapply monic; eauto.
    simpl; intuition.
    exact tt.
Qed.

Lemma surjectivity_is_epic `(f : x ~> y) :
  (∀ y, exists x, f x = y)%type ↔ Epic f.
Proof.
  split.
  - intros HA.
    constructor.
    autounfold in *; intros ??? HB.
    simpl in *; intros.
    specialize (HA x0).
    destruct HA as [? HA].
    rewrite <- HA.
    apply HB.
  - intros HA ?.
    destruct HA.
    specialize epic with (z := Prop).
    specialize epic with (g1 := fun y0 => (exists x0, f x0 = y0)%type).
    simpl in *.
    specialize epic with (g2 := fun y => True).
    erewrite epic.
      constructor.
    intros.
    Axiom propositional_extensionality : forall P : Prop, P -> P = True.
    apply propositional_extensionality.
    exists x0.
    reflexivity.
Qed.