From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ C1 C2 /\ (wd_ A2 P /\ (wd_ A1 P /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ P B1 B2 /\ col_ P C1 C2)))))))) -> col_ A1 A2 P)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** ElGamal encryption scheme.

  We show that DH security implies the security of ElGamal.

*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum
  eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb
  pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude
  AsymScheme.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Theory.
Import Order.POrderTheory.

Local Open Scope ring_scope.
Import GroupScope GRing.Theory.

Import PackageNotation.

Module Type ElGamalParam.

  Parameter gT : finGroupType.
  Definition ζ : {set gT} := [set : gT].
  Parameter g :  gT.
  Parameter g_gen : ζ = <[g]>.
  Parameter order_gt1 : (1 < #[g])%N.

End ElGamalParam.

Module ElGamal (EGP : ElGamalParam).

Import EGP.

Lemma cyclic_zeta: cyclic ζ.
Proof.
  apply /cyclicP. exists g. exact: g_gen.
Qed.

(* order of g *)
Definition q : nat := #[g].

Lemma group_prodC :
  ∀ x y : gT, x * y = y * x.
Proof.
  move => x y.
  have Hx: exists ix, x = g^+ix.
  { apply /cycleP. rewrite -g_gen.
    apply: in_setT. }
  have Hy: exists iy, y = g^+iy.
  { apply /cycleP. rewrite -g_gen.
    apply: in_setT. }
  destruct Hx as [ix Hx].
  destruct Hy as [iy Hy].
  subst.
  repeat rewrite -expgD addnC. reflexivity.
Qed.

Module MyParam <: AsymmetricSchemeParams.

  Definition SecurityParameter : choiceType := nat_choiceType.
  Definition Plain  : finType := FinGroup.arg_finType gT.
  Definition Cipher : finType :=
    prod_finType (FinGroup.arg_finType gT) (FinGroup.arg_finType gT).
  Definition PubKey : finType := FinGroup.arg_finType gT.
  Definition SecKey : finType := [finType of 'Z_q].

  Definition plain0 := g.
  Definition cipher0 := (g, g).
  Definition pub0 := g.
  Definition sec0 : SecKey := 0.

End MyParam.

Module MyAlg <: AsymmetricSchemeAlgorithms MyParam.

  Import MyParam.

  #[export] Instance positive_gT : Positive #|gT|.
  Proof.
    apply /card_gt0P. exists g. auto.
  Qed.

  #[export] Instance positive_SecKey : Positive #|SecKey|.
  Proof.
    apply /card_gt0P. exists sec0. auto.
  Qed.

  Definition Plain_pos : Positive #|Plain| := _.
  Definition PubKey_pos : Positive #|PubKey| := _.
  Definition SecKey_pos : Positive #|SecKey| := _.

  #[export] Instance Cipher_pos : Positive #|Cipher|.
  Proof.
    unfold Cipher. rewrite card_prod.
    exact _.
  Qed.

  Definition chPlain  : choice_type := 'fin #|gT|.
  Definition chPubKey : choice_type := 'fin #|gT|.
  Definition chCipher : choice_type := 'fin #|Cipher|.
  Definition chSecKey : choice_type := 'fin #|SecKey|.

  Definition counter_loc : Location := ('nat ; 0%N).
  Definition pk_loc : Location := (chPubKey ; 1%N).
  Definition sk_loc : Location := (chSecKey ; 2%N).
  Definition m_loc  : Location := (chPlain ; 3%N).
  Definition c_loc  : Location := (chCipher ; 4%N).

  Definition kg_id : nat := 5.
  Definition enc_id : nat := 6.
  Definition dec_id : nat := 7.
  Definition challenge_id : nat := 8. (*challenge for LR *)
  Definition challenge_id' : nat := 9. (*challenge for real rnd *)
  Definition getpk_id : nat := 42. (* routine to get the public key *)

  Definition i_plain := #|Plain|.
  Definition i_cipher := #|Cipher|.
  Definition i_pk := #|PubKey|.
  Definition i_sk := #|SecKey|.
  Definition i_bool := 2.

  (** Key Generation algorithm *)
  Definition KeyGen {L : {fset Location}} :
    code L [interface] (chPubKey × chSecKey) :=
    {code
      x ← sample uniform i_sk ;;
      let x := otf x in
      ret (fto (g^+x), fto x)
    }.

  (** Encryption algorithm *)
  Definition Enc {L : {fset Location}} (pk : chPubKey) (m : chPlain) :
    code L [interface] chCipher :=
    {code
      y ← sample uniform i_sk ;;
      let y := otf y in
      ret (fto (g^+y, (otf pk)^+y * (otf m)))
    }.

  (** Decryption algorithm *)
  Definition Dec_open {L : {fset Location}} (sk : chSecKey) (c : chCipher) :
    code L [interface] chPlain :=
    {code
      ret (fto ((fst (otf c)) * ((snd (otf c))^-(otf sk))))
    }.

  Notation " 'plain " :=
    chPlain
    (in custom pack_type at level 2).

  Notation " 'cipher " :=
    chCipher
    (in custom pack_type at level 2).

  Notation " 'pubkey " :=
    chPubKey
    (in custom pack_type at level 2).

End MyAlg.

Local Open Scope package_scope.

Module ElGamal_Scheme := AsymmetricScheme MyParam MyAlg.

Import MyParam MyAlg ElGamal_Scheme.

Lemma counter_loc_in :
  counter_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Lemma pk_loc_in :
  pk_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Lemma sk_loc_in :
  sk_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Definition DH_loc := fset [:: pk_loc ; sk_loc].

Definition DH_real :
  package DH_loc [interface]
    [interface #val #[10] : 'unit → 'pubkey × 'cipher ] :=
    [package
      #def #[10] (_ : 'unit) : 'pubkey × 'cipher
      {
        a ← sample uniform i_sk ;;
        let a := otf a in
        b ← sample uniform i_sk ;;
        let b := otf b in
        #put pk_loc := fto (g^+a) ;;
        #put sk_loc := fto a ;;
        ret (fto (g^+a), fto (g^+b, g^+(a * b)))
      }
    ].

Definition DH_rnd :
  package DH_loc [interface]
    [interface #val #[10] : 'unit → 'pubkey × 'cipher ] :=
    [package
      #def #[10] (_ : 'unit) : 'pubkey × 'cipher
      {
        a ← sample uniform i_sk ;;
        let a := otf a in
        b ← sample uniform i_sk ;;
        let b := otf b in
        c ← sample uniform i_sk ;;
        let c := otf c  in
        #put pk_loc := fto (g^+a) ;;
        #put sk_loc := fto a ;;
        ret (fto (g^+a), fto (g^+b, g^+c))
      }
    ].

Definition Aux :
  package (fset [:: counter_loc ; pk_loc ])
    [interface #val #[10] : 'unit → 'pubkey × 'cipher]
    [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id'] : 'plain → 'cipher
    ]
  :=
  [package
    #def #[getpk_id] (_ : 'unit) : 'pubkey
    {
      pk ← get pk_loc ;;
      ret pk
    } ;

    #def #[challenge_id'] (m : 'plain) : 'cipher
    {
      #import {sig #[10] : 'unit → 'pubkey × 'cipher } as query ;;
      count ← get counter_loc ;;
      #put counter_loc := (count + 1)%N ;;
      #assert (count == 0)%N ;;
      '(pk, c) ← query Datatypes.tt ;;
      @ret chCipher (fto ((otf c).1 , (otf m) * ((otf c).2)))
    }
  ].

Lemma ots_real_vs_rnd_equiv_true :
  Aux ∘ DH_real ≈₀ ots_real_vs_rnd true.
Proof.
  (* We go to the relation logic using equality as invariant. *)
  eapply eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  all: ssprove_code_simpl.
  (* We are now in the realm of program logic *)
  - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
    move => [a1 h1] [a2 h2] [Heqa Heqh]. intuition auto.
  - ssprove_sync_eq. intro count.
    ssprove_sync_eq.
    ssprove_sync_eq. move => /eqP e. subst.
    ssprove_sync_eq. intro a.
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq.
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq.
    ssprove_sync_eq. intro b.
    rewrite !otf_fto. simpl.
    eapply r_ret. intuition eauto.
    f_equal. f_equal.
    rewrite group_prodC. f_equal.
    apply expgM.
Qed.

Lemma bijective_expgn :
  bijective (λ (a : 'Z_q), g ^+ a).
Proof.
  unshelve eexists (λ x, (proj1_sig (@cyclePmin gT g x _) %% q)%:R).
  - rewrite -g_gen. unfold ζ. apply in_setT.
  - simpl. intros a.
    match goal with
    | |- context [ @cyclePmin _ _ _ ?hh ] =>
      set (h := hh)
    end.
    clearbody h. simpl in h.
    destruct cyclePmin as [n hn e]. simpl.
    move: e => /eqP e. rewrite eq_expg_mod_order in e.
    move: e => /eqP e.
    rewrite -e.
    (* case_eq (q == 1)%N.
    1:{
      fold q in *. set (q' := q) in *. clearbody q'.
      move /eqP => ?. subst. rewrite modn1.
      clear h n e hn.
      destruct a as [a h]. unfold Zp_trunc in *. simpl in *.
      (* So in the case where q = 1, we have 'Z_1 = {0, 1} but a mod 1 = 0. *)
    } *)
    rewrite modn_small.
    2:{
      fold q. eapply leq_trans. 1: eapply ltn_ord.
      rewrite Zp_cast.
      2: apply order_gt1.
      auto.
    }
    apply natr_Zp.
  - simpl. intro x.
    match goal with
    | |- context [ @cyclePmin _ _ _ ?hh ] =>
      set (h := hh)
    end.
    clearbody h. simpl in h.
    destruct cyclePmin as [n hn e]. simpl. subst.
    rewrite modn_small. 2: auto.
    f_equal. rewrite val_Zp_nat. 2: apply order_gt1.
    apply modn_small. auto.
Qed.

#[local] Definition f m : 'Z_q * 'Z_q → gT * gT :=
  λ '(a,b), (g^+a, (otf m) * g^+b).

Lemma bijective_f : ∀ m, bijective (f m).
Proof.
  intro m.
  pose proof bijective_expgn as bij.
  destruct bij as [d hed hde].
  eexists (λ '(x,y), (d x, d ((otf m)^-1 * y))).
  - intros [? ?]. simpl. rewrite hed. f_equal.
    rewrite mulgA. rewrite mulVg. rewrite mul1g.
    apply hed.
  - intros [x y]. simpl. rewrite hde. f_equal.
    rewrite hde. rewrite mulgA. rewrite mulgV. rewrite mul1g.
    reflexivity.
Qed.

#[local] Definition f' (m : chPlain) :
  Arit (uniform (i_sk * i_sk)) → Arit (uniform i_cipher) :=
  λ x,
    let '(a, b) := ch2prod x in
    fto (f m (otf a, otf b)).

Lemma bijective_f' : ∀ m, bijective (f' m).
Proof.
  intro m.
  pose proof (bijective_f m) as bij. destruct bij as [g gf fg].
  unfold f'.
  exists (λ x, let '(a,b) := g (otf x) in prod2ch (fto a, fto b)).
  - cbn - [f]. intros x. rewrite -[RHS]prod2ch_ch2prod.
    set (y := ch2prod x). clearbody y. clear x.
    simpl in y. destruct y as [a b].
    rewrite otf_fto. rewrite gf.
    rewrite !fto_otf. reflexivity.
  - cbn - [f]. intro x.
    replace x with (fto (f m (g (otf x)))) at 2.
    2:{ rewrite fg. rewrite fto_otf. reflexivity. }
    set (y := g (otf x)). change (g (otf x)) with y. clearbody y. clear x.
    destruct y as [a b]. rewrite ch2prod_prod2ch. rewrite !otf_fto.
    reflexivity.
Qed.

Lemma ots_real_vs_rnd_equiv_false :
  ots_real_vs_rnd false ≈₀ Aux ∘ DH_rnd.
Proof.
  (* We go to the relation logic using equality as invariant. *)
  eapply eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  all: ssprove_code_simpl.
  (* We are now in the realm of program logic *)
  - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
    cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  - ssprove_sync_eq. intro count.
    ssprove_sync_eq.
    destruct count.
    2:{
      cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    }
    simpl.
    ssprove_sync_eq. intro a.
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq.
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq.
    eapply r_transR.
    1:{ eapply r_uniform_prod. intros x y. eapply rreflexivity_rule. }
    simpl.
    eapply rsymmetry.
    eapply @r_uniform_bij with (f := f' m). 1: apply bijective_f'.
    simpl. intros x.
    unfold f'. set (z := ch2prod x). clearbody z. clear x.
    destruct z as [x y]. simpl.
    eapply r_ret. intros s ? e. subst.
    intuition auto.
    rewrite !otf_fto. simpl.
    reflexivity.
Qed.

Theorem ElGamal_OT :
  ∀ LA A,
    ValidPackage LA [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id'] : 'plain → 'cipher
    ] A_export A →
    fdisjoint LA (ots_real_vs_rnd true).(locs) →
    fdisjoint LA (ots_real_vs_rnd false).(locs) →
    Advantage ots_real_vs_rnd A <= AdvantageE DH_rnd DH_real (A ∘ Aux).
Proof.
  intros LA A vA hd₀ hd₁.
  simpl in hd₀, hd₁. clear hd₁. rename hd₀ into hd.
  rewrite Advantage_E.
  ssprove triangle (ots_real_vs_rnd false) [::
    Aux ∘ DH_rnd ;
    Aux ∘ DH_real
  ] (ots_real_vs_rnd true) A
  as ineq.
  eapply le_trans. 1: exact ineq.
  clear ineq.
  rewrite ots_real_vs_rnd_equiv_true. 3: auto.
  2:{
    rewrite fdisjointUr. apply/andP. split.
    - unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      rewrite fset_cons. apply fsetUS.
      rewrite !fset_cons -fset0E.
      apply fsetUS.
      apply fsub0set.
    - unfold DH_loc. unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      apply fsubsetUr.
  }
  rewrite ots_real_vs_rnd_equiv_false. 2: auto.
  2:{
    rewrite fdisjointUr. apply/andP. split.
    - unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      rewrite fset_cons. apply fsetUS.
      rewrite !fset_cons -fset0E.
      apply fsetUS.
      apply fsub0set.
    - unfold DH_loc. unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      apply fsubsetUr.
  }
  rewrite GRing.addr0. rewrite GRing.add0r.
  rewrite -Advantage_link. auto.
Qed.

End ElGamal.

Module EGP_Z3 <: ElGamalParam.

  Definition gT : finGroupType := Zp_finGroupType 2.
  Definition ζ : {set gT} := [set : gT].
  Definition g :  gT := Zp1.

  Lemma g_gen : ζ = <[g]>.
  Proof.
    unfold ζ, g. apply Zp_cycle.
  Qed.

  Lemma order_gt1 : (1 < #[g])%N.
  Proof.
    unfold g.
    rewrite order_Zp1.
    reflexivity.
  Qed.

End EGP_Z3.

Module ElGamal_Z3 := ElGamal EGP_Z3.


(**
  [TypeTheory.CwF.CwF_Cats_Simple_Iso]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module establishes an isomorphism of categories of
CwF structures with slightly different definition of morphisms.
Specifically, [CwF_Cats_Simple.weq_cwf_structure_mor_with_ϕ] is
at the core of this isomorpshim.

Main definitions here are

- [cwf_to_cwfS_functor] and [cwf_to_cwfS_is_catiso] — isomorphism of "regular" and "simple" categories of CwF structure.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.CwF.CwF_def.
Require Import TypeTheory.CwF.CwF_Cats.
Require TypeTheory.CwF.CwF_Cats_Simple.
Require Import UniMath.CategoryTheory.catiso.

Section CwF_Cats_Simple_Iso.

  Context (C : category).

  Section mor.

    Context (X Y : cwf_structure C).

    Definition cwf_to_cwfS_structure_mor_with_ϕ
      : cwf_structure_mor X Y → CwF_Cats_Simple.cwf_structure_mor_with_ϕ X Y.
    Proof.
      intros mor.
      set (F_TM := pr11 mor).
      set (F_TY := pr121 mor).
      set (ϕ := pr221 mor).
      set (ax1 := pr12 mor).
      set (ax2 := pr122 mor).
      set (ax3 := pr222 mor).
      exact (((F_TM ,, F_TY) ,, ax2) ,, (ϕ ,, ax1 ,, ax3)).
    Defined.

    Definition cwfS_to_cwf_structure_mor_with_ϕ
      : CwF_Cats_Simple.cwf_structure_mor_with_ϕ X Y → cwf_structure_mor X Y.
    Proof.
      intros morS_with_ϕ.
      set (F_TM := pr111 morS_with_ϕ).
      set (F_TY := pr211 morS_with_ϕ).
      set (ax2 := pr21 morS_with_ϕ).
      set (ϕ := pr12 morS_with_ϕ).
      set (ax1 := pr122 morS_with_ϕ).
      set (ax3 := pr222 morS_with_ϕ).
      exact ((F_TM ,, F_TY ,, ϕ) ,, (ax1 ,, ax2 ,, ax3)).
    Defined.

    Definition isweq_cwf_to_cwfS_structure_mor_with_ϕ
      : isweq cwf_to_cwfS_structure_mor_with_ϕ.
    Proof.
      apply (isweq_iso cwf_to_cwfS_structure_mor_with_ϕ
                       cwfS_to_cwf_structure_mor_with_ϕ).
      - intros mor.
        use cwf_structure_mor_eq.
        + intros Γ A. apply idpath.
        + intros Γ A. apply idpath.
        + intros Γ A. apply id_right.
      - intros morS_with_ϕ.
        use CwF_Cats_Simple.cwf_structure_mor_with_ϕ_eq.
        + apply idpath.
        + apply idpath.
    Defined.

    Definition weq_cwf_cwfS_structure_mor_with_ϕ
      : cwf_structure_mor X Y ≃ CwF_Cats_Simple.cwf_structure_mor_with_ϕ X Y
      := (_ ,, isweq_cwf_to_cwfS_structure_mor_with_ϕ).

    Definition weq_cwf_cwfS_structure_mor
      : cwf_structure_mor X Y ≃ CwF_Cats_Simple.cwf_structure_mor X Y.
    Proof.
      eapply weqcomp.
      apply weq_cwf_cwfS_structure_mor_with_ϕ.
      apply CwF_Cats_Simple.weq_cwf_structure_mor_with_ϕ.
    Defined.

  End mor.

  (* CwF to CwF (simple) functor *)

  Definition cwf_to_cwfS_functor_data
    : functor_data (@cwf_structure_cat C)
                   (@CwF_Cats_Simple.cwf_structure_cat C).
  Proof.
    use make_functor_data.
    - apply idweq.
    - apply weq_cwf_cwfS_structure_mor.
  Defined.

  Definition cwf_to_cwfS_functor_idax
    : functor_idax cwf_to_cwfS_functor_data.
  Proof.
    intros c.
    use total2_paths_f.
    + apply idpath.
    + apply homset_property.
  Defined.

  Definition cwf_to_cwfS_functor_compax
    : functor_compax cwf_to_cwfS_functor_data.
  Proof.
    intros a b c.
    intros f g.

    use total2_paths_f.
    + apply idpath.
    + apply homset_property.
  Defined.

  Definition cwf_to_cwfS_is_functor
    : is_functor cwf_to_cwfS_functor_data
    := (cwf_to_cwfS_functor_idax ,, cwf_to_cwfS_functor_compax).

  Definition cwf_to_cwfS_functor
    : functor (@cwf_structure_precategory_data C)
              (@CwF_Cats_Simple.cwf_structure_precategory_data C).
  Proof.
    use (make_functor cwf_to_cwfS_functor_data).
    apply cwf_to_cwfS_is_functor.
  Defined.

  Definition cwf_to_cwfS_is_catiso : is_catiso cwf_to_cwfS_functor.
  Proof.
    use tpair.
    - unfold fully_faithful.
      intros X Y.
      apply (pr2 (weq_cwf_cwfS_structure_mor _ _)).
    - apply (pr2 (idweq _)).
  Defined.

End CwF_Cats_Simple_Iso.


(** * Soundness of EvalF (a big-step semantics for LDef) *)

(**  This file develops a proof of soundness of [evalF],
     using a recursive definition of
     [value_has_type] rather than an inductive relation
     (as was done in earlier attempts).
     It has been updated to handle records and seems to be working!  *)

Load Init.
Require Export SfLib.
Require Import LibTactics.

Require Export Common LDef LEval.
Import Common LDef LEval.

(* ###################################################################### *)
(** ** Relations between values, types and evalF. *)

(**  We define several relations concurrently:
        - [v ::: T] (aka [value has type v T]):
          value v is the result of evaluating some term of type T.
        - [bs :::* Ls] (aka [bindings_match_decls g G]):
          [bs] is a list of [(xi,vi)] pairs and [Ls] is a list of declarations,
          [(Lv xi Ti)] and [vi:::Ti] for all [i]; thus [bs]
          has exactly the elements specified by
          the typing context Ls (in the same order).
        - [t / g =>: T] (aka [may_eval_to t g T]):
          term t, when evaluated in runtime-context g,
          will either yield a value [v] such that [v:::T] or not terminate
          (but it won't get stuck).
        - [Fs / g =>:* Ls] (aka [may_exec_pdefs_to Fs g Ls]):
          [Fs] is a list of definitions, each [(Fv xi ti)],
          [Ls] is a list of declarations, each [(Lv xi Ti)],
          and for each [i], [ti / g =>: Ti]; thus executing [Fs] will
          either yield a value list [bs], such that [bs :::* Ls]
          or it won't terminate (but it won't get stuck).
        - [result_ok er T]: [er] (an instance of [ef_return]) is either
          [efr_normal v] and [v ::: T]
          or [er] is [efr_nogas]; [er] is not [efr_stuck].
        - [pdefs_result_ok xr Ls]: [xr] (an instance of [xf_return]) is either
          [efr_normal bs] and [bs :::* Ls]
          or [xr] is [efr_nogas]; [xr] is not [efr_stuck].

    If defined as mutually recursive functions, Coq complains about
    the lack of a non-decreasing argument
    (which really is decreasing but Coq can't tell).
    It would be nice if there was a way to get around this.
    In the meantime, [value_has_type] is defined with certain others
    nested within and then the others are defined again
    outside the [value_has_type] definition.
*)

Reserved Notation "v ':::' T" (at level 40).
Reserved Notation "g ':::*' G" (at level 40).
Reserved Notation "t '/' g '=>:' T" (at level 40, g at level 39).

Fixpoint value_has_type (v : evalue) (T : ty) {struct T} : Prop :=
  let result_ok (er : ef_return) (T : ty) : Prop :=
    match er with
      | efr_normal vr => vr ::: T
      | efr_nogas     => True
      | efr_stuck     => False
    end
  in let may_eval_to (t : tm) (g : rctx) (T : ty) : Prop :=
    forall n, result_ok (evalF t g n) T
  in let binding_matches_decl
           (b : vbinding) (L : decl) : Prop :=
    match (L, b) with
      | ((Lv x T), (y, v)) => x=y /\ v ::: T
    end
  in let fix bindings_match_decls
           (bs : alist evalue) (Ls : list decl) {struct Ls} : Prop :=
    match (Ls, bs) with
      | (nil, nil) => True
      | ((L :: Ls'), (b :: bs')) =>
         binding_matches_decl b L /\ bindings_match_decls bs' Ls'
      | (_, _) => False
    end
  in match (T, v) with
    | (TBool, vtrue) => True
    | (TBool, vfalse) => True
    | ((TArrow T1 T2), (vabs xf tb gf)) =>
        forall va, va ::: T1 -> may_eval_to tb (aextend xf va gf) T2
    | ((TRcd Tr), (vrcd vr)) => bindings_match_decls vr Tr
    | (_, _) => False
  end
where "v ':::' T" := (value_has_type v T).

Definition binding_matches_decl (b: vbinding) (L: decl) : Prop :=
  match (L, b) with
    | ((Lv x T), (y, v)) => x=y /\ v ::: T
  end.

Fixpoint bindings_match_decls
           (bs : alist evalue) (Ls : list decl) {struct Ls} : Prop :=
    match (Ls, bs) with
      | (nil, nil) => True
      | (L :: Ls', (b :: bs')) =>
          binding_matches_decl b L /\ bindings_match_decls bs' Ls'
      | (_, _) => False
    end.
Notation "g ':::*' G" := (bindings_match_decls g G).

Definition res_ok_g
  {Tv : Type} {Tty : Type} {Rvht : Tv -> Tty -> Prop}
  (er : ef_return_g Tv) (T : Tty) : Prop :=
    match er with
      | efr_normal v => Rvht v T
      | efr_nogas => True
      | efr_stuck => False
    end.

Definition result_ok : ef_return -> ty -> Prop :=
  res_ok_g (Rvht:=value_has_type).

Definition vb_result_ok (er : bf_return) (L : decl) : Prop :=
  res_ok_g (Rvht:=binding_matches_decl) er L.

Definition pdefs_result_ok (er : xf_return) (Ls : list decl) : Prop :=
  res_ok_g (Rvht:=bindings_match_decls) er Ls.

Definition mevt_g {Ttm : Type} {Tty: Type} {Tv : Type}
                  {Fev : Ttm -> rctx -> nat -> (ef_return_g Tv)}
                  {Rvht : Tv -> Tty -> Prop}
                  (t : Ttm) (g : rctx) (T : Tty) : Prop :=
    forall n, res_ok_g (Rvht:=Rvht) (Fev t g n) T.

Definition may_eval_to (t : tm) (g : rctx) (T : ty) : Prop :=
  mevt_g (Fev:=evalF) (Rvht:=value_has_type) t g T.
Notation "t '/' g '=>:' T" := (may_eval_to t g T)
    (at level 40, g at level 39).

Definition may_exec_def_to (F : def) (g : rctx) (L : decl) : Prop :=
  mevt_g (Fev:=execF_def) (Rvht:=binding_matches_decl) F g L.

Definition may_exec_pdefs_to
      (Fs : list def) (g : rctx) (Ls : list decl) : Prop :=
  mevt_g (Fev:=execF_pdefs) (Rvht:=bindings_match_decls) Fs g Ls.
Notation "Fs '/' g '=>:*' Ls" := (may_exec_pdefs_to Fs g Ls)
    (at level 40, g at level 39).

Hint Unfold value_has_type binding_matches_decl bindings_match_decls
     result_ok vb_result_ok pdefs_result_ok
     may_eval_to may_exec_def_to may_exec_pdefs_to mevt_g.

(** The following are some alternate definition bodies of [bs:::*Ls] that I've
    considered:
<<
    match Ls with
      | nil => True
      | (Lv x T) :: Ls' => (exists v, alookup x bs = Some v /\ v ::: T)
                           /\ bindings_match_decls bs Ls'
    end

   forall x T, lookup_vdecl x Ls = Some T ->
      exists v, alookup x bs = Some v /\ v ::: T

  let decl_implies_lookup bs L :=
    match L with (Lv x T) => exists v, alookup x bs = Some v /\ v ::: T end
  in Forall (decl_implies_lookup bs) Ls.

>>
The following is the original inductive definition:
<<
  Inductive bindings_match_decls: rctx -> context -> Prop :=
    | TC_nil : nil :::* empty
    | TC_cons : forall G g x v T,
                g :::* G -> v ::: T -> (aextend x v g) :::* (add_vdecl x T G)
  where "g ':::*' G" := (bindings_match_decls g G).
>>
*)

(** Here I redefine [value_has_type] using the above functions
    and show that it is equivalent.  My thinking was that this
    would avoid the nested definitions, but they don't seem
    to come up, so this isn't used.*)

Fixpoint value_has_type' (v : evalue) (T : ty) {struct T} : Prop :=
  match (T, v) with
    | (TBool, vtrue) => True
    | (TBool, vfalse) => True
    | ((TArrow T1 T2), (vabs xf tb gf)) =>
        forall va, va ::: T1 -> tb / (aextend xf va gf) =>: T2
    | ((TRcd Tr), (vrcd vr)) => vr :::* Tr
    | (_, _) => False
  end.

Lemma vht_defs_eq:
  forall v T, value_has_type v T <-> value_has_type' v T.
Proof.
  intros. split; intro H.
    Case "->". induction T; destruct v; simpl in H; auto.
    Case "<-". induction T; destruct v; simpl in H; auto.
Qed.

(* ###################################################################### *)
(** ** Lemmas  *)
(** *** A Lemma for induction on [:::*] *)
(** Lemma [bmds_ind] is a handy lemma for doing a form of induction over :::*.
    Use it with the [refine] tactic. *)

Lemma bmds_ind:
  forall (P : list decl -> alist evalue -> Type)
    (fnil : P nil nil)
    (fcons: forall x v T Ls' bs',
      v ::: T -> (P Ls' bs') -> P ((Lv x T)  :: Ls') ((x, v) :: bs')),
    forall (Ls : list decl) (bs : alist evalue), (bs :::* Ls) -> P Ls bs.
Proof.
  intros P fnil fcons Ls.
  induction Ls as [ | [x T] Ls']; intros bs Hbmd;
      destruct bs as [ |[y v] bs']; simpl in Hbmd; try contradiction.
    Case "Ls = []".
      apply fnil.
    Case "Ls = L :: Ls'".
      destruct Hbmd as ([Heq Hvyt] & Hbmd').  subst y.
      apply (fcons _ _ _ _ _ Hvyt (IHLs' _ Hbmd')).
Qed.

(** *** Constructor lemmas *)
(** Lemmas that mimic the inductive constructors that would have
    been defined if Coq allowed us to define our relations that way. *)

Lemma VHT_True :
  vtrue ::: TBool.
Proof. reflexivity. Qed.

Lemma VHT_False :
  vfalse ::: TBool.
Proof. reflexivity. Qed.

Lemma VHT_Abs :
  forall xf tb gf T1 T2,
    (forall va,  va ::: T1 -> tb / (aextend xf va gf) =>: T2) ->
    vabs xf tb gf ::: TArrow T1 T2.
Proof. introv H. exact H. Qed.

Lemma VHT_Rcd :
  forall Fs Ls,
    Fs :::* Ls ->
    vrcd Fs ::: TRcd Ls.
Proof. introv H. simpl. exact H. Qed.

Lemma BMD :
  forall x v T,
    v ::: T ->
    binding_matches_decl (x, v) (Lv x T).
Proof. auto. Qed.

Lemma BMDs_nil :
  nil :::* nil.
Proof. simpl. constructor. Qed.

Lemma BMDs_cons :
  forall b bs L Ls,
    binding_matches_decl b L ->
    bs :::* Ls ->
    (b :: bs) :::* (L :: Ls).
Proof.
  introv Hbmd HgG. simpl. auto.
Qed.

Lemma MET:
  forall t g T,
    (forall n er, evalF t g n = er -> result_ok er T) ->
    (t / g =>: T).
Proof.
  introv H. red. red. apply (fun n => H n (evalF t g n) eq_refl).
Qed.

Lemma ROk_Norm :
  forall v T er,
    efr_normal v = er ->
    v ::: T ->
    result_ok er T.
Proof.
  introv Heq Ht. subst. simpl. exact Ht.
Qed.

Lemma RLOk_Norm:
  forall bs Ls xr,
    efr_normal bs = xr ->
    bs :::* Ls ->
    pdefs_result_ok xr Ls.
Proof.
  introv Heq Ht. subst. simpl. exact Ht.
Qed.

(** *** "Inversion" lemmas *)
(**  Lemmas for "inverting" the [value_has_type] function.
     IN SF, [vht_inv_bool] is called [bool_vals]
     and [vht_inv_arrow] is called [fun_vals]).*)

Lemma vht_inv_bool: forall v, v ::: TBool -> (v = vtrue \/ v = vfalse).
Proof.
  intros v Hvt. destruct v; try (simpl in Hvt; contradiction); auto.
Qed.

Lemma vht_inv_arrow:
  forall v T1 T2, v ::: TArrow T1 T2 ->
    exists xf tb gf,
      v = (vabs xf tb gf)
      /\ (forall va, va ::: T1 -> tb / (aextend xf va gf) =>: T2).
Proof.
  intros v T1 T2 Hvt.  destruct v; simpl in Hvt; try contradiction.
    exists i t a. split.
      reflexivity.
      intros va Hvat n.
        specialize (Hvt va Hvat n).
        destruct (evalF t (aextend i va a) n); simpl; auto.
Qed.

Lemma vht_inv_rcd :
  forall v Ls, v ::: TRcd Ls ->
    exists bs, v = (vrcd bs) /\ bs :::* Ls.
Proof.
  intros v Ls Hvt. destruct v as [ | | | bs]; simpl in Hvt; try contradiction.
    exists bs. split.
      reflexivity.
      assumption.
Qed.

(** The following isn't accepted by Coq because Hvt doesn't have a
    string enough type when passed to the specific inversion functions.
    It has type [v:::T] while it needs to have a type like [v:::TBool].
    (However, it isn't really needed):
<<
  Lemma vht_inversion :
    forall v T (Hvt : v ::: T),
      (T=TBool /\ (vht_inv_bool v Hvt))
      \/ (exists T1 T2, T=TArrow T1 T2 /\ vht_inv_arrow v T1 T2 Hvt)
      \/ (exists Ls, T=TRcd Ls /\ vht_inv_rcd v Ls Hvt).
>>
*)

(** The following two lemmas were experiments that didn't work out.
    They were intended to make it easier to use a hypothesis of the
    form [result_ok ... T]
    but the inversion one had trouble coming up with [P]
    and the case one required a complicated [destruct]. *)

Lemma ROk_inversion:
  forall (P : ef_return -> ty -> Prop),
    forall er T,
      result_ok er T ->
      (forall vr, vr ::: T -> P (efr_normal vr) T) ->
      P efr_nogas T ->
      P er T.
Proof.
  intros P er T Hok Hnorm Hng. destruct er; simpl in Hok.
    apply (Hnorm _ Hok).
    apply Hng.
    contradiction.
Qed.

Lemma ROk_case:
  forall er T,
    result_ok er T -> (
      (exists vr, er = efr_normal vr /\ vr ::: T) \/
      er = efr_nogas ).
Proof.
  intros er T Hok. destruct er as [vr| | ]; simpl in Hok.
    left. exists vr. split. reflexivity. apply Hok.
    right. reflexivity.
    contradiction.
Qed.

(** *** Lemma [ctxts_agree_on_lookup] *)
(** Lemma [ctxts_agree_on_lookup] says that if [bs:::*Ls] and
    a lookup on [Ls] returns [Some T], then the related lookup on [bs]
    returns [Some v] where [v:::T]. *)

Lemma ctxts_agree_on_lookup :
  forall (Ls : context) (bs : rctx),
    bs :::* Ls ->
    forall (x : id) (T : ty),
      lookup_vdecl x Ls = Some T ->
        exists v, alookup x bs = Some v /\ v ::: T.
Proof.
  refine (bmds_ind _ _ _).
    Case "nil". introv Hlk. inverts Hlk.
    Case "cons". introv Hvt IH Hlk.
      apply lookup_add_vdecl_case in Hlk.
      destruct Hlk as [[Hxe HTe] | [Hxn Hle]].
        SCase "x=x0".
          inversion HTe; subst; clear HTe.
          exists v. split.
            apply alookup_cons_eq.
            apply Hvt.
        SCase "x<>x0".
          destruct (IH _ _ Hle) as [v0 [Hlk0 Hvt0]].
          exists v0. split.
            rewrite (alookup_cons_neq _ _ _ _ _ Hxn). apply Hlk0.
            apply Hvt0.
Qed.

(* Version for when :::* was defined inductively:
Lemma ctxts_agree_on_lookup_old :
  forall (x : id) (G : context) (g : rctx) (T : ty),
    g  :::* G ->
    lookup_vdecl x G = Some T ->
      exists v, alookup x g = Some v /\ v ::: T.
Proof.
  introv Hctxts HGxT. induction Hctxts.
    Case "BMDs_nil". inversion HGxT.
    Case "BMDs_cons". unfold lookup_vdecl, add_vdecl in HGxT.
    destruct (eq_id_dec x0 x).
      SCase "x0=x". subst. inverts HGxT. exists v. split.
        simpl. apply eq_id.
        assumption.
      SCase "x0<>x". apply IHHctxts in HGxT. clear IHHctxts.
        inversion HGxT as [v' [Ha' Hb']]. exists v'. split.
          rewrite <- Ha'. simpl. apply (neq_id _ _ _ _ _ n).
          assumption.
Qed.
*)

(** *** Lemmas for reasoning about contexts (runtime and typing). *)
(** No longer used.    *)

Lemma lookup_implies_in:
  forall x G T,
    lookup_vdecl x G = Some T -> In (Lv x T) G.
Proof.
  introv Hlookup. induction G as [ | [y Ty] G'].
  Case "G=[]". inversion Hlookup.
  Case "G=(Lv y Ty)::G'".
    apply lookup_add_vdecl_case in Hlookup.
    destruct Hlookup as [[Hxe HTe] | [Hxn Hle]].
    SCase "y=x". inverts HTe. subst. left. reflexivity.
    SCase "y<>x". right. apply (IHG' Hle).
Qed.

Lemma ctx_tvar_then_some : forall G x T,
  G |-- (tvar x) \in T -> lookup_vdecl x G = Some T.
Proof. introv H. inversion H. auto. Qed.

Lemma ctx_tvar_then_alookup : forall G x T g,
  G |-- (tvar x) \in T -> g :::* G ->
    exists v, alookup x g = Some v /\ v ::: T.
Proof.
  introv HG Hg.
  apply (ctxts_agree_on_lookup G g Hg x T (ctx_tvar_then_some _ _ _ HG)).
Qed.

Lemma ctx_tvar_then_evalsto : forall G x T g,
  G |-- (tvar x) \in T -> g :::* G -> (tvar x) / g =>: T.
Proof.
  introv HG Hg. destruct (ctx_tvar_then_alookup G x T g HG Hg) as [v [Hl Hv]].
  unfold may_eval_to. intro n. destruct n as [ | n' ]; simpl; auto.
    rewrite Hl. auto.
Qed.

(** *** Lemmas for more easily proving [t / g =>: T] and [Fs / g  =>:* Ls] *)
(** These lemmas rearrange things so that the calls to [evalF] and
    [execF_pdefs] are in hypotheses such that [let_val] and associates
    can be applied to them.*)

Lemma evalF_parts :
  forall (t : tm) (T : ty) (g : rctx),
    (forall n' er, evalF t g (S n') = er -> result_ok er T) ->
        t / g  =>: T.
Proof.
  introv H. unfold may_eval_to.
  destruct n  as [ | n' ].
    simpl (evalF _ _ 0). reflexivity.
    apply (H n' _ eq_refl).
Qed.

Lemma eF_parts_g {Ttm : Type} {Tty: Type} {Tv : Type}
                 {Fev : Ttm -> rctx -> nat -> (ef_return_g Tv)}
                 {Rvht : Tv -> Tty -> Prop}:
(*               {Rmet : Ttm -> rctx -> Tty -> Prop}:*)
  forall (t : Ttm) (T : Tty) (g : rctx),
    (forall n' er, Fev t g n' = er -> res_ok_g (Rvht:=Rvht) er T) ->
        mevt_g (Fev:=Fev) (Rvht:=Rvht) t g T.
Proof.
  exact (fun _ _ _ H n' => H n' _ eq_refl).
Qed.

(** *** Lemmas for reasoning about LETRT forms. *)
(** These lemmas are for reasoning about [LETRT] forms.
    Given a hypothesis, [Hev], of the form [LETRT x <== evalF ... IN ...],
    applying [let_val] with [Hev] as the appropriate parameter will yield
    subgoals that reason about the let- and in- clauses.

    Because [LETRT] is a notation, it is essentially generic in that it can
    be used with both [evalF] and [execF_pdefs].  Also the IN clause can be
    either a singelton or a list.  However, lemmas are not notations,
    so there are four lemmas to handle the different cases. *)

Lemma let_ok_g
     {Ttm1 : Type} {Tty1: Type} {Tv1 : Type}
     {Fev1 : Ttm1 -> rctx -> nat -> (ef_return_g Tv1)}
     {Rvht1 : Tv1 -> Tty1 -> Prop}
     {Tv2 : Type} {Tty2 : Type} {Rvht2: Tv2 -> Tty2 -> Prop}:
  let Ter2 := ef_return_g Tv2 in
  let Rrok := res_ok_g (Rvht:=Rvht2) in
  forall {t1} {g} {n'} {f : Tv1 -> Ter2} {erf : Ter2} {T1} {T2 : Tty2},
    (LETRT v <== Fev1 t1 g n' IN f v) = erf ->
    mevt_g (Fev:=Fev1) (Rvht:=Rvht1) t1 g T1 ->
    (forall v1,
       Rvht1 v1 T1 ->
       forall (er2 : Ter2),
         (f v1) = er2 ->
         Rrok er2 T2) ->
    Rrok erf T2.
Proof.
    introv HLet Heval Hin.
    specialize (Heval n').
    destruct (Fev1 t1 g n') as [v1 | | ]; try (subst erf; auto; fail).
      Case "efr_normal v1".
        apply (Hin v1 Heval erf HLet).
Qed.

(* Call this on
   evalue ty value_has_type
   vbinding decl binding_matches_decl
   (alist evalue) (list decl) bindings_match_decls
*)

(* ###################################################################### *)
(**  ** Proof of soundness of evalF *)
(**  *** Proof of [evalF_is_sound_yielding_T] *)
(** This theorem says that if term [t] has type [T],
    then evaluating [t] will either yield a value of type [T]
    or not terminate; in particular, it won't get "stuck".

   The proof is by induction on [t] using the custom induction principle
   so that records are handled correctly.  For each case, the typing relation
   is inverted to yield type assertions about the components of [t] and
   [evalF_parts] (or [execF_pdefs_parts]) and [simpl] are applied ending
   up with the appropriate clause of [evalF] in [Hev].
*)

Theorem evalF_is_sound_yielding_T :
  forall (t : tm) (G : context) (T : ty) (g : rctx),
    G |-- t \in T ->  g :::* G -> t / g  =>: T.
Proof.
  set (Q:=fun F : def =>
          forall (G : context) (L : decl) (g : rctx),
            def_yields G F L ->  g :::* G -> may_exec_def_to F g L).
  set (QL:=fun Fs : list def =>
          forall (G : context) (Ls : list decl) (g : rctx),
            G |-- Fs *\in Ls ->  g :::* G -> Fs / g  =>:* Ls).
  tm_xind_tactic t Q QL Case;
    introv Hty HGg; inverts Hty;
    (apply evalF_parts || apply eF_parts_g);
    intros n' er Hev; simpl in Hev; subst Q QL.

  Case "ttrue".
    exact (ROk_Norm _ _ _ Hev VHT_True).

  Case "tfalse".
    exact (ROk_Norm _ _ _ Hev VHT_False).

  Case "tvar".
    destruct (ctxts_agree_on_lookup _ _ HGg _ _ H1) as [v [Hlk Hvt]].
    rewrite Hlk in Hev. exact (ROk_Norm _ _ _ Hev Hvt).

  Case "tabs".
    apply (ROk_Norm _ _ _ Hev); clear Hev.
    apply VHT_Abs; intros va Hvat.
    apply (IHtb _ _ _ H4); clear IHtb H4.
    apply (BMDs_cons _ _ _ _ (BMD _ _ _ Hvat) HGg).

  Case "tapp".
    (* use IHs to get [Ht1 : t1 / g =>: TArrow T11 T] & [Ht2 : t2 / g =>: T11].  *)
    assert (Ht1 := IHt1 _ _ _ H2 HGg); clear IHt1 H2.
    assert (Ht2 := IHt2 _ _ _ H4 HGg); clear IHt2 H4.
    (* use the [let_val] lemma with Ht1 and Ht2 to decompose the two LETRT forms *)
    apply (let_ok_g Hev Ht1); clear Hev Ht1; intros v1 Hv1t erL2 HevL2.
    destruct (vht_inv_arrow _ _ _ Hv1t) as (xf & tb & gf & -> & Hva); clear Hv1t.
    apply (let_ok_g HevL2 Ht2); clear HevL2 Ht2; intros v2 Hv2t ? <-.
    apply (Hva v2 Hv2t n').

  Case "trcd".
    rewrite <- (execF_pdefs_eq Fs _ n') in Hev.
    assert (HFs := IHFs _ _ _ H1 HGg); clear IHFs H1.
    apply (let_ok_g Hev HFs); clear Hev HFs; intros bs Hbst er2 Hev2.
    apply (ROk_Norm _ _ _ Hev2 (VHT_Rcd _ _ Hbst)).

  Case "tproj".
    assert (Htr := IHtr _ _ _ H2 HGg); clear IHtr H2.
    apply (let_ok_g Hev Htr); clear Hev Htr; intros vr Hvrt erp Hevp.
    destruct (vht_inv_rcd _ _ Hvrt) as [bs [-> HbsT ]].
    destruct (ctxts_agree_on_lookup _ _ HbsT _ _ H4) as [v [Hlk HvT]].
    rewrite Hlk in Hevp.
    apply (ROk_Norm _ _ _ Hevp HvT).

  Case "tif".
    assert (Hti := IHti _ _ _ H3 HGg); clear IHti H3.
    apply (let_ok_g Hev Hti); clear Hev Hti; intros vi Hvit erc Hevc.
    destruct (vht_inv_bool vi Hvit); subst.
      SSCase "v = vtrue". apply (IHtt _ _ _ H5 HGg n').
      SSCase "v = vfalse". apply (IHte _ _ _ H6 HGg n').

  Case "tlet".
    rewrite <- (execF_def_eq F _ n') in Hev.
    assert (HF := IHF _ _ _ H2 HGg); clear IHF H2.
    apply (let_ok_g Hev HF); clear Hev HF; intros b1 Hb1L ? <-.
    apply (IHt _ _ (b1::g) H4 (BMDs_cons _ _ _ _ Hb1L HGg)); clear IHt H4.

  Case "F_v".
    assert (Ht := IHt _ _ _ H3 HGg); clear IHt H3.
    apply (let_ok_g Hev Ht); clear Hev Ht; intros v1 Hv1T ? <-.
    apply (BMD _ _ _ Hv1T).

  Case "Fs_nil".
    apply (RLOk_Norm _ _ _ Hev BMDs_nil).

  Case "Fs_cons".
    assert (HF := IHF _ _ _ H2 HGg); clear IHF H2.
    assert (HFs := IHFs _ _ _ H4 HGg); clear IHFs H4.
    apply (let_ok_g Hev HF); clear Hev HF; intros b1 Hb1L er2 Hev2.
    apply (let_ok_g Hev2 HFs); clear Hev2 HFs; intros bs2 Hbs2t erf Hevf.
    apply (RLOk_Norm _ _ _ Hevf).
    apply (BMDs_cons _ _ _ _ Hb1L Hbs2t).
Qed.

(**  *** Proof of [evalF_is_sound] *)
(** This says that if [t] is well-typed, its evaluation will not get stuck. *)

Corollary evalF_is_sound:
  forall (t : tm) (G : context) (T : ty) (g : rctx) (n : nat),
    G |-- t \in T ->  g :::* G -> evalF t g n  <> efr_stuck.
Proof.
  introv Hty HGg.
  assert (Hr := evalF_is_sound_yielding_T _ _ _ _ Hty HGg n).
  destruct (evalF t g n); try discriminate.
     simpl in Hr; contradiction.
Qed.


From HoTT Require Export HoTT.
From HoTT Require Import Pointed HIT.Pushout.
Require Import Circ HitTactics.

(* TODO: rewrite this with pointed types *)
Section WedgeSum.
Context {A B : Type}.
Context (a : A).
Context (b : B).
Definition wedgesum :=
  @pushout Unit A B (fun _ => a) (fun _ => b).

Definition wedge_point_l : wedgesum := pushl tt.
Definition wedge_point_r : wedgesum := pushr tt.
Definition wedge_point_eq : wedge_point_l = wedge_point_r := pp tt.
Definition wedge_l : A -> wedgesum := push o inl.
Definition wedge_r : B -> wedgesum := push o inr.

Definition wedgesum_rec' (P : Type) (f : A -> P) (g : B -> P)
  (fg_eq : f a = g b) : wedgesum -> P.
Proof.
simple refine (pushout_rec _ _ _).
- apply (sum_ind (fun _ => P) f g).
- intros []. simpl. exact fg_eq.
Defined.

Definition wedgesum_rec (P : Type) (p : P) (f : A -> P) (g : B -> P)
  (f_eq : f a = p) (g_eq : g b = p) : wedgesum -> P.
Proof.
simple refine (pushout_rec _ _ _).
- apply (sum_ind (fun _ => P) f g).
- intros []. simpl. apply (f_eq @ g_eq^).
Defined.

End WedgeSum.

Module Export eight.
Private Inductive eight : Type0 :=
| base8 : eight.
Axiom loop1 : base8 = base8.
Axiom loop2 : base8 = base8.

Definition Eight_ind (P : eight -> Type) (b : P base8) (l1 : loop1 # b = b) (l2 : loop2 # b = b)
  : forall (x:eight), P x := fun x =>
  match x return (_ -> _ -> P x) with
  | base8 => fun _ _ => b
  end l1 l2.

Axiom Eight_ind_beta_loop1 : forall (P : eight -> Type) (b : P base8) (l1 : loop1 # b = b) (l2 : loop2 # b = b),
    apD (Eight_ind P b l1 l2) loop1 = l1.
Axiom Eight_ind_beta_loop2 : forall (P : eight -> Type) (b : P base8) (l1 : loop1 # b = b) (l2 : loop2 # b = b),
    apD (Eight_ind P b l1 l2) loop2 = l2.

Definition Eight_rec (P : Type) (b : P) (l1 l2 : b = b) :
  eight -> P.
Proof.
  refine (Eight_ind (fun _ => P) b _ _).
  refine (transport_const _ _ @ l1).
  refine (transport_const _ _ @ l2).
Defined.

Definition Eight_rec_beta_loop1 (P : Type) (b : P) (l1 l2 : b = b) :
  ap (Eight_rec P b l1 l2) loop1 = l1.
Proof.
  eapply (cancelL (transport_const loop1 _)).
  simple refine ((apD_const _ _)^ @ _).
  apply Eight_ind_beta_loop1.
Defined.

Definition Eight_rec_beta_loop2 (P : Type) (b : P) (l1 l2 : b = b) :
  ap (Eight_rec P b l1 l2) loop2 = l2.
Proof.
  eapply (cancelL (transport_const loop2 _)).
  simple refine ((apD_const _ _)^ @ _).
  apply Eight_ind_beta_loop2.
Defined.

End eight.

Instance Eight_recursion : HitRecursion eight := {
  indTy := _; recTy := _;
  H_inductor := Eight_ind; H_recursor := Eight_rec }.

(* Equivalence *)

Definition ate := wedgesum base base.

Definition a2e : ate -> eight.
Proof.
simple refine (wedgesum_rec' _ _ _ _ _ _).
- hrecursion.
  * exact base8.
  * exact loop1.
- hrecursion.
  * exact base8.
  * exact loop2.
- simpl. reflexivity.
Defined.

(* TODO: this should be encapsulated better *)
Definition e2a : eight -> ate.
Proof.
hrecursion.
- apply wedge_point_l.
- unfold wedge_point_l. unfold pushl. simple refine (ap (fun x => push (inl x)) _). apply loop.
- simple refine (pp _ @ _ @ (pp _)^). unfold pushr.
  simple refine (ap (fun x => push (inr x)) _). apply loop.
Defined.

Lemma eight_ate_eight :
  forall x : eight, a2e (e2a x) = x.
Proof.
hrecursion.
- reflexivity.
- rewrite (@transport_paths_FlFr _ _ _ idmap).
  hott_simpl.
  rewrite (ap_compose e2a a2e _).
  rewrite Eight_rec_beta_loop1.
  rewrite <- (ap_compose (fun x => push (inl x)) a2e). simpl.
  rewrite S1_rec_beta_loop. hott_simpl.
- rewrite (@transport_paths_FlFr _ _ _ idmap).
  hott_simpl.
  rewrite (ap_compose e2a a2e _).
  rewrite Eight_rec_beta_loop2.
  rewrite ?ap_pp, ap_V. rewrite pushout_rec_beta_pp. hott_simpl.
  rewrite <- (ap_compose (fun x => push (inr x)) a2e). simpl.
  rewrite S1_rec_beta_loop. hott_simpl.
Defined.

Lemma ate_eight_l :
  forall a : S1, e2a (a2e (push (inl a))) = push (inl a).
Proof.
hrecursion.
- reflexivity.
- rewrite transport_paths_FlFr. hott_simpl.
  rewrite ap_compose.
  rewrite S1_rec_beta_loop.
  rewrite Eight_rec_beta_loop1. hott_simpl.
Defined.

Lemma ate_eight_r :
  forall a : S1, e2a (a2e (push (inr a))) = push (inr a).
Proof.
hrecursion.
- refine (_ @ pp _). reflexivity.
- rewrite transport_paths_FlFr. hott_simpl.
  rewrite ?concat_pp_p.
  rewrite ap_compose.
  rewrite S1_rec_beta_loop.
  rewrite Eight_rec_beta_loop2.
  rewrite inv_pp. hott_simpl.
Defined.

Lemma ee : eight <~> ate.
Proof.
unshelve esplit.
- exact e2a.
- apply isequiv_biinv. unfold BiInv. split.
  + exists a2e. exact eight_ate_eight.
  + exists a2e. unfold Sect. simple refine (pushout_ind _ _ _ _ _); simpl.
    * simple refine (sum_ind _ _ _); simpl.
      { exact ate_eight_l. }
      { exact ate_eight_r. }
    * intros []; simpl.
      rewrite transport_paths_FlFr. hott_simpl.
      rewrite ap_compose.
      rewrite pushout_rec_beta_pp. hott_simpl.
Defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Finite_sets.
Require Export Constructive_sets.
Require Export Classical_Type.
Require Export Classical_sets.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Powerset_Classical_facts.
Require Export Gt.
Require Export Lt.
Require Export Le.
Require Export Finite_sets_facts.
Require Export Image.

Section Approx.
  Variable U : Type.

  Inductive Approximant (A X:Ensemble U) : Prop :=
    Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X.
End Approx.

Hint Resolve Defn_of_Approximant.

Section Infinite_sets.
  Variable U : Type.

  Lemma make_new_approximant :
    forall A X:Ensemble U,
      ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X).
  Proof.
    intros A X H' H'0.
    elim H'0; intros H'1 H'2.
    apply Strict_super_set_contains_new_element; auto with sets.
    red in |- *; intro H'3; apply H'.
    rewrite <- H'3; auto with sets.
  Qed.

  Lemma approximants_grow :
    forall A X:Ensemble U,
      ~ Finite U A ->
      forall n:nat,
	cardinal U X n ->
	Included U X A ->  exists Y : _, cardinal U Y (S n) /\ Included U Y A.
  Proof.
    intros A X H' n H'0; elim H'0; auto with sets.
    intro H'1.
    cut (Inhabited U (Setminus U A (Empty_set U))).
    intro H'2; elim H'2.
    intros x H'3.
    exists (Add U (Empty_set U) x); auto with sets.
    split.
    apply card_add; auto with sets.
    cut (In U A x).
    intro H'4; red in |- *; auto with sets.
    intros x0 H'5; elim H'5; auto with sets.
    intros x1 H'6; elim H'6; auto with sets.
    elim H'3; auto with sets.
    apply make_new_approximant; auto with sets.
    intros A0 n0 H'1 H'2 x H'3 H'5.
    lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets.
    intros x0 H'2; try assumption.
    elim H'2; intros H'7 H'8; try exact H'8; clear H'2.
    elim (make_new_approximant A x0); auto with sets.
    intros x1 H'2; try assumption.
    exists (Add U x0 x1); auto with sets.
    split.
    apply card_add; auto with sets.
    elim H'2; auto with sets.
    red in |- *.
    intros x2 H'9; elim H'9; auto with sets.
    intros x3 H'10; elim H'10; auto with sets.
    elim H'2; auto with sets.
    auto with sets.
    apply Defn_of_Approximant; auto with sets.
    apply cardinal_finite with (n := S n0); auto with sets.
  Qed.

  Lemma approximants_grow' :
    forall A X:Ensemble U,
      ~ Finite U A ->
      forall n:nat,
	cardinal U X n ->
	Approximant U A X ->
	exists Y : _, cardinal U Y (S n) /\ Approximant U A Y.
  Proof.
    intros A X H' n H'0 H'1; try assumption.
    elim H'1.
    intros H'2 H'3.
    elimtype (exists Y : _, cardinal U Y (S n) /\ Included U Y A).
    intros x H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
    exists x; auto with sets.
    split; [ auto with sets | idtac ].
    apply Defn_of_Approximant; auto with sets.
    apply cardinal_finite with (n := S n); auto with sets.
    apply approximants_grow with (X := X); auto with sets.
  Qed.

  Lemma approximant_can_be_any_size :
    forall A X:Ensemble U,
      ~ Finite U A ->
      forall n:nat,  exists Y : _, cardinal U Y n /\ Approximant U A Y.
  Proof.
    intros A H' H'0 n; elim n.
    exists (Empty_set U); auto with sets.
    intros n0 H'1; elim H'1.
    intros x H'2.
    apply approximants_grow' with (X := x); tauto.
  Qed.

  Variable V : Type.

  Theorem Image_set_continuous :
    forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
      Finite V X ->
      Included V X (Im U V A f) ->
      exists n : _,
	(exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X).
  Proof.
    intros A f X H'; elim H'.
    intro H'0; exists 0.
    exists (Empty_set U); auto with sets.
    intros A0 H'0 H'1 x H'2 H'3; try assumption.
    lapply H'1;
      [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ];
      auto with sets.
    intros x0 H'1; try assumption.
    exists (S n); try assumption.
    elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6;
      clear H'4 H'1.
    clear E.
    generalize H'2.
    rewrite <- H'5.
    intro H'1; try assumption.
    red in H'3.
    generalize (H'3 x).
    intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ];
      auto with sets.
    specialize Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x);
      intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ];
	auto with sets.
    intros x1 H'4; try assumption.
    apply ex_intro with (x := Add U x0 x1).
    split; [ split; [ try assumption | idtac ] | idtac ].
    apply card_add; auto with sets.
    red in |- *; intro H'9; try exact H'9.
    apply H'1.
    elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets.
    elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets.
    red in |- *; auto with sets.
    intros x2 H'4; elim H'4; auto with sets.
    intros x3 H'11; elim H'11; auto with sets.
    elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets.
    apply Im_add; auto with sets.
  Qed.

  Theorem Image_set_continuous' :
    forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
      Approximant V (Im U V A f) X ->
      exists Y : _, Approximant U A Y /\ Im U V Y f = X.
  Proof.
    intros A f X H'; try assumption.
    cut
      (exists n : _,
	(exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)).
    intro H'0; elim H'0; intros n E; elim E; clear H'0.
    intros x H'0; try assumption.
    elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3;
      clear H'1 H'0; auto with sets.
    exists x.
    split; [ idtac | try assumption ].
    apply Defn_of_Approximant; auto with sets.
    apply cardinal_finite with (n := n); auto with sets.
    apply Image_set_continuous; auto with sets.
    elim H'; auto with sets.
    elim H'; auto with sets.
  Qed.

  Theorem Pigeonhole_bis :
    forall (A:Ensemble U) (f:U -> V),
      ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f.
  Proof.
    intros A f H'0 H'1; try assumption.
    elim (Image_set_continuous' A f (Im U V A f)); auto with sets.
    intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
    elim (make_new_approximant A x); auto with sets.
    intros x0 H'2; elim H'2.
    intros H'5 H'6.
    elim (finite_cardinal V (Im U V A f)); auto with sets.
    intros n E.
    elim (finite_cardinal U x); auto with sets.
    intros n0 E0.
    apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n).
    apply card_add; auto with sets.
    rewrite (Im_add U V x x0 f); auto with sets.
    cut (In V (Im U V x f) (f x0)).
    intro H'8.
    rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets.
    rewrite H'4; auto with sets.
    elim (Extension V (Im U V x f) (Im U V A f)); auto with sets.
    apply le_lt_n_Sm.
    apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f);
      auto with sets.
    rewrite H'4; auto with sets.
    elim H'3; auto with sets.
  Qed.

  Theorem Pigeonhole_ter :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      injective U V f -> Finite V (Im U V A f) -> Finite U A.
  Proof.
    intros A f H' H'0 H'1.
    apply NNPP.
    red in |- *; intro H'2.
    elim (Pigeonhole_bis A f); auto with sets.
  Qed.

End Infinite_sets.