(** Coq coding by choukh, June 2021 **)

Require Import ZFC.Lib.FuncFacts.
Require Import ZFC.Lib.Ordinal.
Import WoStruct.
Import WoStruct.EpsilonImage.

Definition WOₛ_spec := λ p S, p = <A S, R S>.

Lemma WOₛ_unique : ∀ p, uniqueness (WOₛ_spec p).
Proof.
  intros p S T H1 H2. unfold WOₛ_spec in *. subst.
  apply op_iff in H2 as []. apply eq_intro; auto.
Qed.

(* 从良序结构集合到良序结构类型 *)
Definition WOₛ := λ p, iota (inhabits ø̃) (WOₛ_spec p).

Lemma WOₛ_spec_intro : ∀ p, (∃ S, WOₛ_spec p S) → WOₛ_spec p (WOₛ p).
Proof.
  intros p [S H].
  apply (iota_spec (inhabits ø̃) (WOₛ_spec p)).
  rewrite <- unique_existence. split.
  exists S. apply H. apply WOₛ_unique.
Qed.

Lemma WOₛ_pair_id : ∀ S, WOₛ <A S, R S> = S.
Proof.
  intros. pose proof (WOₛ_spec_intro <A S, R S>).
  apply op_iff in H as [HA HR].
  apply eq_intro; auto. exists S. reflexivity.
Qed.

(* 良序结构集集 well-ordered structures *)
Definition wos := λ 𝒞, ∀p ∈ 𝒞, ∃ S, WOₛ_spec p S.

Lemma WOₛ_spec_intro_for_wos :
  ∀ 𝒞, wos 𝒞 → ∀p ∈ 𝒞, WOₛ_spec p (WOₛ p).
Proof.
  intros 𝒞 Hwos p Hp.
  apply (iota_spec (inhabits ø̃) (WOₛ_spec p)).
  rewrite <- unique_existence. split.
  apply Hwos. auto. apply WOₛ_unique.
Qed.

(* 从良序结构集到序数*)
Definition ordₛ := λ p, ord (WOₛ p).
(* 从良序结构集集到序数集 *)
Definition ordsₛ := λ 𝒞, {ordₛ p | p ∊ 𝒞}.

(* 从良序结构集到伊普西隆映射 *)
Definition Eₛ := λ p, E (WOₛ p).
(* 从良序结构集集到伊普西隆映射集 *)
Definition Es := λ 𝒞, {Eₛ p | p ∊ 𝒞}.

Lemma Eₛ_pair : ∀ S, Eₛ <A S, R S> = E S.
Proof. intros. unfold Eₛ. now rewrite WOₛ_pair_id. Qed.

(* 尾扩张 *)
Definition EndExtension := λ S T, S ⊑ T ∧
  ∀a ∈ A S, ∀b ∈ A T - A S, (a <ᵣ b) (R T).
Notation "S ⊑⊑ T" := (EndExtension S T) (at level 70) : WoStruct_scope.

(* 尾扩张结构集集 end extension structures *)
Definition ees := λ 𝒞, ∀ S T,
  <A S, R S> ∈ 𝒞 → <A T, R T> ∈ 𝒞 → S ⊑⊑ T ∨ T ⊑⊑ S.

Lemma E_restr : ∀ S T, S ⊑⊑ T → E S = E T ↾ A S.
Proof with eauto.
  intros * [[HAsub HRsub] Hop].
  pose proof (e_bijective S) as [[HfS _] [HdS _]].
  pose proof (e_bijective T) as [[HfT _] [HdT _]].
  apply func_ext... apply restr_func... split.
  replace (dom (E T ↾ A S)) with (A S)...
  symmetry. apply restr_dom... rewrite HdT...
  intros x Hx. rewrite HdS in Hx.
  erewrite restr_ap; revgoals...
  set {x ∊ A S | (E S)[x] = (E T)[x]} as AS'.
  replace (A S) with AS' in Hx. apply SepE2 in Hx... clear Hx x.
  eapply transfinite_induction...
  split. intros t Ht. apply SepE1 in Ht...
  intros t Ht Hsub. apply SepI... rewrite e_ap...
  ext Hx.
  - apply ReplAx in Hx as [s [Hs Hx]].
    apply SepE2 in Hs as Hst. apply Hsub in Hs.
    apply SepE in Hs as [Hs Heq]. rewrite <- Hx, Heq.
    eapply e_ap_order. apply HAsub... apply HAsub...
    rewrite HRsub in Hst. apply SepE1 in Hst...
  - apply e_elim in Hx as [s [Hs [Hst [Heq Hx]]]]; [|apply HAsub]...
    assert (Hst': (s <ᵣ t) (R S)). {
      rewrite HRsub. apply SepI... apply CPrdI...
      contra.
      eapply lo_irrefl. apply (wo T).
      destruct (wo T) as [[_ [Htr _]] _].
      eapply Htr... apply Hop... apply SepI...
    }
    assert (s ∈ seg t (R S)). apply SepI... eapply domI...
    apply ReplAx. exists s. split...
    apply Hsub in H. apply SepE2 in H. congruence.
Qed.

Lemma Es_is_chain : ∀ 𝒞, wos 𝒞 → ees 𝒞 → is_chain (Es 𝒞).
Proof.
  intros 𝒞 Hwos Hees B HB C HC.
  apply ReplAx in HB as [p [Hp HB]].
  apply ReplAx in HC as [q [Hq HC]].
  pose proof (Hwos p Hp) as [S HS].
  pose proof (Hwos q Hq) as [T HT].
  unfold WOₛ_spec in HS, HT. subst.
  repeat rewrite Eₛ_pair.
  pose proof (Hees S T Hp Hq) as [].
  - left. apply E_restr in H. rewrite H.
    intros x Hx. now apply SepE1 in Hx.
  - right. apply E_restr in H. rewrite H.
    intros x Hx. now apply SepE1 in Hx.
Qed.

(* 良序结构集集的并 *)
Definition Unionₐ := λ 𝒞, ⋃{π1 p | p ∊ 𝒞}.
Definition Unionᵣ := λ 𝒞, ⋃{π2 p | p ∊ 𝒞}.

Lemma Unionₐ_eq : ∀ 𝒞, wos 𝒞 → Unionₐ 𝒞 = ⋃{dom f | f ∊ Es 𝒞}.
Proof.
  intros 𝒞 Hwos. unfold Unionₐ. f_equal.
  ext Hx.
  - apply ReplAx in Hx as [p [Hp Heqx]].
    pose proof (Hwos p Hp) as [S HS].
    unfold WOₛ_spec in HS. subst. zfc_simple.
    apply ReplAx. exists (E S). split.
    apply ReplAx. exists <A S, R S>. split; auto.
    now rewrite Eₛ_pair. apply e_spec.
  - apply ReplAx in Hx as [F [HF Heqx]].
    apply ReplAx in HF as [p [Hp HeqF]]. subst.
    pose proof (Hwos p Hp) as [S HS].
    unfold WOₛ_spec in HS. subst. rewrite Eₛ_pair.
    apply ReplAx. exists <A S, R S>. split; auto.
    zfc_simple. symmetry. apply e_spec.
Qed.

Lemma sup_ordsₛ_eq : ∀ 𝒞, wos 𝒞 → sup (ordsₛ 𝒞) = ⋃{ran f | f ∊ Es 𝒞}.
Proof.
  intros 𝒞 Hwos. unfold sup. f_equal.
  ext Hx.
  - apply ReplAx in Hx as [p [Hp Heqp]].
    apply ReplAx. exists (Eₛ p). split; auto.
    now apply ReplI.
  - apply ReplAx in Hx as [F [HF HeqF]].
    apply ReplAx in HF as [p [Hp Heqp]].
    apply ReplAx. exists p. split; auto.
    subst. reflexivity.
Qed.

Lemma union_of_Es_is_bijection : ∀ 𝒞, wos 𝒞 → ees 𝒞 →
  ⋃(Es 𝒞): Unionₐ 𝒞 ⟺ sup (ordsₛ 𝒞).
Proof.
  intros 𝒞 Hwos Hees.
  rewrite Unionₐ_eq, sup_ordsₛ_eq; auto.
  apply union_of_chain_of_injective_functions.
  now apply Es_is_chain. intros f Hf.
  apply ReplAx in Hf as [p [Hp Heq]]. subst.
  apply e_injective.
Qed.

Lemma union_of_Es_preserves_order : ∀ 𝒞, wos 𝒞 → ees 𝒞 →
  let f := ⋃(Es 𝒞) in
  let r := MemberRel (sup (ordsₛ 𝒞)) in
  ∀ x y ∈ Unionₐ 𝒞, (x <ᵣ y) (Unionᵣ 𝒞) ↔ (f[x] <ᵣ f[y]) r.
Proof with eauto; try congruence.
  intros 𝒞 Hwos Hees f r x Hx y Hy. unfold r, f.
  pose proof (union_of_Es_is_bijection 𝒞 Hwos Hees) as Hbi.
  apply bijection_is_func in Hbi as [Hmf [Hinj Hr]].
  assert (H := Hmf). destruct H as [Hf [Hd _]].
  rewrite <- Hd in Hx, Hy.
  assert (H := Hx). apply domE in H as [z1 H1].
  assert (H := Hy). apply domE in H as [z2 H2].
  apply func_ap in H1 as Hap2...
  apply func_ap in H2 as Hap1... subst.
  apply UnionAx in H1 as [F [HF H1]].
  apply UnionAx in H2 as [G [HG H2]].
  apply ReplAx in HF as [u [Hu HF]].
  apply ReplAx in HG as [v [Hv HG]]. subst.
  pose proof (Hwos u Hu) as [U HU].
  pose proof (Hwos v Hv) as [V HV].
  pose proof (e_bijective U) as [[HfU _] [HdU _]].
  pose proof (e_bijective V) as [[HfV _] [HdV _]].
  unfold WOₛ_spec in HU, HV. subst.
  rewrite Eₛ_pair in H1, H2.
  apply domI in H1 as Hd1. apply func_ap in H1...
  apply domI in H2 as Hd2. apply func_ap in H2...
  split; intros Hlt.
  - apply UnionAx in Hlt as [p [Hp Hlt]].
    apply ReplAx in Hp as [s [Hs Hp]].
    pose proof (Hwos s Hs) as [S HS].
    unfold WOₛ_spec in HS. subst. zfc_simple.
    apply binRelI. eapply ap_ran... eapply ap_ran...
    rewrite <- H1, <- H2.
    pose proof (Hees U V Hu Hv) as [];
    apply E_restr in H as Heq; rewrite Heq;
    destruct H as [[Hsub Hrsub] Hop].
    + assert (HxV: x ∈ A V). apply Hsub...
      erewrite restr_ap; revgoals... apply e_ap_order...
      pose proof (Hees S V Hs Hv) as [[[_ H] _]|[[_ H] _]].
      * rewrite H in Hlt. apply SepE1 in Hlt...
      * rewrite H. apply SepI... apply CPrdI...
    + assert (HyU: y ∈ A U). apply Hsub...
      erewrite restr_ap; revgoals... apply e_ap_order...
      pose proof (Hees S U Hs Hu) as [[[_ H] _]|[[_ H] _]].
      * rewrite H in Hlt. apply SepE1 in Hlt...
      * rewrite H. apply SepI... apply CPrdI...
  - apply binRelE3 in Hlt. rewrite <- H1, <- H2 in Hlt.
    pose proof (Hees U V Hu Hv) as [];
    apply E_restr in H as Heq;
    destruct H as [[Hsub Hrsub] Hop].
    + apply UnionAx. exists (R V). split.
      apply ReplAx. exists <A V, R V>. split... zfc_simple.
      assert (HxV: x ∈ A V). apply Hsub...
      apply e_preserve_order... apply binRelI.
      apply e_ap_in_α... apply e_ap_in_α...
      erewrite Heq, restr_ap in Hlt; revgoals...
    + apply UnionAx. exists (R U). split.
      apply ReplAx. exists <A U, R U>. split... zfc_simple.
      assert (HyU: y ∈ A U). apply Hsub...
      apply e_preserve_order... apply binRelI.
      apply e_ap_in_α... apply e_ap_in_α...
      erewrite Heq, restr_ap in Hlt; revgoals...
Qed.

Lemma sup_ordsₛ_is_ord : ∀ 𝒞, sup (ordsₛ 𝒞) ⋵ 𝐎𝐍.
Proof.
  intros. apply union_of_ords_is_ord.
  intros α Hα. apply ReplAx in Hα as [p [_ Heq]].
  subst. apply ord_is_ord.
Qed.

Lemma union_wos_is_binRel : ∀ 𝒞, wos 𝒞 →
  is_binRel (Unionᵣ 𝒞) (Unionₐ 𝒞).
Proof.
  intros 𝒞 Hwos x Hx.
  apply UnionAx in Hx as [a [Ha Hx]].
  apply ReplAx in Ha as [p [Hp HR]].
  pose proof (Hwos p Hp) as [S HS].
  unfold WOₛ_spec in HS. subst. zfc_simple.
  destruct (wo S) as [[Hbr _] _]. apply Hbr in Hx.
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]]. subst.
  apply CPrdI; apply UnionAx; exists (A S); split; auto;
  apply ReplAx; exists <A S, R S>; split; auto; zfc_simple.
Qed.

(* 良序结构尾扩张集集的并是良序结构集 *)
Lemma union_wos_is_woet : ∀ 𝒞, wos 𝒞 → ees 𝒞 →
  woset (Unionₐ 𝒞) (Unionᵣ 𝒞).
Proof.
  intros 𝒞 Hwos Hees.
  pose proof (union_wos_is_binRel 𝒞 Hwos) as Hbr.
  set (OrderedStruct.constr (Unionₐ 𝒞) (Unionᵣ 𝒞) Hbr) as S.
  cut (OrderedStruct.wo S). easy.
  pose proof (sup_ordsₛ_is_ord 𝒞) as [T HT].
  apply (OrderedStruct.iso_wo (parent (Epsilon T))); [|apply wo].
  symmetry. exists (⋃(Es 𝒞)).
  split; simpl; unfold ord in HT; [|unfold ε]; rewrite <- HT.
  now apply union_of_Es_is_bijection.
  now apply union_of_Es_preserves_order.
Qed.

Definition unionStruct_spec := λ 𝒞 S,
  A S = Unionₐ 𝒞 ∧ R S = Unionᵣ 𝒞.

Lemma unionStruct_exists : ∀ 𝒞, wos 𝒞 → ees 𝒞 →
  ∃! S, unionStruct_spec 𝒞 S.
Proof.
  intros 𝒞 Hwos Hees.
  pose proof (union_wos_is_woet 𝒞 Hwos Hees) as Hwo.
  rewrite <- unique_existence. split.
  - exists (constr (Unionₐ 𝒞) (Unionᵣ 𝒞) Hwo). split; auto.
  - intros S T [H11 H12] [H21 H22].
    apply eq_intro; congruence.
Qed.

(* 对良序结构集集取并得到良序结构类型 *)
Definition UnionStruct :=
  λ 𝒞, iota (inhabits ø̃) (unionStruct_spec 𝒞).
Notation "⊔ 𝒞" := (UnionStruct 𝒞) (at level 9, format "⊔ 𝒞") : WoStruct_scope.

Lemma unionStruct_spec_intro : ∀ 𝒞, wos 𝒞 → ees 𝒞 →
  unionStruct_spec 𝒞 ⊔𝒞.
Proof.
  intros 𝒞 Hwos Hees.
  apply (iota_spec (inhabits ø̃) (unionStruct_spec 𝒞)).
  apply unionStruct_exists; auto.
Qed.

(* 良序结构尾扩张集集𝒞的并的序数等于𝒞对应序数集的上确界 *)
Lemma ord_union_eq_sup_ordsₛ_wos : ∀ 𝒞,
  wos 𝒞 → ees 𝒞 → ord ⊔𝒞 = sup (ordsₛ 𝒞).
Proof.
  intros 𝒞 Hwos Hees.
  pose proof (unionStruct_spec_intro 𝒞 Hwos Hees) as [HA HR].
  assert (Ho: sup (ordsₛ 𝒞) ⋵ 𝐎𝐍). apply sup_ordsₛ_is_ord.
  destruct Ho as [S HS]. rewrite HS.
  apply ord_well_defined. rewrite (iso_epsilon S).
  exists (⋃(Es 𝒞)). split; simpl; unfold ord in HS;
  rewrite HA; [|rewrite HR; unfold ε]; rewrite <- HS.
  now apply union_of_Es_is_bijection.
  now apply union_of_Es_preserves_order.
Qed.

(* 从序数到良序结构集 *)
Definition woₒ := λ α, <α, MemberRel α>.
(* 从序数到良序结构类型 *)
Definition WOₒ := λ α, WOₛ (woₒ α).

(*
  ord WOₛ woₒ α =
  ord WOₒ      α =
  ordₛ    woₒ α = α
*)

Lemma WOₛ_eq_Epsilon : ∀ S,
  WOₛ <ord S, MemberRel (ord S)> = Epsilon S.
Proof.
  intros. replace <ord S, MemberRel (ord S)> with <A (Epsilon S), R (Epsilon S)>.
  now rewrite WOₛ_pair_id. now apply op_iff.
Qed.

Lemma A_WOₒ_id : ∀α ⋵ 𝐎𝐍, A (WOₒ α) = α.
Proof.
  intros α [S HS]. subst. unfold WOₒ, woₒ.
  now rewrite WOₛ_eq_Epsilon.
Qed.

Lemma R_WOₒ : ∀α ⋵ 𝐎𝐍, R (WOₒ α) = MemberRel α.
Proof.
  intros α [S HS]. subst. unfold WOₒ, woₒ.
  now rewrite WOₛ_eq_Epsilon.
Qed.

Lemma ord_WOₒ_id : ∀α ⋵ 𝐎𝐍, ord (WOₒ α) = α.
Proof.
  intros α [S HS]. subst. unfold WOₒ, woₒ.
  now rewrite WOₛ_eq_Epsilon, <- ord_of_ord.
Qed.

Lemma ordₛ_woₒ_id : ∀α ⋵ 𝐎𝐍, ordₛ (woₒ α) = α.
Proof.
  intros α H. now rewrite <- (ord_WOₒ_id α) at 2.
Qed.

(* 从序数(集)到良序结构集集 *)
Definition wosₒ := λ A, {woₒ α | α ∊ A}.

Lemma ordsₛ_wosₒ_id : ∀ A, A ⪽ 𝐎𝐍 → ordsₛ (wosₒ A) = A.
Proof with auto.
  intros A Hsub. unfold ordsₛ, wosₒ.
  ext Hx.
  - apply ReplAx in Hx as [p [Hp Hx]].
    apply ReplAx in Hp as [α [Hα Hp]]. subst.
    rewrite ordₛ_woₒ_id...
  - apply ReplAx. exists (woₒ x). split.
    apply ReplAx. exists x. split...
    apply ordₛ_woₒ_id...
Qed.

Lemma wosₒ_is_wos : ∀ A, A ⪽ 𝐎𝐍 → wos (wosₒ A).
Proof with eauto.
  intros A Hsub p Hp.
  apply ReplAx in Hp as [ξ [Hξα Heq]]. subst.
  assert (Hoξ: ξ ⋵ 𝐎𝐍)...
  destruct Hoξ as [S HS]. subst.
  exists (Epsilon S). apply op_iff...
Qed.

Lemma wosₒ_is_ees : ∀ A, A ⪽ 𝐎𝐍 → ees (wosₒ A).
Proof with eauto; try congruence.
  intros B Hsub S T HS HT.
  apply ReplAx in HS as [β [Hβα Heqβ]].
  apply ReplAx in HT as [γ [Hγα Heqγ]].
  assert (Hoβ: β ⋵ 𝐎𝐍)...
  assert (Hoγ: γ ⋵ 𝐎𝐍)...
  apply op_iff in Heqβ as [H11 H12].
  apply op_iff in Heqγ as [H21 H22].
  pose proof (ord_comparability β Hoβ γ Hoγ) as []; subst;
  apply ord_le_iff_sub in H; auto; [left|right]; repeat split...
  - rewrite <- H12, <- H22.
    ext Hx.
    + apply binRelE1 in Hx as [a [Ha [b [Hb [Hx Hab]]]]]. subst.
      apply SepI. apply binRelI... apply CPrdI...
    + apply SepE in Hx as [H1 H2].
      apply CPrdE1 in H2 as [a [Ha [b [Hb Heq]]]]. subst.
      apply binRelE3 in H1. apply binRelI...
  - intros x Hx y Hy. apply SepE in Hy as [Hy Hy'].
    assert (Hoy: y ⋵ 𝐎𝐍). eapply ord_is_ords...
    apply ord_le_iff_not_gt in Hy'...
    rewrite <- H22. apply binRelI...
    destruct Hy'... eapply ord_trans...
  - rewrite <- H12, <- H22.
    ext Hx.
    + apply binRelE1 in Hx as [a [Ha [b [Hb [Hx Hab]]]]]. subst.
      apply SepI. apply binRelI... apply CPrdI...
    + apply SepE in Hx as [H1 H2].
      apply CPrdE1 in H2 as [a [Ha [b [Hb Heq]]]]. subst.
      apply binRelE3 in H1. apply binRelI...
  - intros x Hx y Hy. apply SepE in Hy as [Hy Hy'].
    assert (Hoy: y ⋵ 𝐎𝐍). apply (ord_is_ords (A S))...
    apply ord_le_iff_not_gt in Hy'...
    rewrite <- H12. apply binRelI...
    destruct Hy'... eapply ord_trans...
Qed.

(* 序数集A的结构集集的并的序数等于A的上确界 *)
Lemma ord_union_eq_sup_of_ords : ∀ A,
  A ⪽ 𝐎𝐍 → ord ⊔(wosₒ A) = sup A.
Proof with auto.
  intros A Hsub.
  rewrite <- (ordsₛ_wosₒ_id A) at 2...
  apply ord_union_eq_sup_ordsₛ_wos.
  apply wosₒ_is_wos... apply wosₒ_is_ees...
Qed.


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 P X B1 B2 : Universe, ((wd_ P A1 /\ (wd_ P B1 /\ (wd_ A1 X /\ (wd_ P X /\ (wd_ A1 A2 /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (wd_ A2 B1 /\ (wd_ A2 B2 /\ (wd_ B1 B2 /\ (wd_ P A2 /\ (wd_ X A2 /\ (col_ P B1 B2 /\ (col_ X P A2 /\ col_ P A1 X)))))))))))))) -> col_ P A1 A2)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 A B C D X : Universe, ((wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ Eprime A /\ (wd_ X O /\ (wd_ B X /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime X /\ col_ O E X))))))))))))))) -> col_ O E Eprime)).
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 conj20eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj20eqsynthconj4.


Require Import Raft.

Require Import CommonTheorems.
Require Import SpecLemmas.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import AppendEntriesReplySublogInterface.

Require Import MatchIndexSanityInterface.
Require Import SortedInterface.

Section MatchIndexSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {aersi : append_entries_reply_sublog_interface}.
  Context {si : sorted_interface}.

  Lemma match_index_sanity_init :
    raft_net_invariant_init match_index_sanity.
  Proof using.
    unfold raft_net_invariant_init, match_index_sanity.
    simpl.
    intuition.
  Qed.

  Ltac update_destruct :=
    match goal with
    | [ H : context [ update _ ?x _ ?y ] |- _ ] =>
      destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
    | [ |- context [ update _ ?x _ ?y ] ] =>
      destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
    end.

  Lemma match_index_sanity_client_request :
    raft_net_invariant_client_request match_index_sanity.
  Proof using.
    unfold raft_net_invariant_client_request, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_copy_apply_lem_hyp handleClientRequest_type.
      find_copy_apply_lem_hyp handleClientRequest_matchIndex.
      intuition.
      + repeat find_rewrite. auto.
      + repeat find_rewrite.
        destruct (name_eq_dec h0 leader).
        * subst. rewrite get_set_same_default. auto.
        * rewrite get_set_diff_default by auto.
          eauto using le_trans.
    - auto.
  Qed.

  Lemma match_index_sanity_preserved :
    forall st st',
      matchIndex_preserved st st' ->
      (forall h,
          type st = Leader ->
          assoc_default name_eq_dec (matchIndex st) h 0 <=
          maxIndex (log st)) ->
      (forall h,
          type st' = Leader ->
          assoc_default name_eq_dec (matchIndex st') h 0 <=
          maxIndex (log st')).
  Proof using.
    unfold matchIndex_preserved.
    intros. intuition.
    repeat find_rewrite.
    auto.
  Qed.

  Lemma match_index_sanity_timeout :
    raft_net_invariant_timeout match_index_sanity.
  Proof using.
    unfold raft_net_invariant_timeout, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_apply_lem_hyp handleTimeout_matchIndex_preserved.
      eauto using match_index_sanity_preserved.
    - auto.
  Qed.

  Lemma match_index_sanity_append_entries :
    raft_net_invariant_append_entries match_index_sanity.
  Proof using.
    unfold raft_net_invariant_append_entries, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_apply_lem_hyp handleAppendEntries_matchIndex_preserved.
      eauto using match_index_sanity_preserved.
    - auto.
  Qed.

  Lemma handleAppendEntriesReply_matchIndex :
    forall h st st' m t es res h',
      handleAppendEntriesReply h st h' t es res = (st', m) ->
      type st' = Leader ->
      type st = Leader /\
      (matchIndex st' = matchIndex st \/
       res = true /\
       currentTerm st = t /\
      matchIndex st' =
      (assoc_set name_eq_dec (matchIndex st) h'
                 (Nat.max (assoc_default name_eq_dec (matchIndex st) h' 0)
                          (maxIndex es)))).
  Proof using.
    unfold handleAppendEntriesReply, advanceCurrentTerm.
    intros.
    repeat break_match; repeat find_inversion; do_bool; auto.
  Qed.

  Lemma match_index_sanity_append_entries_reply :
    raft_net_invariant_append_entries_reply match_index_sanity.
  Proof using si aersi.
    unfold raft_net_invariant_append_entries_reply, match_index_sanity.
    simpl. intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - erewrite handleAppendEntriesReply_log by eauto.
      find_copy_apply_lem_hyp handleAppendEntriesReply_matchIndex; auto.
      intuition.
      + repeat find_rewrite. auto.
      + repeat find_rewrite.
        destruct (name_eq_dec h (pSrc p)).
        * subst. rewrite get_set_same_default.
          apply Max.max_case; auto.
          { destruct es; simpl.
            * omega.
            * pose proof append_entries_reply_sublog_invariant _ ltac:(eauto).
              unfold append_entries_reply_sublog in *.
              eapply_prop_hyp pBody pBody; simpl; eauto.
              apply maxIndex_is_max; auto.
              apply logs_sorted_invariant; auto.
          }
        * rewrite get_set_diff_default by auto.
          auto.
    - auto.
  Qed.

  Lemma match_index_sanity_request_vote :
    raft_net_invariant_request_vote match_index_sanity.
  Proof using.
    unfold raft_net_invariant_request_vote, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_apply_lem_hyp handleRequestVote_matchIndex_preserved.
      eauto using match_index_sanity_preserved.
    - auto.
  Qed.

  Lemma handleRequestVoteReply_matchIndex :
    forall n st src t v,
      type (handleRequestVoteReply n st src t v) = Leader ->
      type st = Leader /\
      matchIndex (handleRequestVoteReply n st src t v) =
      matchIndex st \/
      matchIndex (handleRequestVoteReply n st src t v) =
      (assoc_set name_eq_dec nil n (maxIndex (log st))).
  Proof using.
    unfold handleRequestVoteReply, advanceCurrentTerm.
    intros.
    repeat break_match; repeat find_inversion; auto; simpl in *; try congruence.
  Qed.

  Lemma match_index_sanity_request_vote_reply :
    raft_net_invariant_request_vote_reply match_index_sanity.
  Proof using.
    unfold raft_net_invariant_request_vote_reply, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - pose proof handleRequestVoteReply_matchIndex (pDst p) (nwState net (pDst p)) (pSrc p) t v.
      erewrite handleRequestVoteReply_log by eauto.
      intuition.
      + repeat find_rewrite. auto.
      + repeat find_rewrite.
        destruct (name_eq_dec h (pDst p)).
        * subst. rewrite get_set_same_default. auto.
        * rewrite get_set_diff_default by auto.
          unfold assoc_default. simpl. omega.
    - auto.
  Qed.

  Lemma match_index_sanity_do_leader :
    raft_net_invariant_do_leader match_index_sanity.
  Proof using.
    unfold raft_net_invariant_do_leader, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_apply_lem_hyp doLeader_matchIndex_preserved.
      eauto using match_index_sanity_preserved.
    - auto.
  Qed.

  Lemma match_index_sanity_do_generic_server :
    raft_net_invariant_do_generic_server match_index_sanity.
  Proof using.
    unfold raft_net_invariant_do_generic_server, match_index_sanity.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct.
    - find_apply_lem_hyp doGenericServer_matchIndex_preserved.
      eauto using match_index_sanity_preserved.
    - auto.
  Qed.

  Lemma match_index_sanity_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset match_index_sanity.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset, match_index_sanity.
    simpl. intros.
    repeat find_reverse_higher_order_rewrite.
    auto.
  Qed.

  Lemma match_index_sanity_reboot :
    raft_net_invariant_reboot match_index_sanity.
  Proof using.
    unfold raft_net_invariant_reboot, match_index_sanity, reboot.
    simpl.
    intros.
    subst.
    repeat find_higher_order_rewrite.
    update_destruct.
    - unfold assoc_default. simpl. omega.
    - auto.
  Qed.

  Lemma match_index_sanity_invariant :
    forall net,
      raft_intermediate_reachable net ->
      match_index_sanity net.
  Proof using si aersi.
    intros.
    apply raft_net_invariant; auto.
    - apply match_index_sanity_init.
    - apply match_index_sanity_client_request.
    - apply match_index_sanity_timeout.
    - apply match_index_sanity_append_entries.
    - apply match_index_sanity_append_entries_reply.
    - apply match_index_sanity_request_vote.
    - apply match_index_sanity_request_vote_reply.
    - apply match_index_sanity_do_leader.
    - apply match_index_sanity_do_generic_server.
    - apply match_index_sanity_state_same_packet_subset.
    - apply match_index_sanity_reboot.
  Qed.
  Instance matchisi : match_index_sanity_interface.
  Proof.
    split.
    exact match_index_sanity_invariant.
  Qed.
End MatchIndexSanity.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Require Import Definitions.

Require Import utils pos vec.
Require Import subcode sss mm_defs.
Require Import eill eill_mm.

Local Notation "P '/MM/' s ->> t" := (sss_compute (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s ~~> t" := (sss_output (@mm_sss _) P s t) (at level 70, no associativity).

Section MM_HALTING_EILL_PROVABILITY.

  Let f : MM_PROBLEM -> EILL_SEQUENT.
  Proof.
    intros (n & P & v).
    exact (Sig (1,P) 0, vec_map_list v (fun p : pos n => pos2nat p), 2 * n + 1).
  Defined.

  Theorem MM_HALTING_EILL_PROVABILITY : MM_HALTING ⪯ EILL_PROVABILITY.
  Proof.
    exists f.
    intros (n & P & v); simpl.
    rewrite <- G_eill_mm; simpl; auto.
    split.
    + intros (? & _); auto.
    + split; simpl; auto.
  Qed.

End MM_HALTING_EILL_PROVABILITY.


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_ A1 A2 /\ (wd_ C1 C2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ A1 C1 C2 /\ col_ A2 C1 C2))))))))) -> col_ C2 B1 B2)).
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 conj5synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 lv0)).
Admitted.
QuickChick conj5synthconj6.


(************************************************************************)
(* Copyright (c) 2020, 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                            *)
(************************************************************************)

Require Export C_ShallowEmbedding.

(*******************************************************************************)
(************************* Orderding on ComputationType ***************************)
(*******************************************************************************)

(* Reserved Notation "t0 << t1" (at level 80, no associativity).*)

Reserved Notation "t0 <<< t1" (at level 80, no associativity).

(*lt means less than*)
Inductive hag_lt : ComputationType -> ComputationType -> Prop :=
| Det_Hon : Deterministic <<< Honest
| Det_Adv : Deterministic <<< Adversarial
| Hon_Mix : Honest <<< Mixed
| Adv_Mix : Adversarial <<< Mixed
| Mix_Gen : Mixed <<< General
| hag_nil : forall {t}, t <<< t
| hag_trans : forall {t0 t1 t2}, t0 <<< t1 -> t1 <<< t2 -> t0 <<< t2
where "t0 <<< t1" := (hag_lt t0 t1).

Definition hag_ltb (t1 t2: ComputationType) : bool :=
  match t1 with
  | Deterministic => true
  | Honest => match t2 with
             | Deterministic => false
             | Adversarial => false
             | _ => true
             end
  | Adversarial => match t2 with
                   | Deterministic => false
                  | Honest => false
                  | _ => true
                  end
  | Mixed => match t2 with
              | Mixed => true
              | General => true
              | _ => false
              end
  | General => match t2 with
              | General => true
              | _ => false
              end
  end.

Lemma hag_ltb_lt : forall t1 t2, hag_ltb t1 t2 = true <-> t1 <<< t2.
  split; intros.
  destruct t1; destruct t2; try inversion H; try repeat constructor;
    match goal with
    | |-  Deterministic <<< General =>
      apply (@hag_trans Deterministic Honest General); try repeat constructor
    | |- ?t1 <<< ?t2 =>
      apply (@hag_trans t1 t2 t2); try repeat constructor
    end.
  apply (@hag_trans Deterministic Honest Mixed); constructor.
  apply (@hag_trans Honest Mixed General); constructor.
  apply (@hag_trans Honest Mixed General); constructor.
  apply (@hag_trans Adversarial Mixed General); constructor.
  induction H. all: auto.
  destruct t; auto.
 destruct t0; destruct t1; destruct t2; auto.
Qed.

Lemma hag_reflect : forall t1 t2, reflect (t1 <<< t2) (hag_ltb t1 t2).
  intros t1 t2.
  apply iff_reflect.
  apply (iff_sym (hag_ltb_lt t1 t2)).
Qed.

Ltac ProveHag :=
  match goal with
  | H: ?t0 <<< ?t2 , H0: ?t1 <<< ?t0  |- ?t1 <<< ?t2 => apply (@hag_trans t1 t0 t2)
  | |- ?t1 <<< ?t2 => assert (Prove_HAG := hag_reflect t1 t2); inversion Prove_HAG; auto ; clear Prove_HAG
  end.

Goal Deterministic <<< General.
ProveHag.
Defined.

Goal General <<< General.
  ProveHag.
Defined.

Theorem ppt_up
  : forall {t0 t1 f},
    t0 <<< t1 -> PPT t0 f -> PPT t1 f.
Proof.   intros.
  induction H.
  - apply DeterministicHonest; auto.
  - apply DeterministicAdversarial; auto.
  - apply HonestMixed; auto.
  - apply AdversarialMixed; auto.
  - apply MixedGeneral; auto.
  - auto.
  - apply IHhag_lt2. apply IHhag_lt1. auto.
Qed.

(**************************************************************************************)
(**************************************************************************************)
(*************************** Auxilliary Functions for Lists ***************************)
(**************************************************************************************)
(**************************************************************************************)

(* 0th entry, head of a list. nil is mappted to default *)
Definition HD (lx : list ppt) : ppt :=  hd default lx.

(* Tail of a list, taking off the first enrty *)
Definition TL (lx : list ppt) : list ppt :=  tl lx.

(* Mapping on the nth element. nil is mappted to default *)
Definition Nth (n : nat) (lx : list ppt) := nth n lx default.

(* Zeroth element and Head are the same *)
Lemma ZerothisHD :
      Nth 0 = HD.
Proof. apply functional_extensionality. intros. induction x. cbn.
 reflexivity. cbn. reflexivity. Qed.

(* S(n)th element and the nth of the tail are the same *)
Lemma SnthisnthTL :
      forall {n} ,
        (fun lx => Nth (S n) lx) = (fun lx => Nth  n (TL lx)).
Proof. intros. apply functional_extensionality. intros. induction x.
cbn. induction n. reflexivity. reflexivity. cbn. reflexivity. Qed.

(* concetanating the head and the tail is the identity map on non-nil. *)
Lemma IDisHDTL :
      forall {lx} ,
        lx <> [] -> lx = (HD lx) :: (TL lx).
Proof. intros. induction lx. destruct H. reflexivity. cbn. reflexivity. Qed.

(**************************************************************************************)
(**************************************************************************************)
(************************************** PPT Ltac **************************************)
(**************************************************************************************)
(**************************************************************************************)

Ltac ProvePPT :=
  repeat ( intros;
match goal with
|H : ?prop |- ?prop => apply H
| |- ?hag1 <<< ?hag2  => ProveHag
|   |- PPT _ (fun _ : list ppt => ConstInt _ _) => apply ConstHAG
      |   |- PPT ?hag (FuncInt ?hag ?arg ?f) => apply FunHAG
      |   |- PPT ?hag2 (FuncInt ?hag1 ?arg ?f) => apply (@ppt_up hag1 hag2)
      |H: PPT ?hag1 ?f  |- PPT ?hag2 ?f => apply (@ppt_up hag1 hag2)
  end).

(* Deterministic algorithms are in particular Honest, Adversarial and General *)
Proposition DeterministicHAG :
      forall {lf : list ppt -> ppt} ,
        (PPT Deterministic) lf
         -> forall (hag : ComputationType) , (PPT hag) lf.
Proof.
  intros. destruct hag. all: ProvePPT.
 Qed.

Proposition HAGGeneral :
      forall (hag : ComputationType) , forall {lf : list ppt -> ppt} ,
          (PPT hag) lf
            -> (PPT General) lf .
Proof.
  intros.
  destruct hag. all : ProvePPT.
Qed.

Proposition GeneralHAG :
      forall {f} {P : Prop} , (PPT General f -> P) ->
forall hag , (PPT hag f -> P).
Proof.
  intros. apply H.  apply (HAGGeneral hag). auto.
Qed.

Proposition HonestGeneral :
      forall {lf : list ppt -> ppt} ,
        (PPT Honest) lf
        -> (PPT General) lf.
Proof. ProvePPT. Qed.

Proposition AdversarialGeneral :
      forall {lf : list ppt -> ppt} ,
        (PPT Adversarial) lf
         -> (PPT Mixed) lf.
Proof. ProvePPT. Qed.

(**************************************************************************************)
(**************************************************************************************)
(************************************** CONTEXTS **************************************)
(**************************************************************************************)
(**************************************************************************************)

(****************************** some auxiliary functions *****************************)

(* Labels to distinguish ppt and list ppt *)

Inductive TermOrList : Set :=
| Term
| List.

Definition ToL (tol : TermOrList) : Set :=
match tol with
| Term => ppt
| List => list ppt
end.

(* Id represents the identity function for ppt -> ppt and
  for list ppt -> list ppt. For ppt -> list ppt it assigns [x] to x, and
for list ppt -> ppt it assigns HD lx to lx*)

Definition Id (tol : TermOrList ) (tol' : TermOrList ) : (ToL tol) -> (ToL tol') :=
match tol with
| Term => match tol' with Term => (fun x : ppt => x) | List => (fun x : ppt => [x]) end
| List => match tol' with Term => (fun lx : list ppt => Nth 0 lx) | List => (fun lx : list ppt => lx) end
end.

Proposition IdNth :
forall tol, (fun x  => Id tol Term x ) = (fun x  => Nth 0 (Id tol List x )).
Proof. intros. destruct tol.
  - unfold Id at 2. unfold HD. simpl. auto.
  - unfold Id. auto.
Qed.

(**************************************************************************************)
(********************************* Context Definition *********************************)
(**************************************************************************************)

(* Context is something that is a term context created with our function symbols. Accordingly,
it has Deterministic, Honest, Adversarial, General versions. *)

Section Context.
(* Recursive definition of a Context outputting a list ppt and a ContextTerm outputting
a ppt. The input for both is (ToL tol), which is either ppt or list ppt.
for each hag Deterministic, Honest, Adversarial, General, contexts are defined.
 *)
(* Parameter ListContext : ComputationType -> (list ppt -> list ppt) -> Prop. *)
(* Parameter TermContext : ComputationType -> (ppt -> list ppt) -> Prop. *)
Variable hag : ComputationType.
(* Below ct is for ContextTerm variables, c is for Context variables *)

(* It might be useful to separate contexts with list operations and ID and those with function
symbols *)

Inductive Context (tol : TermOrList) : (ToL tol -> list ppt) -> Prop :=  (* metapredicate *)
| clength   :
      forall {c n} ,
        Context tol c
        -> Context  tol (fun x => (skipn ((length (c x)) - n) (c x)))
| cApp  :
      forall {c1 c2},
        Context tol c1
        -> Context tol c2
        -> Context tol  (fun x => (c1 x)++(c2 x))
| cNth :
      forall {c},
      (forall n, ContextTerm tol (fun x => (Nth n (c x)))) ->
      Context tol c
| cId  :
    Context tol (Id tol List)
with ContextTerm (tol : TermOrList)  : (ToL tol -> ppt) -> Prop :=
| ctId   :
      ContextTerm tol (Id tol Term)
| ctNth :
      forall {n c},
        Context tol c
          -> ContextTerm tol (fun x => (Nth n (c x)))
| ctCT:
      forall {f: list ppt -> ppt} {c : ToL tol -> list ppt} ,
        (PPT hag) f
        -> Context tol c
        -> ContextTerm tol  (fun x => (f (c x))).
End Context.

(**************************************************************************************)
(********************************* Mutual Induction *********************************)
(**************************************************************************************)

Scheme Context_mut := Minimality for Context Sort Prop
  with ContextTerm_mut := Minimality for ContextTerm Sort Prop.

(**************************************************************************************)
(********************************* Properties *********************************)
(**************************************************************************************)

Proposition Nth0_and_HD : forall lx, Nth 0 lx = HD lx.
  intros.
unfold HD.  unfold Nth.
induction lx.
auto.
simpl.
reflexivity.
Qed.

Proposition IdHD :
forall tol, (fun x  => Id tol Term x ) = (fun x  => HD (Id tol List x )).
Proof. intros. destruct tol.
  - unfold Id at 2. unfold HD. simpl. auto.
  - unfold Id. apply functional_extensionality.
    intros. rewrite Nth0_and_HD. auto.
Qed.

Proposition Nth_and_TL : forall lx n, Nth (S n) lx = Nth n (TL lx).
  intros.
  unfold TL.  unfold Nth.
  induction n.
induction lx.
simpl.
reflexivity.
simpl.
reflexivity.
induction lx. simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Proposition ctHD  :
      forall {hag tol c} ,
        Context hag tol c
        -> ContextTerm  hag tol (fun x => (HD (c x))).
Proof.
  intros.
  assert ( (fun x : ToL tol => HD (c x)) =  (fun x : ToL tol => Nth 0 (c x)) ).
  apply functional_extensionality.
  intros.
  rewrite  Nth0_and_HD.
  reflexivity.
  rewrite H0.
  apply ctNth.
  assumption.
Qed.

(* ConstInt map of the right hag class is ContextTerm *)
Proposition ctPPT0 :
      forall {hag tol x0} ,
        (PPT hag) (fun lx => x0)
        -> ContextTerm hag tol (fun x => x0).
Proof. intros.   apply (@ctCT hag tol (fun lx : list ppt => x0) (Id tol List) H).
apply cId. Qed.

Proposition DetFSContext :
  forall arg  hag f,
    ContextTerm hag List (FuncInt Deterministic arg f).
Proof. intros.   apply ctCT. destruct hag ; ProvePPT. apply cId. Qed.

Proposition DetCSContext :
  forall c  hag tol,
    ContextTerm hag tol (fun lx => ConstInt Deterministic c).
Proof. intros.   apply ctPPT0.   destruct hag ; ProvePPT.
Qed.

Proposition ctl :
      forall  {hag tol c} ,
        ContextTerm hag tol c
        -> Context  hag tol (fun x => [c x]).
Proof.
  intros.
  apply cNth.
  intros.
  induction n.
unfold Nth.
simpl.
apply H.
unfold Nth.
induction n.
simpl.
apply DetCSContext.
simpl.
apply DetCSContext.
Qed.

Proposition cTL   :
      forall {hag tol c} ,
        Context hag tol c
        -> Context  hag tol (fun x => (TL (c x))).
Proof.
  intros.
  apply cNth.
  intros.
  assert ((fun x : ToL tol => Nth n (TL (c x))) = (fun x : ToL tol => Nth (S n)(c x))).
  apply functional_extensionality.
  intros.
  rewrite Nth_and_TL.
  reflexivity.
  rewrite H0.
apply ctNth.
assumption.
Qed.

Proposition Nth_and_firstn1 :
  forall lx n1 n2, n1 < n2 -> Nth n1 (firstn n2 lx) = Nth n1 lx.
Proof.
  intros lx.
  - induction lx.
    + intros.
      destruct n2.
      * simpl firstn.
        reflexivity.
      * simpl firstn.
        reflexivity.
    + intros.
      destruct n2.
      * assert (not (n1 < 0)).
        {  lia. }
        contradiction.
      *  simpl firstn.
         destruct n1.
         ** unfold Nth.
            simpl nth.
            reflexivity.
         ** unfold Nth.
            simpl nth.
            unfold Nth in IHlx.
            apply IHlx.
            lia.
Qed.

Proposition Nth_and_firstn2 :
  forall lx n1 n2,  n1 >= n2 -> Nth n1 (firstn n2 lx)  = default.
Proof.
  intros lx.
  - induction lx.
    + intros.
      destruct n2.
      * simpl firstn.
        unfold Nth.
        destruct n1.
        ** simpl nth.
           reflexivity.
        ** simpl nth.
           reflexivity.
      * simpl firstn.
        unfold Nth.
        destruct n1.
        ** simpl nth.
           reflexivity.
        ** simpl nth.
           reflexivity.
    + intros.
      destruct n2.
      * simpl firstn.
        unfold Nth.
        destruct n1.
        ** simpl nth.
           reflexivity.
        ** simpl nth.
           reflexivity.
      * simpl firstn.
        unfold Nth.
        destruct n1.
        ** assert (not (0 >= S n2)).
           { lia. }
           contradiction.
        ** simpl nth.
           unfold Nth in IHlx.
           apply IHlx.
           lia.
Qed.

Proposition cfirstn   :
      forall {hag tol c n} ,
        Context hag tol c
        -> Context  hag tol (fun x => (firstn n (c x))).
Proof.
  intros.
  apply cNth.
  intros.
  assert ((n0 < n) \/ (n0 >= n)).
  lia.
  destruct H0.
  assert ((fun x : ToL tol => Nth n0 (firstn n (c x))) = (fun x : ToL tol => Nth n0 (c x) )).
  apply functional_extensionality.
  intros.
  rewrite Nth_and_firstn1.
  reflexivity.
  assumption.
  rewrite H1.
  apply ctNth.
  assumption.
  assert ((fun x : ToL tol => Nth n0 (firstn n (c x))) = (fun x : ToL tol => default)).
  apply functional_extensionality.
  intros.
  rewrite Nth_and_firstn2.
  reflexivity.
  assumption.
  rewrite H1.
  apply DetCSContext.
Qed.

Proposition Nth_and_skipn :
  forall lx n1 n2, Nth n1 (skipn n2 lx) = Nth (n1 + n2) lx.
Proof.
  intros lx.
  - induction lx.
    + intros.
      destruct n2.
      * simpl skipn.
        assert (n1 + 0 =n1).
        { lia. }
        rewrite H.
        reflexivity.
      * simpl skipn.
        unfold Nth.
        destruct n1.
        ** assert (0 + S n2 = S n2).
           { lia. }
           simpl.
           reflexivity.
        ** assert (S n1 + S n2 = S (S (n1 + n2))).
           { lia. }
           simpl.
           reflexivity.
    + intros.
      destruct n2.
      * simpl skipn.
        assert (n1 + 0 =n1).
        { lia. }
        rewrite H.
        reflexivity.
      * simpl skipn.
        rewrite IHlx.
        assert ((n1 + S n2) = S (n1 + n2)).
        { lia. }
        rewrite H.
        unfold Nth.
        simpl.
        reflexivity.
Qed.

Proposition cskipn   :
      forall {hag tol c n} ,
        Context hag tol c
        -> Context  hag tol (fun x => (skipn n (c x))).
Proof.
  intros.
  apply cNth.
  intros.
  assert ((fun x : ToL tol => Nth n0 (skipn n (c x))) = (fun x : ToL tol => Nth (n0 + n) (c x))).
  apply functional_extensionality.
  { intros.
    apply Nth_and_skipn. }
  rewrite H0.
  apply ctNth.
  assumption.
Qed.

Proposition  cnil   :
      forall tol hag , Context  hag tol (fun x : ToL tol => nil).
Proof. intros. destruct tol. simpl. assert  ((fun (x : ppt) =>  []) = (fun (x: ppt)  => firstn 0 [x])).
apply functional_extensionality. unfold firstn. intros. auto.
rewrite H. apply @cfirstn. apply ctl. apply ctId.   assert  ((fun (x : list ppt) =>  []) = (fun (x: list ppt)  => firstn 0 x)).
apply functional_extensionality.  unfold firstn. intros. auto. simpl.   rewrite H. apply @cfirstn.
apply cId. Qed.

Proposition cCons  :
      forall tol hag {ct c},
        ContextTerm hag tol ct
        -> Context hag tol c
        -> Context hag tol (fun x => (ct x)::(c x)).
Proof. intros. assert ((fun x => (ct x)::(c x)) = (fun x => [ct x]++(c x))).
apply functional_extensionality. intros. rewrite <- (app_nil_l (c x )) at 1. apply app_comm_cons.
rewrite H1. apply cApp. apply ctl. auto. auto. Qed.

Proposition cCont   :
      forall hag tol {c1 c2 } ,
        Context hag List  c1
        -> Context hag tol c2
        -> Context hag tol (fun x   => (c1 (c2 x)) ).
Proof.
  Proof. intros.
         apply ( Context_mut  hag List (fun c =>   Context hag tol (fun x : ToL tol => c (c2 x)))
                   (fun c =>   ContextTerm hag tol (fun x : ToL tol => c (c2 x)))); try (intros; unfold Id; constructor; auto; constructor; auto).
Qed.

Proposition tcCont   :
      forall  hag tol {tc1 c2},
        Context hag  Term tc1
        -> ContextTerm hag  tol c2
        -> Context  hag tol (fun x => (tc1  (c2 x))).
 Proof. intros. apply (Context_mut hag   Term (fun c =>  Context  hag tol (fun x : ToL tol => c (c2 x)))
                         (fun c =>  ContextTerm  hag tol (fun x : ToL tol => c (c2 x)))) ; try (intros; unfold Id; constructor; auto; constructor; auto; apply ctl; auto).
  - unfold Id. auto.
Qed.

Theorem ctx_up1:
   forall tol c0 f,
        (Context c0 tol f -> forall c1, (c0 <<< c1) -> Context c1 tol f).
Proof. intros.
   apply (Context_mut c0 tol) with
      (P := fun  f =>  Context  c1 tol f)
      (P0 := fun f => ContextTerm  c1 tol f); intros;  try (intros; unfold Id; constructor; auto; constructor; auto; apply ctl; auto). apply ctCT; ProvePPT.
Qed.

Theorem ctx_up2:
           forall tol c0 f,
                (ContextTerm  c0 tol f -> forall c1, (c0 <<< c1) -> ContextTerm  c1 tol f).
Proof. intros.
   apply (ContextTerm_mut c0 tol) with
      (P := fun  f =>  Context  c1 tol f)
      (P0 := fun f => ContextTerm  c1 tol f); intros; try (intros; unfold Id; constructor; auto; constructor; auto; apply ctl; auto). apply ctCT; ProvePPT.
auto. Qed.

Theorem ctx_up:
            (forall tol c0 f,
                (Context c0 tol f -> forall c1, (c0 <<< c1) -> Context c1 tol f))
          /\ (forall tol c0 f,
                (ContextTerm  c0 tol f -> forall c1, (c0 <<< c1) -> ContextTerm  c1 tol f)).
Proof.
apply conj. apply ctx_up1. apply ctx_up2.
Qed.

Theorem ContextUp:
            forall c0 c1 tol f,
                c0 <<< c1 -> Context c0 tol f ->  Context c1 tol f.
Proof.
   intros. apply (ctx_up1 tol c0 f H0 c1). auto.
Qed.

Theorem ContextTermUp:
          forall c0 c1 tol  f,
                c0 <<< c1 -> ContextTerm c0 tol f ->  ContextTerm c1 tol f.
Proof.
   intros. apply (ctx_up2 tol c0 f H0 c1). auto.
Qed.

Goal (forall tol f, Context  Deterministic tol f -> Context Honest tol f).
Proof. intros tol f. apply ContextUp.
    ProveHag.
Qed.

Goal (forall tol f, Context  Deterministic tol f -> Context General tol f).
Proof. intros tol f. apply ContextUp.
    ProveHag.
Qed.

(*
(* [ ] makes a Context from ContextTerm*)
Proposition ctl :
      forall {hag tol ct},
        ContextTerm hag tol ct
        -> Context hag tol (fun x => [ (ct x)]).
Proof. intros. apply ctl. auto. Qed.*)

(* Various ways of combining two Contexts *)
Proposition ctlCont :
      forall {hag tol c1 c2},
        Context hag Term c1
        -> ContextTerm hag tol c2
        -> Context hag tol (fun x => (c1  (c2 x))).
Proof. intros. apply tcCont.   assumption. assumption. Qed.

Proposition cllCont :
      forall {hag tol c1 c2},
        Context hag List c1
        -> Context hag tol c2
        -> Context hag tol (fun x => (c1  (c2 x))).
Proof. intros. apply cCont.  assumption. assumption. Qed.

Proposition cttCont :
      forall {hag tol tc1 tc2},
        ContextTerm hag Term tc1
        -> ContextTerm hag tol tc2
        -> ContextTerm hag tol (fun x => (tc1  (tc2 x))).
Proof. intros. assert ((fun x : ToL tol => tc1 (tc2 x))= (fun x : ToL tol => HD [tc1 (tc2 x)])). simpl. reflexivity.
rewrite H1. apply ctHD.  apply (@ctlCont hag tol (fun x => [tc1 x]) tc2). apply ctl. assumption. assumption. Qed.

Proposition cltCont :
      forall {hag tol tc1 tc2},
        ContextTerm hag List tc1
        -> Context hag tol tc2
        -> ContextTerm hag tol (fun x => (tc1  (tc2 x))).
Proof. intros. assert ((fun x : ToL tol => tc1 (tc2 x))= (fun x : ToL tol => HD [tc1 (tc2 x)])). simpl. reflexivity.
rewrite H1. apply ctHD.  apply (@cllCont hag tol (fun x => [tc1 x]) tc2). apply ctl. assumption. assumption. Qed.

Proposition NthContext:
forall {hag n},
 ContextTerm hag List (Nth n).
Proof. intros. apply ctNth. apply cId. Qed.

Proposition HDContext:
forall {hag},
 ContextTerm hag List HD.
Proof. intros. apply ctHD. apply cId. Qed.

Proposition TLContext:
forall {hag},
 Context hag List TL.
Proof. intros. apply cTL. apply cId. Qed.

Proposition firstnContext:
forall {hag n},
 Context hag List (firstn n).
Proof. intros. apply cfirstn. apply cId. Qed.

Proposition skipnContext:
forall {hag n},
 Context hag List (skipn n).
Proof. intros. apply cskipn. apply cId. Qed.

Proposition lengthContext:
forall {hag n},
 Context hag List (fun x => (skipn ((length x) - n) x)).
Proof. intros. apply clength. apply cId. Qed.

Proposition HonFSContext :
  forall arg f,
    ContextTerm Honest List (FuncInt Honest arg f)
    /\ ContextTerm Mixed List (FuncInt Honest arg f)
    /\ ContextTerm General List (FuncInt Honest arg f).
Proof. intros. repeat apply conj;   apply ctCT; ProvePPT; apply cId. Qed.

Proposition AdvFSContext :
  forall arg (f: Symbols Adversarial arg) ,
    ContextTerm Adversarial List (FuncInt Adversarial arg f)
    /\ ContextTerm Mixed List (FuncInt Adversarial arg f)
    /\ ContextTerm General List (FuncInt Adversarial arg f).
Proof. intros. repeat apply conj;   apply ctCT; ProvePPT; apply cId. Qed.

Proposition MixFSContext :
  forall arg (f: Symbols Mixed arg) ,
    ContextTerm Mixed List (FuncInt Mixed arg f)
    /\ ContextTerm General List (FuncInt Mixed arg f) .
Proof. intros. repeat apply conj;   apply ctCT; ProvePPT; apply cId. Qed.

Proposition GenFSContext :
  forall arg f,
    ContextTerm General List (FuncInt General  arg f).
Proof. intros.  apply ctCT. apply FunHAG. apply cId.  Qed.

Proposition HonCSContext :
  forall  c tol,
    ContextTerm Honest tol (fun lx => ConstInt Honest c)
    /\ ContextTerm Mixed tol (fun lx => ConstInt Honest c)
    /\ ContextTerm General tol (fun lx => ConstInt Honest c).
Proof. intros.  repeat apply conj; apply ctPPT0; ProvePPT.  Qed.

Proposition AdvCSContext :
  forall c tol,
    ContextTerm Adversarial tol (fun lx => ConstInt Adversarial c)
    /\ ContextTerm Mixed tol (fun lx => ConstInt Adversarial c)
    /\ ContextTerm General tol (fun lx => ConstInt Adversarial c).
Proof. intros.  repeat apply conj; apply ctPPT0; ProvePPT. Qed.

Proposition MixCSContext :
  forall c tol,
    ContextTerm Mixed tol (fun lx => ConstInt Mixed c)
    /\ ContextTerm General tol (fun lx => ConstInt Mixed c).
Proof. intros.  repeat apply conj; apply ctPPT0; ProvePPT. Qed.

Proposition GenCSContext :
  forall c tol, ContextTerm General tol (fun lx => ConstInt General c).
Proof. intros.  apply ctPPT0. ProvePPT. Qed.

Proposition ctConstant :
      forall {x0 : ppt} {tol},
        ContextTerm General tol (fun x => x0).
Proof. intros. apply ctPPT0. apply ConstantGeneral. Qed.

Proposition cConstant :
  forall {x : list ppt}  {tol} ,
    Context General tol (fun _ : ToL tol => x).
Proof. intros. induction x. apply cnil. apply cCons.  apply ctConstant.  trivial. Qed.

(**************************************************************************************)
(***************************** Automated Check of Context *****************************)
(**************************************************************************************)

(* Automated proof that something is a context. *)
Ltac ProveContext :=
  repeat ( intros;
match goal with
      |H : ?prop |- ?prop => apply H
      |    |- ?c1 <<< ?c2  => ProveHag
      |    |- PPT ?hag ?f  => ProvePPT
      |H : Context Deterministic ?tol ?c |- Context ?hag ?tol ?c => apply (ContextUp Deterministic)
      |H : Context Honest ?tol ?c |- Context Mixed ?tol ?c => apply (ContextUp Honest)
      |H : Context Honest ?tol ?c |- Context General ?tol ?c => apply (ContextUp Honest)
      |H : Context Adversarial ?tol ?c |- Context Mixed ?tol ?c => apply (ContextUp Adversarial)
      |H : Context Adversarial ?tol ?c |- Context General ?tol ?c => apply (ContextUp Adversarial)
      |H : Context Mixed ?tol ?c |- Context General ?tol ?c => apply (ContextUp Mixed)
      |H : ContextTerm Deterministic ?tol ?c |- ContextTerm ?hag ?tol ?c => apply (ContextTermUp Deterministic)
      |H : ContextTerm Honest ?tol ?c |- ContextTerm Mixed ?tol ?c => apply (ContextTermUp Honest)
      |H : ContextTerm Honest ?tol ?c |- ContextTerm General ?tol ?c => apply (ContextTermUp Honest)
      |H : ContextTerm Adversarial ?tol ?c |- ContextTerm Mixed ?tol ?c => apply (ContextTermUp Adversarial)
      |H : ContextTerm Adversarial ?tol ?c |- ContextTerm General ?tol ?c => apply (ContextTermUp Adversarial)
      |H : ContextTerm Mixed ?tol ?c |- ContextTerm General ?tol ?c => apply (ContextTermUp Mixed)
 (*    |H : ComputationType |- _ => destruct H *)
  (*    |H : TermOrList  |- _ => destruct H *)
      |   |- Context _ List (fun lx  => lx) => apply @cId
      |   |- Context _ List id => apply @cId
      |   |- Context _ _ (fun x   => ?a :: ?m) => apply @cCons
      |   |- Context _ _ (fun x   => ?a ++ ?m) => apply @cApp
      |   |- Context _ List (cons ?a) => apply @cCons
      |   |- Context _ _ (fun x => [ ]) => apply @cnil
      |   |- Context _ _ TL => apply @TLContext
      |   |- Context _ _ (fun x   => TL ?t) => apply @cllCont
      |   |- Context _ _ (firstn ?n) => apply @firstnContext
      |   |- Context _ _ (fun x   => firstn ?n ?t) => apply @cllCont
      |   |- Context _ _ (skipn ((length ?t) - ?n)) => apply @lengthContext
      |   |- Context _ _ (fun x   => skipn ((length ?t) - ?n) ?t) => apply @lengthContext
      |   |- Context _ _ (skipn ?n) => apply @skipnContext
      |   |- Context _ _ (fun x   => skipn ?n ?t) => apply @cllCont
      |   |- ContextTerm _ Term (fun x  => x) => apply @ctId
      |   |- ContextTerm _ Term id => apply @ctId
   (*   |   |- ContextTerm _ _ (fun x => TRue) => apply @TRueContext
      |   |- ContextTerm _ _ (fun x => FAlse) => apply @FAlseContext
      |   |- ContextTerm _ _ (fun x => default) => apply @defaultContext*)
      |   |- ContextTerm _ _ (fun x => ConstInt Deterministic ?c) => apply @DetCSContext
      |   |- ContextTerm _ _ (fun x => ConstInt Honest ?c) => apply @HonCSContext
      |   |- ContextTerm _ _ (fun x => ConstInt Adversarial ?c) => apply @AdvCSContext
      |   |- ContextTerm _ _ (fun x => ConstInt Mixed ?c) => apply @MixCSContext
      |   |- ContextTerm _ _ (fun x => ConstInt General ?c) => apply @GenCSContext
  (*  |   |- ContextTerm _ _ (fun x => rbk ?n) => apply @rbkContext *)
      |   |- ContextTerm _ _ (Nth ?n) => apply @NthContext
      |   |- ContextTerm _ _ HD => apply @HDContext
      |   |- ContextTerm _ List (FuncInt Deterministic ?arg ?f) => apply @DetFSContext
      |   |- ContextTerm _ List (FuncInt Honest ?arg ?f) => apply @HonFSContext
      |   |- ContextTerm _ List (FuncInt Adversarial ?arg ?f) => apply @AdvFSContext
      |   |- ContextTerm _ List (FuncInt Mixed ?arg ?f) => apply @MixFSContext
      |   |- ContextTerm _ List (FuncInt General ?arg ?f) => apply @GenFSContext
  (*    |   |- ContextTerm _ _ (adv _) => apply @advContext  *)
   (*   |   |- ContextTerm _ _ If_Then_Else_ => apply @ITEContext  *)
  (*    |   |- ContextTerm _ _ EQ => apply @EQContext *)
      |   |- ContextTerm _ _ (fun x   => HD ?t) => apply @cltCont
      |   |- ContextTerm _ _ (fun x  => Nth ?n ?t) => apply @cltCont
   (*   |   |- ContextTerm _ _ (fun x   => adv ?n ?t) => apply @cltCont *)
   (*   |   |- ContextTerm _ _ (fun x   => EQ ?t) => apply @cltCont *)
   (*   |   |- ContextTerm _ _ (fun x   => If_Then_Else_ ?t) => apply @cltCont *)
      |   |- ContextTerm _ _ (fun x  => (FuncInt ?hag' ?arg ?f) ?t) => apply @cltCont
      | H : Context _ List ?c  |- Context _ _ (fun lx => (?c ?t)) => apply (@cllCont _ _)
      | H : Context _ List ?c  |- Context _ List (fun lx : list ppt => (?c ?t)) => apply (@cllCont _ List)
      | H : Context _ List ?c  |- Context _ Term (fun x : ppt => (?c ?t)) => apply (@cllCont _ Term)
      | H : Context _ Term ?c  |- Context _ _ (fun x : ToL _ => (?c ?t)) => apply (@ctlCont _ _)
      | H : Context _ Term ?c  |- Context _ Term (fun x : ppt => (?c ?t)) => apply (@ctlCont _ Term)
      | H : Context _ Term ?c  |- Context _ List (fun lx : list ppt => (?c ?t)) => apply (@ctlCont _ List)
      | H : ContextTerm _ List ?c  |- ContextTerm _ _ (fun lx : ToL _ => (?c ?t)) => apply (@cltCont _ _)
      | H : ContextTerm _ List ?c  |- ContextTerm _ List (fun lx : list ppt => (?c ?t)) => apply (@cltCont _ List)
      | H : ContextTerm _ List ?c  |- ContextTerm _ Term (fun x : ppt => (?c ?t)) => apply (@cltCont _ Term)
      | H : ContextTerm _ Term ?c  |- ContextTerm _ _ (fun x : ToL _ => (?c ?t)) => apply (@cttCont _ _)
      | H : ContextTerm _ Term ?c  |- ContextTerm _ Term (fun x : ppt => (?c ?t)) => apply (@cttCont _ Term)
      | H : ContextTerm _ Term ?c  |- ContextTerm _ List (fun lx : list ppt => (?c ?t)) => apply (@cttCont _ List)
      | H : ContextTerm ?hag List (fun _  => ?t)   |- ContextTerm ?hag Term (fun _  => ?t) => apply (@cltCont H (@cId ?hag Term))
      |   |- ContextTerm _ _ (fun x => (?f ?t)) => apply @ctCT
      |   |- ContextTerm General _ (fun x => ?t) => apply @ctConstant
      |   |- Context General _ (fun x => ?t) => apply @cConstant
      |   |- ContextTerm _ _ (fun x  => ?t) => apply @ctPPT0
  end). (* Works quite well but needs to be extended. PPT _ _ goals should be skipped down. *)

(******************************** Testing the Automation ******************************)

(* TRue, FAlse, default, EQ, If Then Else are contexts *)
Parameter pairs : Symbols Deterministic (narg 2).

Notation "'pair'" := (FuncInt Deterministic (narg 2) pairs).

Goal forall (nl : list ppt), Context Adversarial List
  (fun lx : list ppt =>
   firstn (length nl) lx ++
   [pair [Nth (length nl + 0) lx; Nth (length nl + 1) lx];
   pair [Nth (length nl + 2) lx; Nth (length nl + 3) lx]]).
ProveContext. Defined.

Goal Deterministic <<< General. ProveContext. Defined.

Goal forall tol c , ContextTerm Adversarial tol c -> ContextTerm General tol c.
intros. ProveContext.  Defined.

Proposition defaultContext :
      forall {hag tol},
        ContextTerm hag tol (fun x => default).
Proof. ProveContext. Qed.

(*Proposition cTRue :
forall {hag tol},
    Context hag tol (fun x => [TRue]).
Proof. intros. apply ctl. apply TRueContext. Qed.*)
Proposition FAlseContext :
      forall {hag tol},
        ContextTerm hag tol (fun x => FAlse).
Proof. ProveContext. Qed.
(*Proposition cFAlse :
      forall {hag tol},
        Context hag tol (fun x => [FAlse]).
Proof. intros. apply ctl. apply FAlseContext.
Qed.*)

Proposition TRueContext :
      forall {hag tol},
        ContextTerm hag tol (fun x => TRue).
Proof. ProveContext. Qed.

Proposition nonceContext :
  forall n  tol ,
    ContextTerm Honest tol (fun x => nonce n)
    /\ ContextTerm Mixed tol (fun x => nonce n)
    /\ ContextTerm General tol (fun x => nonce n) .
Proof.  intros. repeat apply conj ; ProveContext.    Qed.

Proposition ITEContext :
      forall {hag},
        ContextTerm hag List If_Then_Else_.
Proof. intros. destruct hag ; ProveContext.  Qed.

Proposition ctITE :
      forall {hag tol tc1 tc2 tc3},
        ContextTerm hag tol tc1
        -> ContextTerm hag tol tc2
        -> ContextTerm hag tol tc3
        -> ContextTerm hag tol (fun x => (If_Then_Else_ [(tc1 x); (tc2 x); (tc3 x)])).
Proof. ProveContext. Qed.

Proposition cITE :
      forall {hag tol tc1 tc2 tc3},
        ContextTerm hag tol tc1
        -> ContextTerm hag tol tc2
        -> ContextTerm hag tol tc3
        -> Context hag tol (fun x => [If_Then_Else_ [(tc1 x); (tc2 x); (tc3 x)]]).
Proof. ProveContext. Qed.

Proposition ctEQ :
      forall {hag tol tc1 tc2},
        ContextTerm hag tol tc1
        -> ContextTerm hag tol tc2
        -> ContextTerm hag tol (fun x => (EQ [(tc1 x) ; (tc2 x)])).
Proof. ProveContext. Qed.
Proposition cEQ :
      forall {hag tol tc1 tc2},
        ContextTerm hag tol tc1 ->ContextTerm hag tol tc2 -> Context hag tol (fun x =>  [EQ [(tc1 x) ; (tc2 x)]]).
Proof. intros. ProveContext. Qed.

Proposition EQContext :
      forall {hag},
        ContextTerm hag List EQ.
Proof. ProveContext. Qed.

Proposition FAlseContext2 :
      forall {hag tol},
        ContextTerm hag tol (fun x => FAlse).
Proof. ProveContext. Qed.

Proposition advContext :
  forall n  ,
    ContextTerm Adversarial List (adv  n)
    /\ ContextTerm Mixed List (adv n)
    /\ ContextTerm General List (adv n) .
Proof. intros. repeat apply conj; ProveContext. Qed.

Proposition bla11 :
  Context Adversarial List (fun x0 : ToL List => x0).
Proof.  ProveContext. Qed.

Proposition  bla10: forall tc1 tc2 , ContextTerm Honest Term tc1 -> ContextTerm Honest Term tc2 -> Context Honest Term
  (fun x : ToL Term => [tc1 x; tc2 x]).
Proof.
 ProveContext. Qed.

Proposition bla : forall hag , ContextTerm hag Term (fun x : ToL Term => x).
Proof. ProveContext.  Qed.

Proposition bla0 : forall hag , ContextTerm hag List (fun x : ToL List => HD x ).
Proof.   ProveContext.  Qed.

Proposition bla2 :  forall hag  t1 t2 ,
(PPT hag (fun x => t1)) -> (PPT hag (fun x => t2)) ->
ContextTerm hag List (fun x : ToL List => (EQ [t1 ; t2])).
Proof. ProveContext.  Qed.

(* Proposition bla3 : forall t : ppt , ContextTerm General Term (fun x : ToL Term => (EQ [x ; t])).
Proof. ProveContext.  Qed.

Proposition bla4 : forall t1 t2 : ppt , ContextTerm General Term (fun x : ToL Term => (If x Then t1 Else t2)).
Proof. ProveContext. Qed.

Proposition bla5 : forall b (x1 : ppt) (y1:ppt) t1  , ContextTerm General Term
  (fun t2' : ToL Term =>
   If b
      Then If b
              Then t1 x1
              Else t1 y1
      Else t2').
Proof. ProveContext. Qed.

Proposition bla6 : Context General Term (fun x : ToL Term => [x;x]).
Proof. ProveContext.    Qed.

Proposition ite : ContextTerm General Term (fun x => If x Then x Else x).
Proof.   ProveContext.  Qed.
*)

(********************************* EXAMPLE: Projection ********************************)

Proposition proj02 :
      forall {hag} ,
        Context hag List (fun x => [HD x ; HD (TL (TL x))]).
Proof. ProveContext. Qed.

(****************** EXAMPLE: Permutation - using the nth, it's easier *****************)

Proposition perm021 :
      forall {hag } c , Context hag List c ->
        Context hag List (fun x => [Nth 0 (c x) ; Nth 2 x ; Nth 1 x ]).
Proof. ProveContext.  Qed.