Require Import CoqlibC.

Set Implicit Arguments.

Class Linker (A: Type) := {
  link: A -> A -> option A;
  linkorder: A -> A -> Prop;
  linkorder_refl: forall x, linkorder x x;
  linkorder_trans: forall x y z, linkorder x y -> linkorder y z -> linkorder x z;
  link_linkorder: forall x y z, link x y = Some z -> linkorder x z /\ linkorder y z
}.

Inductive link_res (A: Type): Type :=
| empty
| fail
| success: A -> link_res A.

Arguments empty [A].
Arguments fail [A].

Fixpoint link_list_aux X `{Linker X} (xs: list X): link_res X :=
  match xs with
  | [] => empty
  | x0 :: tl =>
    match link_list_aux tl with
    | empty => success x0
    | fail => fail
    | success x1 =>
      match link x0 x1 with
      | Some x => success x
      | None => fail
      end
    end
  end.

Definition link_list X `{Linker X} (xs: list X): option X :=
  match link_list_aux xs with
  | empty => None (* Note that we are not giving semantics to empty programs. *)
  | success x => Some x
  | fail => None
  end.

Lemma link_list_cons
      X `{Linker X} hd tl restl res
      (TL: link_list tl = Some restl)
      (HD: link hd restl = Some res):
    <<LINK: link_list (hd :: tl) = Some res>> /\ <<LINKORDER: Forall (fun x => linkorder x res) (hd :: tl)>>.
Proof.
  split; red.
  - unfold link_list in *. des_ifs; ss; des_ifs.
  - eapply link_linkorder in HD. des. econs; auto. clear HD. unfold link_list in TL. des_ifs.
    generalize dependent restl. generalize dependent res.
    induction tl as [|h l]; auto. i. econs; unfold link_list_aux in *; des_ifs.
    { eapply link_linkorder in Heq1. des. eapply linkorder_trans; eauto. }
    { destruct l; auto. des_ifs. }
    eapply IHl; eauto. eapply link_linkorder in Heq1. des. eapply linkorder_trans; eauto.
Qed.

Lemma link_list_linkorder
      X `{Linker X} xs xs_res
      (LINK: link_list xs = Some xs_res):
    <<LINKORDER: Forall (fun x => linkorder x xs_res) xs>>.
Proof.
  destruct xs as [| hd tl]; auto.
  unfold link_list in LINK. des_ifs. unfold link_list_aux in Heq. des_ifs; fold link_list_aux in *.
  { destruct tl; ss. econs. apply linkorder_refl. econs. des_ifs. }
  econs. { eapply link_linkorder in Heq1. des. auto. }
  assert (link_list tl = Some x).
  { unfold link_list. rewrite Heq0. auto. }
  exploit link_list_cons; eauto. i. des.
  inv LINKORDER. auto.
Qed.

Lemma link_list_cons_inv
      X `{Linker X} hd tl res
      (LINK: link_list (hd :: tl) = Some res)
      (LEN: tl <> []):
    exists restl, <<TL: link_list tl = Some restl>> /\ <<HD: link hd restl = Some res>>.
Proof.
  unfold link_list in LINK. des_ifs. unfold link_list_aux in Heq. des_ifs; fold link_list_aux in *.
  { destruct tl; ss. econs. des_ifs. }
  exists x. split; auto. unfold link_list. rewrite Heq0. auto.
  Unshelve. auto.
Qed.


Require Import
  HoTT.HProp
  HoTT.Types
  HoTT.Classes.theory.ua_homomorphism.

Import algebra_notations ne_list.notations.

Section closed_under_op.
  Context `{Funext} {σ} (A : Algebra σ) (P : ∀ s, A s → Type).

  (** Let [α : A s1 → A s2 → ... → A sn → A t] be an algebra
      operation. Then [P] satisfies [ClosedUnderOp α] iff
      for [x1 : A s1], [x2 : A s2], ..., [xn : A sn],

    <<
      P s1 x1 ∧ P s2 x2 ∧ ... ∧ P sn xn
    >>

    implies

    <<
      P t (α x1 x2 ... xn)
    >>
  *)

  Fixpoint ClosedUnderOp {w : SymbolType σ} : Operation A w → Type :=
    match w with
    | [:s:] => P s
    | s ::: w' => λ (α : A s → Operation A w'),
                    ∀ (x : A s), P s x → ClosedUnderOp (α x)
    end.

  Global Instance trunc_closed_under_op {n} `{∀ s x, IsTrunc n (P s x)}
    {w : SymbolType σ} (α : Operation A w)
    : IsTrunc n (ClosedUnderOp α).
  Proof.
    induction w; cbn; exact _.
  Qed.

  Definition IsClosedUnderOps : Type
    := ∀ (u : Symbol σ), ClosedUnderOp u.#A.

  Global Instance trunc_is_closed_under_ops
    {n} `{∀ s x, IsTrunc n (P s x)}
    : IsTrunc n IsClosedUnderOps.
  Proof.
    apply istrunc_forall.
  Qed.
End closed_under_op.

(** [P : ∀ s, A s → Type] is a subalgebra predicate if it is closed
    under operations [IsClosedUnderOps A P] and [P s x] is an h-prop. *)

Section subalgebra_predicate.
  Context  {σ} (A : Algebra σ) (P : ∀ s, A s → Type).

  Class IsSubalgebraPredicate
    := BuildIsSubalgebraPredicate
    { hprop_subalgebra_predicate : ∀ s x, IsHProp (P s x);
      is_closed_under_ops_subalgebra_predicate : IsClosedUnderOps A P }.

  Global Instance hprop_is_subalgebra_predicate `{Funext}
    : IsHProp IsSubalgebraPredicate.
  Proof.
    apply hprop_allpath.
    intros [x1 x2] [y1 y2].
    by destruct (path_ishprop x1 y1), (path_ishprop x2 y2).
  Defined.
End subalgebra_predicate.

Global Arguments BuildIsSubalgebraPredicate {σ A P hprop_subalgebra_predicate}.

Global Existing Instance hprop_subalgebra_predicate.

(** The next section defines subalgebra. *)

Section subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}.

(** The subalgebra carriers is the family of subtypes defined by [P]. *)

  Definition carriers_subalgebra : Carriers σ
    := λ (s : Sort σ), {x | P s x}.

(** Let [α : A s1 → ... → A sn → A t] be an operation and let [C :
    ClosedUnderOp A P α]. The corresponding subalgebra operation
    [op_subalgebra α C : (A&P) s1 → ... → (A&P) sn → (A&P) t] is
    given by

    <<
      op_subalgebra α C (x1; p1) ... (xn; pn) =
        (α x1 ... xn; C x1 p1 x2 p2 ... xn pn).
    >>
*)

  Fixpoint op_subalgebra {w : SymbolType σ}
    : ∀ (α : Operation A w),
      ClosedUnderOp A P α → Operation carriers_subalgebra w
    := match w with
       | [:t:] => λ α c, (α; c)
       | s ::: w' => λ α c x, op_subalgebra (α x.1) (c x.1 x.2)
       end.

(** The subalgebra operations [ops_subalgebra] are defined in terms of
    [op_subalgebra]. *)

  Definition ops_subalgebra (u : Symbol σ)
    : Operation carriers_subalgebra (σ u)
    := op_subalgebra u.#A (is_closed_under_ops_subalgebra_predicate A P u).

  Definition Subalgebra : Algebra σ
    := BuildAlgebra carriers_subalgebra ops_subalgebra.

  Global Instance trunc_subalgebra {n : trunc_index}
    `{!IsTruncAlgebra n.+1 A}
    : IsTruncAlgebra n.+1 Subalgebra.
  Proof.
    pose proof (hprop_subalgebra_predicate A P).
    intro s. apply @istrunc_sigma.
    - exact _.
    - intro. induction n; exact _.
  Qed.
End subalgebra.

Module subalgebra_notations.

  Notation "A && P" := (Subalgebra A P) : Algebra_scope.

End subalgebra_notations.

Import subalgebra_notations.

(** The following section defines the inclusion homomorphism
    [Homomorphism (A&P) A], and some related results. *)

Section hom_inc_subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}.

  Definition def_inc_subalgebra (s : Sort σ) : (A&&P) s → A s
    := pr1.

  Lemma oppreserving_inc_subalgebra {w : SymbolType σ}
    (α : Operation A w) (C : ClosedUnderOp A P α)
    : OpPreserving def_inc_subalgebra (op_subalgebra A P α C) α.
  Proof.
    induction w.
    - reflexivity.
    - intros x. apply IHw.
  Defined.

  Global Instance is_homomorphism_inc_subalgebra
    : IsHomomorphism def_inc_subalgebra.
  Proof.
    intro u. apply oppreserving_inc_subalgebra.
  Defined.

  Definition hom_inc_subalgebra : Homomorphism (A&&P) A
    := BuildHomomorphism def_inc_subalgebra.

  Lemma is_isomorphism_inc_improper_subalgebra
    (improper : ∀ s (x : A s), P s x)
    : IsIsomorphism hom_inc_subalgebra.
  Proof.
    intro s.
    refine (isequiv_adjointify _ (λ x, (x; improper s x)) _ _).
    - intro x. reflexivity.
    - intro x. by apply path_sigma_hprop.
  Qed.
End hom_inc_subalgebra.

(** The next section provides paths between subalgebras. These paths
    are convenient to have because the implicit type-class argument
    [IsClosedUnderOps] of [Subalgebra] is complicating things. *)

Section path_subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) {CP : IsSubalgebraPredicate A P}
    (Q : ∀ s, A s → Type) {CQ : IsSubalgebraPredicate A Q}.

  Lemma path_subalgebra `{Funext} (p : P = Q) : A&&P = A&&Q.
  Proof.
    by destruct p, (path_ishprop CP CQ).
  Defined.

  Lemma path_subalgebra_iff `{Univalence} (R : ∀ s x, P s x <-> Q s x)
    : A&&P = A&&Q.
  Proof.
    apply path_subalgebra.
    funext s x.
    apply (@path_universe _ _ _ (fst (R s x))).
    apply (equiv_equiv_iff_hprop _ _ (R s x)).
  Defined.
End path_subalgebra.


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 O A B T : Universe, ((wd_ A B /\ (wd_ T A /\ (wd_ T B /\ (wd_ O A /\ (wd_ O B /\ (col_ O A T /\ col_ A T B)))))) -> col_ O A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e206m5_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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 O E Eprime B C : Universe, ((wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E O /\ (col_ O E B /\ (col_ O E C /\ col_ O E O))))))) -> col_ O C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj3_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 lv2) lv3) ->  (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (plus lv1 (Succ Zero)))).
Admitted.
QuickChick conj18synthconj3_hyp.


(************************************************************************)
(* Copyright (c) 2022, Gergei Bana, Qianli Zhang                        *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(*                                                                      *)
(* Special thanks to Dr. Eeralla                                        *)
(************************************************************************)

Require Import Coq.micromega.Lia.
Require Export axioms.
Import ListNotations.
Require Export Coq.Arith.PeanoNat.

(*  *)
Proposition cca2 : CCA2L Len Enc Dec Pkey Skey Rand Error.
Proof.
  pose cca_2.
  apply CCA2toCCA2L in c.
  auto.
  all : apply O.
Qed.

(*  *)
Lemma decGame: forall m r c,
(*-----------------------------------*)
    (decS c) = If (c ≟ (❴m❵_pkS ＾ (Rand [nonce r]))) Then m Else (decS c).
Proof.
  intros.
  rewrite <- (@If_same (c ≟ (❴m❵_pkS ＾ (Rand [nonce r]))) c) at 1.
  rewrite (@Eq_branch (c) (❴m❵_pkS ＾ (Rand [nonce r]))  (fun x => x) _ ).
  rewrite (@If_morph (fun x => decS x) (c ≟ (❴m❵_pkS ＾ (Rand [nonce r]))) _ _ ).
  rewrite decenc.
  reflexivity.
  all : ProveContext.
Qed.

Lemma decIfThenElse: forall m r c,
(*-----------------------------------*)
    (decS c)
    =
    If (c ≟ (❴m❵_pkS ＾ (Rand [nonce r])))
       Then m
       Else (If (c ≟ (❴m❵_pkS ＾ (Rand [nonce r])))
                Then Error
                Else decS c).
Proof.
  intros.
  rewrite (@If_eval (fun _ => _) (fun b => If b Then Error Else _) (c ≟ (❴m❵_pkS ＾ (Rand [nonce r])))).
  rewrite If_false.
  rewrite <- decGame.
  reflexivity.
  all: ProveboolandContext.
Qed.

Lemma decSimpl: forall {b m c error }, bppt b ->
(*-----------------------------------*)
    (If b
       Then m
       Else If b Then error Else c)
    =
    (If b Then m Else c).
Proof.
  intros.
  rewrite (@If_eval (fun _ => _) (fun x => If x Then error Else c) ).
  rewrite If_false.
  reflexivity.
  all: ProveboolandContext.
Qed.

(***************************************************************************************************)
(***************************************************************************************************)
(****************************          Axioms.v        *****************************************)
(***************************************************************************************************)
(***************************************************************************************************)

(*  *)

Proposition frccCont : forall n f t0, Freshc n t0 -> Freshc n f -> Freshc n (fun x : list ppt => t0 (f x)).
Proof.
  intros.
  apply (Freshc_mut (fun n tl =>  Freshc n f -> Freshc n (fun x : list ppt => tl (f x)))
           (fun n t  =>  Freshc n f -> FreshTermc n (fun x : list ppt => t (f x)))); intros; simpl; try ProveFreshC.
  - apply frcApp; auto.
  - apply frcFAdv; auto.
  - apply frcFAdv; auto.
Qed.

(*  *)
Proposition CompHidEx : forall t0 t1 t2 n1 n2,
    ( | t1 | = | t2 | ) ->
    n1 <> n2 ->
  Fresh (nonce n1) [t1; t2] -> Freshc (nonce n1) t0 ->
  Fresh (nonce n2) [t1; t2] -> Freshc (nonce n2) t0 ->
  t0 [(com t1 (Comk (nonce n1))); (com t2 (Comk (nonce n2)))]
 ~
  t0 [(com t2 (Comk (nonce n1))); (com t1 (Comk (nonce n2)))].
Proof.
  intros.
  pose (CompHid (fun x => t0 [Proj1 x ; Proj2 x] ) ⫠ t1 t2 n1 n2) as c.
  apply ceq_eq in H. unfold CompHid_prop in c. simpl in c. rewrite H in c. rewrite If_true in c.
  rewrite If_true in c. rewrite proj1pair in c. rewrite proj2pair in c.
  rewrite proj1pair in c. rewrite proj2pair in c.
  apply c. assumption. all: ProveFresh.
  apply (frccCont (nonce (n1)) (fun x => [Proj1 x; Proj2 x]) t0); auto. ProveFreshC.
  apply (frccCont (nonce (n2)) (fun x => [Proj1 x; Proj2 x]) t0); auto. ProveFreshC.
Qed.

(***************************************************************************************************)
(***************************************************************************************************)
(*********************************          Ltacs.v        *****************************************)
(***************************************************************************************************)
(***************************************************************************************************)

Ltac ProveFreshC_prop11 :=
  repeat
   ( auto;
     match goal with
     | |- ?c1 <<< ?c2 => ProveHag; auto
     | |- PPT ?hag ?f => ProvePPT; auto
     | |- Context ?hag ?tol ?f => ProveContext; auto
     | |- ContextTerm ?hag ?tol ?f => ProveContext; auto
     | |- Fresh _ _ => ProveFresh; auto
     | |- FreshTerm _ _ => ProveFresh; auto

     | |- Freshc _  (fun _ => []) => apply frcnil
     | |- Freshc _  (fun _ => _ :: _ ) => apply frcConc

     | |- FreshTermc _  (fun _ => nonce _ ) => apply frtcNN; lia
     | |- FreshTermc _  (fun _ => ConstInt ?f ?g ) => try (apply frtcCAdv; ProveContext)
     | |- FreshTermc _  ( Nth _ )=> try (apply frtcCAdv; ProveContext)

     | |- FreshTermc _  (fun _ => ?f _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _ _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _ _ _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _ _ _ _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
     | |- FreshTermc _  (fun _ => ?f _ _ _ _ _ _ _)=> first [apply frtcFAdv; ProveContext | unfold f]
 (*     | |- FreshTermc _  ?c => first [apply frtcCAdv; ProveContext | unfold c]  *)

     | |- Freshc _  (fun x => x)  => apply frcCAdv; ProveContext
     end).

(***************************************************************************************************)
(***************************************************************************************************)
(************************          Prop11.v        ************************************)
(***************************************************************************************************)
(***************************************************************************************************)

(* NonceListNewFresh states that, for any Nonce List {lx} with a nonce {nonce n} that is fresh in it,
   we can always find another nonce {nonce n'} that  n ≠ n' and nonce n' is also fresh in lx. *)

Proposition NonceListNewFresh:
  forall lx n, NonceList lx -> Fresh nonce (n) lx -> exists n', n <> n' /\ Fresh nonce (n') lx.
Proof.
  intros.
  apply (nlN (nonce (n)) lx) in H.
  apply FreshExists in H.
  inversion H.
  inversion_clear H1.
  apply invfrtNN in H2.
  exists x.
  split.
  - lia.
  - auto.
  - unfold Nonce. exists n. auto.
Qed.

(* FreshNewFresh states that, if a nonce {nonce n} is fresh in a list of terms {lx},
   Then we can always find another nonce {nonce n'} that n ≠ n' and nonce n' is also fresh in lx. *)

Proposition FreshNewFresh:
  forall lx n, Fresh nonce (n) lx -> exists n', n <> n' /\ Fresh nonce (n') lx.
Proof.
  intros.
  apply FreshfromNonceList  in H.
  destruct H as [f [lx0 [cnxt [nl [fresh]]]]].
  apply (NonceListNewFresh lx0 n nl) in fresh.
  destruct fresh.
  destruct H0.
  exists x.
  split; auto.
  rewrite H.
  apply (FreshfromNonceList (nonce x) (f lx0)).
  exists f. exists lx0.
  split; auto.
Qed.

(* FreshFreshNewFresh states that, if a nonce {nonce n} is fresh in both term list lx0 and lx1,
   Then we can always find a new nonce {nonce n'} that n ≠ n' and nonce n' is also fresh in lx0 and lx1 *)

Proposition FreshFreshNewFresh:
  forall lx0 lx1 n, Fresh nonce (n) lx0 -> Fresh nonce (n) lx1 ->
   exists n', n <> n' /\ Fresh nonce (n') lx0 /\ Fresh nonce (n') lx1.
Proof.
  intros.
  assert (Fresh (nonce n) (lx0 ++ lx1)).
    apply frlConc; auto.
  apply FreshNewFresh in H1.
  destruct H1.
  destruct H1.
  exists x.
  split.
  - auto.
  - apply invfrlConc in H2. destruct H2.
    split; auto.
Qed.

(* FreshFreshcNewFresh states that, if nonce {nonce n} is fresh in term t and ContextTerm t1,
   then we can always find a new nonce {nonce n'} that n ≠ n' and nonce n' is also fresh in t and t1 *)

Proposition FreshFreshcNewFresh: forall n t t1,
  FreshTerm (nonce n) t ->   FreshTermcTerm (nonce n) t1 ->
  exists n', n' <> n  /\ FreshTerm  (nonce n') t /\  FreshTermcTerm (nonce n') t1.
Proof.
  intros n t t1 H0 H1.
  apply FreshTermfromNonceList in H0.
  destruct H0 as [f0 [lx0 [Cntx0 [Nl0 [Fresh0 H0]]]]].
  apply FreshTermcTermfromNonceList in H1.
  destruct H1 as [f1 [lx1 [Cntx1 [Nl1 [Fresh1 H1]]]]].
  apply (FreshFreshNewFresh lx0 lx1 n Fresh0) in Fresh1.
  destruct Fresh1 as [x [neq [Freshx0 Freshx1]]].
  exists x.
  split; auto.
  split.
  - rewrite H0. apply (FreshTermfromNonceList (nonce x) (f0 lx0)).
    exists f0. exists lx0.
    split; auto.
  - rewrite H1. apply (FreshTermcTermfromNonceList (nonce x) (fun x0 : ppt => f1 (x0 :: lx1))).
    exists f1. exists lx1.
    split; auto.
Qed.

(*  *)

Proposition Fresh2Freshc : forall n t,
  FreshTerm nonce (n) t -> FreshTermc nonce (n) (fun _ : list ppt => t).
Proof.
  intros.
  apply FreshTermfromNonceList in H.
  destruct H as [f [lx [cnxt [nl [fresh ]]]]].
  apply FreshTermcfromNonceList.
  rewrite H.
  exists (fun x => f (firstn (length lx) x)). exists lx.
  split; auto. ProveContext.
  split; auto.
  split; auto.
  assert ((fun x => f (firstn (length lx) (lx ++ x))) = (fun _ => f lx)).
    apply functional_extensionality.
    intros. rewrite firstn_app_exact.
    reflexivity.
    rewrite H0; clear H0.
    reflexivity.
Qed.

(*  *)

Proposition frtcCont: forall n f t0,
    FreshTermc (nonce n) t0 -> Freshc (nonce n) f -> FreshTermc (nonce n) (fun x : list ppt => t0 (f x)).
Proof.
  intros.
  apply frcConc with (tc := fun lx => []) in H.
  apply (frccCont (nonce n) f) in H.
  apply frtcFAdv with (t := fun lx => Nth 0 lx) in H.
  unfold Nth in H; simpl in H.
  all : auto.
  ProveContext.
  ProveFreshC_prop11.
Qed.

(*  *)

Proposition frfrtcCont: forall n f t0,
    FreshTermcTerm n t0 -> FreshTermc n f -> FreshTermc n (fun x : list ppt => t0 (f x)).
Proof.
  intros.
  apply (FreshTermcTerm_mut (fun nc t => nc = n -> Freshc nc (fun x : list ppt => t (f x)))
                            (fun nc t => nc = n -> FreshTermc nc (fun x : list ppt => t (f x)))); intros; ProveFreshC_prop11. (* we need to add nc = n as an assumption *)
  - assert (Nonce nc).
    apply (FreshTermcTermNonce) with (t := t). auto.
    inversion_clear H6.
    rewrite <- H7 in *.
    apply (frcConc x (fun x => t (f x)) (fun x => tc (f x))); auto.
  - assert (Nonce nc). apply FreshcTermNonce with (tl := tc1). auto.
    inversion_clear H6.
    rewrite <- H7 in *.
    apply (frcApp x (fun x0 : list ppt => tc1 (f x0)) (fun x0 : list ppt => tc2 (f x0))); auto.
  - assert (Nonce nc). apply FreshcTermNonce with (tl := tc). auto.
    inversion_clear H5.
    rewrite <- H6 in *.
    apply frcFAdv; auto.
  - assert (Nonce nc). apply FreshcTermNonce with (tl := tc). auto.
    inversion_clear H5.
    rewrite <- H6 in *.
    apply frtcFAdv; auto.
  - pose (frtcFAdv n0 (fun lx => t (Nth 0 lx)) (fun lx => [f lx])) as c. unfold Nth in c; simpl in c.
    apply c.
    assert ((fun lx : list ppt => t (nth 0 lx default)) = (fun lx : list ppt => t (Nth 0 lx))).
      apply functional_extensionality. intros. reflexivity.
    rewrite H3. clear H3.
    ProveContext.
    rewrite <- H2 in H0.
    ProveFreshC_prop11.
Qed.

(***************************************************************************************************)
(***************************************************************************************************)
(****************************          Lemma_21.v        *****************************************)
(***************************************************************************************************)
(***************************************************************************************************)

(* Not in the paper *)
Lemma AndGuard2 : forall {b1 b2 c} c' {d}, bppt b1 -> bppt b2 ->
    If (b1 & b2) Then c Else d = If (b1 & b2) Then (If b1 Then c Else c') Else d.
Proof.
  intros.
  rewrite (@If_morph (fun x => If x Then (If b1 Then c Else c') Else d)).
  rewrite (@If_eval (fun b1 => If b2 Then If b1 Then c Else c' Else d ) (fun _ => _)).
  rewrite (@If_morph (fun x => If x Then _ Else d)).
  rewrite If_true.
  repeat rewrite If_false.
  reflexivity.
  all : ProveContext.
Qed.

(***************************************************************************************************)
(***************************************************************************************************)
(****************************          Lemma_25.v        *****************************************)
(***************************************************************************************************)
(***************************************************************************************************)

Lemma c0EqVot : forall s, (com (vot s) kc0) = c0 s.
Proof.
  destruct s; reflexivity.
Qed.

(***************************************************************************************************)
(***************************************************************************************************)
(****************************          Lemma_26_A.v        *****************************************)
(***************************************************************************************************)
(***************************************************************************************************)

(* Properties of Dv *)

Lemma dv_perm12:
  forall v1 v2 v3 y,
    dv v1 v2 v3 y = dv v2 v1 v3 y.
Proof.
  { intros. unfold dv, dist.
    rewrite Example7_6.
    rewrite (AndComm (! (v1 ≟ v3)) (! (v2 ≟ v3))).
    unfold pchkv.
    repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri.
    rewrite <- (AndAsso (ph2 ≟ (π2 v1))).
    rewrite <- (AndAsso (ph2 ≟ (π2 v2))).
    rewrite (AndComm ((ph2 ≟ (π2 v1)))).
    reflexivity. all : Provebool. }
Qed.

(* Properties of Dist check *)
Lemma dist_swap12: forall m1 m2 m3, dist m1 m2 m3 = dist m2 m1 m3.
  { intros. unfold dist. rewrite (Example7_6 m1 m2). rewrite (AndComm (! (m1 ≟ m3)) (! (m2 ≟ m3))). reflexivity. all : Provebool. }
Qed.

Lemma dist_swap13: forall m1 m2 m3, dist m1 m2 m3 = dist m3 m2 m1.
  { intros. unfold dist. rewrite (Example7_6 m2 m1). rewrite (Example7_6 m3 m1). rewrite (Example7_6 m3 m2). rewrite (AndComm (! (m1 ≟ m3)) (! (m2 ≟ m3))).
    rewrite <- AndAsso. rewrite (AndComm (! (m1 ≟ m2)) (! (m2 ≟ m3))). rewrite AndAsso. rewrite (AndComm (! (m1 ≟ m2)) (! (m1 ≟ m3))). reflexivity. all : Provebool. }
Qed.

Lemma dist_swap23: forall m1 m2 m3, dist m1 m2 m3 = dist m1 m3 m2.
  { intros. unfold dist. rewrite (Example7_6 m3 m2). rewrite <- AndAsso. rewrite (AndComm (! (m1 ≟ m2)) (! (m1 ≟ m3))). rewrite AndAsso. reflexivity. all : Provebool. }
Qed.

(* Properties of Pchko *)
Lemma pchko_swap12: forall m1 m2 m3, pchko (＜ m1, m2, m3 ＞) = pchko (＜ m2, m1, m3 ＞).
  { intros. unfold pchko. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. rewrite <- AndAsso. rewrite (AndComm (ph3 ≟ (π2 m1)) (ph3 ≟ (π2 m2))). rewrite AndAsso. reflexivity. all : Provebool. }
Qed.

Lemma pchko_swap13: forall m1 m2 m3, pchko (＜ m1, m2, m3 ＞) = pchko (＜ m3, m2, m1 ＞).
  { intros. unfold pchko. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. rewrite (AndComm (ph3 ≟ (π2 m3)) ((ph3 ≟ (π2 m2)) & (ph3 ≟ (π2 m1)))).
    rewrite (AndComm (ph3 ≟ (π2 m2)) (ph3 ≟ (π2 m1))). rewrite AndAsso. reflexivity. all : Provebool. }
Qed.

Lemma pchko_swap23: forall m1 m2 m3, pchko (＜ m1, m2, m3 ＞) = pchko (＜ m1, m3, m2 ＞).
  { intros. unfold pchko. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. rewrite (AndComm (ph3 ≟ (π2 m3)) (ph3 ≟ (π2 m2))). reflexivity. all : Provebool.  }
Qed.

(* Properties of isinkc *)
Lemma isinkc_kc_swap: forall m1 m2 m3, isinkc kc0 kc1 (＜ π2 (π1 m1), π2 (π1 m2), π2 (π1 m3) ＞) = isinkc kc1 kc0 (＜ π2 (π1 m1), π2 (π1 m2), π2 (π1 m3) ＞).
  { intros.
    unfold isinkc. unfold isin. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri.
    rewrite xnor_comm.
    reflexivity. all : Provebool. }
Qed.

Lemma isinkc_swap12: forall m1 m2 m3, isinkc kc0 kc1 (＜ π2 (π1 m1), π2 (π1 m2), π2 (π1 m3) ＞) = isinkc kc0 kc1 (＜ π2 (π1 m2), π2 (π1 m1), π2 (π1 m3) ＞).
  { intros. unfold isinkc. unfold isin. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. repeat rewrite OrAsso. rewrite (OrComm (kc0 ≟ (π2 (π1 m1))) _).
    rewrite (OrComm (kc1 ≟ (π2 (π1 m1))) _). reflexivity. all : Provebool. }
Qed.

Lemma isinkc_swap13: forall m1 m2 m3, isinkc kc0 kc1 (＜ π2 (π1 m1), π2 (π1 m2), π2 (π1 m3) ＞) = isinkc kc0 kc1 (＜ π2 (π1 m3), π2 (π1 m2), π2 (π1 m1) ＞).
 { intros. unfold isinkc. unfold isin. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. rewrite (OrComm (kc0 ≟ (π2 (π1 m1))) _). rewrite (OrComm (kc1 ≟ (π2 (π1 m1))) _).
   repeat rewrite OrAsso.  rewrite (OrComm (kc0 ≟ (π2 (π1 m2))) _). rewrite (OrComm (kc1 ≟ (π2 (π1 m2))) _). reflexivity. all : Provebool. }
Qed.

Lemma isinkc_swap23: forall m1 m2 m3, isinkc kc0 kc1 (＜ π2 (π1 m1), π2 (π1 m2), π2 (π1 m3) ＞) = isinkc kc0 kc1 (＜ π2 (π1 m1), π2 (π1 m3), π2 (π1 m2) ＞).
 { intros. unfold isinkc. unfold isin. repeat rewrite Tau1Tri, Tau2Tri, Tau3Tri. rewrite (OrComm (kc0 ≟ (π2 (π1 m2))) _). rewrite (OrComm (kc1 ≟ (π2 (π1 m2))) _). reflexivity. all : Provebool. }
Qed.

(**)

(**)

(* Properties of Do *)

Lemma Do_swap12: forall m1 m2 m3, Do m1 m2 m3 = Do m2 m1 m3.
Proof.
{ intros. unfold Do. rewrite dist_swap12, pchko_swap12, isinkc_swap12, shufl_perm12. reflexivity. }
Qed.

Lemma Do_swap13: forall m1 m2 m3, Do m1 m2 m3 = Do m3 m2 m1.
Proof.
  { intros. unfold Do. rewrite dist_swap13, pchko_swap13, isinkc_swap13, shufl_perm13.
    reflexivity. }
Qed.

Lemma Do_swap23: forall m1 m2 m3, Do m1 m2 m3 = Do m1 m3 m2.
Proof.
  { intros. unfold Do. rewrite dist_swap23, pchko_swap23, isinkc_swap23, shufl_perm23.
    reflexivity. }
Qed.

Lemma Do_dist12: forall m1 m2, Do m1 m1 m2 = ⫠.
Proof.
  { intros. unfold Do, dist. rewrite ceqeq. rewrite If_true. repeat rewrite If_false.
    reflexivity. }
Qed.

Lemma Do_dist13: forall m1 m2, Do m1 m2 m1 = ⫠.
Proof.
  { intros. unfold Do, dist. rewrite ceqeq. rewrite If_true. rewrite If_false. rewrite If_same. repeat rewrite If_false.
    reflexivity. }
Qed.

Lemma Do_dist23: forall m1 m2, Do m2 m1 m1 = ⫠.
Proof.
  { intros. unfold Do, dist. rewrite ceqeq. rewrite If_true. repeat rewrite If_same. repeat rewrite If_false.
    reflexivity. }
Qed.


Require Import POCS.

Module Vars.

  Inductive var :=
  | VarCount
  | VarSum.

  Inductive Op : Type -> Type :=
  | Read (v : var) : Op nat
  | Write (v : var) (val : nat) : Op unit.

  (** The state the program manipulates as it executes. *)
  Record State := mkState {
    StateCount : nat;
    StateSum : nat;
  }.

  Instance var_dec : EqualDec var.
    unfold EqualDec; intros.
    destruct x; destruct y;
      try (left; congruence);
      try (right; congruence).
  Defined.

  (* help out type inference *)
  Implicit Type (state:State).

  Inductive op_step : forall `(op: Op T), Semantics State T :=
  | step_read_count : forall r state,
      StateCount state = r ->
      op_step (Read VarCount) state r state
  | step_read_sum : forall r state,
      StateSum state = r ->
      op_step (Read VarSum) state r state
  | step_write_count : forall val state,
      op_step (Write VarCount val) state tt (mkState val (StateSum state))
  | step_write_sum : forall val state,
      op_step (Write VarSum val) state tt (mkState (StateCount state) val).

  Definition crash_relation state state' := False.
  Definition inited state := True.

  Definition API : InterfaceAPI Op State :=
    {|
      op_sem := @op_step;
      crash_effect := crash_relation;
      init_sem := inited;
    |}.

  Ltac inv_step :=
    idtac;  (* Ltac evaluation order issue when passing tactics *)
    match goal with
    | [ H: op_step _ _ _ _ |- _ ] =>
      inversion H; subst; clear H;
      repeat sigT_eq;
      safe_intuition
    end.

End Vars.


Require Export Basic_Definitions.

(** Axiom of Choice **)

Module Type Axiom_Choice.

Axiom Choice_Axiom : forall (X: Class),
  Ensemble X -> exists ε, Choice_Function ε X.

Hint Resolve Choice_Axiom : Axiom_of_Choice.

End Axiom_Choice.

(** Tukey's Lemma **)

Module Type Tukey_Lemma.

Declare Module AC : Axiom_Choice.

(* Hypotheses *)

Definition En_F' F f := \{ λ x, x ∈ (∪f) /\ (F ∪ [x])∈f \}.

Definition eq_dec (A : Type) := forall x y: A, {x = y} + {x <> y}.
Parameter beq : eq_dec Class.
Definition Function_χ (F f ε: Class) : Class :=
  match beq ((En_F' F f) ~ F) Φ with
  | left _ => F
  | right _ => F ∪ [ε[(En_F' F f)~F]]
  end.

Definition tSubset f' f ε : Prop :=
  f' ⊂ f /\ Φ∈f' /\ (forall F, F∈f' -> (Function_χ F f ε) ∈ f')
  /\ (forall φ, φ ⊂ f' /\ Nest φ -> (∪φ) ∈ f').

Definition tSub_f'0 f ε := ∩ \{ λ f', tSubset f' f ε \}.

Definition En_u C f ε := \{ λ A, A ∈ (tSub_f'0 f ε) /\ (A ⊂ C \/ C ⊂ A) \}.

Definition En_f'1 f ε : Class :=
  \{ λ C, C ∈ (tSub_f'0 f ε) /\ (En_u C f ε) = (tSub_f'0 f ε) \}.

Definition En_ν D f ε : Class :=
  \{ λ A, A ∈ (tSub_f'0 f ε) /\ (A⊂D \/ (Function_χ D f ε) ⊂ A) \}.

(* Property Proof *)

Lemma Property_Φ : forall x y, y ⊂ x -> x ~ y = Φ <-> x = y.
Proof.
  intros; split; intros.
  - apply Property_ProperSubset in H; destruct H; auto.
    apply Property_ProperSubset' in H; destruct H as [z H], H.
    assert (z ∈ (x ~ y)).
    { unfold Setminus; apply Theorem4'; split; auto.
      unfold Complement; apply AxiomII; split; Ens. }
    rewrite H0 in H2; generalize (Theorem16 z); intros.
    contradiction.
  - rewrite <- H0; apply AxiomI; split; intros.
    + unfold Setminus in H1; apply Theorem4' in H1.
      destruct H1; unfold Complement in H2.
      apply AxiomII in H2; destruct H2; contradiction.
    + generalize (Theorem16 z); intros; contradiction.
Qed.

Lemma Property_χ : forall ε F f,
  Choice_Function ε (∪f) -> F∈f -> F ⊂ (Function_χ F f ε).
Proof.
  intros.
  generalize (classic ((En_F' F f) ~ F = Φ)); intros; destruct H1.
  - unfold Function_χ; destruct (beq (En_F' F f ~ F) Φ); try tauto.
    unfold Included; intros; auto.
  - unfold Function_χ; destruct (beq (En_F' F f ~ F) Φ); try tauto.
    unfold Included; intros; apply Theorem4; tauto.
Qed.

Lemma Ens_F'F : forall f F, Ensemble (∪ f) -> Ensemble (En_F' F f ~ F).
Proof.
  intros.
  assert (En_F' F f ~ F ⊂ ∪ f).
  { unfold Included; intros.
    unfold Setminus in H0; apply Theorem4' in H0; destruct H0.
    unfold En_F' in H0; apply AxiomII in H0; apply H0. }
  apply Theorem33 in H0; auto.
Qed.

Lemma Property_f'0 : forall f ε,
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) -> tSubset (tSub_f'0 f ε) f ε
  /\ (forall f', f' ⊂ f /\ tSubset f' f ε -> (tSub_f'0 f ε) ⊂ f').
Proof.
  intros; double H.
  apply Property_FinSet in H; unfold FiniteSet in H1; destruct H1, H1.
  apply Property_NotEmpty in H2; destruct H2 as [F H2]; split.
  - assert (tSubset f f ε).
    { unfold tSubset; repeat split; try apply H; intros.
      - unfold Included; intros; auto.
      - generalize (Theorem26 F); intros.
        apply H with (A:=F); split; auto.
      - generalize (classic((En_F' F0 f) ~ F0 = Φ)); intros; destruct H5.
        + unfold Function_χ; destruct (beq (En_F' F0 f ~ F0) Φ); tauto.
        + double H5; unfold Function_χ.
          destruct (beq (En_F' F0 f ~ F0) Φ); try tauto.
          unfold Choice_Function in H0; destruct H0, H7, H8.
          assert ((En_F' F0 f ~ F0) ∈ dom( ε)).
          { rewrite H8; unfold Setminus at 2; apply Theorem4'; split.
            - unfold PowerSet; apply AxiomII; apply AxiomVI in H1.
              split; try (apply Ens_F'F); auto.
              unfold Included; intros; unfold Setminus in H10.
              apply Theorem4' in H10; destruct H10.
              unfold En_F' in H10; apply AxiomII in H10; apply H10.
            - unfold Complement; apply AxiomII; double H1.
              apply AxiomVI in H10; split; try (apply Ens_F'F); auto.
              intro; unfold Singleton in H11; apply AxiomII in H11.
              destruct H11; rewrite H12 in H6; try contradiction.
              apply Theorem19; generalize (Theorem26 f); intros.
              apply Theorem33 in H13; auto. }
           apply H9 in H10; unfold Setminus in H10.
           apply Theorem4' in H10; destruct H10.
           unfold En_F' at 2 in H10; apply AxiomII in H10; apply H10. }
    assert ((tSub_f'0 f ε) ⊂ f).
    { unfold tSub_f'0; unfold Included; intros.
      unfold Element_I in H5; apply AxiomII in H5.
      apply H5; apply AxiomII; split; auto. }
    unfold tSubset; repeat split; auto.
    + unfold tSub_f'0; apply AxiomII; split; intros.
      * generalize (Theorem26 f); intros; apply Theorem33 in H6; auto.
      * apply AxiomII in H6; destruct H6; unfold tSubset in H7; apply H7.
    + intros; double H6; unfold Included in H5.
      apply H5 in H7; unfold tSubset in H4; apply H4 in H7.
      unfold tSub_f'0; apply AxiomII; split; intros; Ens.
      apply AxiomII in H8; destruct H8.
      double H9; unfold tSubset in H9; apply H9.
      unfold tSub_f'0 in H6; apply AxiomII in H6; destruct H6.
      apply H11; apply AxiomII; split; auto.
    + intros; unfold tSubset in H4; destruct H6; double H6.
      add ((tSub_f'0 f ε) ⊂ f) H6; apply Theorem28 in H6.
      add (Nest φ) H6; apply H4 in H6; unfold tSub_f'0; apply AxiomII.
      split; Ens; intros; apply AxiomII in H9; destruct H9.
      unfold tSubset in H10; apply H10; split; auto.
      assert ((tSub_f'0 f ε) ⊂ y).
      { unfold Included; intros; unfold tSub_f'0 in H11.
        unfold Element_I; apply AxiomII in H11.
        destruct H11; apply H12; apply AxiomII; split; auto. }
      add ((tSub_f'0 f ε) ⊂ y) H8; apply Theorem28 in H8; auto.
  - intros; destruct H4; unfold Included; intros.
    unfold tSub_f'0 in H6; unfold Element_I in H6.
    apply AxiomII in H6; destruct H6; apply H7.
    apply AxiomII; apply Theorem33 in H4; auto.
Qed.

Lemma FF' : forall (f ε F: Class),
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) -> F∈f ->
  (En_F' F f)~F ≠ Φ ->  F = F ∪ [ε[(En_F' F f)~F]] -> False.
Proof.
  intros.
  unfold Choice_Function in H0; assert (F~F=Φ).
  { unfold Φ; apply AxiomI; split; intros.
    - unfold Setminus in H4; apply Theorem4' in H4; destruct H4.
      apply AxiomII in H5; destruct H5; contradiction.
    - apply AxiomII in H4; destruct H4; contradiction. }
  assert (F~F≠Φ); try contradiction.
  { rewrite H3 at 1; apply Property_NotEmpty; exists (ε [En_F' F f ~ F]).
    assert ((En_F' F f ~ F) ∈ dom( ε)).
    { destruct H0, H5, H6; rewrite H6; assert (En_F' F f ~ F ⊂ ∪ f).
      { unfold Included; intros; apply Theorem4' in H8; destruct H8.
        unfold En_F' in H8; apply AxiomII in H8; apply H8. }
      assert (Ensemble (En_F' F f ~ F)).
      { apply Theorem33 in H8; auto; destruct H.
        unfold FiniteSet in H; destruct H; apply AxiomVI; auto. }
      unfold Setminus at 2; apply Theorem4'; split.
      - unfold PowerSet; apply AxiomII; split; auto.
      - unfold Complement; apply AxiomII; split; auto.
        unfold NotIn; intro; unfold Singleton in H10.
        apply AxiomII in H10; destruct H10; assert (Φ ∈ μ).
        { apply Theorem19; generalize (Theorem26 (∪ f)); intros.
          unfold FiniteSet in H; destruct H.
          apply Theorem33 in H12; auto; apply AxiomVI; apply H. }
        apply H11 in H12; contradiction. }
    apply H0 in H5; unfold Setminus in H5.
    apply AxiomII in H5; destruct H5, H6; unfold Setminus.
    apply Theorem4'; split; auto; apply Theorem4; right.
    unfold Singleton; apply AxiomII; split; auto. }
Qed.

Lemma Property_F' : forall F f, F ∈ f -> F ⊂ (En_F' F f).
Proof.
  unfold En_F', Included; intros.
  apply AxiomII; repeat split; Ens.
  - unfold Element_U; apply AxiomII; split; Ens.
  - assert (F ∪ [z] = F).
    { apply AxiomI; split; intros; try (apply Theorem4; tauto).
      apply Theorem4 in H1; destruct H1; auto.
      unfold Singleton in H1; apply AxiomII in H1.
      destruct H1; rewrite H2; auto; apply Theorem19; Ens. }
    rewrite H1; auto.
Qed.

(* Lemma Proof *)

Lemma LemmaT1 : forall f ε,
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) ->
  (forall D, D ∈ (En_f'1 f ε) -> tSubset (En_ν D f ε) f ε).
Proof.
  intros.
  apply (Property_f'0 _ ε) in H; auto; destruct H.
  assert ((En_ν D f ε) ⊂ f).
  { unfold En_ν; unfold Included; intros.
    apply AxiomII in H3; destruct H3, H4.
    unfold tSubset in H; destruct H.
    unfold Included in H; apply H in H4; auto. }
  unfold tSubset; repeat split; auto.
  - unfold En_ν; apply AxiomII.
    unfold tSubset in H; destruct H, H4.
    repeat split; Ens; left; apply Theorem26.
  - intro A; intros.
    double H4; unfold Included in H3; apply H3 in H4.
    unfold En_ν in H5; unfold En_ν.
    apply AxiomII; apply AxiomII in H5; destruct H5, H6.
    double H6; unfold tSubset in H; apply H in H8.
    repeat split; Ens; destruct H7.
    + apply Property_ProperSubset in H7; destruct H7.
      * left; generalize (classic ((Function_χ A f ε) ⊂ D)); intros.
        destruct H9; auto; unfold En_f'1 in H1; apply AxiomII in H1.
        destruct H1, H10; rewrite <- H11 in H8.
        unfold En_u in H8; apply AxiomII in H8; destruct H8, H12.
        apply Property_ProperSubset'' in H13; auto.
        double H7; apply Property_ProperSubset' in H7.
        double H13; apply Property_ProperSubset' in H13.
        destruct H7, H13, H7, H13.
        generalize (classic (x=x0)); intros; destruct H18.
        -- rewrite H18 in H7; contradiction.
        -- unfold ProperSubset in H15; destruct H15.
           unfold Included in H15; apply H15 in H7.
           assert (x0 ∉ A).
           { unfold NotIn; intro; unfold ProperSubset in H14.
             destruct H14; unfold Included in H14.
             apply H14 in H20; contradiction. }
           generalize (classic ((En_F' A f)~A=Φ)); intros; destruct H21.
           ++ unfold Function_χ in H13; unfold NotIn in H20.
              destruct (beq (En_F' A f ~ A) Φ); tauto.
           ++ unfold Function_χ in H7, H8, H13.
              destruct (beq (En_F' A f ~ A) Φ); try tauto.
              apply Theorem4 in H7; apply Theorem4 in H13.
              destruct H7, H13; try contradiction.
              unfold Singleton in H13; apply AxiomII in H13.
              unfold Singleton in H7; apply AxiomII in H7; destruct H13, H7.
              apply AxiomIV' in H8; destruct H8.
              apply Theorem42' in H24; apply Theorem19 in H24.
              double H24; apply H22 in H24; apply H23 in H25.
              rewrite <- H24 in H25; contradiction.
      * right; rewrite H7.
        unfold Included; intros; auto.
    + apply (Property_χ ε _ _) in H4; auto.
      add (A ⊂ Function_χ A f ε) H7; apply Theorem28 in H7; auto.
  - intro ϑ; intros; destruct H4.
    unfold En_ν; apply AxiomII.
    assert ((∪ ϑ) ∈ (tSub_f'0 f ε)).
    { unfold tSubset in H; apply H; split; auto.
      red; intros; unfold Included in H4.
      apply H4 in H6; unfold En_ν in H6.
      apply AxiomII in H6; apply H6. }
    repeat split; Ens.
    generalize (classic (forall B, B∈ϑ -> B ⊂ D)).
    intros; destruct H7.
    + left; unfold Included; intros.
      unfold Element_U in H8; apply AxiomII in H8.
      destruct H8, H9, H9; apply H7 in H10.
      unfold Included in H10; apply H10 in H9; auto.
    + apply not_all_ex_not in H7; destruct H7.
      apply imply_to_and in H7; destruct H7.
      double H7; unfold Included in H4; apply H4 in H7.
      unfold En_ν in H7; apply AxiomII in H7.
      destruct H7, H10, H11; try contradiction.
      right; unfold Included; intros.
      unfold Element_U; apply AxiomII; split; Ens.
Qed.

Lemma LemmaT2 : forall f ε,
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) ->
  (forall D, D ∈ (En_f'1 f ε) -> (Function_χ D f ε) ∈ (En_f'1 f ε)).
Proof.
  intros; double H1.
  unfold En_f'1 in H2; apply AxiomII in H2.
  destruct H2, H3; double H3; unfold tSub_f'0 in H5.
  double H; apply (Property_f'0 _ ε) in H6; auto.
  destruct H6; unfold tSubset in H6.
  double H3; apply H6 in H8; double H8.
  unfold tSub_f'0 in H9; destruct H6.
  unfold Included in H6; apply H6 in H3.
  apply (Property_χ ε _ _) in H3; auto.
  assert ((En_ν D f ε) ⊂ (En_u (Function_χ D f ε) f ε)).
  { unfold En_ν, En_u, Included; intros.
    apply AxiomII in H11; apply AxiomII; destruct H11, H12.
    repeat split; auto; destruct H13; auto. }
  assert ((En_u (Function_χ D f ε) f ε) ⊂ (tSub_f'0 f ε)).
  { unfold En_u, Included; intros.
    apply AxiomII in H12; apply H12. }
  apply (LemmaT1 f ε) in H1; auto.
  unfold FiniteSet in H; destruct H, H.
  assert ((En_ν D f ε) ⊂ f /\ tSubset (En_ν D f ε) f ε).
  { split; auto; unfold En_ν, Included; intros.
    apply AxiomII in H15; destruct H15, H16.
    apply H6 in H16; auto. }
  apply H7 in H15; add ((En_ν D f ε) ⊂ (En_u (Function_χ D f ε) f ε)) H15.
  apply Theorem28 in H15.
  add ((tSub_f'0 f ε) ⊂ (En_u (Function_χ D f ε) f ε)) H12.
  apply Theorem27 in H12; auto.
  unfold En_f'1; apply AxiomII; repeat split; Ens.
Qed.

Lemma LemmaT3 : forall f ε,
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) -> Nest (tSub_f'0 f ε).
Proof.
  intros; double H.
  apply (Property_f'0 _ ε) in H1; auto; destruct H1.
  assert ((En_f'1 f ε) ⊂ (tSub_f'0 f ε) /\ Nest (En_f'1 f ε)).
  { assert ((En_f'1 f ε) ⊂ (tSub_f'0 f ε)).
    { unfold Included; intros.
      unfold En_f'1 in H3; apply AxiomII in H3; apply H3. }
    split; auto; unfold tSubset in H1.
    add ((tSub_f'0 f ε) ⊂ f) H3; try apply H1.
    apply Theorem28 in H3; unfold FiniteSet in H; destruct H, H.
    apply Theorem33 with (z:=(En_f'1 f ε)) in H; auto.
    unfold Nest; intros; unfold En_f'1 in H6; destruct H6.
    apply AxiomII in H6; apply AxiomII in H7.
    destruct H6, H7, H8, H9; rewrite <- H11 in H8.
    unfold En_u in H8; apply AxiomII in H8; apply H8. }
  destruct H3.
  assert ((En_f'1 f ε) ⊂ f /\ tSubset (En_f'1 f ε) f ε).
  { unfold tSubset in H1.
    add ((tSub_f'0 f ε) ⊂ f) H3; try apply H1.
    apply Theorem28 in H3; split; auto.
    unfold tSubset; repeat split; auto; intros.
    - unfold En_f'1; apply AxiomII.
      destruct H1, H5; repeat split; Ens.
      apply AxiomI; split; intros.
      + unfold En_u; apply AxiomII in H7; apply H7.
      + unfold En_u; apply AxiomII; repeat split; Ens.
        right; apply Theorem26.
    - apply (LemmaT2 _ ε); auto.
    - unfold En_f'1; apply AxiomII.
      assert ((∪ φ) ∈ (tSub_f'0 f ε)).
      { destruct H5; assert (φ ⊂ (tSub_f'0 f ε)).
        { unfold Included; intros.
          unfold Included in H5; apply H5 in H7.
          unfold En_f'1; apply AxiomII in H7; apply H7. }
        add (Nest φ) H7; apply H1 in H7; auto. }
      repeat split; Ens.
      apply AxiomI; split; intros.
      + unfold En_u in H7; apply AxiomII in H7; apply H7.
      + unfold En_u; apply AxiomII; repeat split; Ens.
        generalize (classic (forall B, B ∈ φ -> B ⊂ z)).
        intros; destruct H8.
        * right; unfold Included; intros.
          unfold Element_U in H9; apply AxiomII in H9.
          destruct H9, H10, H10; apply H8 in H11.
          unfold Included in H11; apply H11; auto.
        * apply not_all_ex_not in H8; destruct H8.
          apply imply_to_and in H8; destruct H5, H8.
          double H8; unfold Included in H5; apply H5 in H8.
          unfold En_f'1 in H8; apply AxiomII in H8; destruct H8, H12.
          rewrite <- H13 in H7; unfold En_u in H7; apply AxiomII in H7.
          destruct H7, H14; destruct H15; try contradiction.
          left; unfold Included; intros.
          unfold Element_U; apply AxiomII; split; Ens. }
  apply H2 in H5; add ((En_f'1 f ε) ⊂ (tSub_f'0 f ε)) H5.
  apply Theorem27 in H5; auto; rewrite H5; auto.
Qed.

Lemma LemmaT4 : forall f ε,
  FiniteSet f /\ f ≠ Φ -> Choice_Function ε (∪f) -> (∪ tSub_f'0 f ε) ∈ f /\
  (Function_χ (∪ (tSub_f'0 f ε)) f ε) = ∪ (tSub_f'0 f ε).
Proof.
  intros; double H.
  apply (Property_f'0 _ ε) in H1; auto.
  destruct H1; unfold tSubset in H1.
  assert ((tSub_f'0 f ε) ⊂ (tSub_f'0 f ε) /\ Nest (tSub_f'0 f ε)).
  { split; try unfold Included; auto.
    apply (LemmaT3 _ ε) in H; auto. }
  apply H1 in H3; split.
  - destruct H1; unfold Included in H1; apply H1 in H3; auto.
  - unfold tSub_f'0 at 2 in H3; destruct H1.
    unfold Included in H1; double H3; apply H1 in H5.
    apply (Property_χ ε _ _) in H5; auto.
    assert ((Function_χ (∪ (tSub_f'0 f ε)) f ε) ⊂ ∪ (tSub_f'0 f ε)).
    { apply H4 in H3; unfold Included; intros.
    unfold Element_U; apply AxiomII; split; Ens. }
    apply Theorem27; auto.
Qed.

(* Tukey's Lemma Proof *)

Theorem Tukey : forall (f: Class),
  FiniteSet f /\ f ≠ Φ -> exists x, MaxMember x f.
Proof.
  intros; double H.
  unfold FiniteSet in H0; destruct H0, H0.
  assert (Ensemble (∪f)). { apply AxiomVI in H0; auto. }
  apply AC.Choice_Axiom in H3; destruct H3 as [ε H3].
  assert (exists F, F∈f /\ (En_F' F f) ~ F = Φ).
  { exists (∪(tSub_f'0 f ε)); double H3.
    apply (LemmaT4 _ ε) in H4; auto; destruct H4; split; auto.
    generalize (classic(En_F'(∪ tSub_f'0 f ε)f~(∪ tSub_f'0 f ε)=Φ)).
    intros; destruct H6; auto.
    assert ((Function_χ (∪ (tSub_f'0 f ε)) f ε) = (∪ tSub_f'0 f ε) ∪
    [ε [En_F' (∪ tSub_f'0 f ε) f ~ (∪ tSub_f'0 f ε)]]).
    { unfold Function_χ; destruct (beq (En_F' (∪ tSub_f'0 f ε) f ~
      (∪ tSub_f'0 f ε)) Φ); tauto. }
    rewrite H5 in H7; apply FF' in H7; auto; inversion H7. }
  destruct H4 as [F H4]; destruct H4; exists F.
  apply -> Property_Φ in H5; try (apply Property_F'; auto).
  unfold MaxMember; intro; clear H6; repeat split; auto; intros F' H6; intro.
  double H7; rewrite <- H5 in H8; apply Property_ProperSubset' in H8.
  destruct H8 as [z H8], H8; assert (F' ⊂ (En_F' F f)).
  { unfold En_F', Included; intros; apply AxiomII; repeat split; Ens.
    - unfold Element_U; apply AxiomII; split; Ens.
    - assert ((F ∪ [z0]) ⊂ F').
      { unfold ProperSubset in H7; destruct H7.
        unfold Included in H7; unfold Included; intros.
        apply Theorem4 in H12; destruct H12; try (apply H7 in H12; auto).
        unfold Singleton in H12; apply AxiomII in H12.
        destruct H12; rewrite H13; auto; apply Theorem19; Ens. }
      apply Property_FinSet in H; apply H with (A:= F'); split; auto. }
  unfold Included in H10; apply H10 in H8; contradiction.
Qed.

Hint Resolve Tukey : Axiom_of_Choice.

End Tukey_Lemma.


Require Export SystemFR.SubtypePi.
Require Export SystemFR.SubtypeMisc.

Opaque reducible_values.

Lemma npi: forall ρ S S' T T',
  valid_interpretation ρ ->
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  pfv T term_var = nil ->
  pfv T' term_var = nil ->
  [ ρ ⊨ S = S' ] ->
  (forall a, [ ρ ⊨ a : S' ]v -> [ ρ ⊨ open 0 T a = open 0 T' a ]) ->
  [ ρ ⊨ T_arrow S T = T_arrow S' T' ].
Proof.
  intros.
  unfold equivalent_types;
    repeat step || simp_red_goal || rewrite reducibility_rewrite;
    t_closer.

  - eapply equivalent_types_reducible; eauto.
    eapply reducible_app; eauto using reducible_value_expr; steps.
    eapply equivalent_types_reducible_back; eauto using reducible_value_expr.

  - eapply equivalent_types_reducible_back; eauto.
    + eapply reducible_app; eauto using reducible_value_expr; steps.
      eapply equivalent_types_reducible; eauto using reducible_value_expr.
    + apply_any; eauto using equivalent_types_reducible_values.
Qed.

Lemma open_npi_helper: forall Θ Γ S S' T T' x,
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  subset (fv T) (support Γ) ->
  subset (fv T') (support Γ) ->
  ~ x ∈ pfv S' term_var ->
  ~ x ∈ pfv_context Γ term_var ->
  [ Θ; Γ ⊨ S = S' ] ->
  [ Θ; (x, S') :: Γ ⊨ open 0 T (fvar x term_var) = open 0 T' (fvar x term_var) ] ->
  [ Θ; Γ ⊨ T_arrow S T = T_arrow S' T' ].
Proof.
  unfold open_equivalent_types; repeat step || apply npi; t_closer.

  unshelve epose proof (H8 ρ ((x, a) :: l) _ _ _);
    repeat step || apply SatCons || t_substitutions; t_closer.
Qed.

Lemma open_npi: forall Γ S S' T T' x,
  is_erased_type T ->
  is_erased_type T' ->
  wf T 1 ->
  wf T' 1 ->
  subset (fv T) (support Γ) ->
  subset (fv T') (support Γ) ->
  ~ x ∈ pfv S term_var ->
  ~ x ∈ pfv S' term_var ->
  ~ x ∈ pfv_context Γ term_var ->
  [ Γ ⊫ S = S' ] ->
  [ (x, S') :: Γ ⊫ open 0 T (fvar x term_var) = open 0 T' (fvar x term_var) ] ->
  [ Γ ⊫ T_arrow S T = T_arrow S' T' ].
Proof.
  eauto using open_npi_helper.
Qed.


Require List.
Require Import CMorphisms PeanoNat Omega.

Require Import Term Convertibility Typing.

Set Primitive Projections.
Set Implicit Arguments.

Record eval_ntr (Γ : list type) A (t : term) := {
  eval_atm_red : term;
  eval_atm_typ : inhabited [ Γ ⊢ne eval_atm_red : A ];
  eval_atm_cnv : convertible t eval_atm_red;
}.

Definition eval_atm Γ n t := eval_ntr Γ (atm n) t.

Inductive eval_sum evalA evalB Γ A B t :=
| eval_sum_lft :
  forall r, (forall Δ e (eε : typing_lift e Δ Γ), evalA Δ (lift_term e r)) -> convertible t (lft r) -> eval_sum evalA evalB Γ A B t
| eval_sum_rgt :
  forall r, (forall Δ e (eε : typing_lift e Δ Γ), evalB Δ (lift_term e r)) -> convertible t (rgt r) -> eval_sum evalA evalB Γ A B t
| eval_sum_ntr : eval_ntr Γ (sum A B) t -> eval_sum evalA evalB Γ A B t
.

Unset Implicit Arguments.

Fixpoint eval (Γ : list type) (A : type) (t : term) {struct A} : Type :=
match A with
| atm n => eval_atm Γ n t
| arr A B =>
  forall (x : term)
  (xε : forall Δ (e : lift) (eε : typing_lift e Δ Γ), eval Δ A (lift_term e x)), eval Γ B (app t x)
| sum A B => eval_sum (fun Γ => eval Γ A) (fun Γ => eval Γ B) Γ A B t
end.

Definition realizes Γ A t :=
  (forall Δ e (eε : typing_lift e Δ Γ), eval Δ A (lift_term e t)).

Lemma lift_realizes : forall Γ Δ A t e, [ Δ ⊢lift e : Γ ] ->
  realizes Γ A t -> realizes Δ A (lift_term e t).
Proof.
intros Γ Δ A t e eε Ht Ξ e' eε'.
rewrite <- lift_term_compose.
apply Ht.
eapply typing_lift_compose; eassumption.
Qed.

Lemma eval_ntr_convertible_compat : forall Γ A t r, convertible t r -> eval_ntr Γ A t -> eval_ntr Γ A r.
Proof.
intros Γ A t r Hr Ht.
destruct Ht as [s Hs H]; exists s.
- assumption.
- apply convertible_trans with t; [|assumption].
  apply convertible_sym; assumption.
Qed.

Lemma eval_convertible_compat : forall Γ A t r, convertible t r -> eval Γ A t -> eval Γ A r.
Proof.
intros Γ A; revert Γ; induction A as [n|A IHA B IHB|A IHA B IHB]; intros Γ t r Hr Ht; cbn in *.
+ eapply eval_ntr_convertible_compat; eassumption.
+ intros x xε.
  apply IHB with (app t x).
  rewrite Hr; reflexivity.
  apply Ht, xε.
+ destruct Ht as [x xε Hx|y yε Hy|n].
  - apply (eval_sum_lft _ _ _ _ xε).
    rewrite <- Hx; symmetry; assumption.
  - apply (eval_sum_rgt _ _ _ _ yε).
    rewrite <- Hy; symmetry; assumption.
  - eapply eval_sum_ntr, eval_ntr_convertible_compat; eassumption.
Qed.

Instance Proper_eval : Proper (eq ==> eq ==> convertible ==> iffT) eval.
Proof.
intros Γ Γ' <- A A' <- t t' Ht; split; intros; eapply eval_convertible_compat; try eassumption.
symmetry; eassumption.
Qed.

Set Implicit Arguments.

Record reified Γ A t := Reified {
  reify_trm : term;
  reify_typ : inhabited [ Γ ⊢nf reify_trm : A ];
  reify_cvn : convertible t reify_trm;
}.

Record interp (A : type) := {
  reflect : forall Γ t, inhabited [ Γ ⊢ne t : A ] -> realizes Γ A t;
  reify : forall Γ t, realizes Γ A t -> reified Γ A t;
}.

Unset Implicit Arguments.

Lemma completeness : forall A, interp A.
Proof.
induction A; split; cbn in *.
+ intros Γ t Ht Δ e eε; cbn in *.
  exists (lift_term e t); [|constructor].
  destruct Ht; constructor.
  eapply NF_typing_lift_compat; eassumption.
+ intros Γ t Ht.
  specialize (Ht Γ ELID (typing_ELID _)).
  rewrite lift_term_ELID in Ht.
  unshelve refine (Reified _ _).
  - cbn in *.
    refine (Ht.(eval_atm_red)).
  - destruct Ht as [? [Ht] ?]; cbn in *.
    constructor. apply NF.typing_ne; apply Ht.
  - cbn in *.
    destruct Ht as [r ? Hr]; cbn.
    assumption.
+ intros Γ t Ht Δ e eε; cbn in *; intros x xε.
  destruct (@reify A1 IHA1 Δ x xε) as [r Hr Hrx].
  apply eval_convertible_compat with (app (lift_term e t) r).
  { rewrite Hrx; reflexivity. }
  rewrite <- (lift_term_ELID (app (lift_term e t) r)).
  refine (IHA2.(reflect) _ (typing_ELID _)).
  destruct Hr as [Hr], Ht as [Ht]; constructor.
  apply NF.typing_app with A1; [|assumption].
  apply NF_typing_lift_compat with Γ; assumption.
+ intros Γ t Ht.
  assert (xε : realizes (A1 :: Γ) A2 (app (lift_term (ELSHFT ELID) t) (var 0))).
  { intros Δ e eε; specialize (Ht Δ).
    cbn in *.
    fold (lift_term e (var 0)).
    rewrite <- lift_term_compose.
    refine (Ht _ _ _ _); [eapply typing_lift_compose; [eassumption|repeat constructor]|].
    intros Ξ e' eε'.
    rewrite <- lift_term_compose.
    refine (@reflect _ IHA1 (cons A1 Γ) _ _ _ _ _).
    { repeat constructor. }
    { eapply typing_lift_compose; eassumption. }
  }
  assert (r := @reify _ IHA2 (cons A1 Γ) (app (lift_term (ELSHFT ELID) t) (var 0)) xε).
  destruct r as [r Hr Hre].
  unshelve refine (Reified _ _).
  - refine (lam r).
  - destruct Hr as [Hr]; constructor; cbn.
    apply NF.typing_lam; assumption.
  - rewrite <- Hre, convertible_η; reflexivity.
+ intros Γ t Ht Δ e eε.
  apply eval_sum_ntr; exists (lift_term e t).
  - destruct Ht as [Ht]; constructor.
    eapply NF_typing_lift_compat; eassumption.
  - reflexivity.
+ intros Γ t Ht.
  specialize (Ht Γ ELID (typing_ELID _)).
  rewrite lift_term_ELID in Ht.
  destruct Ht as [r Htr Hr|r Htr Hr|[r Htr Hr]].
  - unshelve refine (Reified _ _); cbn.
    { exact (lft ((IHA1.(reify) Htr).(reify_trm))). }
    { destruct (IHA1.(reify)) as [s [Hts] Hs].
     cbn; constructor; apply NF.typing_lft; assumption. }
    { rewrite Hr; apply convertible_lft, IHA1.(reify). }
  - unshelve refine (Reified _ _); cbn.
    { exact (rgt ((IHA2.(reify) Htr).(reify_trm))). }
    { destruct (IHA2.(reify)) as [s [Hts] Hs].
     cbn; constructor; apply NF.typing_rgt; assumption. }
    { rewrite Hr; apply convertible_rgt, IHA2.(reify). }
  - unshelve refine (Reified _ _); cbn.
    { refine r. }
    { destruct Htr as [Htr]; constructor; apply NF.typing_ne; assumption. }
    { assumption. }
Qed.

Lemma subs_term_CONS_SHFT_LIFT_n : forall t σ n,
  subs_term (LIFTn n (CONS (var 0) (SHFT σ))) t = subs_term (LIFTn (S n) σ) t.
Proof.
induction t; intros σ m; cbn in *; try (solve [f_equal; intuition eauto]).
+ revert n σ; induction m as [|m]; intros n σ; cbn.
  - rewrite expand_term_CONS, expand_term_LIFT.
    destruct n as [|n]; [reflexivity|].
    rewrite expand_term_SHFT; f_equal.
  - rewrite !expand_term_LIFT; destruct n as [|n]; [reflexivity|]; cbn.
    f_equal; apply IHm.
+ f_equal; apply (IHt _ (S m)).
+ f_equal; [intuition|apply (IHt2 _ (S m))|apply (IHt3 _ (S m))].
Qed.

Lemma subs_term_CONS_SHFT_LIFT : forall t σ,
  subs_term (CONS (var 0) (SHFT σ)) t = subs_term (LIFT σ) t.
Proof.
intros t σ; apply subs_term_CONS_SHFT_LIFT_n with (n := 0).
Qed.

(*
Inductive eval_subs : list type -> list type -> subs term -> Type :=
| eval_subs_ESID : forall Γ e, eval_subs Γ nil (subs_of_lift e)
| eval_subs_CONS : forall Γ Δ A t σ, realizes Γ A t -> eval_subs Γ Δ σ -> eval_subs Γ (cons A Δ) (CONS t σ)
| eval_subs_SHFT : forall Γ Δ A σ, eval_subs Γ Δ σ -> eval_subs (cons A Γ) Δ (SHFT σ)
(* | eval_subs_LIFT : forall Γ Δ A σ, eval_subs Γ Δ σ -> eval_subs (cons A Γ) (cons A Δ) (LIFT σ) *)
.

Lemma eval_subst_lift : forall Γ Δ Ξ e σ,
  [Ξ ⊢lift e : Δ] ->
  eval_subs Δ Γ σ ->
  eval_subs Ξ Γ (subs_compose subs_term (subs_of_lift e) σ).
Proof.
intros Γ Δ Ξ e σ eε Hσ.
revert Γ σ Hσ; induction eε; intros Ξ σ Hσ; cbn.
- assumption.
- constructor; apply IHeε; assumption.
- remember (A :: Δ)%list as Ω; revert A Δ eε IHeε HeqΩ; induction Hσ; intros B Ξ eε IHeε HeqΩ; subst.
  { clear. destruct e; cbn.
    - change (LIFT (subs_of_lift el)) with (@subs_of_lift term (ELLFT el)); constructor.
    - rewrite <- subs_lift_compose; do 2 constructor.
    - rewrite <- subs_lift_compose. refine (eval_subs_ESID _ (ELLFT _)).
  }
  { constructor.
    + change (LIFT (subs_of_lift el)) with (@subs_of_lift term (ELLFT el)).
      rewrite subs_term_lift. eapply lift_realizes; [constructor|]; eassumption.
    + eapply IHHσ; [eassumption|eassumption|reflexivity]. }
  { constructor; apply IHeε.
    injection HeqΩ; intros -> ->; assumption. }
Qed.
*)

Inductive eval_subs : list type -> list term -> Type :=
| eval_subs_nil : eval_subs nil nil
| eval_subs_cons : forall Γ A t σ,
  eval_subs Γ σ -> realizes nil A t -> eval_subs (A :: Γ) (t :: σ).

Fixpoint closed (σ : list term) := match σ with
| nil => ESID
| cons t σ => CONS t (closed σ)
end.

Lemma realizes_eval : forall Γ A t, realizes Γ A t -> eval Γ A t.
Proof.
intros Γ A t Ht.
rewrite <- lift_term_ELID.
apply Ht; constructor.
Qed.

(* Γ ⊢ t : A -> α ⊩ Γ -> α ⊩ A *)
Lemma soundness : forall Γ A t σ,
  [ Γ ⊢ t : A ] -> eval_subs Γ σ -> realizes nil A (subs_term (closed σ) t).
Proof.
intros Γ A t σ Ht; revert σ; induction Ht; cbn in *; intros σ Hσ.
+ revert n A e; induction Hσ; intros n B e'; cbn in *.
  - apply List.nth_error_In in e'; elim e'.
  - destruct n as [|n]; cbn in *.
    { injection e'; intros ->; rewrite lift_term_ELID; assumption. }
    { apply IHHσ; assumption. }
+ intros Δ e eε x xε; cbn.
  eapply eval_convertible_compat; [symmetry; apply convertible_β|].
  rewrite <- subs_term_lift, <- !subs_term_compose; cbn.
  eapply eval_convertible_compat; [|unshelve eapply (IHHt (cons x σ) _ _ _ eε); constructor].
admit.
assumption.
intros Ω e' e'ε.
apply xε.
  apply (IHHt (cons x σ)); constructor; [assumption|].
  apply realizes_eval; assumption.
+ apply IHHt1; [assumption|].
  intros Δ e eε.
  rewrite <- subs_term_lift.
  rewrite <- subs_term_compose.

  apply (IHHt2 Δ σ Hσ).
  eapply typing_lift_compose; eassumption.

(* Γ ⊢ t : A -> α ⊩ Γ -> α ⊩ A *)
Lemma soundness : forall Γ Δ A t σ,
  [ Γ ⊢ t : A ] -> eval_subs Δ Γ σ -> eval Δ A (subs_term σ t).
Proof.
intros Γ Δ A t σ Ht; revert Δ σ; induction Ht; cbn in *; intros Δ σ Hσ.
+ revert n A e; induction Hσ; intros n B e'; cbn in *.
  - apply List.nth_error_In in e'; elim e'.
  - destruct n as [|n]; cbn in *.
    { injection e'; intros ->; rewrite lift_term_ELID; apply r; constructor. }
    { apply IHHσ; assumption. }
  - rewrite expand_term_SHFT.
    apply lift_realizes with Γ; [repeat constructor|].
    apply IHHσ; assumption.
+ intros Ξ e eε x xε.
  eapply eval_convertible_compat; [symmetry; apply convertible_β|].
  rewrite <- subs_term_lift, <- !subs_term_compose; cbn.
  match goal with [ |- eval _ _ ?t ] => rewrite <- (lift_term_ELID t) end.
  refine (IHHt _ _ _ Ξ ELID (typing_ELID _)).
  constructor; [intros ? ? ?; apply xε; assumption|].
  eapply eval_subst_lift; eassumption.
+ intros Ξ e eε.
  specialize (IHHt1 Δ σ Hσ Ξ e eε).
  cbn in *.
  apply IHHt1.
  intros Ω α αε; rewrite <- lift_term_compose.
  apply (IHHt2 Δ σ Hσ).
  eapply typing_lift_compose; eassumption.
+ intros Ξ e eε; cbn.
  apply eval_sum_lft with (lift_term e (subs_term σ t)).
  - intros Ω α αε; rewrite <- lift_term_compose.
    eapply (IHHt Δ σ Hσ), typing_lift_compose; eassumption.
  - reflexivity.
+ intros Ξ e eε; cbn.
  apply eval_sum_rgt with (lift_term e (subs_term σ t)).
  - intros Ω α αε; rewrite <- lift_term_compose.
    eapply (IHHt Δ σ Hσ), typing_lift_compose; eassumption.
  - reflexivity.
+ intros Ξ e eε; cbn.
  destruct (IHHt1 _ _ Hσ Ξ e eε) as [r Htr Hr|r Htr Hr|[r Htr Hr]].
  - eapply eval_convertible_compat.
    { apply convertible_cse_e; symmetry; eassumption. }
    eapply eval_convertible_compat; [symmetry; eapply convertible_step, reduction_ι_l|].
    eapply eval_convertible_compat; [|refine (IHHt2 _ (CONS (lift_term e r) σ) _ _ _ eε)].
    ++ admit.
    ++ constructor; [|assumption].
      change (realizes Ξ A r) in Htr.
       clear - e eε Htr; intros Σ e' e'ε.
       rewrite <- lift_term_compose. apply Htr.
       eapply typing_lift_compose; [eassumption|].
       apply Htr.
unfold realizes.
    rewrite <- subs_term_lift.
    rewrite <- subs_term_compose; cbn.
    rewrite <- subs_term_compose; cbn.
    apply IHHt2; constructor; assumption.
  - eapply eval_convertible_compat.
    { apply convertible_cse_e; symmetry; eassumption. }
    eapply eval_convertible_compat; [symmetry; eapply convertible_step, reduction_ι_r|].
    rewrite <- subs_term_compose; cbn.
    apply IHHt3; constructor; assumption.
  - unshelve refine (let r1 := (completeness C).(reify) _ _ (IHHt2 (cons A Δ) (CONS (var 0) (SHFT σ)) _) in _).
    { apply eval_subs_CONS, eval_subs_SHFT, Hσ.
      apply (completeness A).
      constructor; apply (NF.typing_var _ _ 0); reflexivity. }
    unshelve refine (let r2 := (completeness C).(reify) _ _ (IHHt3 (cons B Δ) (CONS (var 0) (SHFT σ)) _) in _).
    { apply eval_subs_CONS, eval_subs_SHFT, Hσ.
      apply (completeness B).
      constructor; apply (NF.typing_var _ _ 0); reflexivity. }
    apply eval_convertible_compat with (cse r r1.(reify_trm) r2.(reify_trm)).
    { apply convertible_cse.
      + symmetry; apply Hr.
      + rewrite <- r1.(reify_cvn).
        rewrite subs_term_CONS_SHFT_LIFT; reflexivity.
      + rewrite <- r2.(reify_cvn).
        rewrite subs_term_CONS_SHFT_LIFT; reflexivity.
    }
    apply (completeness C).(reflect).
    destruct Htr as [Htr], r1.(reify_typ) as [rt1], r2.(reify_typ) as [rt2].
    constructor; apply NF.typing_cse with A B; assumption.
Qed.


Require Import Coq.NArith.BinNat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.

Require Import CompCert.Events.

Require Import Common.Definitions.
Require Import Common.Maps.

Require Import Intermediate.Machine.

Require Import extructures.ord.

From mathcomp Require Import ssreflect ssrfun ssrbool ssreflect.eqtype.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.

Definition DEPTH := 5%nat.

Definition Procedure := (Component.id * Procedure.id)%type.

Definition Node :=  (Procedure * nat * (list Procedure))%type.

Definition CallGraph := list Node.

Theorem proc_eq_dec :  forall l1 l2 : Procedure,  {l1 = l2} + {l1 <> l2}.
Proof.
  repeat decide equality. Defined.

Theorem callGraph_eq_dec :  forall g1 g2 : CallGraph,  {g1 = g2} + {g1 <> g2}.
Proof.
  repeat decide equality. Defined.

Definition list2fset {A:ordType} (l : list A) : {fset A} :=
  let fix app  l  :=
      match l with
      | nil => fset0
      | x::xs => fsetU (fset1 x) (app xs)
      end in
  app l.

Definition proc_eqb (p1 : Procedure) (p2 : Procedure) : bool :=
  andb (Nat.eqb (fst p1) (fst p2))
       (Nat.eqb (snd p1) (snd p2)).

Definition nodeGetCid (v : Node) : Component.id :=
  fst (fst (fst v)).

Definition nodeGetPid (v : Node) : Procedure.id :=
  snd (fst (fst v)).

Definition nodeGetProcedure (v : Node) : Procedure :=
  fst (fst v).

Definition nodeGetDepth (v : Node) : nat :=
  snd (fst v).

Definition nodeGetCallList (v : Node) : list Procedure :=
  snd v.

Definition existsb (p : Procedure) (cg : CallGraph) : bool :=
  List.existsb
    (fun n => proc_eqb n p)
    (List.map nodeGetProcedure cg).

Definition size (ip : Intermediate.program) : nat :=
  List.fold_left
    (fun acc '(_,pmap) =>
       List.fold_left
         (fun acc' '(_,lc) => (acc' + (List.length lc))%nat )
         (elementsm pmap) acc
    )
    (elementsm (Intermediate.prog_procedures ip)) 0%nat.

Definition buildCallGraph (ip : Intermediate.program) : CallGraph :=
  let fix worker
          (wklst : list (Procedure*nat))
          (acc : CallGraph)
          (sz : nat) := (* sz is a decreasing parameter for termination check *)
      match sz with
      | O => acc
      | S sz' =>
        match wklst with
        | nil => acc
        | (p,depth) :: xs =>
          if existsb p acc
          then worker xs acc sz'
          else
            (* process p *)
            match getm (Intermediate.prog_procedures ip) (fst p) with
            | None => acc
            | Some pmap =>
              match getm pmap (snd p) with
              | None => acc
              | Some lc =>
                let calledProcs :=
                    List.map
                      (fun i =>
                         match i with
                         | ICall cid pid => (cid,pid)
                         | _ => (1%nat,1%nat) (* this is not applicable *)
                         end )
                      (List.filter (fun i =>
                                      match i with
                                      | ICall _ _ => true
                                      | _ => false
                                      end ) lc) in
                let wklst' := (xs ++ (List.map (fun x => (x,(depth+1)%nat)) calledProcs))%list in
                worker wklst' ((p,depth,calledProcs)::acc) sz'
              end
            end
        end
      end in
  match Intermediate.prog_main ip with
  | false => nil
  | true => worker [(Component.main,Procedure.main,0%nat)] nil (size ip)
  end.

Definition  shrinkNode (pn:Node) : (list (list Procedure)) :=
  let p := nodeGetProcedure pn in
  let depth := nodeGetDepth pn in
  let lp := nodeGetCallList pn in
  (* shrink head *)
  let n := List.length lp in
  List.map (fun nn => List.firstn nn lp)
           (List.rev (List.seq 0%nat (List.length lp))).

Definition find (p : Procedure) (cg : CallGraph) : option Node :=
  List.find
    (fun v => proc_eqb p (nodeGetProcedure v) )
    cg.

Definition shrinkCallGraph (main : Procedure)  (cg : CallGraph) : (list CallGraph) :=

  let fix worker
          (wklst : list Procedure)
          (acc : CallGraph)
          (cg : CallGraph)
          (sz : nat) := (* sz is a decreasing parameter for termination check *)
      match sz with
      | O => [acc]
      | S sz' =>
        match wklst with
        | nil => [acc]
        | p :: xs =>
          if existsb p acc
          then (* node already in generated graph *)
            worker xs acc cg sz'
          else (* node not processed yet *)
            match find p cg with
            | None => [acc] (* this should not happen *)
            | Some n =>
              let depth := nodeGetDepth n in
              let calls := nodeGetCallList n in
              if Nat.ltb depth DEPTH
              then (* this node can be shrunk*)
                (* shrink the node and not the procedures it calls *)
                ((List.flat_map
                    ( fun (newCallList : list Procedure) =>
                        worker
                          xs  (* worklist *)
                          (* accumulator : add all procedures in newCallList
                             that are not already in *)
                          (List.fold_left
                             (fun acc' p' =>
                                if existsb p' acc'
                                then acc'
                                else
                                  match find p' cg with
                                  | None => acc'
                                  | Some x => acc' ++ [x]
                                  end
                             )
                             newCallList
                             (acc ++ [(p,depth,newCallList)])
                          )
                          cg sz'
                    )
                    (shrinkNode n))
                   ++
                   (
                     worker (xs++calls) (acc++[n]) cg sz'
                   )
                )%list
              else (* node not in graph, but depth too big *)
                worker xs (acc++[n]) cg sz'
            end
        end
      end in
  match find main cg with
  | None => nil
  | Some nodeMain =>
    List.remove
      callGraph_eq_dec (* just in case the original program slips in *)
      cg
      (worker [(nodeGetProcedure nodeMain)]
              nil
              cg
              (1+ (List.fold_left
                     ( fun acc v => (acc + (List.length (nodeGetCallList v)))%nat )
                     cg 0%nat))%nat
      )
  end.

Definition getComponents (cg : CallGraph) : list Component.id :=
  List.nodup Nat.eq_dec (List.map (fun n => nodeGetCid n ) cg).

Definition buildInterface (components : list Component.id)
           (cg : CallGraph) : (Program.interface) :=
  List.fold_left
    (
      fun acc cid =>
        let newExport :=
            List.nodup
              Nat.eq_dec
              (
                List.map
                  nodeGetPid
                  (List.filter
                     (fun n => Component.eqb (nodeGetCid n) cid)
                     cg)
              )
        in
        let newImport := (* all the called procs by this component *)
            List.nodup proc_eq_dec
                       ( List.fold_left
                           (fun acc' n =>
                              if Component.eqb (nodeGetCid n) cid
                              then
                                acc' ++ (nodeGetCallList n)
                              else acc'
                           ) cg nil
                       ) in

        let newcint := Component.mkCompInterface (list2fset newExport)
                                                 (list2fset newImport)
        in
        setm acc cid newcint
    )
    components
    emptym.

Definition buildProcedures (components : list Component.id)
           (cg : CallGraph)
           (ip : Intermediate.program) : NMap (NMap code) :=
  let all_procs :=
      List.fold_left
        (fun acc n => (nodeGetProcedure n)::acc) cg nil in
  let all_code :=
      List.fold_left
        (fun acc '(p,_,callList) =>
        let cid := fst p in
        let pid := snd p in
        match getm (Intermediate.prog_procedures ip) cid with
        | None => acc
        | Some pmap =>
          let oldmap := (match getm acc cid with
                         | None => emptym
                         | Some x => x
                         end) in
          match getm pmap pid with
          | None => acc
          | Some lcode =>
            let newcode := List.map
                             ( fun i =>
                                 match i with
                                 | ICall c' p' =>
                                   if (List.existsb (fun p => proc_eqb p (c',p') ) all_procs)
                                   then i
                                   else INop
                                 | _ => i
                                 end
                             )
                             lcode in
            setm acc cid (setm oldmap pid newcode)
          end
        end
     )
     cg
     emptym in

  mapm
    ( fun pmaps =>

        let declared :=
            List.fold_left
              (fun acc '(pid,li) =>
                 List.fold_left
                   (fun acc' i =>
                      match i with
                      | ILabel l => l::acc'
                      | _ => acc'
                      end) li acc
              ) (elementsm pmaps) nil
        in

        mapm
          (fun li =>
             List.map
               (fun i =>
                  match i with
                  | IJal l =>
                    if (List.existsb (fun l' => Nat.eqb l' l) declared)
                    then i
                    else INop
                  | IBnz _ l =>
                    if (List.existsb (fun l' => Nat.eqb l' l) declared)
                    then i
                    else INop
                  | _ => i
                  end) li
          ) pmaps
    )
    all_code
.

Definition buildBuffers (components : list Component.id)
           (cg : CallGraph)
           (ip : Intermediate.program)
  : {fmap nat_ordType -> {fmap Block.id -> nat + list value}}  :=
  List.fold_left
    ( fun acc cid =>
        match (Intermediate.prog_buffers ip) cid with
        | None => acc
        | Some x => setm acc cid x
        end
    )
    components
    emptym.

Definition buildIntermediateProgram (cg : CallGraph)
           (ip : Intermediate.program) : Intermediate.program :=
  let components := getComponents cg in
  {|
    Intermediate.prog_interface := buildInterface components cg;
    Intermediate.prog_procedures := buildProcedures components cg ip;
    Intermediate.prog_buffers := buildBuffers components cg ip;
    Intermediate.prog_main := (Intermediate.prog_main ip)
  |}.

Definition list_eqb {A : Type} (eqb : A -> A -> bool) (l1 l2 : list A) : bool :=
  andb
    (List.fold_left
       (
         fun acc x => andb (List.existsb (eqb x) l1) acc
       )
       l2 true)
    (List.fold_left
       (
         fun acc x => andb (List.existsb (eqb x) l2) acc
       )
       l1 true).

Definition interface_contained (small : Program.interface)
           (big : Program.interface) : bool :=
  List.fold_left
    (fun acc '(cid,cint) =>
       if acc
       then
         match getm big cid with
         | None => false
         | Some bigCint =>
           if list_eqb Nat.eqb (val (Component.export cint)) (val (Component.export bigCint))
           then
             list_eqb proc_eqb (val (Component.import cint)) (val (Component.import bigCint))
           else false
         end
       else false
    )
    (elementsm small) true.

Instance shrinkIntermediateProgram : Shrink Intermediate.program :=
  {|
    shrink :=
      fun ip =>
        match Intermediate.prog_main ip with
        | false => nil
        | true =>
          (* must deal with the case the program represented by
             the call graph is already smallest and not the same
             as the original *)
          let cg := buildCallGraph ip in
          let newip := buildIntermediateProgram cg ip in
          let newCallGraphs := shrinkCallGraph (Component.main, Procedure.main) cg in
          let shrinked := List.map (fun ncg => buildIntermediateProgram ncg ip) newCallGraphs in
          if interface_contained (Intermediate.prog_interface ip)
               (Intermediate.prog_interface newip)
          then shrinked
          else newip::shrinked
        end
  |}.


Require Import DynamicProp.
Require Import TypesProp.
Require Import WellFormednessProp.
Require Import Progress.
Require Import Preservation.
Require Import Shared.

Theorem type_soundness :
  forall P t' Gamma cfg t cfg',
    wfProgram P t' ->
    wfConfiguration P Gamma cfg t ->
    P / cfg ==>* cfg' ->
    (exists Gamma',
       wfConfiguration P Gamma' cfg' t /\
       wfSubsumption Gamma Gamma'
    ) /\
    (cfg_exn(cfg') \/ cfg_done(cfg') \/
     cfg_blocked(cfg') \/
     exists cfg'', P / cfg' ==> cfg'').
Proof with eauto with env.
  introv wfP wfCfg HstepMulti.
  split.
  + Case "Preservation".
    gen Gamma.
    induction HstepMulti as [cfg|cfg cfg' cfg'' Hstep]; intros.
    - SCase "cfg = cfg'".
      exists Gamma...
    - SCase "cfg ==> cfg'".
      eapply preservation in Hstep
        as (Gamma' & wfCfg' & HSub)...
      apply IHHstepMulti in wfCfg'
        as (Gamma'' & wfCfg'' & HSub').
      exists Gamma''. split...
      eapply wfSubsumption_trans...
  + Case "Progress".
    gen Gamma.
    induction HstepMulti as [cfg|cfg cfg' cfg'' Hstep]; intros.
    - SCase "cfg = cfg'".
      eapply progress in wfCfg...
    - SCase "cfg ==> cfg'".
      eapply preservation in Hstep
        as (Gamma' & wfCfg' & HSub)...
Qed.