From 291243a0d9694662db75283f266a001a1ea3bdb0 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 12 Feb 2025 23:53:27 +0100 Subject: [PATCH 01/10] Fixing proofs --- proofs/ssprove/handwritten/Core.v | 10 +- proofs/ssprove/handwritten/CoreTheorem.v | 61 +- proofs/ssprove/handwritten/KeyPackages.v | 33 +- .../ssprove/handwritten/KeySchedulePackages.v | 4 +- proofs/ssprove/handwritten/MapPackage.v | 1303 +++++++---------- proofs/ssprove/handwritten/Utility.v | 237 ++- proofs/ssprove/handwritten/XTR_XPD.v | 66 +- 7 files changed, 797 insertions(+), 917 deletions(-) diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 2f497976..9da6f1e0 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -102,8 +102,8 @@ Section Core. #val #[ SET PSK 0 d ] : chSETinp → chSETout ] :|: DH_interface - :|: XTR_n_ℓ d - :|: XPD_n_ℓ d) + :|: XTR_n d + :|: XPD_n d) (UNQ_O_star d) ). @@ -170,7 +170,7 @@ Section Core. package (L_K :|: L_L) [interface] - (XPD_n_ℓ d :|: (DH_interface :|: XTR_n_ℓ d)) := + (XPD_n d :|: (DH_interface :|: XTR_n d)) := {package (par (XPD_packages d ∘ (par (Ks d XPR false erefl ∘ Ls d XPR F erefl) hash)) @@ -323,8 +323,8 @@ Section Core. ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout ] :|: DH_interface :|: - XTR_n_ℓ d :|: - XPD_n_ℓ d :|: + XTR_n d :|: + XPD_n d :|: GET_O_star_ℓ d) (GET_O_star_ℓ d) := {package (Ks d O_star true erefl ∘ Score) }. diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 38338c4b..e7587624 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -111,70 +111,67 @@ Axiom R_sodh : package fset0 [interface] [interface]. Axiom Gcore_sodh : package fset0 [interface] [interface]. Lemma core_theorem : - (* forall (d : nat), *) - forall (Score : Simulator), + forall (d : nat), + forall (Score : Simulator d), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → + ValidPackage LA (KS_interface d) A_export A → (AdvantageE - (Gcore_real (* d *)) - (Gcore_ideal (* d *) Score) (A (* ∘ R d M H *)) + (Gcore_real d) + (Gcore_ideal d Score) (A (* ∘ R d M H *)) <= sumR_l [R_cr; R_Z; R_D] (fun R => Advantage Gacr (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE Gcore_sodh (Gcore_ideal (* d *) Score) (Ai A i)) + +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE Gcore_sodh (Gcore_ideal d Score) (Ai A i)) )%R. Proof. intros. - - - Admitted. Lemma equation20_lhs : - (* forall (d : nat), *) - forall (Score : Simulator), + forall (d : nat), + forall (Score : Simulator d), forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → - (AdvantageE Gcore_sodh (Gcore_hyb 0) (Ai A i) = 0)%R. + ValidPackage LA (KS_interface d) A_export A → + (AdvantageE Gcore_sodh (Gcore_hyb d 0) (Ai A i) = 0)%R. Proof. Admitted. Lemma equation20_rhs : - (* forall (d : nat), *) - forall (Score : Simulator), + forall (d : nat), + forall (Score : Simulator d), forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → - (AdvantageE Gcore_ki (Gcore_hyb d) (Ai A i) = 0)%R. + ValidPackage LA (KS_interface d) A_export A → + (AdvantageE Gcore_ki (Gcore_hyb d d) (Ai A i) = 0)%R. Proof. Admitted. Lemma hyb_telescope : - (* forall (d : nat), *) - forall (Score : Simulator), + forall (d : nat), + forall (Score : Simulator d), (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → - (AdvantageE (Gcore_hyb 0) (Gcore_hyb d) (Ai A i) - = sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb ℓ) (Gcore_hyb (ℓ+1)) (Ai A i)) + ValidPackage LA (KS_interface d) A_export A → + (AdvantageE (Gcore_hyb d 0) (Gcore_hyb d d) (Ai A i) + = sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) )%R. Proof. Admitted. Lemma equation20_eq : - (* forall (d : nat), *) - forall (Score : Simulator), + forall (d : nat), + forall (Score : Simulator d), (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → - (AdvantageE Gcore_sodh (Gcore_ideal (* d *) Score) (Ai A i) - <= AdvantageE Gcore_ki (Gcore_ideal (* d *) Score) (Ai A i) - +sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb ℓ) (Gcore_hyb (ℓ + 1)) (Ai A i)) + ValidPackage LA (KS_interface d) A_export A → + (AdvantageE Gcore_sodh (Gcore_ideal d Score) (Ai A i) + <= AdvantageE Gcore_ki (Gcore_ideal d Score) (Ai A i) + +sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) )%R. Proof. intros. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb 0)). - rewrite (equation20_lhs (* d *) Score). + instantiate (1 := (Gcore_hyb d 0)). + rewrite (equation20_lhs d Score). rewrite add0r. eapply Order.le_trans ; [ apply Advantage_triangle | ]. @@ -183,9 +180,9 @@ Proof. apply Num.Theory.lerD ; [ easy | ]. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb d)). + instantiate (1 := (Gcore_hyb d d)). - epose (e := equation20_rhs (* d *) Score). + epose (e := equation20_rhs d Score). setoid_rewrite (Advantage_sym _ _) in e. rewrite e ; clear e. rewrite addr0. diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index 506ff57c..eef74310 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -240,29 +240,6 @@ Proof. apply trimmed_empty_package. Qed. -Definition combined (A : eqType) (d : nat) L (f : A -> _) g Names (i : forall (n : nat), (n <= d)%nat -> forall (a : A), package L (f a) (g a n)) - (H : forall n, (n <= d)%nat -> ∀ x y : A, x ≠ y → idents (g x n) :#: idents (g y n)) - (H0 : forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y : A, idents (g x ℓ) :#: idents (g y n)) - (H1 : forall n (H_le : (n <= d)%nat), ∀ a : A, trimmed (g a n) (i n H_le a)) - (H3 : uniq Names) : - package L - (interface_foreach f Names) - (interface_hierarchy_foreach g Names d) := - ℓ_packages - d - (fun n H_le => - parallel_package d Names (i n H_le) (H n H_le) (H1 n H_le) H3 - ) - (fun n H_le => - trimmed_parallel_raw - (g^~ n) - Names - _ - (H n H_le) - H3 - (trimmed_pairs_map _ _ _ (H1 n H_le))) - (fun n ℓ i0 i1 => idents_foreach_disjoint_foreach _ _ Names (H0 n ℓ i0 i1)). - Lemma function_fset_cat : forall {A : eqType} {T} x xs, (fun (n : A) => fset (x n :: xs n)) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n)). Proof. now setoid_rewrite <- (fset_cat). Qed. @@ -320,11 +297,11 @@ Proof. intros. unfold Ks. unfold combined. - set (ℓ_packages _ _ _ _). + rewrite trimmed_eq_rect. destruct (function2_fset_cat _ _). - - refine (trimmed_ℓ_packages d (λ (n : nat) (H0 : (n <= d)%N), {package parallel_raw (List.map (λ y : name, _) Names) }) _ _). + rewrite trimmed_eq_rect_r. + apply (trimmed_ℓ_packages d). Qed. (* Fig 15 *) @@ -400,6 +377,10 @@ Next Obligation. rewrite fset_cons ; rewrite imfsetU ; rewrite <- fset1E. solve_imfset_disjoint. Qed. +Next Obligation. + intros. + now rewrite <- interface_hierarchy_trivial. +Qed. Fail Next Obligation. End KeyPackages. diff --git a/proofs/ssprove/handwritten/KeySchedulePackages.v b/proofs/ssprove/handwritten/KeySchedulePackages.v index 75bbcaea..38e81c15 100644 --- a/proofs/ssprove/handwritten/KeySchedulePackages.v +++ b/proofs/ssprove/handwritten/KeySchedulePackages.v @@ -90,8 +90,8 @@ Section KeySchedulePackages. #val #[ SET PSK 0 d ] : chSETinp → chSETout ] :|: DH_interface (* DHEXP, DHGEN *) - :|: XTR_n_ℓ d (* {ES,HS,AS}, 0..d *) - :|: XPD_n_ℓ d (* XPN, 0..d *) + :|: XTR_n d (* {ES,HS,AS}, 0..d *) + :|: XPD_n d (* XPN, 0..d *) :|: GET_O_star_ℓ d). Definition key_schedule_export d := diff --git a/proofs/ssprove/handwritten/MapPackage.v b/proofs/ssprove/handwritten/MapPackage.v index 5b117096..5db0b8da 100644 --- a/proofs/ssprove/handwritten/MapPackage.v +++ b/proofs/ssprove/handwritten/MapPackage.v @@ -140,7 +140,7 @@ Axiom level : chHandle -> code fset0 [interface] (chOption chNat). Definition KS_interface d := ([interface #val #[SET PSK 0 d] : chSETinp → chSETout ] :|: DH_interface - :|: (XPD_n_ℓ d :|: XTR_n_ℓ d) + :|: (XPD_n d :|: XTR_n d) :|: GET_O_star_ℓ d ). @@ -156,7 +156,7 @@ Notation " 'chXTRout' " := Definition R_ch_map_XTR_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) : (n \in XTR_names) -> (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> - package L_M (XTR_n_ℓ d (* ℓ.+1 *)) + package L_M (XTR_n_ℓ d ℓ (* ℓ.+1 *)) [interface #val #[ XTR n ℓ d (* ℓ.+1 *)] : chXTRinp → chXTRout ]. @@ -181,7 +181,7 @@ Proof. end ;; (* *) - assertD (ℓ' <= d)%nat (fun H => + assertD (ℓ' <= ℓ)%nat (fun H => #import {sig #[ XTR n ℓ' d (* ℓ.+1 *) ] : chXTRinp → chXTRout } as XTR_fn ;; h ← xtr_angle n h1 h2 ;; @@ -232,7 +232,8 @@ Proof. unfold XTR_names in H. rewrite !in_cons in H. - repeat (move: H => /orP [ /eqP H | H ] ; subst) ; (repeat (apply /orP ; ((left ; now apply /eqP) || right)) ; now apply /eqP). + repeat (move: H => /orP [ /eqP H | H ] ; subst). + all: try (repeat (apply /orP ; ((left ; now apply /eqP) || right)) ; now apply /eqP). } { unfold set_at. @@ -241,56 +242,70 @@ Proof. Defined. Fail Next Obligation. +Lemma interface_hierarchy_idemp : + forall d f, + (interface_hierarchy (λ (ℓ : nat), interface_hierarchy f ℓ) d) = + interface_hierarchy f d. +Proof. + intros. + induction d. + - reflexivity. + - simpl. + rewrite IHd. + rewrite fsetUA. + rewrite fsetUid. + reflexivity. +Defined. + +Lemma interface_hierarchy_interface_foreach_swap : + forall {A} (L : list A) d f, + (interface_hierarchy (λ (ℓ : nat), interface_foreach (f ℓ) L) d) = + (interface_foreach (λ n, interface_hierarchy (f^~ n) d) L). +Proof. + intros. + induction d. + - reflexivity. + - simpl. + rewrite IHd. + now rewrite interface_foreach_U. +Defined. + +Lemma interface_hierarchy_foreach_idemp : + forall {A} (L : list A) d f, + (interface_hierarchy_foreach + (λ (_ : A) (ℓ : nat), + interface_hierarchy_foreach f L ℓ) L d) = + interface_hierarchy_foreach f L d. +Proof. + intros. + destruct L. + - simpl. + unfold interface_hierarchy_foreach. + now rewrite interface_hierarchy_empty. + - unfold interface_hierarchy_foreach. + rewrite interface_hierarchy_interface_foreach_swap. + rewrite (interface_hierarchy_idemp d (λ ℓ0 : nat, interface_foreach (f^~ ℓ0) _)). + rewrite interface_hierarchy_interface_foreach_swap. + now rewrite <- interface_foreach_trivial. +Defined. Definition R_ch_map_XTR_packages (d : nat) (M : chHandle -> nat) (H_inLM : name → ∀ s : chHandle, ('option ('fin #|fin_handle|); M s) \in L_M) : - package L_M (XTR_n_ℓ d) (XTR_n_ℓ d). + package L_M (XTR_n d) (XTR_n d). Proof. - assert (H1 : forall n, ∀ x y : ExtraTypes_name__canonical__eqtype_Equality, - x ≠ y - → idents [interface #val #[XTR x n d] : chXTRinp → chXTRout ] - :#: idents [interface #val #[XTR y n d] : chXTRinp → chXTRout ] + unfold XTR_n at 1. + rewrite <- (interface_hierarchy_foreach_idemp XTR_names d (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])). + refine (ℓ_parallel XTR_names XTR_names d + (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) + (fun ℓ H_le a H => R_ch_map_XTR_package d ℓ a (fun _ => M) H H_inLM) + (fun a H => H) + _ _ _ ). - { - intros. - unfold idents. - solve_imfset_disjoint. - } - - assert (H2 : uniq XTR_names) by reflexivity. - - assert (H3 : forall ℓ, trimmed_pairs - (List.map (fun n : name => [interface #val #[(@XTR n ℓ d)] : chXTRinp → chXTRout ]) XTR_names) - (map_with_in_rel XTR_names XTR_names (H_in := fun a H0 => H0) (fun (x : name) H0 => pack (R_ch_map_XTR_package d ℓ x (fun _ : name => M) H0 H_inLM)))) by now repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. - - set (XTR_n_ℓ) at 2. - rewrite (interface_hierarchy_trivial (XTR_n_ℓ d) XTR_names d _). - 2: easy. - subst i. - refine (ℓ_packages - d - (fun ℓ H => - (parallel_package d XTR_names) - (* {package parallel_raw (map_with_in_rel XTR_names XTR_names (H_in := fun a H0 => H0) (fun x H0 => pack (R_ch_map_XTR_package d ℓ x (fun _ => M) H0 H_inLM))) *) - (* #with *) - (* (valid_forall_map_with_in_rel *) - (* (λ (n : name) (ℓ : nat), (XTR_n_ℓ d) (* [interface #val #[XTR n ℓ] : chXTRinp → chXTRout ] *)) *) - (* (λ n : name, [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ]) *) - (* XTR_names *) - (* (λ ℓ (x : name) (H0 : x \in XTR_names), R_ch_map_XTR_package d ℓ x (λ _ : name, M) H0 H_inLM) *) - (* d *) - (* ℓ *) - (* H (H1 _) H2 (H3 _) _ ) } *) - ) - (fun _ _ => trimmed_parallel_raw _ _ _ (H1 _) H2 (H3 _)) _ ). - - unfold XTR_names, map_with_in_rel, List.map. - unfold valid_pairs. - split ; [ | split ] ; apply R_ch_map_XTR_package. - intros. - apply idents_foreach_disjoint_foreach. - intros. unfold idents. - solve_imfset_disjoint. + destruct H ; solve_imfset_disjoint. + - reflexivity. + - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. Defined. Fail Next Obligation. @@ -306,7 +321,7 @@ Definition R_ch_map_XPD_package d (ℓ : nat) (n : name) (M : name -> chHandle - (n \in XPR) -> (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> (forall s1 s k, ('option ('fin #|fin_handle|); M_ℓ s1 s k) \in L_M) -> - package L_M (XPD_n_ℓ d (* ℓ.+1 *)) + package L_M (XPD_n_ℓ d ℓ (* ℓ.+1 *)) [interface #val #[ XPD n ℓ d (* ℓ.+1 *) ] : chXPDinp → chXPDout ]. @@ -324,7 +339,7 @@ Definition R_ch_map_XPD_package d (ℓ : nat) (n : name) (M : name -> chHandle - | None => @fail 'nat ;; ret (chCanonical 'nat) (* fail? *) end) ;; (* *) - assertD (ℓ1 <= d)%nat (fun H => + assertD (ℓ1 <= ℓ)%nat (fun H => h ← xpd_angle n label h1 args ;; #import {sig #[ XPD n ℓ1 d (* ℓ.+1 *) ] : chXPDinp → chXPDout } @@ -421,83 +436,22 @@ Qed. Definition R_ch_map_XPD_packages (d : nat) (M : chHandle -> nat) : (forall s, ('option ('fin #|fin_handle|); M s) \in L_M) -> - package L_M (XPD_n_ℓ d) (XPD_n_ℓ d). + package L_M (XPD_n d) (XPD_n d). Proof. intros H_L_M. - (* refine (ℓ_packages *) - (* d (fun ℓ H => {package parallel_raw (map_with_in XPR (fun x H => pack (R_ch_map_XPD_package ℓ x (fun _ => M) (fun _ _ => M) H (fun _ => H_L_M) (fun _ _ => H_L_M)))) #with _ }) *) - (* _ _ _). *) - - (* 2: intros ; apply trimmed_parallel_raw_R_ch_map_XPD. *) - (* 2: now apply interface_foreach_idents_XPD. *) - - assert (H1 : forall n, ∀ x y : ExtraTypes_name__canonical__eqtype_Equality, - x ≠ y - → idents [interface #val #[XPD x n d] : chXPDinp → chXPDout ] - :#: idents [interface #val #[XPD y n d] : chXPDinp → chXPDout ] + unfold XPD_n at 1. + rewrite <- (interface_hierarchy_foreach_idemp XPR d _). + refine (ℓ_parallel XPR XPR d + (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) + (fun ℓ H_le a H => R_ch_map_XPD_package d ℓ a (fun _ => M) (fun _ _ => M) H (fun _ => H_L_M) (fun _ _ => H_L_M)) + (fun a H => H) + _ _ _ ). - { - intros. - unfold idents. - solve_imfset_disjoint. - } - - assert (H2 : uniq XPR) by reflexivity. - - eassert (H3 : forall ℓ, trimmed_pairs - (@List.map (Equality.sort ExtraTypes_name__canonical__eqtype_Equality) Interface - (fun n : name => - @fset - (Datatypes_prod__canonical__Ord_Ord Datatypes_nat__canonical__Ord_Ord - (Datatypes_prod__canonical__Ord_Ord choice_type_choice_type__canonical__Ord_Ord - choice_type_choice_type__canonical__Ord_Ord)) - (@cons (prod nat (prod choice_type choice_type)) - (@pair nat (prod choice_type choice_type) (@XPD n ℓ d) - (@pair choice_type choice_type (chProd (chProd chHandle chBool) bitvec) chHandle)) - (@nil (prod nat (prod choice_type choice_type))))) XPR) - (map_with_in_rel XPR XPR (H_in := fun a H0 => H0) - (fun (x : name) (H0 : x \in XPR) => - @pack _ _ _ - (R_ch_map_XPD_package d ℓ x (fun _ : name => M) (fun (_ : name) (_ : nat) => M) H0 - (fun _ => H_L_M) (fun _ _ => H_L_M))))). - { - intros. - unfold pack. - unfold trimmed_pairs, XPR, "++", List.map, R_ch_map_XPD_package, map_with_in. - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. - } - - set (XPD_n_ℓ) at 2. - rewrite (interface_hierarchy_trivial (XPD_n_ℓ d) XPR d _). - 2: easy. - subst i. - refine (ℓ_packages - d - (fun ℓ H => {package parallel_raw (map_with_in_rel XPR XPR (H_in := fun a H0 => H0) (fun x H0 => pack (R_ch_map_XPD_package d ℓ x (fun _ => M) (fun _ _ => M) H0 (fun _ => H_L_M) (fun _ _ => H_L_M)))) - #with - (valid_forall_map_with_in_rel - (λ (n : name) (ℓ : nat), (XPD_n_ℓ d) (* [interface #val #[XPD n ℓ] : chXPDinp → chXPDout ] *)) - (λ n : name, [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout ]) - XPR - (λ ℓ (x : name) (H0 : x \in XPR), R_ch_map_XPD_package d ℓ x (λ _ : name, M) (λ _ _ , M) H0 _ _) - d - ℓ - H (H1 _) H2 (H3 _) _ ) }) - (fun _ _ => trimmed_parallel_raw _ _ _ (H1 _) H2 (H3 _)) _ ). - - (* unfold map_with_in_rel. *) - (* unfold XPR. , List.map, "++". *) - unfold valid_pairs. - unfold XPR. - unfold "++". - unfold List.map. - unfold map_with_in_rel. - repeat split. - all: apply R_ch_map_XPD_package. - intros. - apply idents_foreach_disjoint_foreach. - intros. unfold idents. - solve_imfset_disjoint. + destruct H ; solve_imfset_disjoint. + - reflexivity. + - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. Defined. Fail Next Obligation. @@ -508,15 +462,16 @@ Definition R_ch_map (d : nat) : package (L_M :|: (L_K :|: L_L)) ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface :|: - XTR_n_ℓ d :|: - XPD_n_ℓ d) + XTR_n d :|: + XPD_n d) (KS_interface d) - (* (SET_O_star_ℓ :|: GET_O_star_ℓ) *). +(* (SET_O_star_ℓ :|: GET_O_star_ℓ) *). +Proof. refine (let base_package : package L_M ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface :|: - XTR_n_ℓ d :|: - XPD_n_ℓ d) ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) + XTR_n d :|: + XPD_n d) ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) := [package #def #[ SET PSK 0 d ] ('(h,hon,k) : chSETinp) : chSETout { @@ -545,44 +500,49 @@ Definition R_ch_map (d : nat) : 1: refine ({package par (base_package ) (par (par - (R_ch_map_XPD_packages d _ _) + (R_ch_map_XPD_packages d M _) (R_ch_map_XTR_packages d M H)) (Ks d O_star false erefl ∘ Ls d O_star F erefl) ) }). 1:{ - ssprove_valid. + assert (H_trim_ch_map_XTR : trimmed (XTR_n d) (R_ch_map_XTR_packages d M H)). { - (* simpl. *) - unfold FDisjoint. - apply @parable. + unfold R_ch_map_XTR_packages. + unfold eq_rect. + destruct (interface_hierarchy_foreach_idemp). + apply trimmed_ℓ_packages. + } - eassert (trimmed (XTR_n_ℓ d) (R_ch_map_XTR_packages d M H)). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. + assert (H_trim_ch_map_XPD : trimmed (XPD_n d) (R_ch_map_XPD_packages d M (H BOT))). + { + unfold R_ch_map_XPD_packages. + unfold eq_rect. + destruct (interface_hierarchy_foreach_idemp). + apply trimmed_ℓ_packages. + } - eassert (trimmed (XPD_n_ℓ d) (R_ch_map_XPD_packages d M (H BOT))). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. + assert (H_trim_PSK : trimmed ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) base_package). + { + unfold DH_interface. + rewrite <- fset_cat. + simpl fset. - eassert (trimmed ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) base_package). - { - unfold DH_interface. - rewrite <- fset_cat. - simpl fset. + unfold trimmed. + unfold base_package. + unfold pack. - unfold trimmed. - unfold base_package. - unfold pack. + do 3 apply trimmed_package_cons ; apply trimmed_empty_package. + } - do 3 apply trimmed_package_cons ; apply trimmed_empty_package. - } - rewrite <- H. clear H. + ssprove_valid. + { + (* simpl. *) + unfold FDisjoint. + apply @parable. + + rewrite <- H_trim_ch_map_XTR. + rewrite <- H_trim_ch_map_XPD. + rewrite <- H_trim_PSK. rewrite <- trimmed_Ks. rewrite !link_trim_commut. @@ -615,10 +575,32 @@ Definition R_ch_map (d : nat) : (* apply idents_interface_foreach_disjoint. *) rewrite imfsetU. rewrite fdisjointUl. - apply /andP ; split ; [ solve_imfset_disjoint | ]. - apply idents_disjoint_foreach ; intros. - unfold idents. - solve_imfset_disjoint. + apply /andP ; split. + { + assert (PSK \notin O_star) by easy. + induction O_star. + - simpl. + rewrite <- fset0E. + rewrite imfset0. + apply fdisjoints0. + - rewrite interface_foreach_cons. + rewrite !imfsetU. + rewrite !fdisjointUr. + + rewrite notin_cons in H0. + move: H0 => /andP [ /eqP H0 H1 ]. + + repeat (apply /andP ; split). + + clear -H0. + solve_imfset_disjoint. + + solve_imfset_disjoint. + + now apply IHl. + } + { + apply idents_disjoint_foreach ; intros. + unfold idents. + solve_imfset_disjoint. + } } } { @@ -626,23 +608,12 @@ Definition R_ch_map (d : nat) : unfold FDisjoint. apply @parable. - eassert (trimmed (XTR_n_ℓ d) (R_ch_map_XTR_packages d M H)). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. - - eassert (trimmed (XPD_n_ℓ d) (R_ch_map_XPD_packages d M (H BOT))). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. + rewrite <- H_trim_ch_map_XTR. + rewrite <- H_trim_ch_map_XPD. rewrite <- trimmed_Ks. rewrite !link_trim_commut. - + solve_Parable. { @@ -681,20 +652,9 @@ Definition R_ch_map (d : nat) : unfold FDisjoint. apply @parable. - eassert (trimmed (XTR_n_ℓ d) (R_ch_map_XTR_packages d M H)). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. + rewrite <- H_trim_ch_map_XTR. + rewrite <- H_trim_ch_map_XPD. - eassert (trimmed (XPD_n_ℓ d) (R_ch_map_XPD_packages d M (H BOT))). - { - rewrite trimmed_eq_rect_r. - apply trimmed_ℓ_packages. - } - rewrite <- H. clear H. - solve_Parable. { @@ -707,6 +667,8 @@ Definition R_ch_map (d : nat) : intros. (* apply idents_foreach_disjoint_foreach_different ; intros. *) unfold idents. + + clear. solve_imfset_disjoint. } } @@ -829,6 +791,7 @@ Program Definition Gks_real_map (d : nat) : ∘ (par (XPD_DH_XTR d) (K_package d PSK O erefl false ∘ L_package d PSK F)) }. Next Obligation. intros. + rewrite <- fsetUid. eapply valid_link. 2:{ @@ -851,13 +814,24 @@ Next Obligation. unfold pack. (* assert (trimmed _ (XPD_packages d)). *) - unfold XPD_packages ; rewrite <- trimmed_ℓ_packages ; fold (XPD_packages d). + + unfold XPD_packages. + unfold eq_rect_r. + unfold eq_rect. + destruct (Logic.eq_sym _). + destruct (Logic.eq_sym _). + destruct (Logic.eq_sym _). + rewrite <- trimmed_ℓ_packages. rewrite !link_trim_commut. rewrite <- trimmed_dh. rewrite !link_trim_commut. - unfold XTR_packages ; rewrite <- trimmed_ℓ_packages ; fold (XTR_packages d). + unfold XTR_packages. + unfold eq_rect_r. + unfold eq_rect. + destruct (Logic.eq_sym _). + rewrite <- (trimmed_ℓ_packages d (λ (ℓ : nat) (H : (ℓ <= d)%N), xtr_level d ℓ H)) ; fold (XTR_packages d). rewrite !link_trim_commut. (* rewrite <- (trimmed_Ks d O_star). *) @@ -964,7 +938,7 @@ Program Definition Gks_ideal_map (d : nat) (Score : Simulator d) : package fset0 (KS_interface d) - (GET_O_star_ℓ d) := {package Score ∘ (R_ch_map d) }. + (GET_O_star_ℓ d) := {package (R_ch_map d) ∘ Score }. Next Obligation. admit. Admitted. @@ -1064,15 +1038,42 @@ Proof. now rewrite IHk. Qed. +Lemma get_map_with_in_num_notin2 : + forall (d : nat) k (Hk_le : (k <= d)%nat) x index n m, + forall (p : forall n, (d >= n)%nat → raw_package), + (n > k)%nat -> + (forall k Hk_le, (k < n)%nat -> getm (p k Hk_le) (serialize_name x n m index) = None) -> + map_with_in_num_upper d k + (H_le := Hk_le) + (λ (n : nat) (x1 : (n <= d)%N), p n x1) + (serialize_name x n m index) + = None. +Proof. + clear. + intros. + induction k. + - simpl. + intros. + now rewrite H0. + - intros. + simpl. + rewrite unionmE. + + replace (isSome (getm (map_with_in_num_upper _ _ _) _)) with false ; [ | symmetry ]. + 1: now rewrite H0. + + now rewrite IHk. +Qed. + Lemma map_with_in_num_upper_getm : forall (d : nat) (k : nat) (Hk_le : (k <= d)%nat) - (p : forall d n, (d >= n)%nat → raw_package) + (p : forall n, (d >= n)%nat → raw_package) x x0 index m, forall (H_le : (x0 <= k)%nat), (x0 <= m)%nat -> - (forall n k Hk_le, (k <> n)%nat -> (n <= m)%nat -> getm (p d k Hk_le) (serialize_name x n m index) = None) -> - getm (map_with_in_num_upper d k (H_le := Hk_le) (λ (n : nat) (x1 : (n <= d)%N), p d n x1)) (serialize_name x x0 m index) - = getm (p d x0 (leq_trans H_le Hk_le)) (serialize_name x x0 m index). + (forall n k Hk_le, (k <> n)%nat -> (n <= m)%nat -> getm (p k Hk_le) (serialize_name x n m index) = None) -> + getm (map_with_in_num_upper d k (H_le := Hk_le) (λ (n : nat) (x1 : (n <= d)%N), p n x1)) (serialize_name x x0 m index) + = getm (p x0 (leq_trans H_le Hk_le)) (serialize_name x x0 m index). Proof. intros. induction k. @@ -1092,7 +1093,7 @@ Proof. replace (isSome _) with false ; [ | symmetry ]. 1: now replace (leq_trans _ _) with (Hk_le). - rewrite get_map_with_in_num_notin ; [ reflexivity | .. ]. + rewrite get_map_with_in_num_notin2 ; [ reflexivity | .. ]. 1: apply H_le. intros. now rewrite H0. @@ -1104,7 +1105,7 @@ Proof. rewrite !IHk. - Lia.lia. - intros. - destruct (p d x0 _ _) eqn:pd_is. + destruct (p x0 _ _) eqn:pd_is. + unfold isSome. set (leq_trans _ _) in pd_is. replace (leq_trans _ _) with i by easy. @@ -1119,30 +1120,30 @@ Proof. Qed. Lemma ℓ_package_getm : - forall {L I} (d : nat) - {f : nat -> nat -> Interface} - (p : forall d (n : nat), (d >= n)%nat → package L (I d) (f d n)) - (H_trim_p : forall n, forall (H_ge : (d >= n)%nat), trimmed (f d n) (p d n H_ge)) - (Hdisj : ∀ (n ℓ : nat) , (n > ℓ)%nat -> (d >= n)%nat -> idents (f d ℓ) :#: idents (f d n)), + forall {L} (d : nat) + {g : nat -> Interface} + {f : nat -> Interface} + (p : forall (n : nat), (d >= n)%nat → package L (g n) (f n)) + (H_trim_p : forall n, forall (H_ge : (d >= n)%nat), trimmed (f n) (p n H_ge)) + (Hdisj : ∀ (n ℓ : nat) , (n > ℓ)%nat -> (d >= n)%nat -> idents (f ℓ) :#: idents (f n)), forall x x0 index, (forall (H_le : (x0 <= d)%nat), (∀ (n k : nat) (Hk_le : (k <= d)%N), - k ≠ n → (n <= d)%N → getm (pack (p d k Hk_le)) (serialize_name x n d index) = None) -> - getm (pack (ℓ_packages d (p d) H_trim_p Hdisj)) (serialize_name x x0 d index) = - getm (pack (p d x0 H_le)) (serialize_name x x0 d index) + k ≠ n → (n <= d)%N → getm (pack (p k Hk_le)) (serialize_name x n d index) = None) -> + getm (pack (ℓ_packages d (p) H_trim_p Hdisj)) (serialize_name x x0 d index) = + getm (pack (p x0 H_le)) (serialize_name x x0 d index) ). Proof. intros. unfold ℓ_packages. unfold pack. + unfold ℓ_raw_packages. rewrite (map_with_in_num_upper_getm d d (leqnn d) p x x0 index d). - now replace (leq_trans _ _) with (H_le). - assumption. - apply H. Qed. -(* parallel_raw (List.map (λ y : name, K_package d y x0 H1 false) O_star) (serialize_name x x0 d 1) *) - Lemma getm_parallel_raw : forall x y m (f : name -> raw_package) l index, uniq l -> @@ -1207,66 +1208,50 @@ Proof. ++ now apply IHl. Qed. -(* (parallel_raw (List.map (fun y => (pack (K_package d y n x1 false))) O_star)) *) - -Definition parallel_in_package - (A : eqType) (d : nat) L (f : A -> _) g Names (i : forall (a : A) (_ : a \in Names), package L (f a) (g a)) - (H : ∀ x y : A, x ≠ y → idents (g x) :#: idents (g y)) - (H1 : ∀ (a : A) (_ : a \in Names), trimmed (g a) (i a _)) - (H3 : uniq Names) : - package L - (interface_foreach f Names) - (interface_foreach g Names) := - {package - parallel_raw _ #with - valid_parable _ _ _ _ _ _ - (H) - H3 - (trimmed_pairs_cons_map_with_in_rel _ _ _ _ _ (fun a _ => H1 _ _)) - (valid_pairs_cons _ _ _ _ _ (fun m => pack_valid (i _ m))) }. - Lemma ℓ_list : forall {L I} (d : nat) (l : seq name) (l_uniq : uniq l) {f : nat -> name -> nat -> Interface} - (p : forall d (a : name) (n : nat), (d >= n)%nat → package L (I d a) (f d a n)) - (H_trim_p : forall d a n, forall (H_ge : (d >= n)%nat), trimmed (f d a n) (p d a n H_ge)) + (p : forall (a : name) (n : nat), (d >= n)%nat → package L (I d a) (f d a n)) + (H_trim_p : forall a n, forall (H_ge : (d >= n)%nat), trimmed (f d a n) (p a n H_ge)) (Hdisj : ∀ d a y n (ℓ : nat), ((a <> y /\ n = ℓ) \/ (n > ℓ)%nat) -> (d >= n)%nat -> idents (f d a ℓ) :#: idents (f d y n)), forall x x0 index (_ : x \in l), (forall (H_le : (x0 <= d)%nat), (∀ d (a x1 : name) x0 H_le n, (x0 <= d)%N /\ (n <= d)%N -> ((a ≠ x1) \/ (a = x1 /\ x0 <> n)) → - getm (pack (p d a x0 H_le)) (serialize_name x1 n d index) = None) -> + getm (pack (p a x0 H_le)) (serialize_name x1 n d index) = None) -> getm (pack (ℓ_packages d - (fun n x1 => parallel_package _ d L _ _ _ (fun a => p d a n x1) (fun a y H => Hdisj d a y n n (or_introl (conj H erefl)) x1) (fun a => H_trim_p d a n x1) l_uniq) + (fun n x1 => parallel_package d l + (fun a => p a n x1) + (fun a y H => Hdisj d a y n n (or_introl (conj H erefl)) x1) + (fun a => H_trim_p a n x1) + l_uniq) (fun n x1 => trimmed_parallel_raw - _ - l - _ (fun x y H => Hdisj d x y n n (or_introl (conj H erefl)) x1) l_uniq - (trimmed_pairs_cons _ _ _ (fun x => H_trim_p _ _ _ _))) - (fun n ℓ H1 H2 => idents_foreach_disjoint_foreach _ _ l (fun a b => Hdisj _ _ _ _ _ (or_intror H1) H2 )) (* (Hdisj x) *))) + (trimmed_pairs_map _ _ _ (fun x => H_trim_p _ _ _))) + (fun n ℓ H1 H2 => idents_foreach_disjoint_foreach _ _ l + (fun a b => Hdisj _ _ _ _ _ (or_intror H1) H2 )))) (serialize_name x x0 d index) = - getm (pack (p d x x0 H_le)) (serialize_name x x0 d index) + getm (pack (p x x0 H_le)) (serialize_name x x0 d index) ). Proof. intros. set (tp := fun _ _ => _). - pattern d in tp. + (* pattern d in tp. *) set (ℓp := fun _ _ => _) in tp. subst tp. set (t_trim := fun _ _ => _). - pattern d in t_trim. + (* pattern d in t_trim. *) set (ℓ_trim := fun _ _ => _) in t_trim. subst t_trim. set (t_disj := fun _ _ _ _ => _). - pattern d in t_disj. + (* pattern d in t_disj. *) set (ℓ_disj := fun _ _ _ _ => _) in t_disj. subst t_disj. @@ -1300,8 +1285,7 @@ Lemma map_intro_c2 : Proof. intros. - apply: eq_rel_perf_ind_ignore. - 1: apply fsubsetxx. + apply: eq_rel_perf_ind_eq. 2: now rewrite fdisjointUr in H0 ; apply (ssrbool.elimT andP) in H0 as []. 2: apply H0. 1:{ @@ -1419,67 +1403,91 @@ Proof. destruct function2_fset_cat. unfold combined. + unfold eq_rect_r. + destruct Logic.eq_sym. + unfold eq_rect. - epose (ℓ_list d O_star erefl - (fun d a n H_le => K_package d a n H_le false) _ _ x x0 1%nat _ _ _). - Unshelve. - 1: erewrite e. - 1:{ - unfold K_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET. + rewrite (ℓ_package_getm d). + - unfold parallel_package. + unfold pack. - replace (_ == _) with false. - 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + induction O_star ; [ easy | ]. + move: H2 => /orP [ /eqP H2 | H2 ] ; subst. + + rewrite map_eta. + rewrite parallel_raw_cons. + rewrite unionmE. - rewrite setmE. + unfold K_package. - unfold GET. + set ([fmap _ ; _ ]). + set (Option_Some _). + assert (getm f (serialize_name a x0 d 1) = o) ; subst f o. + { + unfold K_package. + rewrite !setmE. + unfold ".1", ".2". + unfold SET. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + rewrite eqxx. + reflexivity. + } + rewrite H2. + unfold isSome. + reflexivity. + + rewrite map_eta. + rewrite parallel_raw_cons. + rewrite unionmE. + + unfold K_package. + rewrite !setmE. + unfold ".1", ".2". + unfold SET. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + destruct (x == a) eqn:s_eq ; move: s_eq => /eqP s_eq ; subst. + * rewrite eqxx. + reflexivity. + * replace (_ == _) with false ; [ | symmetry ; apply /eqP ]. + 2: now apply serialize_name_notin_different_name. + rewrite emptymE. + unfold isSome. + + apply IHl. + apply H2. + - intros. + unfold parallel_package. + unfold pack. + + clear H2. + induction O_star ; [ easy | ]. + + rewrite map_eta. + rewrite parallel_raw_cons. + rewrite unionmE. + + unfold K_package. - rewrite eqxx. - reflexivity. - } - { - intros ; hnf. - do 2 apply trimmed_package_cons. - apply trimmed_empty_package. - } - { - intros. - hnf. - rewrite fset_cons. - rewrite fdisjointC. - rewrite fset_cons. - unfold idents. - destruct H3 ; solve_imfset_disjoint. - } - { - assumption. - } - { - assumption. - } - { - intros. - hnf. unfold K_package. - rewrite setmE. + rewrite !setmE. unfold ".1", ".2". unfold SET. replace (_ == _) with false. 2: symmetry ; apply /eqP ; solve_imfset_disjoint. - rewrite setmE. - unfold GET. replace (_ == _) with false. - 2: symmetry ; apply /eqP ; destruct H4 ; solve_imfset_disjoint. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } + rewrite emptymE. + unfold isSome. + apply IHl. } erewrite (lookup_op_spec_inv (R_ch_map d) (GET x x0 d)). @@ -1509,166 +1517,195 @@ Proof. unfold R_ch_map_XPD_packages. unfold eq_rect_r. + (* unfold eq_rect. *) + destruct interface_hierarchy_foreach_idemp. unfold eq_rect. - destruct Logic.eq_sym. - - epose (ℓ_list d XPR erefl - (fun d a n H_le => R_ch_map_XPD_package d n _ (λ _ : name, M) (λ (_ : name) (_ : nat), M) _ _ _) _ _ x x0 1%nat _ _ _). - erewrite e. - - erewrite (ℓ_package_getm d d (fun d n x1 => {package (parallel_raw (map_with_in XPR (fun y _ => pack (R_ch_map_XPD_package d n _ (λ _ : name, M) (λ (_ : name) (_ : nat), M) _ _ _))))}) _ _ _ x x0 1%nat H1). - - unfold ℓ_packages. - unfold pack. - unfold ℓ_raw_packages. - - (* Set Printing Implicit. *) - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (map_with_in XPR (fun y _ => pack (R_ch_map_XPD_package d n _ (λ _ : name, M) (λ (_ : name) (_ : nat), M) _ _ _)))) x x0 1 d _ H1). - { - unfold XPR. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e f g x0, - (x0 <= d)%nat -> - getm (pack (R_ch_map_XPD_package d x0 a b c e f g)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XPD_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XPD. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). - now rewrite emptymE. - } - Unshelve. - 2:{ admit. } - 2:{ apply H1. } - - { - admit. - (* intros. *) - (* unfold XPR. *) - - (* Optimize Heap. *) - (* (* Optimize Proof. *) *) - - (* unfold "++". *) - (* unfold map_with_in. *) - (* rewrite parallel_raw_cons. *) - (* (* rewrite !parallel_raw_cons. *) *) - (* Time Optimize Heap. *) - (* rewrite unionmE. *) - - (* unfold R_ch_map_XPD_package. *) - (* rewrite setmE. *) - (* unfold ".1", ".2". *) - (* unfold SET, GET. *) - (* unfold XPD. *) - - (* replace (_ == _) with false ; [ | symmetry ]. *) - (* 2: apply /eqP ; solve_imfset_disjoint. *) - (* now rewrite emptymE. *) - (* } *) - - (* repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). *) - (* now rewrite emptymE. *) - (* replace (isSome (getm _ _)) with false ; [ | symmetry ]. *) - (* 2: now rewrite H3. *) - (* 2:{ *) - (* unfold R_ch_map_XPD_package. *) - (* rewrite setmE. *) - (* unfold ".1", ".2". *) - (* unfold SET, GET. *) - (* unfold XPD. *) - - (* replace (_ == _) with false ; [ | symmetry ]. *) - (* 2: apply /eqP ; solve_imfset_disjoint. *) - - (* now rewrite emptymE. *) - (* } *) - } + unfold ℓ_parallel. + + set (p := fun _ _ => _). + set (H_abc := fun _ _ => _). + set (H_abcd := fun _ _ => _). + + rewrite (ℓ_package_getm d p). + - unfold parallel_package. + unfold pack. + + subst p. + hnf. + unfold parallel_package_with_in_rel_hierarchy. + + induction O_star. + + easy. + + move: H2 => /orP [ /eqP H2 | H2 ] ; subst. + * clear IHl. + unfold R_ch_map_XPD_package. + unfold pack. + + clear H_abc H_abcd. + + set (H_in := fun _ H => H). + generalize dependent H_in. + + set (XPR) at 2 3 5. + generalize dependent l0. + + induction XPR ; intros. + -- easy. + -- rewrite !map_with_in_rel_eta. + rewrite !parallel_raw_cons. + rewrite unionmE. + rewrite !setmE. + unfold ".1", ".2". + unfold XPD. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + rewrite emptymE. + unfold isSome at 2. + + apply IHl0. + * now apply IHl. + - intros. + + subst p. + hnf. + unfold parallel_package_with_in_rel_hierarchy. + unfold pack. + + induction O_star. + + easy. + + move: H2 => /orP [ /eqP H2 | H2 ] ; subst. + * clear IHl. + unfold R_ch_map_XPD_package. + unfold pack. + + clear H_abc H_abcd. + + set (H_in := fun _ H => H). + generalize dependent H_in. + + set (XPR) at 2 3 5. + generalize dependent l0. + + induction XPR ; intros. + -- easy. + -- rewrite !map_with_in_rel_eta. + rewrite !parallel_raw_cons. + rewrite unionmE. + rewrite !setmE. + unfold ".1", ".2". + unfold XPD. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + rewrite emptymE. + unfold isSome. + + apply IHl0. + * now apply IHl. } { unfold R_ch_map_XTR_packages. unfold eq_rect_r. + (* unfold eq_rect. *) + destruct interface_hierarchy_foreach_idemp. unfold eq_rect. - destruct Logic.eq_sym. - - unfold ℓ_packages. - unfold pack. - unfold ℓ_raw_packages. - - (* Set Printing Implicit. *) - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (map_with_in XTR_names (fun y _ => pack (R_ch_map_XTR_package d n _ (λ _ : name, M) _ _)))) x x0 1 d _ H1). - { - unfold XTR_names. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e x0, - (x0 <= d)%nat -> - getm (pack (R_ch_map_XTR_package d x0 a b c e)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XTR_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XTR_names. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). - now rewrite emptymE. - } - Unshelve. - 2: apply H1. - { - intros. - - unfold XTR_names. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e k x0, - (k <= d)%nat -> - (x0 <= d)%nat -> - getm (pack (R_ch_map_XTR_package d k a b c e)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XTR_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XTR_names. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - rewrite unionmE. - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H5] ; try rewrite unionmE). - now rewrite emptymE. - } + unfold ℓ_parallel. + + (* epose (ℓ_list d XPR erefl *) + (* (fun ℓ H_le a H => R_ch_map_XPD_package d ℓ _ (fun _ => M) (fun _ _ => M) _ (fun _ => _) (fun _ _ => _)) *) + (* _ _ x x0 1%nat _ _ _). *) + (* erewrite e. *) + + (* epose (ℓ_package_getm d (fun d n x1 => {package (parallel_raw (map_with_in XPR (fun y _ => pack (R_ch_map_XPD_package d n _ (λ _ : name, M) (λ (_ : name) (_ : nat), M) _ _ _))))}) _ _ x x0 1%nat H1). *) + (* rewrite e. *) + + set (p := fun _ _ => _). + set (H_abc := fun _ _ => _). + set (H_abcd := fun _ _ => _). + + rewrite (ℓ_package_getm d p). + - unfold parallel_package. + unfold pack. + + subst p. + hnf. + unfold parallel_package_with_in_rel_hierarchy. + + induction O_star. + + easy. + + move: H2 => /orP [ /eqP H2 | H2 ] ; subst. + * clear IHl. + unfold R_ch_map_XTR_package. + unfold pack. + + clear H_abc H_abcd. + + set (H_in := fun _ H => H). + generalize dependent H_in. + + set (XTR_names) at 2 3 5. + generalize dependent l0. + + induction XTR_names ; intros. + -- easy. + -- rewrite !map_with_in_rel_eta. + rewrite !parallel_raw_cons. + rewrite unionmE. + rewrite !setmE. + unfold ".1", ".2". + unfold XTR_names. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + rewrite emptymE. + unfold isSome at 2. + + apply IHl0. + * now apply IHl. + - intros. + + subst p. + hnf. + unfold parallel_package_with_in_rel_hierarchy. + unfold pack. + + induction O_star. + + easy. + + move: H2 => /orP [ /eqP H2 | H2 ] ; subst. + * clear IHl. + unfold R_ch_map_XTR_package. + unfold pack. + + clear H_abc H_abcd. + + set (H_in := fun _ H => H). + generalize dependent H_in. + + set (XTR_names) at 2 3 5. + generalize dependent l0. + + induction XTR_names ; intros. + -- easy. + -- rewrite !map_with_in_rel_eta. + rewrite !parallel_raw_cons. + rewrite unionmE. + rewrite !setmE. + unfold ".1", ".2". + unfold XTR_names. + + replace (_ == _) with false. + 2: symmetry ; apply /eqP ; solve_imfset_disjoint. + + rewrite emptymE. + unfold isSome. + + apply IHl0. + * now apply IHl. } } @@ -1731,7 +1768,7 @@ Proof. replace (_ == _) with false. 2: symmetry ; apply /eqP ; solve_imfset_disjoint. - + destruct (x == a) eqn:s_eq ; move: s_eq => /eqP s_eq ; subst. * rewrite eqxx. reflexivity. @@ -1743,13 +1780,21 @@ Proof. apply IHl. apply H2. } - - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) x x0 1 d _ H1). + + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + + (* erewrite (map_with_in_num_upper_getm). *) + erewrite (map_with_in_num_upper_getm d d (leqnn d) (* (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) *) _ x x0 1 d _ H1). { now rewrite H3. } { clear ; intros. + + unfold parallel_package. + induction O_star. - easy. - rewrite map_eta. @@ -1773,34 +1818,6 @@ Proof. } } - - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) x x0 1 d _ H1). - { - now rewrite H3. - } - { - clear ; intros. - induction O_star. - - easy. - - rewrite map_eta. - rewrite parallel_raw_cons. - rewrite unionmE. - - rewrite !setmE. - unfold ".1", ".2". - unfold SET, GET. - - destruct (n == k) eqn:n_is_neq_k ; move: n_is_neq_k => /eqP n_is_neq_k ; subst. - * Lia.lia. - * replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - now rewrite emptymE. - } - } Unshelve. 2:{ apply H1. } @@ -1808,324 +1825,28 @@ Proof. unfold bind ; fold @bind. unfold code_link ; fold @code_link. - erewrite (lookup_op_spec_inv (R_ch_map d) (GET x x0 d)). - 2:{ - rewrite !setmE. - unfold ".1", ".2". - unfold SET, GET. - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - rewrite unionmE. - - replace (isSome _) with false ; [ | symmetry ]. - 2:{ - rewrite unionmE. - replace (isSome (getm _ _)) with false ; [ | symmetry ]. - 2:{ - unfold R_ch_map_XPD_packages. - - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - - unfold ℓ_packages. - unfold pack. - unfold ℓ_raw_packages. - - (* Set Printing Implicit. *) - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (map_with_in XPR (fun y _ => pack (R_ch_map_XPD_package d n _ (λ _ : name, M) (λ (_ : name) (_ : nat), M) _ _ _)))) x x0 1 d _ H1). - { - unfold XPR. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e f g x0, - (x0 <= d)%nat -> - getm (pack (R_ch_map_XPD_package d x0 a b c e f g)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XPD_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XPD. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). - now rewrite emptymE. - } - Unshelve. - 2:{ admit. } - 2:{ apply H1. } - - { - admit. - (* intros. *) - (* unfold XPR. *) - - (* Optimize Heap. *) - (* (* Optimize Proof. *) *) - - (* unfold "++". *) - (* unfold map_with_in. *) - (* rewrite parallel_raw_cons. *) - (* (* rewrite !parallel_raw_cons. *) *) - (* Time Optimize Heap. *) - (* rewrite unionmE. *) - - (* unfold R_ch_map_XPD_package. *) - (* rewrite setmE. *) - (* unfold ".1", ".2". *) - (* unfold SET, GET. *) - (* unfold XPD. *) - - (* replace (_ == _) with false ; [ | symmetry ]. *) - (* 2: apply /eqP ; solve_imfset_disjoint. *) - (* now rewrite emptymE. *) - (* } *) - - (* repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). *) - (* now rewrite emptymE. *) - (* replace (isSome (getm _ _)) with false ; [ | symmetry ]. *) - (* 2: now rewrite H3. *) - (* 2:{ *) - (* unfold R_ch_map_XPD_package. *) - (* rewrite setmE. *) - (* unfold ".1", ".2". *) - (* unfold SET, GET. *) - (* unfold XPD. *) - - (* replace (_ == _) with false ; [ | symmetry ]. *) - (* 2: apply /eqP ; solve_imfset_disjoint. *) - - (* now rewrite emptymE. *) - (* } *) - } - } - { - unfold R_ch_map_XTR_packages. - - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - - unfold ℓ_packages. - unfold pack. - unfold ℓ_raw_packages. - - (* Set Printing Implicit. *) - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (map_with_in XTR_names (fun y _ => pack (R_ch_map_XTR_package d n _ (λ _ : name, M) _ _)))) x x0 1 d _ H1). - { - unfold XTR_names. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e x0, - (x0 <= d)%nat -> - getm (pack (R_ch_map_XTR_package d x0 a b c e)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XTR_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XTR_names. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H3] ; try rewrite unionmE). - now rewrite emptymE. - } - Unshelve. - 2: apply H1. - { - intros. - - unfold XTR_names. - unfold "++". - unfold map_with_in. - rewrite !parallel_raw_cons. - rewrite unionmE. - - assert (forall a b c d e k x0, - (k <= d)%nat -> - (x0 <= d)%nat -> - getm (pack (R_ch_map_XTR_package d k a b c e)) (serialize_name x x0 d 1) = None). - { - intros. - unfold R_ch_map_XTR_package. - rewrite setmE. - unfold ".1", ".2". - unfold SET, GET. - unfold XTR_names. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - now rewrite emptymE. - } - - rewrite unionmE. - repeat (replace (isSome (getm _ _)) with false ; [ | symmetry ] ; [ | now rewrite H5] ; try rewrite unionmE). - now rewrite emptymE. - } - } - } - - rewrite mapmE. - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - - unfold combined. - - unfold ℓ_packages. - unfold pack. - unfold ℓ_raw_packages. - - eassert (forall H_le, - parallel_raw - (List.map (λ y : name, pack (K_package d y x0 H_le false)) O_star) - (serialize_name x x0 d 1) - = some (_)). - { - clear -H2 ; intros. - induction O_star. - - easy. - - move: H2 => /orP [ /eqP H2 | H2 ] ; subst. - + rewrite map_eta. - rewrite parallel_raw_cons. - rewrite unionmE. - - unfold K_package. - - set ([fmap _ ; _ ]). - set (Option_Some _). - assert (getm f (serialize_name a x0 d 1) = o) ; subst f o. - { - unfold K_package. - rewrite !setmE. - unfold ".1", ".2". - unfold SET. - - replace (_ == _) with false. - 2: symmetry ; apply /eqP ; solve_imfset_disjoint. - - rewrite eqxx. - reflexivity. - } - rewrite H2. - unfold isSome. - reflexivity. - + rewrite map_eta. - rewrite parallel_raw_cons. - rewrite unionmE. - - unfold K_package. - rewrite !setmE. - unfold ".1", ".2". - unfold SET. - - replace (_ == _) with false. - 2: symmetry ; apply /eqP ; solve_imfset_disjoint. - - destruct (x == a) eqn:s_eq ; move: s_eq => /eqP s_eq ; subst. - * rewrite eqxx. - reflexivity. - * replace (_ == _) with false ; [ | symmetry ; apply /eqP ]. - 2: now apply serialize_name_notin_different_name. - rewrite emptymE. - unfold isSome. - - apply IHl. - apply H2. - } - - erewrite (map_with_in_num_upper_getm d d (leqnn d) (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) x x0 1 d _ H1). - { - now rewrite H3. - } - { - clear ; intros. - induction O_star. - - easy. - - rewrite map_eta. - rewrite parallel_raw_cons. - rewrite unionmE. - - rewrite !setmE. - unfold ".1", ".2". - unfold SET, GET. - - destruct (n == k) eqn:n_is_neq_k ; move: n_is_neq_k => /eqP n_is_neq_k ; subst. - * Lia.lia. - * replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - replace (_ == _) with false ; [ | symmetry ]. - 2: apply /eqP ; solve_imfset_disjoint. - - now rewrite emptymE. - } - } - } - Unshelve. - 2: apply H1. - - - (* epose getmP. *) - - unfold get_or_fn. - unfold bind ; fold @bind. - unfold code_link ; fold @code_link. - - ssprove_sync. - 1: admit. + ssprove_sync_eq. intros. - destruct a. - + simpl. - apply r_ret. - intros. - split. - * reflexivity. - * apply H3. - + simpl. - ssprove_sync. - intros. - apply r_ret. - split. - * reflexivity. - * apply H3. + destruct a ; [ now apply r_ret | ]. + simpl. + ssprove_sync_eq. + intros. + now apply r_ret. } } -Admitted. +Defined. Axiom AdvantageFrame : forall G0 G1 G2 G3 A, (AdvantageE G0 G1 A = 0)%R -> (AdvantageE G2 G3 A = 0)%R -> AdvantageE G0 G2 A = AdvantageE G1 G3 A. +Axiom Gks : forall Names, + loc_GamePair (interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (Names) d + :|: interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (Names) d + ). + Lemma map_outro_c5 : forall (d : nat), forall (Score : Simulator d), @@ -2152,9 +1873,41 @@ Proof. unfold Gcore_ideal. - (* rewrite <- link_assoc. *) + unfold Gcore_real. + + unfold R_ch_map. + set ({package _}). + + epose Advantage_par. + + rewrite <- !link_assoc. + rewrite <- Advantage_link. + replace (Ks d O_star false erefl) with (Ks d O_star true erefl) by admit. + rewrite <- Advantage_link. + + unfold XPD_DH_XTR. + unfold pack. + + (* erewrite <- interchange. *) + (* 1:{ *) + (* erewrite <- interchange. *) + + + (* rewrite par_link. *) + + (* Advantage_par *) + (* interchange *) + + (* rewrite <- !link_assoc. *) + (* (* epose Advantage_link. *) *) (* epose Advantage_link. *) (* rewrite <- Advantage_link. *) + + (* epose Advantage_triangle. *) + + (* replace (Ks d O_star false erefl) with (Ks d O_star true erefl) by admit. *) + (* rewrite <- Advantage_link. *) + (* rewrite <- Advantage_link. *) (* rewrite <- Advantage_link. *) diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index c2c0d4d0..71fe8ea5 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -1118,7 +1118,7 @@ Proof. now apply (ssrbool.elimN eqP) in H0. Qed. -Lemma trimmed_parallel_raw : forall {A : eqType} f I L, +Lemma trimmed_parallel_raw : forall {A : eqType} {f I L}, (∀ x y : A, x ≠ y → idents (f x) :#: idents (f y)) -> uniq I -> (* all_idents_disjoint f I -> *) trimmed_pairs (List.map f I) L -> @@ -1475,6 +1475,34 @@ Qed. (forall n m, idents (f n) :#: idents (g m)) -> idents (interface_foreach f Lf) :#: idents (interface_foreach g Lg)). Proof. + (* intros. *) + (* induction Lf. *) + (* + simpl. *) + (* rewrite <- fset0E. *) + (* unfold idents. *) + (* rewrite imfset0. *) + (* apply fdisjoint0s. *) + (* + rewrite interface_foreach_cons. *) + (* unfold idents. *) + (* rewrite !imfsetU. *) + (* rewrite fdisjointUl. *) + (* rewrite IHLf ; clear IHLf. *) + (* rewrite Bool.andb_true_r. *) + + (* induction Lg. *) + (* * simpl. *) + (* rewrite <- fset0E. *) + (* unfold idents. *) + (* rewrite imfset0. *) + (* apply fdisjoints0. *) + (* * rewrite interface_foreach_cons. *) + (* unfold idents. *) + (* rewrite !imfsetU. *) + (* rewrite fdisjointUr. *) + (* rewrite IHLg ; clear IHLg. *) + (* rewrite Bool.andb_true_r. *) + (* apply H. *) + intros. apply idents_disjoint_foreach ; intros. rewrite fdisjointC. @@ -1609,7 +1637,7 @@ Qed. } } Qed. - + Definition parallel_package_with_in_rel {A : eqType} (d : nat) {L} Names {f : A -> _} {g : forall (a : A), (a \in Names) -> _} (i : forall (a : A) (H : a \in Names), package L (f a) (g a H)) (H : ∀ (x y : A) Hx Hy, x ≠ y → idents (g x Hx) :#: idents (g y Hy)) @@ -1697,34 +1725,36 @@ Theorem valid_forall : forall {A : eqType} {L} g f u Names (d ℓ : nat), (d >= ℓ)%nat -> (∀ x y : A, x ≠ y → idents (f x) :#: idents (f y)) -> uniq Names -> trimmed_pairs (List.map f Names) (List.map (u ℓ) Names) -> - (valid_pairs L (List.map (g^~ ℓ) Names) (List.map f Names) + (valid_pairs L (List.map g Names) (List.map f Names) (List.map (u ℓ) Names)) -> ValidPackage L - (interface_hierarchy_foreach g Names d) - (interface_foreach (A := A) f Names) (parallel_raw (List.map (u ℓ) Names)). + (interface_foreach g Names) + (interface_foreach (A := A) f Names) + (parallel_raw (List.map (u ℓ) Names)). Proof. intros. eapply valid_package_inject_import. - - instantiate (1 := interface_foreach (g^~ ℓ) Names). + - instantiate (1 := interface_foreach g Names). unfold interface_hierarchy_foreach. unfold interface_hierarchy ; fold interface_hierarchy. induction d. - + simpl. - destruct ℓ ; [ | discriminate ]. + + (* simpl. *) + (* destruct ℓ ; [ | discriminate ]. *) apply fsubsetxx. - + apply fsubsetU. fold interface_hierarchy. - apply /orP. - destruct (ℓ == d.+1) eqn:is_eq. - * apply (ssrbool.elimT eqP) in is_eq. - subst. - right. - apply fsubsetxx. - * apply (ssrbool.elimF eqP) in is_eq. - left. - apply IHd. - Lia.lia. + + apply fsubsetxx. + (* apply fsubsetU. fold interface_hierarchy. *) + (* apply /orP. *) + (* destruct (ℓ == d.+1) eqn:is_eq. *) + (* * apply (ssrbool.elimT eqP) in is_eq. *) + (* subst. *) + (* right. *) + (* apply fsubsetxx. *) + (* * apply (ssrbool.elimF eqP) in is_eq. *) + (* left. *) + (* apply IHd. *) + (* Lia.lia. *) - now apply valid_parable. (* + apply H0. *) (* + apply H1. *) @@ -1772,39 +1802,53 @@ Proof. (* + apply H3. *) Qed. -Theorem valid_forall_map_with_in_rel : forall {A : eqType} {L} g f Names u (d ℓ : nat), - (d >= ℓ)%nat -> - (∀ x y : A, x ≠ y → idents (f x) :#: idents (f y)) -> uniq Names -> - trimmed_pairs (List.map f Names) (map_with_in_rel Names Names (H_in := fun a H0 => H0) (u ℓ)) -> - (valid_pairs L (List.map (g^~ ℓ) Names) (List.map f Names) - (map_with_in_rel Names Names (H_in := fun a H0 => H0) (u ℓ))) -> +Theorem valid_forall_map_with_in_rel : forall {A : eqType} {L} Names l (d : nat) {g f} ℓ (H_le : (ℓ <= d)%nat) (u : forall a (H : a \in Names), raw_package) H_in, + (∀ (x y : A), x ≠ y → idents (f x) :#: idents (f y)) -> uniq l -> + (trimmed_pairs (List.map f l) (map_with_in_rel Names l (H_in := H_in) u)) -> + (valid_pairs L (List.map g l) (List.map (f) l) + (map_with_in_rel Names l (H_in := H_in) u)) -> ValidPackage L - (interface_hierarchy_foreach g Names d) - (interface_foreach (A := A) f Names) (parallel_raw (map_with_in_rel Names Names (H_in := fun a H0 => H0) (u ℓ))). + (interface_foreach g l) + (interface_foreach f l) + (parallel_raw (map_with_in_rel Names l (H_in := H_in) u)). Proof. intros. eapply valid_package_inject_import. - - instantiate (1 := interface_foreach (g^~ ℓ) Names). + - instantiate (1 := interface_foreach g l). unfold interface_hierarchy_foreach. unfold interface_hierarchy ; fold interface_hierarchy. induction d. + simpl. - destruct ℓ ; [ | discriminate ]. + (* destruct ℓ ; [ | discriminate ]. *) + apply fsubsetxx. + + (* apply fsubsetU. fold interface_hierarchy. *) + (* apply /orP. *) + (* right. *) apply fsubsetxx. - + apply fsubsetU. fold interface_hierarchy. - apply /orP. - destruct (ℓ == d.+1) eqn:is_eq. - * apply (ssrbool.elimT eqP) in is_eq. - subst. - right. - apply fsubsetxx. - * apply (ssrbool.elimF eqP) in is_eq. - left. - apply IHd. - Lia.lia. - now apply valid_parable. + (* + apply H. *) + (* + apply H0. *) + (* + apply H1. *) + (* + apply H2. *) + (* epose (H1 ℓ H_le). *) +Qed. + +Lemma forall_valid_from_packages : + forall {A : eqType} {L} {g f} Names l (ℓ : nat) (u : forall a (H : a \in Names), package L (g a ℓ) (f a)) H_in, + valid_pairs L (List.map (g^~ ℓ) l) (List.map f l) + (map_with_in_rel Names l (H_in := H_in) (λ (a : A) (H3 : (a \in Names) = true), pack (u a H3))). +Proof. + intros. + induction l. + - reflexivity. + - rewrite !map_eta. + rewrite map_with_in_rel_eta. + rewrite valid_pairs_cons. + split. + + apply u. + + apply IHl. Qed. Theorem map_with_in_num_upper_trimmed : @@ -1863,18 +1907,19 @@ Proof. now apply map_with_in_num_upper_trimmed. Qed. -Definition ℓ_packages {L I} +Definition ℓ_packages {L} (d : nat) + {g : nat -> Interface} {f : nat -> Interface} - (p : forall (n : nat), (d >= n)%nat → package L I (f n)) + (p : forall (n : nat), (d >= n)%nat → package L (g n) (f n)) (H_trim_p : forall n, forall (H_ge : (d >= n)%nat), trimmed (f n) (p n H_ge)) (Hdisj : ∀ (n ℓ : nat) , (n > ℓ)%nat -> (d >= n)%nat -> idents (f ℓ) :#: idents (f n)) - : package L I (interface_hierarchy f d). + : package L (interface_hierarchy g d) (interface_hierarchy f d). Proof. refine {package ℓ_raw_packages d p}. unfold ℓ_raw_packages. set (leqnn d). - set d in i at 2 |- * at 1 3. + set d in i at 2 |- * at 1 2 4. generalize dependent i. generalize dependent n. induction n ; intros. @@ -1882,7 +1927,7 @@ Proof. apply p. - simpl. rewrite <- (fsetUid L). - rewrite <- (fsetUid I). + (* rewrite <- (fsetUid I). *) apply valid_par. + (* epose ℓ_raw_level_Parable. *) @@ -1908,14 +1953,14 @@ Proof. + apply p. Defined. -Lemma interface_foreach_trivial : forall i L (* d *), +Lemma interface_foreach_trivial : forall {A} i L (* d *), L <> [] -> - i = (interface_foreach (λ (n : name), i) L ). + i = (interface_foreach (λ (n : A), i) L ). Proof. intros. destruct L ; [ easy | ]. clear H. - generalize dependent n. + generalize dependent a. induction L ; intros. { rewrite interface_foreach_cons. @@ -1931,31 +1976,107 @@ Proof. } Qed. -Lemma interface_hierarchy_trivial : forall i L d, - L <> [] -> - i = (interface_hierarchy_foreach (λ (n : name) (d0 : nat), i) L d ). +Lemma interface_hierarchy_empty : forall d, + (interface_hierarchy (λ (n : nat), [interface]) d ) = [interface]. Proof. intros. + rewrite <- fset0E. + induction d. + - reflexivity. + - simpl. rewrite fsetU0. rewrite IHd. reflexivity. +Qed. - unfold interface_hierarchy_foreach. - simpl. +Lemma interface_hierarchy_trivial : forall i d, + i = (interface_hierarchy (λ (_ : nat), i) d ). +Proof. + intros. induction d. { - now apply interface_foreach_trivial. + reflexivity. } { simpl. rewrite <- IHd. - rewrite <- interface_foreach_trivial. - 2: easy. now rewrite fsetUid. } Defined. -Definition trimmed_ℓ_packages {L I} +Lemma interface_hierarchy_foreach_trivial : forall {A} i L d, + L <> [] -> + i = (interface_hierarchy_foreach (λ (_ : A) (_ : nat), i) L d ). +Proof. + intros. + unfold interface_hierarchy_foreach. + rewrite <- interface_hierarchy_trivial. + now apply interface_foreach_trivial. +Defined. + +Definition combined (A : eqType) (d : nat) L (f : A -> _) g Names (i : forall (n : nat), (n <= d)%nat -> forall (a : A), package L (f a) (g a n)) + (H : forall n, (n <= d)%nat -> ∀ x y : A, x ≠ y → idents (g x n) :#: idents (g y n)) + (H0 : forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y : A, idents (g x ℓ) :#: idents (g y n)) + (H1 : forall n (H_le : (n <= d)%nat), ∀ a : A, trimmed (g a n) (i n H_le a)) + (H3 : uniq Names) : + package L + (interface_foreach f Names) + (interface_hierarchy_foreach g Names d). +Proof. + rewrite (interface_hierarchy_trivial (interface_foreach f (Names)) d). + apply (ℓ_packages + d + (fun n H_le => + parallel_package d (Names) (i n H_le) (H n H_le) (H1 n H_le) H3 + ) + (fun n H_le => + trimmed_parallel_raw + (H n H_le) + H3 + (trimmed_pairs_map _ _ _ (H1 n H_le))) + (fun n ℓ i0 i1 => idents_foreach_disjoint_foreach _ _ (Names) (H0 n ℓ i0 i1)) + ). +Defined. + +Definition parallel_package_with_in_rel_hierarchy {A : eqType} {L} {g f} Names l (d : nat) (u : forall ℓ (H_le : (ℓ <= d)%nat) a (H : a \in Names), package L (g a ℓ) (f a ℓ)) H_in : + (∀ ℓ n, ∀ x y : A, (x ≠ y \/ ℓ ≠ n) → idents (f x ℓ) :#: idents (f y n)) -> + uniq l -> + (forall ℓ H_le, trimmed_pairs (List.map (f^~ℓ) l) (map_with_in_rel Names l (H_in := H_in) (fun a H => pack (u ℓ H_le a H)))) -> + forall ℓ H_le, + package L (interface_foreach (g^~ ℓ) l) (interface_foreach (f^~ ℓ) l) := + (fun H H0 H1 ℓ H_le => + {package (parallel_raw (map_with_in_rel Names l (H_in := H_in) (fun a H => pack (u ℓ H_le a H)))) + #with + valid_forall_map_with_in_rel + (f := (f^~ℓ)) + Names l d _ H_le (u _ _) H_in (fun _ _ H_neq => H _ _ _ _ (or_introl H_neq)) H0 (H1 _ _) + (forall_valid_from_packages Names l _ (u ℓ H_le) H_in)}). + +Definition ℓ_parallel {A : eqType} {L} {g f} Names l (d : nat) (u : forall ℓ (H_le : (ℓ <= d)%nat) a (H : a \in Names), package L (g a ℓ) (f a ℓ)) H_in : + (∀ ℓ n, ∀ x y : A, (x ≠ y \/ ℓ ≠ n) → idents (f x ℓ) :#: idents (f y n)) -> + uniq l -> + (forall ℓ H_le, trimmed_pairs (List.map (f^~ℓ) l) (map_with_in_rel Names l (H_in := H_in) (fun a H => pack (u ℓ H_le a H)))) -> + package L + (interface_hierarchy_foreach g l d) + (interface_hierarchy_foreach f l d) := + (fun H H0 H1 => + ℓ_packages d + (λ ℓ H_le, parallel_package_with_in_rel_hierarchy Names l d u H_in H H0 H1 ℓ H_le) + (fun a H_le => trimmed_parallel_raw (fun _ _ H_neq => H _ _ _ _ (or_introl H_neq)) H0 (H1 _ _)) + (fun n ℓ H_le H_ge => idents_foreach_disjoint_foreach _ _ _ + (fun _ _ => + H _ _ _ _ + (or_intror + ((eq_ind_r (λ ℓ0 : nat, (ℓ0 < n)%N → False) (λ H_le0 : (n < n)%N, + (eq_ind_r (λ b : bool, b → False) (λ H_le1 : false, + False_ind False (eq_ind false (λ e : bool, if e then False else True) I true H_le1)) (ltnn n)) + H_le0) (y:=ℓ))^~ + H_le + ) + )))). + +Definition trimmed_ℓ_packages {L} (d : nat) + {g : nat -> Interface} {f : nat -> Interface} - (p : forall (n : nat), (d >= n)%nat → package L I (f n)) + (p : forall (n : nat), (d >= n)%nat → package L (g n) (f n)) (H_trim_p : forall n, forall (H_ge : (d >= n)%nat), trimmed (f n) (p n H_ge)) (Hdisj : ∀ (n ℓ : nat) , (n > ℓ)%nat -> (d >= n)%nat -> idents (f ℓ) :#: idents (f n)) : trimmed (interface_hierarchy f d) (ℓ_packages d p H_trim_p Hdisj). diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index e86c1b5a..157679da 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -149,15 +149,22 @@ Section XTR_XPD. Definition XTR_names := [ES; HS; AS]. + Definition GET_XTR_ℓ d ℓ := interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) XTR_names. + Definition GET_XTR d : Interface := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XTR_names) d. + Definition SET_XTR_ℓ d ℓ := interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) XTR_names. + Definition SET_XTR d : Interface := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XTR_names) d. - Definition XTR_n_ℓ d := + Definition XTR_n d := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names d. + Definition XTR_n_ℓ d ℓ := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names ℓ. + Lemma trimmed_Xtr : forall ℓ n d, trimmed [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ] @@ -174,16 +181,17 @@ Section XTR_XPD. Lemma valid_xtr_level : forall d ℓ, (ℓ <= d)%N -> - ValidPackage f_parameter_cursor_loc (GET_XTR d :|: SET_XTR d) + ValidPackage f_parameter_cursor_loc + (GET_XTR_ℓ d ℓ :|: SET_XTR_ℓ d ℓ) (interface_foreach (fun n => [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout]) XTR_names) (xtr_level_raw ℓ d). Proof. intros. - rewrite interface_hierarchy_foreachU. + rewrite interface_foreach_U. apply (valid_forall (L := fset0) - (λ (n : name) (ℓ : nat), + (λ (n : name), [interface #val #[GET n ℓ d] : chXTRout → chGETout ] :|: [interface #val #[SET n ℓ d] : chSETinp → chSETout ]) (λ n : name, [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ]) @@ -232,9 +240,11 @@ Section XTR_XPD. Qed. Definition XTR_packages (d : nat) : - package fset0 (GET_XTR d :|: SET_XTR d) (XTR_n_ℓ (d)). + package fset0 (GET_XTR d :|: SET_XTR d) (XTR_n (d)). Proof. - refine (ℓ_packages d (xtr_level d) _ _). + unfold GET_XTR. + rewrite interface_hierarchy_U. + refine (ℓ_packages d (g := fun ℓ => GET_XTR_ℓ d ℓ :|: SET_XTR_ℓ d ℓ) (fun ℓ H => xtr_level d ℓ H) _ _). { intros ℓ ?. apply trimmed_xtr_level. @@ -304,17 +314,26 @@ Section XTR_XPD. [EEM; CET; BIND; BINDER; SHT; CHT; HSALT; RM; CAT; SAT; EAM] ++ (* has a single parent *) [] (* or exactly on sibling of n is contained in XPR *). - Definition XPD_n_ℓ (d : nat) := + Definition XPD_n (d : nat) := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout ]) XPR d. + Definition XPD_n_ℓ d ℓ := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]) XPR ℓ. + Definition GET_XPD d : Interface := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XPR) d. + Definition GET_XPD_ℓ d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XPR). + Definition SET_XPD d : Interface := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XPR) d. + Definition SET_XPD_ℓ d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XPR). + Lemma trimmed_Xpd : forall ℓ n d, trimmed [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout ] @@ -331,23 +350,19 @@ Section XTR_XPD. Lemma valid_xpd_level : forall d ℓ, (ℓ <= d)%nat -> - ValidPackage f_parameter_cursor_loc (GET_XPD d :|: SET_XPD d :|: [interface #val #[ HASH ] : chHASHinp → chHASHout]) + ValidPackage f_parameter_cursor_loc + (GET_XPD_ℓ d ℓ :|: SET_XPD_ℓ d ℓ :|: [interface #val #[ HASH ] : chHASHinp → chHASHout]) (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) XPR) (xpd_level_raw ℓ d). Proof. intros. - (* unfold XPR. *) - unfold "++". - rewrite (interface_hierarchy_trivial [interface #val #[HASH] : chHASHout → chHASHout ] XPR d). + rewrite (interface_foreach_trivial [interface #val #[HASH] : chHASHout → chHASHout ] XPR). 2: easy. - rewrite interface_hierarchy_foreachU. - rewrite interface_hierarchy_foreachU. - - (* setoid_rewrite interface_hierarchy_foreachU. *) + rewrite !interface_foreach_U. apply (valid_forall - (λ (n : name) (ℓ : nat), + (λ (n : name), [interface #val #[GET n ℓ d] : chXPDout → chGETout ] :|: [interface #val #[SET n ℓ d] : chSETinp → chSETout ] :|: [interface #val #[HASH] : chHASHout → chHASHout ]) @@ -392,8 +407,11 @@ Section XTR_XPD. Definition XPD_packages (d : nat) : package fset0 ((GET_XPD d :|: SET_XPD d) :|: - [interface #val #[ HASH ] : chHASHinp → chHASHout]) (XPD_n_ℓ d). + [interface #val #[ HASH ] : chHASHinp → chHASHout]) (XPD_n d). Proof. + rewrite (interface_hierarchy_trivial [interface #val #[HASH] : chHASHout → chHASHout ] d). + rewrite !interface_hierarchy_U. + refine (ℓ_packages d (xpd_level d) _ _). { intros. @@ -471,10 +489,17 @@ Section XTR_XPD. Qed. Lemma trimmed_xpd_package : forall (d : nat), - trimmed (XPD_n_ℓ d) (XPD_packages d). + trimmed (XPD_n d) (XPD_packages d). Proof. intros. simpl. + unfold XPD_packages. + unfold eq_rect_r. + destruct (Logic.eq_sym (interface_hierarchy_trivial [interface #val #[HASH] : chHASHout → chHASHout ] d)). + unfold eq_rect. + destruct (Logic.eq_sym _). + unfold eq_rect. + destruct (Logic.eq_sym _). erewrite <- (ℓ_raw_package_trimmed d ([eta xpd_level] d)). 2:{ intros ℓ. @@ -491,10 +516,13 @@ Section XTR_XPD. Qed. Lemma trimmed_xtr_package : forall (d : nat), - trimmed (XTR_n_ℓ d) (XTR_packages d). + trimmed (XTR_n d) (XTR_packages d). Proof. intros. simpl. + unfold XTR_packages. + unfold eq_rect_r. + destruct (Logic.eq_sym _). erewrite <- (ℓ_raw_package_trimmed d ([eta xtr_level] d)). 2:{ intros ℓ. From 453aef88086e638477f0ecf00425645b489c83f6 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 19 Feb 2025 17:34:41 +0100 Subject: [PATCH 02/10] Re-index key packages, so GET is prev and SET is next --- proofs/ssprove/handwritten/BasePackages.v | 14 +- proofs/ssprove/handwritten/Core.v | 562 +++++++++++++--- proofs/ssprove/handwritten/CoreTheorem.v | 420 +++++++++--- proofs/ssprove/handwritten/Dependencies.v | 52 +- proofs/ssprove/handwritten/KeyPackages.v | 237 +++---- .../ssprove/handwritten/KeySchedulePackages.v | 12 +- proofs/ssprove/handwritten/MainTheorem.v | 17 +- proofs/ssprove/handwritten/MapPackage.v | 18 +- proofs/ssprove/handwritten/Utility.v | 24 +- proofs/ssprove/handwritten/XTR_XPD.v | 631 ++++++++++++++---- proofs/ssprove/handwritten/ssp_helper.v | 154 ++++- 11 files changed, 1671 insertions(+), 470 deletions(-) diff --git a/proofs/ssprove/handwritten/BasePackages.v b/proofs/ssprove/handwritten/BasePackages.v index 472b130e..56721146 100644 --- a/proofs/ssprove/handwritten/BasePackages.v +++ b/proofs/ssprove/handwritten/BasePackages.v @@ -96,7 +96,19 @@ Notation " 'chHASHinp' " := Notation " 'chHASHout' " := (bitvec) (in custom pack_type at level 2). -Definition HASH := 1%nat. +(* Definition HASH := 1%nat. *) + +Inductive HashFunction := +| f_hash +| f_xtr +| f_xpd. + +Definition HASH (f : HashFunction) : nat := + 22%nat + match f with + | f_hash => 0 + | f_xtr => 1 + | f_xpd => 2 + end. Notation " 'chUNQinp' " := (chHandle × 'bool × chKey) diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 9da6f1e0..1437b19d 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -83,28 +83,60 @@ Section Core. Context {DepInstance : Dependencies}. Existing Instance DepInstance. - Axiom Gcore_ki : package fset0 [interface] [interface]. - Axiom Gcore_hyb : forall d (ℓ : nat), + Notation " 'chXTRinp' " := + (chHandle × chHandle) + (in custom pack_type at level 2). + Notation " 'chXTRout' " := + (chHandle) + (in custom pack_type at level 2). + + Definition Gcore_sodh (d : nat) : + package fset0 + ([interface + #val #[ DHEXP ] : chDHEXPinp → chDHEXPout ; + #val #[ DHGEN ] : chDHGENinp → chDHGENout + ] :|: interface_hierarchy (fun ℓ => [interface #val #[ XTR HS ℓ d ] : chXTRinp → chXTRout]) d) + [interface]. + Proof. + Admitted. + + Definition Gcore_hyb : forall d (ℓ : nat), package f_parameter_cursor_loc - ((GET_XPD d :|: SET_XPD d) - :|: (GET_DH d :|: SET_DH d) - :|: [interface #val #[ HASH ] : chHASHinp → chHASHout] - :|: (GET_XTR d :|: SET_XTR d)) - (SET_O_star_ℓ d :|: GET_O_star_ℓ d). + ((GET_ℓ XPR d ℓ :|: SET_ℓ XPR d ℓ) + :|: (GET_DH_ℓ d ℓ :|: SET_DH_ℓ d ℓ) + :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] + :|: (GET_ℓ XTR_names d ℓ :|: SET_ℓ XTR_names d ℓ)) + (SET_O_star_ℓ d ℓ :|: GET_O_star_ℓ d ℓ). + Proof. + intros. + epose {package (Ks ℓ d _ O_star false erefl ∘ Ls ℓ O_star F erefl)}. + fold GET. + Admitted. - Axiom hash : package fset0 [interface] [interface #val #[ HASH ] : chHASHinp → chHASHout]. - Lemma trimmed_hash : (trimmed ([interface #val #[ HASH ] : chHASHinp → chHASHout]) hash). Admitted. + Definition Gcore_ki : forall d k, + package f_parameter_cursor_loc + ((GET_n XPR d k :|: SET_n XPR d k) + :|: (GET_DH d k :|: SET_DH d k) + :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] + :|: (GET_n XTR_names d k :|: SET_n XTR_names d k)) + (SET_O_star d k :|: GET_O_star d k). + Proof. + intros. + Admitted. - Definition Simulator d := + Axiom Hash : package fset0 [interface] [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. + Lemma trimmed_hash : (trimmed ([interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) Hash). Admitted. + + Definition Simulator d k := (package fset0 ([interface - #val #[ SET PSK 0 d ] : chSETinp → chSETout + #val #[ SET PSK 0 k ] : chSETinp → chSETout ] :|: DH_interface - :|: XTR_n d - :|: XPD_n d) - (UNQ_O_star d) + :|: XTR_n d k + :|: XPD_n d k) + (UNQ_O_star k) ). Lemma idents_interface_hierachy2 : @@ -122,8 +154,8 @@ Section Core. apply H. Qed. - Lemma xtr_dh : forall (d : nat), - domm (pack (XTR_packages d)) :#: domm (pack (DH_package d)) = true. + Lemma xtr_dh : forall (d k : nat) H_lt, + domm (pack (XTR_packages d k H_lt)) :#: domm (pack (DH_package d k)) = true. Proof. intros. unfold pack. @@ -143,8 +175,8 @@ Section Core. all: Lia.lia. Qed. - Lemma xpd_dh : forall (d : nat), - domm (pack (XPD_packages d)) :#: domm (pack (DH_package d)) = true. + Lemma xpd_dh : forall (d k : nat) H_lt, + domm (pack (XPD_packages d k H_lt)) :#: domm (pack (DH_package d k)) = true. Proof. intros. unfold pack. @@ -165,89 +197,429 @@ Section Core. all: Lia.lia. Qed. + Lemma subset_pair : forall {A : ordType} (x : {fset A}) y Lx Ly, + x :<=: y -> + Lx :<=: Ly -> + x :|: Lx :<=: y :|: Ly. + Proof. + intros. + rewrite fsubUset ; apply /andP ; split. + * rewrite fsubsetU ; [ easy | ]. + apply /orP ; left. + apply H. + * rewrite fsubsetU ; [ easy | ]. + apply /orP ; right. + apply H0. + Qed. + + Lemma interface_foreach_subset_pairs : forall {A: eqType} f g (L : seq A), + (forall (x : A), (x \in L) -> f x :<=: g x) -> + interface_foreach f L :<=: interface_foreach g L. + Proof. + intros. + induction L. + + apply fsubsetxx. + + rewrite !interface_foreach_cons. + apply subset_pair. + * apply H. + apply mem_head. + * apply IHL. + intros. + apply H. + rewrite in_cons. + now apply /orP ; right. + Qed. + + Lemma interface_hierarchy_subset_pairs : forall f g d, + (forall ℓ, (ℓ <= d)%nat -> f ℓ :<=: g ℓ) -> + interface_hierarchy f d :<=: interface_hierarchy g d. + Proof. + intros. + induction d. + + now apply H. + + simpl. + apply subset_pair. + * apply IHd. + now intros ; apply H. + * now apply H. + Qed. + + Lemma interface_hierarchy_foreach_subset_pairs : forall {A: eqType} f g (L : seq A) d, + (forall (x : A), (x \in L) -> forall ℓ, (ℓ <= d)%nat -> f x ℓ :<=: g x ℓ) -> + interface_hierarchy_foreach f L d :<=: interface_hierarchy_foreach (A := A) g L d. + Proof. + intros. + unfold interface_hierarchy_foreach. + apply interface_hierarchy_subset_pairs. + intros. + now apply interface_foreach_subset_pairs. + Qed. + + Lemma interface_foreach_subset : forall {A: eqType} f (L : seq A) K, + (forall (x : A), (x \in L) -> f x :<=: K) -> + interface_foreach f L :<=: K. + Proof. + intros. + induction L. + + simpl. rewrite <- fset0E. apply fsub0set. + + rewrite interface_foreach_cons. + rewrite fsubUset. + apply /andP ; split. + * apply H. + apply mem_head. + * apply IHL. + intros. + apply H. + rewrite in_cons. + now apply /orP ; right. + Qed. + + Lemma interface_foreach_subsetR : forall {A: eqType} f (L : seq A) K, + (exists (x : A) (H_in : x \in L), K :<=: f x) -> + L <> [] -> + K :<=: interface_foreach f L. + Proof. + intros. + induction L ; [ easy | ]. + unfold interface_hierarchy. + rewrite interface_foreach_cons. + rewrite fsubsetU ; [ easy | ]. + apply /orP. + + destruct H as [? []]. + rewrite in_cons in x0. + move: x0 => /orP [/eqP ? | x0 ] ; subst. + + now left. + + right. + apply IHL. + 2: destruct L ; easy. + exists x, x0. + apply H. + Qed. + + Lemma interface_hierarchy_foreach_subset : forall {A: eqType} f (L : seq A) d K, + (forall (x : A), (x \in L) -> forall ℓ, (ℓ <= d)%nat -> f x ℓ :<=: K) -> + interface_hierarchy_foreach f L d :<=: K. + Proof. + intros. + unfold interface_hierarchy_foreach. + induction d in H |- * at 1. + - now apply interface_foreach_subset. + - simpl. + rewrite fsubUset. + apply /andP ; split. + + now apply IHn. + + now apply interface_foreach_subset. + Qed. + + Lemma interface_hierarchy_foreach_subsetR : forall {A: eqType} f (L : seq A) d K, + (exists (x : A) (H_in : x \in L) ℓ (H_le : (ℓ <= d)%nat), K :<=: f x ℓ) -> + L <> [] -> + K :<=: interface_hierarchy_foreach f L d. + Proof. + intros. + unfold interface_hierarchy_foreach. + induction d in H |- * at 1. + - destruct H as [? [? [? []]]]. + apply interface_foreach_subsetR. + 2: easy. + exists x, x0. + destruct x1 ; [ | easy ]. + apply H. + - simpl. + rewrite fsubsetU ; [ easy | ]. + apply /orP. + + destruct H as [? [? [? []]]]. + destruct (x1 == n.+1) eqn:x_eq ; move: x_eq => /eqP x_eq ; subst. + + right. + clear IHn. + apply interface_foreach_subsetR. + 2: easy. + exists x, x0. + apply H. + + left. + apply IHn. + exists x, x0, x1. + eexists ; [ Lia.lia | ]. + apply H. + Qed. + Obligation Tactic := (* try timeout 8 *) idtac. - Program Definition XPD_DH_XTR d : + + Lemma interface_hierarchy_foreach_shift : + forall d k {index p} L, + interface_hierarchy_foreach (fun n ℓ => (fset [(serialize_name n ℓ k index, p)])) L d.+1 = + interface_foreach (fun n => fset [(serialize_name n O k index, p)]) L + :|: interface_hierarchy_foreach (fun n ℓ => fset [(serialize_name n (ℓ.+1) k index,p ) ]) L d + . + Proof. + intros. + induction d. + - simpl. reflexivity. + - unfold interface_hierarchy_foreach at 2. + unfold interface_hierarchy ; fold interface_hierarchy. + fold (interface_hierarchy_foreach (λ n ℓ, fset [(serialize_name n ℓ.+1 k index, p)]) L). + rewrite fsetUA. + rewrite fsetUC. + rewrite <- IHd. + rewrite fsetUC. + reflexivity. + Qed. + + Program Definition XPD_ d k H_lt : package (L_K :|: L_L) [interface] (XPD_n d k) := + {package + XPD_packages d k H_lt ∘ + (par + (Ks d.+1 k (H_lt) (undup (XPR ++ XPR_parents)) false erefl ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) + Hash) + #with _ + }. + (* Next Obligation. *) + (* intros. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* Qed. *) + (* Next Obligation. *) + (* intros. *) + (* simpl. *) + (* rewrite fset_cons. *) + (* rewrite fdisjointC. *) + (* rewrite fset_cons. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* Qed. *) + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1: apply pack_valid. + + rewrite <- fsetU0. + rewrite <- (fsetUid (fset [::])). + apply valid_par. + 3: apply pack_valid. + 2:{ + eapply valid_link. + 2: apply pack_valid. + { + unfold GET_n. + unfold GET_ℓ. + fold (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) XPR_parents). + + eapply valid_package_inject_export. + 2: apply pack_valid. + + rewrite fsetUC. + apply subset_pair. + - rewrite fsubUset. + apply /andP. + split. + + rewrite interface_hierarchy_foreach_shift. + unfold SET. + + apply fsubsetU. + apply /orP ; right. + + unfold interface_hierarchy_foreach. + apply interface_hierarchy_subset_pairs. + intros. + solve_in_fset. + + unfold SET_n. + + unfold interface_hierarchy_foreach. + unfold interface_hierarchy ; fold interface_hierarchy. + apply fsubsetU. + apply /orP ; left. + + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + assert (x \in undup (XPR ++ XPR_parents)). + { + rewrite !in_cons in H0 ; rewrite <- in_cons in H0 ; rewrite mem_seq1 in H0. + now repeat move: H0 => /orP [ /eqP ? | H0 ] ; [ .. | move: H0 => /eqP ? ] ; subst. + } + exists x, H1. + apply fsubsetxx. + - unfold GET_n. + + unfold interface_hierarchy_foreach. + unfold interface_hierarchy ; fold interface_hierarchy. + apply fsubsetU. + apply /orP ; left. + + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + assert (x \in undup (XPR ++ XPR_parents)). + { + rewrite !in_cons in H0 ; rewrite <- in_cons in H0 ; rewrite mem_seq1 in H0. + now repeat move: H0 => /orP [ /eqP ? | H0 ] ; [ .. | move: H0 => /eqP ? ] ; subst. + } + exists x, H1. + apply fsubsetxx. + } + } + + rewrite <- trimmed_Ks. + rewrite !link_trim_commut. + rewrite <- trimmed_hash. + solve_Parable. + + unfold interface_hierarchy_foreach. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + apply idents_disjoint_foreach. + intros. + rewrite (fset_cons (SET _ _ _, _)). + unfold idents. + solve_imfset_disjoint. + Qed. + + Lemma idents_disjoint_foreach_in : + (forall {A: eqType} f g (L : list A), + (forall m, (m \in L) -> idents f :#: idents (g m)) -> + idents f :#: idents (interface_foreach g L)). + Proof. + intros. + induction L. + + simpl. + rewrite <- fset0E. + unfold idents. + rewrite imfset0. + apply fdisjoints0. + + rewrite interface_foreach_cons. + unfold idents. + rewrite !imfsetU. + rewrite fdisjointUr. + rewrite IHL ; clear IHL. + * rewrite Bool.andb_true_r. + apply H. + apply mem_head. + * intros. + apply H. + rewrite in_cons. + apply /orP. + now right. + Qed. + + Program Definition XPD_DH_XTR d k H_lt : package (L_K :|: L_L) [interface] - (XPD_n d :|: (DH_interface :|: XTR_n d)) := + (XPD_n d k :|: (DH_interface :|: XTR_n d k)) := {package (par - (XPD_packages d ∘ (par (Ks d XPR false erefl ∘ Ls d XPR F erefl) hash)) - (par (DH_package d ∘ (Ks d [DH] false erefl ∘ Ls d [DH] F erefl)) - (XTR_packages d ∘ (Ks d XTR_names false erefl ∘ Ls d XTR_names F erefl)))) - ∘ (Ks d O_star false erefl ∘ Ls d O_star F (erefl))}. + (XPD_ d k H_lt) + (par (DH_package d k ∘ (Ks d k (ltnW H_lt) [DH] false erefl ∘ Ls k [DH] F erefl)) + (XTR_packages d k (ltnW H_lt) ∘ (Ks d k (ltnW H_lt) (undup (XTR_names ++ XTR_parent_names)) false erefl ∘ Ls k (undup (XTR_names ++ XTR_parent_names)) Z erefl)))) + ∘ (Ks d k (ltnW H_lt) O_star false erefl ∘ Ls k O_star Z (erefl))}. Final Obligation. intros. rewrite <- fsetUid. eapply valid_link. - 2:{ - eapply valid_package_inject_import. - 2: eapply valid_link ; [ apply Ks | apply Ls ]. - rewrite <- fset0E. - apply fsub0set. - } + 2: eapply valid_link ; apply pack_valid. - rewrite <- trimmed_xpd_package. + (* rewrite <- trimmed_xpd_package. *) rewrite <- trimmed_dh. - rewrite <- trimmed_hash. + (* rewrite <- trimmed_hash. *) rewrite <- trimmed_xtr_package. eapply valid_par_upto. - 2:{ - eapply valid_link. - 1: apply valid_trim ; apply (pack_valid (XPD_packages d)). - apply valid_par. - 2: rewrite (fsetUC) ; eapply valid_link ; apply pack_valid. - 2: apply valid_trim ; apply pack_valid. - rewrite <- trimmed_Ks. - rewrite link_trim_commut. - solve_Parable. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - rewrite function_fset_cat. - unfold idents. - solve_imfset_disjoint. - } - + 2: apply pack_valid. 2:{ apply valid_par. 2:{ eapply valid_link. - 2:{ - eapply valid_link. - - apply (Ks _ _ _). - - apply (Ls _ _ _). + 2: eapply valid_link ; apply pack_valid. + 1:{ + apply valid_trim. + eapply valid_package_inject_import. + 2: apply pack_valid. + apply fsubsetU. + apply /orP. + left. + apply fsubsetxx. + } + } + 2:{ + eapply valid_link. + 2: eapply valid_link ; apply pack_valid. + 1:{ + apply valid_trim. + eapply valid_package_inject_import. + 2: apply pack_valid. + rewrite fsetUC. + apply subset_pair. + 1:{ + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + assert (x \in undup (XTR_names ++ XTR_parent_names)). + { + rewrite !in_cons in H0 ; rewrite <- in_cons in H0 ; rewrite mem_seq1 in H0. + now repeat move: H0 => /orP [ /eqP ? | H0 ] ; [ .. | move: H0 => /eqP ? ] ; subst. + } + exists x, H1. + apply fsubsetxx. + } + 1:{ + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + assert (x \in undup (XTR_names ++ XTR_parent_names)). + { + rewrite !in_cons in H0 ; rewrite <- in_cons in H0 ; rewrite mem_seq1 in H0. + now repeat move: H0 => /orP [ /eqP ? | H0 ] ; [ .. | move: H0 => /eqP ? ] ; subst. + } + exists x, H1. + apply fsubsetxx. + } } - apply valid_trim ; eapply valid_package_inject_import ; [ | apply pack_valid ]. - 1: unfold SET_DH , interface_hierarchy_foreach, interface_foreach ; solve_in_fset. } - 1:{ + { rewrite !link_trim_commut. solve_Parable. + rewrite fdisjointC. - unfold XTR_n_ℓ. + unfold XTR_n. + unfold DH_interface. + rewrite fdisjointC. apply idents_interface_hierachy3. intros. - unfold DH_interface. rewrite fset_cons. unfold idents. solve_imfset_disjoint. } - { - eapply valid_link. - 2:{ - eapply valid_link. - - apply (Ks _ _ _). - - apply (Ls _ _ _). - } - apply valid_trim ; eapply valid_package_inject_import ; [ | apply pack_valid ]. - 1: fold (GET_XTR d) ; fold (SET_XTR d) ; solve_in_fset. - } } - 1:{ + rewrite !link_trim_commut. + unfold XPD_. + unfold pack. + rewrite <- trimmed_xpd_package. rewrite !link_trim_commut. solve_Parable. @@ -267,8 +639,17 @@ Section Core. rewrite fdisjointC. apply idents_interface_hierachy3. intros. + apply idents_disjoint_foreach_in. + intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. + intros. unfold idents. solve_imfset_disjoint. + + rewrite !in_cons in H1. + rewrite !in_cons in H2. + repeat move: H1 => /orP [/eqP ? | H1 ] ; subst ; repeat move: H2 => /orP [/eqP ? | H2 ] ; subst ; now apply serialize_name_notin_different_name. } } 1: solve_in_fset. @@ -286,56 +667,59 @@ Section Core. Defined. Obligation Tactic := (* try timeout 8 *) idtac. - Program Definition Gcore_real (d : nat) : + Program Definition Gcore_real (d k : nat) H_lt : package (L_K :|: L_L) [interface] (* ((GET_XPD :|: SET_XPD) *) (* :|: DH_Set_interface *) (* :|: [interface #val #[ HASH ] : chHASHinp → chHASHout] *) (* :|: (GET_XTR :|: SET_XTR)) *) - ((* SET_O_star_ℓ d :|: *)GET_O_star_ℓ d) + ((* SET_O_star_ℓ d :|: *) GET_O_star d k) (* ([interface #val #[SET_psk 0] : chSETinp → chSETout ; *) (* #val #[DHGEN] : 'unit → 'unit ; *) (* #val #[DHEXP] : 'unit → 'unit ] :|: XTR_n_ℓ d :|: XPD_n_ℓ d :|: *) (* GET_o_star_ℓ d) *) := - {package (Ks d O_star false erefl ∘ Ls d O_star F erefl) ∘ XPD_DH_XTR d}. + {package (Ks d k (ltnW H_lt) O_star false erefl ∘ Ls k O_star F erefl) ∘ XPD_DH_XTR d k H_lt}. Final Obligation. intros. rewrite <- fsetUid. eapply valid_link. 2: apply XPD_DH_XTR. eapply valid_link. - - eapply valid_package_inject_export. - 2: apply (Ks _ _ _). - unfold GET_O_star_ℓ. - solve_in_fset. - - eapply valid_package_inject_import. - 2: apply (Ls _ _ _). - rewrite <- fset0E. - solve_in_fset. + - eapply valid_package_inject_export. + 2: apply (Ks _ _ _). + unfold GET_O_star. + apply fsubsetU. + apply /orP. + right. + apply fsubsetxx. + - eapply valid_package_inject_import. + 2: apply (Ls _ _ _). + rewrite <- fset0E. + solve_in_fset. Defined. Fail Next Obligation. - Program Definition Gcore_ideal (d : nat) (Score : Simulator d) : + Program Definition Gcore_ideal (d k : nat) H_lt (Score : Simulator d k) : package L_K ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout ] :|: DH_interface :|: - XTR_n d :|: - XPD_n d :|: - GET_O_star_ℓ d) - (GET_O_star_ℓ d) := - {package (Ks d O_star true erefl ∘ Score) }. + XTR_n d k :|: + XPD_n d k :|: + GET_O_star d k) + (GET_O_star d k) := + {package (Ks d k H_lt O_star true erefl ∘ Score) }. Final Obligation. intros. rewrite <- fsetUid. - eapply (valid_link_upto L_K _ _ _ (UNQ_O_star d)). - - epose (pack_valid (Ks d O_star true erefl)). + eapply (valid_link_upto L_K _ _ _ (UNQ_O_star k)). + - epose (pack_valid (Ks d k H_lt O_star true erefl)). eapply valid_package_inject_export. 2: apply v. - unfold GET_O_star_ℓ. + unfold GET_O_star. solve_in_fset. - eapply valid_package_inject_import. 2: apply (pack_valid Score). diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index e7587624..0219599d 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -88,106 +88,352 @@ Section CoreTheorem. Context {DepInstance : Dependencies}. Existing Instance DepInstance. - Axiom R_cr : package fset0 [interface] [interface]. - Axiom R_Z : package fset0 [interface] [interface]. - Axiom R_D : package fset0 [interface] [interface]. + Definition Gacr (f : HashFunction) (b : bool) : + package fset0 + [interface] + [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. + Proof. + (* refine [package *) + (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) + (* (* get_or_fn _ _ _ *) *) + (* d ← untag (f t) ;; *) + (* if b && d \in Hash *) + (* then fail *) + (* else Hash *) + (* } *) + (* ]. *) + (* Qed. *) + Admitted. + + (* Definition Gacr : *) + (* loc_GamePair *) + (* [interface *) + (* (* #val #[ ACR ] : 'unit → 'unit *) *) + (* ]. *) + (* (* HASH(t) .. *) *) + + Definition R_cr : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + + Definition R_Z (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. -Axiom Gacr : - loc_GamePair - [interface - (* #val #[ ACR ] : 'unit → 'unit *) - ]. -(* HASH(t) .. *) + Axiom R_D : package fset0 [interface] [interface]. -Axiom Gsodh : + Axiom Gsodh : loc_GamePair [interface (* #val #[ SODH ] : 'unit → 'unit *) ]. -Axiom Ai : raw_package -> bool -> raw_package. -Axiom R_sodh : package fset0 [interface] [interface]. - -Axiom Gcore_sodh : package fset0 [interface] [interface]. - -Lemma core_theorem : - forall (d : nat), - forall (Score : Simulator d), - forall (LA : {fset Location}) (A : raw_package), + Axiom Ai : raw_package -> bool -> raw_package. + Axiom R_sodh : package fset0 [interface] [interface]. + + (* Definition Nk_package (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : *) + (* package *) + (* L_K *) + (* [interface *) + (* #val #[ UNQ DH d ] : chUNQinp → chUNQout ; *) + (* #val #[ SET DH ℓ d ] : chSETinp → chSETout *) + (* ] *) + (* [interface *) + (* #val #[ GET DH ℓ d ] : chGETinp → chGETout *) + (* ]. *) + + Obligation Tactic := (* try timeout 8 *) idtac. + Program Definition layer1 ℓ d (H_le : (ℓ <= d)%nat) : + package fset0 + [interface] + [interface + #val #[ GET DH ℓ d ] : chGETinp → chGETout + ] := + {package Nk_package ℓ d H_le ∘ (par (DH_package d) (Ls d [DH] Z erefl)) #with _ }. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer2_zero d : + package fset0 + [interface + #val #[ SET PSK O d ] : chSETinp → chSETout + ] + [interface + #val #[ GET PSK O d ] : chGETinp → chGETout + ] := + {package Ks d [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer2_succ ℓ d (H_le : (ℓ <= d)%nat) : + package fset0 + [interface + #val #[ SET PSK ℓ d ] : chSETinp → chSETout + ] + [interface + #val #[ GET PSK ℓ d ] : chGETinp → chGETout + ] := + {package Ks d [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer2_xpd ℓ d (H_le : (ℓ <= d)%nat) : + package fset0 + [interface] + (XPD_n_ℓ d ℓ) := + xpd_level d ℓ H_le. + Admit Obligations. + Fail Next Obligation. + + Definition layer3 ℓ d (H_le : (ℓ <= d)%nat) := Hash. + + Program Definition layer4_salt d : + package fset0 + [interface] + (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ d ] : chGETinp → chGETout]) d) := + {package Ks d [ZERO_SALT] false erefl ∘ Ls d [ZERO_SALT] Z erefl #with _}. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer4_ikm d : + package fset0 + [interface] + (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ d ] : chGETinp → chGETout]) d) := + {package Ks d [ZERO_IKM] false erefl ∘ Ls d [ZERO_IKM] Z erefl #with _}. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer4_xtr ℓ d H_le : + package fset0 + (XTR_n_ℓ d ℓ :|: GET_XTR_ℓ d ℓ) + (SET_XTR_ℓ d ℓ) := xtr_level d ℓ H_le. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer4_check d : + package fset0 + (XPD_n d) + (XPD_n d :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. + Admit Obligations. + Fail Next Obligation. + + Program Definition layer4_xpd d : + package fset0 + (XPD_n d :|: SET_XPD d) + (GET_XPD d) := {package XPD_packages d ∘ layer4_check d #with _}. + Admit Obligations. + Fail Next Obligation. + + Definition core (d : nat) : package fset0 + (interface_hierarchy (fun x => [interface]) d) + (GET_O_star d). + Proof. + refine (ℓ_packages d _ _ _). + Unshelve. + 3:{ + intros n H. + epose (dh := layer1 n d H). + epose (layer2_xpd n d H). + epose (hash := layer3 n d H). + epose (salt0 := layer4_salt d). + epose (ikm0 := layer4_ikm d). + epose (check := layer4_check d). + epose (xtr := layer4_xtr n d H). + epose (xpd := layer4_xpd d). + + epose (T := package fset0 + [interface] + (match n with + | O => [interface] + | S n => (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) all_names n) + end)). + + epose (set_xtr := fun psk (sub_packages : T) => {package + xtr ∘ + parallel_raw [ + pack dh; + pack psk; + pack hash; + pack salt0; + pack ikm0; + pack sub_packages] + #with _} : package fset0 [interface] (SET_XTR_ℓ d n)). + Unshelve. + { + + } + + epose (set_xpd := fun psk (sub_packages : T) => {package + xpd ∘ + parallel_raw [ + pack dh; + pack psk; + pack hash; + pack salt0; + pack ikm0; + pack sub_packages] + #with _} : package fset0 [interface] (SET_XPD_ℓ d n)). + + (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) + (* (parallel_raw [ *) + (* pack (set_xtr psk sub_packages); *) + (* pack (set_xpd psk sub_packages); *) + (* pack (Ls d O_star Z _)]) #with _}). *) + epose (output := fun psk + (sub_packages : T) => + {package Ks d all_names false erefl ∘ + (parallel_raw [ + pack (set_xtr psk sub_packages); + pack (set_xpd psk sub_packages); + pack (Ls d all_names Z _)]) #with _}). + + + assert (package fset0 + [interface] + (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) all_names n)). + { + induction n as [ | ℓ ]. + - epose (psk0 := layer2_zero d). + refine (output psk0 _). + unfold GET_XPD_ℓ. + refine {package emptym #with valid_empty_package _ _}. + - epose (pskS := layer2_succ (S ℓ) d H). + refine (output pskS _). + specialize (IHℓ (leq_trans H (leqnSn _))). + apply IHℓ. + } + + Unshelve. + { + simpl. + + (* refine {package (pack IHℓ) #with _}. *) + (* apply (pack_valid IHℓ). *) + + (* apply (valid_package_inject_export _ _ _ (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) *) + (* all_names ℓ)). *) + (* 2: apply (pack_valid IHℓ). *) + + (* unfold GET_XPD_ℓ. *) + + + + + + + apply + + Unshelve. + { + ssprove_valid. + - epose valid_parable. + + } + + } + Qed. + + Lemma core_theorem : + forall (d : nat), + forall (Score : Simulator d), + forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d) A_export A → - (AdvantageE - (Gcore_real d) - (Gcore_ideal d Score) (A (* ∘ R d M H *)) - <= sumR_l [R_cr; R_Z; R_D] (fun R => Advantage Gacr (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE Gcore_sodh (Gcore_ideal d Score) (Ai A i)) - )%R. -Proof. - intros. -Admitted. - -Lemma equation20_lhs : - forall (d : nat), - forall (Score : Simulator d), - forall i, - forall (LA : {fset Location}) (A : raw_package), + (AdvantageE + (Gcore_real d) + (Gcore_ideal d Score) (A (* ∘ R d M H *)) + <= sumR_l [R_cr; (R_Z f_hash); R_D] (fun R => Advantage (Gacr f_hash) (A ∘ R)) + +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d) (Gcore_ideal d Score) (Ai A i)) + )%R. + Proof. + intros. + unfold sumR_l. + rewrite addr0. + rewrite addrA. + + unfold Gcore_real. + unfold pack. + + + (* unfold Gacr. *) + (* simpl. *) + (* simpl. *) + Admitted. + + Lemma equation20_lhs : + forall (d : nat), + forall (Score : Simulator d), + forall i, + forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d) A_export A → - (AdvantageE Gcore_sodh (Gcore_hyb d 0) (Ai A i) = 0)%R. -Proof. Admitted. - -Lemma equation20_rhs : - forall (d : nat), - forall (Score : Simulator d), - forall i, - forall (LA : {fset Location}) (A : raw_package), + (AdvantageE (Gcore_sodh d) (Gcore_hyb d 0) (Ai A i) = 0)%R. + Proof. Admitted. + + Lemma equation20_rhs : + forall (d : nat), + forall (Score : Simulator d), + forall i, + forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d) A_export A → - (AdvantageE Gcore_ki (Gcore_hyb d d) (Ai A i) = 0)%R. -Proof. Admitted. - -Lemma hyb_telescope : - forall (d : nat), - forall (Score : Simulator d), - (* forall (K_table : chHandle -> nat), *) - forall i, - forall (LA : {fset Location}) (A : raw_package), + (AdvantageE (Gcore_ki d) (Gcore_hyb d d) (Ai A i) = 0)%R. + Proof. + intros. + Admitted. + + Lemma hyb_telescope : + forall (d : nat), + forall (Score : Simulator d), + (* forall (K_table : chHandle -> nat), *) + forall i, + forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d) A_export A → (AdvantageE (Gcore_hyb d 0) (Gcore_hyb d d) (Ai A i) - = sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) + = sumR 0 (d-1) (leq0n (d-1)) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) )%R. -Proof. Admitted. - -Lemma equation20_eq : - forall (d : nat), - forall (Score : Simulator d), - (* forall (K_table : chHandle -> nat), *) - forall i, - forall (LA : {fset Location}) (A : raw_package), + Proof. + intros. + unfold sumR. + induction d. + - simpl. + (* unfold Gcore_hyb. *) + Admitted. + + Lemma equation20_eq : + forall (d : nat), + forall (Score : Simulator d), + (* forall (K_table : chHandle -> nat), *) + forall i, + forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d) A_export A → - (AdvantageE Gcore_sodh (Gcore_ideal d Score) (Ai A i) - <= AdvantageE Gcore_ki (Gcore_ideal d Score) (Ai A i) - +sumR 0 (d-1) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) - )%R. -Proof. - intros. - - eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb d 0)). - rewrite (equation20_lhs d Score). - rewrite add0r. - - eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := Gcore_ki). - rewrite addrC. - apply Num.Theory.lerD ; [ easy | ]. - - eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb d d)). - - epose (e := equation20_rhs d Score). - setoid_rewrite (Advantage_sym _ _) in e. - rewrite e ; clear e. - rewrite addr0. - - setoid_rewrite <- hyb_telescope ; easy. -Qed. + (AdvantageE (Gcore_sodh d) (Gcore_ideal d Score) (Ai A i) + <= AdvantageE (Gcore_ki d) (Gcore_ideal d Score) (Ai A i) + +sumR 0 (d-1) (leq0n (d-1)) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) + )%R. + Proof. + intros. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (Gcore_hyb d 0)). + rewrite (equation20_lhs d Score). + rewrite add0r. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := Gcore_ki d). + rewrite addrC. + apply Num.Theory.lerD ; [ easy | ]. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (Gcore_hyb d d)). + + epose (e := equation20_rhs d Score). + setoid_rewrite (Advantage_sym _ _) in e. + rewrite e ; clear e. + rewrite addr0. + + setoid_rewrite <- hyb_telescope ; easy. + Qed. End CoreTheorem. diff --git a/proofs/ssprove/handwritten/Dependencies.v b/proofs/ssprove/handwritten/Dependencies.v index e77fde07..2e41ca3e 100644 --- a/proofs/ssprove/handwritten/Dependencies.v +++ b/proofs/ssprove/handwritten/Dependencies.v @@ -82,7 +82,7 @@ Definition fin_L_table : finType := Definition chL_table := 'fin #|fin_L_table|. Class Dependencies := { - PrntN: name -> code fset0 fset0 (chName × chName) ; + (* PrntN: name -> (* code fset0 fset0 *) (chProd chName chName) ; *) Labels : name -> bool -> code fset0 fset0 chLabel ; (* O_star : list name ; *) xpd : chKey -> (chLabel * bitvec) -> code fset0 fset0 chKey ; @@ -111,5 +111,55 @@ Class Dependencies := { DHEXP_function : chGroup -> chGroup -> code fset0 fset0 chHandle ; }. +Definition PrntN (n : name) : chProd chName chName := + let (a,b) := + match n with + | ES => (ZERO_SALT, PSK) + | EEM | CET | ESALT | BIND => (ES, BOT) + | BINDER => (BIND, BOT) + | HS => (ESALT, DH) + | SHT | CHT | HSALT => (HS, BOT) + | AS => (HSALT, ZERO_IKM) + | CAT | SAT | RM | EAM => (AS, BOT) + | PSK => (RM, BOT) + | _ => (BOT, BOT) + end + in (name_to_chName a, name_to_chName b). + +Lemma TlsLikeKeySchedule : + (ZERO_SALT \in all_names) + /\ (PSK \in all_names) + /\ (ES \in all_names) + /\ (ESALT \in all_names) + /\ (DH \in all_names) + /\ (HS \in all_names) + /\ (HSALT \in all_names) + /\ (ZERO_IKM \in all_names) + /\ (AS \in all_names) + /\ (RM \in all_names) + (* Maps 0salt, dh and 0ikm to (⊥,⊥) *) + /\ PrntN ZERO_SALT = (name_to_chName BOT, name_to_chName BOT) + /\ PrntN DH = (name_to_chName BOT, name_to_chName BOT) + /\ PrntN ZERO_IKM = (name_to_chName BOT, name_to_chName BOT) + (* Maps es, hs and as by *) + /\ PrntN ES = (name_to_chName ZERO_SALT, name_to_chName PSK) + /\ PrntN HS = (name_to_chName ESALT, name_to_chName DH) + /\ PrntN AS = (name_to_chName HSALT, name_to_chName ZERO_IKM) + (* Remaining names *) + /\ forall n, + n \notin [:: ZERO_SALT; DH; ZERO_IKM; ES; HS; AS] -> + n \in all_names -> + exists n1, ((PrntN n = (name_to_chName n1, name_to_chName BOT)) /\ (n1 != BOT)). +Proof. + repeat split. + intros. + rewrite !in_cons in H1. + rewrite !notin_cons in H0. + repeat (move: H0 => /andP [ /eqP ] ? H0) ; clear H0. + repeat (move: H1 => /orP [ /eqP ? | H1 ] ; subst) ; [ .. | discriminate ]. + all: try contradiction. + all: try (eexists ; split ; [ reflexivity | apply /eqP ; try discriminate ]). +Qed. + Definition chFinGroup : finGroupType := {| FinGroup.sort := chGroup; FinGroup.class := chGroup_is_finGroup |}. diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index eef74310..4ccb0b03 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -86,11 +86,17 @@ Section KeyPackages. Definition UNQ_O_star d : Interface := interface_foreach (fun n => [interface #val #[ UNQ n d ] : chUNQinp → chUNQout]) (O_star). - Definition SET_O_star_ℓ d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (O_star) d. + Definition SET_O_star d k : Interface := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ k ] : chSETinp → chSETout]) (O_star) d. - Definition GET_O_star_ℓ d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (O_star) d. + Definition SET_O_star_ℓ d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (O_star). + + Definition GET_O_star d k : Interface := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) (O_star) d. + + Definition GET_O_star_ℓ d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (O_star). (* Fig 13-14. K key and log *) @@ -145,7 +151,7 @@ Section KeyPackages. ] [interface #val #[ SET n ℓ d ] : chSETinp → chSETout ; - #val #[ GET n ℓ d ] : chGETinp → chGETout + #val #[ GET n ℓ d ] : chGETinp → chGETout ]. Proof. refine [package @@ -194,131 +200,134 @@ Section KeyPackages. Defined. Fail Next Obligation. -Definition Ls d (Names : list name) (P : ZAF) : - uniq Names -> - package - (L_L) - [interface] - (interface_foreach (fun n =>[interface - #val #[ UNQ n d ] : chUNQinp → chUNQout - ]) Names). -Proof. - intros. - destruct Names. - - exact ({package emptym #with valid_empty_package L_L [interface]}). - - rewrite (interface_foreach_trivial [interface] (n :: Names)) ; [ | easy ]. - refine (parallel_package d (n :: Names) (fun a => L_package _ _ P) _ _ H). - + intros. + Definition Ls d (Names : list name) (P : ZAF) : + uniq Names -> + package + (L_L) + [interface] + (interface_foreach (fun n => [interface + #val #[ UNQ n d ] : chUNQinp → chUNQout + ]) Names). + Proof. + intros. + destruct Names. + - exact ({package emptym #with valid_empty_package L_L [interface]}). + - rewrite (interface_foreach_trivial [interface] (n :: Names)) ; [ | easy ]. + refine (parallel_package d (n :: Names) (fun a => L_package _ _ P) _ _ H). + + intros. + unfold idents. + solve_imfset_disjoint. + + intros. + apply trimmed_package_cons. + apply trimmed_empty_package. + Defined. + + Lemma trimmed_Ls d (Names : _) : + forall (H : uniq Names), + trimmed (interface_foreach (fun n =>[interface + #val #[ UNQ n d ] : chUNQinp → chUNQout + ]) Names) (Ls d Names F H). + Proof. + intros. + unfold Ls. + destruct Names ; [ intros ; apply trimmed_empty_package | ]. + rewrite trimmed_eq_rect_r. + unfold pack. + set (s :: Names) in *. replace (s :: _) with l by reflexivity. + + apply trimmed_parallel_raw. + - intros. unfold idents. solve_imfset_disjoint. - + intros. + - apply H. + - apply trimmed_pairs_map. + intros. apply trimmed_package_cons. apply trimmed_empty_package. -Defined. - -Lemma trimmed_Ls d (Names : _) : - forall (H : uniq Names), - trimmed (interface_foreach (fun n =>[interface - #val #[ UNQ n d ] : chUNQinp → chUNQout - ]) Names) (Ls d Names F H). -Proof. - intros. - unfold Ls. - destruct Names ; [ intros ; apply trimmed_empty_package | ]. - rewrite trimmed_eq_rect_r. - unfold pack. - set (s :: Names) in *. replace (s :: _) with l by reflexivity. - - apply trimmed_parallel_raw. - - intros. - unfold idents. - solve_imfset_disjoint. - - apply H. - - apply trimmed_pairs_map. - intros. - apply trimmed_package_cons. - apply trimmed_empty_package. -Qed. + Qed. -Lemma function_fset_cat : - forall {A : eqType} {T} x xs, (fun (n : A) => fset (x n :: xs n)) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n)). -Proof. now setoid_rewrite <- (fset_cat). Qed. + Lemma function_fset_cons : + forall {A : eqType} {T} x xs, (fun (n : A) => fset (x n :: xs n)) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n)). + Proof. now setoid_rewrite <- (fset_cat). Qed. -Lemma function2_fset_cat : - forall {A B : eqType} {T} x xs, (fun (a : A) (b : B) => fset (x a b :: xs a b)) = (fun (a : A) (b : B) => fset (T := T) ([x a b]) :|: fset (xs a b)). -Proof. now setoid_rewrite <- (fset_cat). Qed. + Lemma function2_fset_cat : + forall {A B : eqType} {T} x xs, (fun (a : A) (b : B) => fset (x a b :: xs a b)) = (fun (a : A) (b : B) => fset (T := T) ([x a b]) :|: fset (xs a b)). + Proof. now setoid_rewrite <- (fset_cat). Qed. -Definition Ks (d : nat) (Names : list name) (b : bool) : - uniq Names -> - package - (L_K) - (interface_foreach (fun n => [interface #val #[ UNQ n d ] : chUNQinp → chUNQout]) Names) - (interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (Names) d - :|: interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (Names) d - ). -Proof. - intros. - rewrite interface_hierarchy_foreachU. - - rewrite <- function2_fset_cat. - refine (combined _ d L_K - (λ n : name, [interface #val #[UNQ n d] : chUNQinp → chUNQout ]) - (λ (n : name) (ℓ : nat), - [interface #val #[SET n ℓ d] : chUNQinp → chDHEXPout - ; #val #[GET n ℓ d] : chDHEXPout → chGETout]) - Names (fun n H0 y => K_package d y n H0 b) _ _ _ H). - - intros. - rewrite fset_cons. - rewrite fdisjointC. - rewrite fset_cons. - unfold idents. - solve_imfset_disjoint. - - intros. - rewrite fset_cons. - rewrite fdisjointC. - rewrite fset_cons. - unfold idents. - solve_imfset_disjoint. - - intros. - apply trimmed_package_cons. - apply trimmed_package_cons. - apply trimmed_empty_package. -Defined. -Fail Next Obligation. - -Lemma trimmed_Ks d (Names : _) b : - forall (H : uniq Names), - trimmed (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), - [interface - #val #[SET n ℓ d] : chSETinp → chSETout ; - #val #[GET n ℓ d] : chGETinp → chGETout ]) Names d) (Ks d Names b H). -Proof. - intros. - unfold Ks. - unfold combined. + Definition Ks (d k : nat) (H_lt : (d <= k)%nat) (Names : list name) (b : bool) : + uniq Names -> + package + (L_K) + (interface_foreach (fun n => [interface #val #[ UNQ n k ] : chUNQinp → chUNQout]) Names) + (interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ k ] : chSETinp → chSETout]) (Names) d + :|: interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) (Names) d + ). + Proof. + intros. + rewrite interface_hierarchy_foreachU. + + rewrite <- function2_fset_cat. + refine (combined _ d L_K + (λ n : name, [interface #val #[UNQ n k] : chUNQinp → chUNQout ]) + (λ (n : name) (ℓ : nat), + [interface #val #[SET n ℓ k] : chUNQinp → chDHEXPout + ; #val #[GET n ℓ k] : chDHEXPout → chGETout]) + Names (fun n H0 y => K_package k y n (leq_trans H0 H_lt) b) _ _ _ H). + - intros. + rewrite fset_cons. + rewrite fdisjointC. + rewrite fset_cons. + unfold idents. + solve_imfset_disjoint. + - intros. + rewrite fset_cons. + rewrite fdisjointC. + rewrite fset_cons. + unfold idents. + solve_imfset_disjoint. + - intros. + apply trimmed_package_cons. + apply trimmed_package_cons. + apply trimmed_empty_package. + Defined. + Fail Next Obligation. - rewrite trimmed_eq_rect. - destruct (function2_fset_cat _ _). - rewrite trimmed_eq_rect_r. - apply (trimmed_ℓ_packages d). -Qed. + Lemma trimmed_Ks d k H_lt (Names : _) b : + forall (H : uniq Names), + trimmed (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), + [interface + #val #[SET n ℓ k] : chSETinp → chSETout ; + #val #[GET n ℓ k] : chGETinp → chGETout ]) Names d) (Ks d k H_lt Names b H). + Proof. + intros. + unfold Ks. + unfold combined. + + rewrite trimmed_eq_rect. + destruct (function2_fset_cat _ _). + unfold eq_rect. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + apply (trimmed_ℓ_packages). + Qed. (* Fig 15 *) -Definition Nk_package (n : name) (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : +Definition Nk_package (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : package L_K [interface - #val #[ UNQ n d ] : chUNQinp → chUNQout + #val #[ UNQ DH d ] : chUNQinp → chUNQout ] [interface - #val #[ SET n ℓ d ] : chSETinp → chSETout ; - #val #[ GET n ℓ d ] : chGETinp → chGETout + #val #[ SET DH ℓ d ] : chSETinp → chSETout ; + #val #[ GET DH ℓ d ] : chGETinp → chGETout ]. refine [package - #def #[ SET n ℓ d ] ('(h,hon,k) : chSETinp) : chSETout { - #import {sig #[ UNQ n d ] : chUNQinp → chUNQout } + #def #[ SET DH ℓ d ] ('(h,hon,k) : chSETinp) : chSETout { + #import {sig #[ UNQ DH d ] : chUNQinp → chUNQout } as unq_fn ;; get_or_case_fn (K_table h) fin_K_table chHandle ( unq_fn (h, hon, k) ;; @@ -326,7 +335,7 @@ Definition Nk_package (n : name) (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : ret h ) (fun _ => ret h) } ; - #def #[ GET n ℓ d ] (h : chGETinp) : chGETout { + #def #[ GET DH ℓ d ] (h : chGETinp) : chGETout { p ← get_or_fail (K_table h) fin_K_table ;; let (k, hon) := (fto (fst (otf p)) , snd (otf p) : 'bool) : (chProd chKey 'bool) @@ -353,7 +362,7 @@ Notation " 'chKinp' " := Notation " 'chKout' " := (chHandle) (in custom pack_type at level 2). -Definition K (n : chName) (ℓ : nat) := 10%nat. +(* Definition K (n : chName) (ℓ : nat) := 10%nat. *) (**** *) diff --git a/proofs/ssprove/handwritten/KeySchedulePackages.v b/proofs/ssprove/handwritten/KeySchedulePackages.v index 38e81c15..27104871 100644 --- a/proofs/ssprove/handwritten/KeySchedulePackages.v +++ b/proofs/ssprove/handwritten/KeySchedulePackages.v @@ -92,14 +92,14 @@ Section KeySchedulePackages. :|: DH_interface (* DHEXP, DHGEN *) :|: XTR_n d (* {ES,HS,AS}, 0..d *) :|: XPD_n d (* XPN, 0..d *) - :|: GET_O_star_ℓ d). + :|: GET_O_star d). Definition key_schedule_export d := - GET_O_star_ℓ d :|: SET_O_star_ℓ d. + GET_O_star d :|: SET_O_star d. (* Context {ord : chGroup → nat} {E : nat -> nat}. *) - Lemma required_O_subset d : SET_DH d :<=: SET_O_star_ℓ d :|: GET_O_star_ℓ d. + Lemma required_O_subset d : SET_DH d :<=: SET_O_star d :|: GET_O_star d. Proof. (* DH must be in O_star *) unfold SET_DH. @@ -133,7 +133,7 @@ Section KeySchedulePackages. package (L_K :|: L_L) [interface] - (GET_O_star_ℓ d) := + (GET_O_star d) := {package Gcore_real d (* ∘ XPD_DH_XTR *) #with @@ -148,7 +148,7 @@ Section KeySchedulePackages. package L_K (key_schedule_interface d) - (GET_O_star_ℓ d) + (GET_O_star d) := {package (* (par (par (XPD_packages d) (XTR_packages d)) (DH_package ord E)) ∘ *) @@ -161,7 +161,7 @@ Section KeySchedulePackages. 1:{ eapply valid_package_inject_export. 2: apply (pack_valid (Ks d O_star true erefl)). - unfold GET_O_star_ℓ. + unfold GET_O_star. solve_in_fset. } 1:{ diff --git a/proofs/ssprove/handwritten/MainTheorem.v b/proofs/ssprove/handwritten/MainTheorem.v index 31b9e37d..4e5741b7 100644 --- a/proofs/ssprove/handwritten/MainTheorem.v +++ b/proofs/ssprove/handwritten/MainTheorem.v @@ -131,19 +131,20 @@ Axiom level : chHandle -> nat. (* Fig 12. the real XPD and XTR games *) Lemma main_reduction : - forall (Score : Simulator), + forall d, + forall (Score : Simulator d), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → + ValidPackage LA (KS_interface d) A_export A → (AdvantageE - (Gks_real) - (Gks_ideal Score) A = + (Gks_real d) + (Gks_ideal d Score) A = AdvantageE - (Gcore_real) - (Gcore_ideal Score) (A ∘ R_ch_map) + (Gcore_real d) + (Gcore_ideal d Score) (A ∘ R_ch_map d) )%R. Proof. intros. - rewrite (map_outro_c5 Score LA). + rewrite (map_outro_c5 d Score LA). unfold Gks_real_map , Gks_ideal_map , pack. unfold Gcore_real. @@ -236,7 +237,7 @@ Axiom Gxtr_hs : nat -> loc_GamePair Definition Gxpd : forall (n : name) (ℓ : nat), (ℓ <= d)%N -> loc_GamePair - ([interface #val #[XPD n ℓ] : ((chSETout) × ('bool)) × (chHASHout) → chSETout ]). + ([interface #val #[XPD n ℓ d] : ((chSETout) × ('bool)) × (chHASHout) → chSETout ]). Proof. intros. refine (fun b => {| locs := L_K :|: L_L ; diff --git a/proofs/ssprove/handwritten/MapPackage.v b/proofs/ssprove/handwritten/MapPackage.v index 5db0b8da..a2af4661 100644 --- a/proofs/ssprove/handwritten/MapPackage.v +++ b/proofs/ssprove/handwritten/MapPackage.v @@ -141,7 +141,7 @@ Definition KS_interface d := ([interface #val #[SET PSK 0 d] : chSETinp → chSETout ] :|: DH_interface :|: (XPD_n d :|: XTR_n d) - :|: GET_O_star_ℓ d + :|: GET_O_star d ). Notation " 'chXTRinp' " := @@ -156,7 +156,7 @@ Notation " 'chXTRout' " := Definition R_ch_map_XTR_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) : (n \in XTR_names) -> (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> - package L_M (XTR_n_ℓ d ℓ (* ℓ.+1 *)) + package L_M (interface_hierarchy (XTR_n_ℓ d) ℓ (* ℓ.+1 *)) [interface #val #[ XTR n ℓ d (* ℓ.+1 *)] : chXTRinp → chXTRout ]. @@ -719,8 +719,8 @@ Proof. rewrite fset1E. rewrite <- fset0E ; rewrite fsetU0. - fold (GET_O_star_ℓ d). - fold (SET_O_star_ℓ d). + fold (GET_O_star d). + fold (SET_O_star d). solve_in_fset. } } @@ -784,7 +784,7 @@ Program Definition Gks_real_map (d : nat) : (L_M :|: (L_K :|: L_L)) [interface] (* ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout]) *) - (GET_O_star_ℓ d) := + (GET_O_star d) := {package (* (Ks d O_star false erefl ∘ Ls d O_star F erefl) ∘ *) R_ch_map d @@ -938,7 +938,7 @@ Program Definition Gks_ideal_map (d : nat) (Score : Simulator d) : package fset0 (KS_interface d) - (GET_O_star_ℓ d) := {package (R_ch_map d) ∘ Score }. + (GET_O_star d) := {package (R_ch_map d) ∘ Score }. Next Obligation. admit. Admitted. @@ -1276,7 +1276,7 @@ Lemma map_intro_c2 : (* forall (d : nat), *) forall (Score : Simulator d), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (GET_O_star_ℓ d) A_export A → + ValidPackage LA (GET_O_star d) A_export A → LA :#: L_M :|: (L_K :|: L_L) -> (AdvantageE (Gks_real d) @@ -1306,8 +1306,8 @@ Proof. clear -hin. simpl in hin. - unfold SET_O_star_ℓ in hin. - unfold GET_O_star_ℓ in hin. + unfold SET_O_star in hin. + unfold GET_O_star in hin. unfold interface_hierarchy_foreach in hin. diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index 71fe8ea5..6c3d161d 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -124,8 +124,6 @@ Definition get_or_sample (n : nat) (T : finType) `{Positive #|T|} : raw_code ('f Definition untag : chKey -> chKey := id. -Axiom xpn_eq : name -> name -> bool. - Definition nfto (x : chName) : name := match (nat_of_ord (otf x)) as k return (k < 20)%nat -> _ with | 0 => fun _ => BOT @@ -178,6 +176,14 @@ Definition name_to_chName (n : name) : chName := fto (inord ( | ZERO_IKM => 19 end)). +Lemma nfto_name_to_chName_cancel : forall a, nfto (name_to_chName a) = a. +Proof. + intros. + unfold nfto, name_to_chName ; rewrite otf_fto. + unfold inord, insubd, odflt, oapp, insub. + destruct idP, a ; (reflexivity || Lia.lia). +Qed. + Axiom len : chKey -> chNat (* TODO: should be key *). Definition alg : chKey -> chHash := (fun x => fto (fst (otf x))). (* TODO: should be key *) Axiom alg2 : chHandle -> chName (* TODO: should be key *). @@ -572,7 +578,7 @@ Lemma serialize_name_notin_different_index : serialize_name n1 ℓ1 d index1 <> serialize_name n2 ℓ2 d index2. Proof. intros. - + unfold serialize_name. set 100%N. generalize dependent n. @@ -1099,7 +1105,7 @@ Proof. rewrite fdisjointUr. rewrite IHL. 2:{ - apply (ssrbool.elimT andP) in H0 as []. + apply (ssrbool.elimT andP) in H0 as []. apply (ssrbool.elimT andP) in H1 as []. apply (ssrbool.introT andP). fold (uniq L) in *. @@ -1277,7 +1283,7 @@ Proof. { destruct H1. rewrite <- H1. - destruct E, P ; [ | destruct H4 ; try destruct E ; contradiction.. | ] ; [ | destruct H4] ; rewrite <- H4 ; solve_Parable ; apply H ; apply (ssrbool.elimT andP) in H0 as [? _] ; rewrite notin_cons in H0 ; apply (ssrbool.elimT andP) in H0 as [] ; now apply /eqP. + destruct E, P ; [ | destruct H4 ; try destruct E ; contradiction.. | ] ; [ | destruct H4] ; rewrite <- H4 ; solve_Parable ; apply H ; apply (ssrbool.elimT andP) in H0 as [? _] ; rewrite notin_cons in H0 ; apply (ssrbool.elimT andP) in H0 as [] ; now apply /eqP. } { apply IHP. @@ -1502,7 +1508,7 @@ Qed. (* rewrite IHLg ; clear IHLg. *) (* rewrite Bool.andb_true_r. *) (* apply H. *) - + intros. apply idents_disjoint_foreach ; intros. rewrite fdisjointC. @@ -1510,7 +1516,7 @@ Qed. rewrite fdisjointC. apply H. Qed. - + Theorem valid_parable_map_with_in_rel : forall {N : eqType} (P : list raw_package) L I E2 E1 H_in f g, (∀ (x y : N) Hx Hy, x ≠ y → idents (f x Hx) :#: idents (f y Hy)) -> uniq E1 -> @@ -1637,7 +1643,7 @@ Qed. } } Qed. - + Definition parallel_package_with_in_rel {A : eqType} (d : nat) {L} Names {f : A -> _} {g : forall (a : A), (a \in Names) -> _} (i : forall (a : A) (H : a \in Names), package L (f a) (g a H)) (H : ∀ (x y : A) Hx Hy, x ≠ y → idents (g x Hx) :#: idents (g y Hy)) @@ -1879,7 +1885,7 @@ Proof. solve_Parable. clear -K_le Hdisj. - apply (idents_interface_hierachy). + apply (idents_interface_hierachy). - Lia.lia. - intros. now apply Hdisj. diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index 157679da..19a5bed9 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -87,6 +87,18 @@ Section XTR_XPD. Context {DepInstance : Dependencies}. Existing Instance DepInstance. + Definition SET_ℓ Names d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) Names. + + Definition SET_n Names d k : Interface := + interface_hierarchy (SET_ℓ Names k) d. + + Definition GET_ℓ Names d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) Names. + + Definition GET_n Names d k : Interface := + interface_hierarchy (GET_ℓ Names k) d. + (* p. 5,6 *) (* Context {xtr_angle : name -> chHandle -> chHandle -> code fset0 fset0 chHandle}. *) (* Context {xtr : chKey -> chKey -> code fset0 fset0 chKey}. *) @@ -100,36 +112,38 @@ Section XTR_XPD. (chHandle) (in custom pack_type at level 2). - Definition XTR (n : name) (ℓ (* 0 .. d *) : nat) (d : nat) : nat := serialize_name n ℓ d 2. Definition Xtr - (n : name) (ℓ : nat) (d : nat) (b : bool) - {GET : nat} {SET : nat} - : + (n : name) (ℓ : nat) (d : nat) (b : bool) : package fset0 [interface - #val #[ GET ] : chGETinp → chGETout ; - #val #[ SET ] : chSETinp → chSETout + #val #[ GET (nfto (fst (PrntN n))) ℓ d ] : chGETinp → chGETout ; + #val #[ GET (nfto (snd (PrntN n))) ℓ d ] : chGETinp → chGETout ; + #val #[ SET n ℓ d ] : chSETinp → chSETout ] [interface - #val #[ XTR n ℓ d ] : chXTRinp → chXTRout + #val #[ XTR n ℓ d ] : chXTRinp → chXTRout ]. refine [package #def #[ XTR n ℓ d ] ('(h1,h2) : chXTRinp) : chXTRout { - #import {sig #[ SET ] : chSETinp → chSETout } + #import {sig #[ SET n ℓ d ] : chSETinp → chSETout } as set_fn ;; - #import {sig #[ GET ] : chGETinp → chGETout } - as get_fn ;; - '(n1,n2) ← PrntN n ;; - (if Datatypes.andb (xpn_eq (nfto (alg2 h1)) BOT) (xpn_eq (nfto (alg2 h2)) BOT) - then assert ( xpn_eq (nfto (alg2 h1)) (nfto (alg2 h2)) ) + '(n1,n2) ← ret (PrntN n : (chProd chName chName)) ;; + assertD (n1 == fst (PrntN n)) (fun _ => + #import {sig #[ GET (nfto n1) ℓ d ] : chGETinp → chGETout } + as get_fn1 ;; + assertD (n2 == snd (PrntN n)) (fun _ => + #import {sig #[ GET (nfto n2) ℓ d ] : chGETinp → chGETout } + as get_fn2 ;; + (if Datatypes.andb (name_eq (nfto (alg2 h1)) BOT) (name_eq (nfto (alg2 h2)) BOT) + then assert ( name_eq (nfto (alg2 h1)) (nfto (alg2 h2)) ) else ret Datatypes.tt) ;; (* temp1 ← get_or_fn (M (nfto i1) h1) chHandle (@fail _ ;; ret _) ;; *) h ← xtr_angle n h1 h2 ;; - '(k1,hon1) ← get_fn (h1) ;; - '(k2,hon2) ← get_fn (h2) ;; + '(k1,hon1) ← get_fn1 (h1) ;; + '(k2,hon2) ← get_fn2 (h2) ;; k ← xtr k1 k2 ;; hon ← ret (Datatypes.orb hon1 hon2) ;; k ← (if Datatypes.andb b hon2 @@ -139,36 +153,82 @@ Section XTR_XPD. else ret k) ;; h ← set_fn (h, hon, k) ;; ret h - } + ))} ]. ssprove_valid ; ssprove_valid'_2. + { + move: x => /eqP ? ; subst. + rewrite in_cons. + apply /orP. now left. + } + { + move: x0 => /eqP ? ; subst. + rewrite in_cons. + apply /orP. right. + rewrite in_cons. + apply /orP. now left. + } + Unshelve. all: apply DepInstance. Defined. Fail Next Obligation. Definition XTR_names := [ES; HS; AS]. + Definition XTR_parent_names := [:: ZERO_SALT; PSK; ESALT; DH; HSALT; ZERO_IKM]. + Lemma XTR_parent_names_correct : XTR_parent_names = + undup (List.fold_left (fun y x => y ++ [nfto (fst (PrntN x)); nfto (snd (PrntN x))]) XTR_names []). + Proof. + intros. + now simpl ; rewrite !nfto_name_to_chName_cancel. + Qed. + + Lemma xtr_parents_is_f_xtr_names : + forall d ℓ, + GET_ℓ XTR_parent_names d ℓ = + (interface_foreach (λ (n : name), + [interface + #val #[GET (nfto (fst (PrntN n))) ℓ d] : chXTRout → chGETout ; + #val #[GET (nfto (snd (PrntN n))) ℓ d] : chXTRout → chGETout]) XTR_names + + ). + Proof. + intros. + unfold GET_ℓ. + unfold XTR_names, XTR_parent_names, interface_foreach. + rewrite !(fset_cons (GET (nfto _.1) ℓ d, _)). + rewrite !fset1E. + rewrite !fsetUA. + simpl. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + Qed. - Definition GET_XTR_ℓ d ℓ := interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) XTR_names. + (* Definition GET_XTR_ℓ d ℓ := *) + (* interface_foreach (fun n => [interface *) + (* #val #[ GET (nfto (fst (PrntN n))) ℓ d ] : chGETinp → chGETout ; *) + (* #val #[ GET (nfto (snd (PrntN n))) ℓ d ] : chGETinp → chGETout]) *) + (* XTR_names. *) - Definition GET_XTR d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XTR_names) d. + (* Definition GET_XTR d : Interface := *) + (* interface_hierarchy (GET_XTR_ℓ d) d. *) - Definition SET_XTR_ℓ d ℓ := interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) XTR_names. + (* Definition SET_XTR_ℓ d ℓ := *) + (* interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) XTR_names. *) - Definition SET_XTR d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XTR_names) d. + (* Definition SET_XTR d : Interface := *) + (* interface_hierarchy (SET_XTR_ℓ d) d. *) - Definition XTR_n d := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names d. + Definition XTR_n d k := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) XTR_names d. Definition XTR_n_ℓ d ℓ := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names ℓ. + interface_foreach (fun n => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names. Lemma trimmed_Xtr : forall ℓ n d, trimmed [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ] - (Xtr n ℓ d false (GET := GET n ℓ d) (SET := SET n ℓ d)). + (Xtr n ℓ d false). Proof. intros. unfold trimmed. @@ -176,26 +236,30 @@ Section XTR_XPD. Qed. Definition xtr_level_raw (ℓ : nat) (d : nat) := - parallel_raw (List.map (fun n => pack (Xtr n ℓ d false (GET := GET n ℓ d) (SET := SET n ℓ d))) XTR_names). + parallel_raw (List.map (fun n => pack (Xtr n ℓ d false)) XTR_names). Lemma valid_xtr_level : forall d ℓ, (ℓ <= d)%N -> ValidPackage f_parameter_cursor_loc - (GET_XTR_ℓ d ℓ :|: SET_XTR_ℓ d ℓ) + (GET_ℓ XTR_parent_names d ℓ :|: SET_ℓ XTR_names d ℓ) (interface_foreach (fun n => [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout]) XTR_names) (xtr_level_raw ℓ d). Proof. intros. + rewrite xtr_parents_is_f_xtr_names. rewrite interface_foreach_U. + apply (valid_forall (L := fset0) (λ (n : name), - [interface #val #[GET n ℓ d] : chXTRout → chGETout ] + [interface + #val #[GET (nfto (fst (PrntN n))) ℓ d] : chXTRout → chGETout ; + #val #[GET (nfto (snd (PrntN n))) ℓ d] : chXTRout → chGETout] :|: [interface #val #[SET n ℓ d] : chSETinp → chSETout ]) (λ n : name, [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ]) - (λ ℓ (n : name), pack (Xtr n ℓ d false (GET := GET n ℓ d) (SET := SET n ℓ d))) + (λ ℓ (n : name), pack (Xtr n ℓ d false)) XTR_names d ℓ @@ -221,8 +285,9 @@ Section XTR_XPD. subst f. unfold XTR_names, valid_pairs, List.map. - repeat split ; - apply (pack_valid (@Xtr _ ℓ d false (GET _ ℓ d) (SET _ ℓ d))). + repeat split ; match goal with + | |- context [ Xtr ?n _ _ ] => apply (pack_valid (@Xtr _ ℓ d false)) + end. Qed. Definition xtr_level d ℓ (H : (ℓ <= d)%N) := @@ -239,12 +304,12 @@ Section XTR_XPD. - repeat split ; apply trimmed_Xtr. Qed. - Definition XTR_packages (d : nat) : - package fset0 (GET_XTR d :|: SET_XTR d) (XTR_n (d)). + Definition XTR_packages (d k : nat) (H_lt : (d <= k)%nat) : + package fset0 (GET_n XTR_parent_names d k :|: SET_n XTR_names d k) (XTR_n d k). Proof. - unfold GET_XTR. + unfold GET_n. rewrite interface_hierarchy_U. - refine (ℓ_packages d (g := fun ℓ => GET_XTR_ℓ d ℓ :|: SET_XTR_ℓ d ℓ) (fun ℓ H => xtr_level d ℓ H) _ _). + refine (ℓ_packages d (g := fun ℓ => GET_ℓ XTR_parent_names k ℓ :|: SET_ℓ XTR_names k ℓ) (fun ℓ H => xtr_level k ℓ (leq_trans H H_lt)) _ _). { intros ℓ ?. apply trimmed_xtr_level. @@ -266,109 +331,209 @@ Section XTR_XPD. (in custom pack_type at level 2). Definition XPD (n : name) (ℓ : nat) (d : nat) : nat := serialize_name n ℓ d 2. + Definition Xpd (n : name) (ℓ : nat) (d : nat) - {GET : nat} {SET : nat} {HASH : nat} + (* {GET : nat} {SET : nat} {HASH : nat} *) : package fset0 [interface - #val #[ GET ] : chGETinp → chGETout ; - #val #[ SET ] : chSETinp → chSETout ; - #val #[ HASH ] : chHASHinp → chHASHout + #val #[ GET (nfto (fst (PrntN n))) ℓ d ] : chGETinp → chGETout ; + #val #[ SET n (ℓ + name_eq n PSK)%nat d ] : chSETinp → chSETout ; + #val #[ HASH f_hash ] : chHASHinp → chHASHout ] [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout ]. - refine [package + refine ( + [package #def #[ XPD n ℓ d ] ('(h1,r,args) : chXPDinp) : chXPDout { - #import {sig #[ SET ] : chSETinp → chSETout } - as set_fn ;; - #import {sig #[ GET ] : chGETinp → chGETout } - as get_fn ;; - #import {sig #[ HASH ] : chHASHinp → chHASHout } + #import {sig #[ HASH f_hash ] : chHASHinp → chHASHout } as hash_fn ;; - '(n1,_) ← PrntN n ;; + '(n1,_) ← ret (PrntN n) ;; + assertD (n1 == fst (PrntN n)) (fun _ => + #import {sig #[ GET (nfto n1) ℓ d ] : chGETinp → chGETout } + as get_fn ;; label ← Labels n r ;; h ← xpd_angle n label h1 args ;; '(k1,hon) ← get_fn h1 ;; - k ← (if xpn_eq n PSK + h ← (if name_eq n PSK then - ℓ ← ret (ℓ + 1) ;; - xpd k1 (label, args) + k ← xpd k1 (label, args) ;; + #import {sig #[ SET n (ℓ+1) d ] : chSETinp → chSETout } + as set_fn ;; + set_fn (h, hon, k) else - d ← hash_fn args ;; - xpd k1 (label, d) ) ;; - h ← set_fn (h, hon, k) ;; + digest ← hash_fn args ;; + k ← xpd k1 (label, digest) ;; + #import {sig #[ SET n ℓ d ] : chSETinp → chSETout } + as set_fn ;; + set_fn (h, hon, k)) ;; ret h - } - ]. + )} + ]). + ssprove_valid ; ssprove_valid'_2. + { + move: x => /eqP ? ; subst. + rewrite in_cons. + apply /orP. now left. + } + { + (* move: x2 => /eqP ? ; subst. *) + rewrite in_cons. + apply /orP. right. + rewrite in_cons. + apply /orP. left. + + rewrite addn0. + now apply /eqP. + } + Unshelve. all: apply DepInstance. Defined. Fail Next Obligation. - Definition XPR := - [PSK; ESALT] ++ + Definition XPR_sub_PSK := + [ESALT] ++ [EEM; CET; BIND; BINDER; SHT; CHT; HSALT; RM; CAT; SAT; EAM] ++ (* has a single parent *) [] (* or exactly on sibling of n is contained in XPR *). + Definition XPR_sub_PSK_parents := [ES; BIND; HS; AS]. + Lemma XPR_sub_PSK_parent_correct : + XPR_sub_PSK_parents = + undup (List.map (fun x => nfto (fst (PrntN x))) XPR_sub_PSK). + Proof. + intros. + unfold XPR_sub_PSK, List.map, "++" ; rewrite !nfto_name_to_chName_cancel. + simpl. + reflexivity. + Qed. + + Lemma xpr_sub_psk_parents_is_f_xpr_sub_psk : + forall d ℓ, + GET_ℓ XPR_sub_PSK_parents d ℓ = + (interface_foreach (λ (n : name), + [interface + #val #[GET (nfto (fst (PrntN n))) ℓ d] : chXTRout → chGETout]) XPR_sub_PSK + + ). + Proof. + intros. + unfold GET_ℓ. + unfold XPR_sub_PSK, XPR_sub_PSK_parents, interface_foreach, "++". + simpl. + rewrite !nfto_name_to_chName_cancel. + repeat (try rewrite !fsetUid ; rewrite !fsetUA ; try rewrite !fsetUid ; f_equal ; rewrite <- !fsetUA). + Qed. - Definition XPD_n (d : nat) := - interface_hierarchy_foreach (fun n ℓ => [interface - #val #[ XPD n ℓ d ] : chXPDinp → chXPDout + Lemma xpr_sub_psk_parents_is_f_xpr_sub_psk_set : + forall d ℓ, + SET_ℓ XPR_sub_PSK d ℓ = + interface_foreach + (λ n : name, + [interface #val #[SET n (ℓ + name_eq n PSK) d] : chUNQinp → chXPDout ]) + XPR_sub_PSK. + Proof. + intros. + unfold SET_ℓ. + unfold XPR_sub_PSK, interface_foreach, "++". + simpl. + rewrite addn0. + repeat (try rewrite !fsetUid ; rewrite !fsetUA ; try rewrite !fsetUid ; f_equal ; rewrite <- !fsetUA). + Qed. + + Definition XPR := + PSK :: XPR_sub_PSK. + Definition XPR_parents := [RM; ES; BIND; HS; AS]. + Lemma XPR_parent_correct : + XPR_parents = + undup (List.map (fun x => nfto (fst (PrntN x))) XPR). + Proof. + intros. + unfold XPR, XPR_sub_PSK, List.map, "++" ; rewrite !nfto_name_to_chName_cancel. + simpl. + reflexivity. + Qed. + + Lemma xpr_parents_is_f_xpr : + forall d ℓ, + GET_ℓ XPR_parents d ℓ = + (interface_foreach (λ (n : name), + [interface + #val #[GET (nfto (fst (PrntN n))) ℓ d] : chXTRout → chGETout]) XPR). + Proof. + intros. + unfold GET_ℓ. + unfold XPR, XPR_sub_PSK, XPR_sub_PSK_parents, interface_foreach, "++". + simpl. + rewrite !nfto_name_to_chName_cancel. + repeat (try rewrite !fsetUid ; rewrite !fsetUA ; try rewrite !fsetUid ; f_equal ; rewrite <- !fsetUA). + f_equal. + rewrite !fsetUA. + rewrite !fsetUid. + reflexivity. + Qed. + + Definition XPD_n (d k : nat) := + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ k ] : chXPDinp → chXPDout ]) XPR d. Definition XPD_n_ℓ d ℓ := interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]) XPR ℓ. - Definition GET_XPD d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XPR) d. + (* Definition GET_XPD_ℓ d ℓ : Interface := *) + (* interface_foreach (fun n => [interface #val #[ GET (nfto (fst (PrntN n))) ℓ d ] : chGETinp → chGETout]) (XPR). *) - Definition GET_XPD_ℓ d ℓ : Interface := - interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) (XPR). + (* Definition GET_XPD d : Interface := *) + (* interface_hierarchy (GET_XPD_ℓ d) d. *) - Definition SET_XPD d : Interface := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XPR) d. + (* Definition SET_XPD_ℓ d ℓ : Interface := *) + (* interface_foreach (fun n => [interface #val #[ SET n (ℓ + name_eq n PSK)%nat d ] : chSETinp → chSETout]) (XPR). *) - Definition SET_XPD_ℓ d ℓ : Interface := - interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) (XPR). + (* Definition SET_XPD d : Interface := *) + (* interface_hierarchy (SET_XPD_ℓ d) d.-1 :|: *) + (* interface_foreach (fun n => [interface #val #[ SET n d d ] : chSETinp → chSETout]) (XPR_sub_PSK). *) - Lemma trimmed_Xpd : forall ℓ n d, + Lemma trimmed_Xpd : forall n ℓ d, trimmed [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout ] - (Xpd n ℓ d (GET := GET n ℓ d) (SET := SET n ℓ d) (HASH := HASH)). + (Xpd n ℓ d). Proof. intros. unfold trimmed. trim_is_interface. Qed. - Definition xpd_level_raw (ℓ : nat) (d : nat) := - parallel_raw (List.map (fun n => pack (Xpd n ℓ d (GET := GET n ℓ d) (SET := SET n ℓ d) (HASH := HASH))) XPR). + Definition xpd_level_sub_psk_raw (ℓ : nat) (d : nat) : raw_package := + parallel_raw (List.map (fun n => pack (Xpd n ℓ d)) XPR_sub_PSK). - Lemma valid_xpd_level : - forall d ℓ, + Lemma valid_xpd_level_sub_psk : + forall ℓ d, (ℓ <= d)%nat -> ValidPackage f_parameter_cursor_loc - (GET_XPD_ℓ d ℓ :|: SET_XPD_ℓ d ℓ :|: [interface #val #[ HASH ] : chHASHinp → chHASHout]) - (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) XPR) - (xpd_level_raw ℓ d). + (GET_ℓ XPR_sub_PSK_parents d ℓ :|: SET_ℓ XPR_sub_PSK d ℓ :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) + (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) XPR_sub_PSK) + (xpd_level_sub_psk_raw ℓ d). Proof. intros. - rewrite (interface_foreach_trivial [interface #val #[HASH] : chHASHout → chHASHout ] XPR). + rewrite (interface_foreach_trivial [interface #val #[HASH f_hash] : chHASHout → chHASHout ] XPR_sub_PSK). 2: easy. + + rewrite <- (addn0 ℓ) at 2. + rewrite xpr_sub_psk_parents_is_f_xpr_sub_psk. rewrite !interface_foreach_U. apply (valid_forall (λ (n : name), - [interface #val #[GET n ℓ d] : chXPDout → chGETout ] - :|: [interface #val #[SET n ℓ d] : chSETinp → chSETout ] - :|: [interface #val #[HASH] : chHASHout → chHASHout ]) + [interface #val #[GET (nfto (fst (PrntN n))) ℓ d] : chGETinp → chGETout ] + :|: [interface #val #[SET n (ℓ + 0)%nat d] : chSETinp → chSETout ] + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) (λ n : name, [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout ]) (λ ℓ (n : name), _) - XPR + XPR_sub_PSK d ℓ H @@ -384,19 +549,22 @@ Section XTR_XPD. unfold trimmed_pairs. hnf. - repeat split ; apply (trimmed_Xpd ℓ). - - unfold XPR, serialize_name, "++", valid_pairs, List.map. + repeat split ; apply (trimmed_Xpd _ ℓ). + - unfold XPR_sub_PSK, serialize_name, "++", valid_pairs, List.map. rewrite <- !fset_cat ; simpl fset. - repeat split ; apply (pack_valid (@Xpd _ ℓ d (GET _ ℓ d) (SET _ ℓ d) HASH)). + (* rewrite !nfto_name_to_chName_cancel. *) + repeat split ; match goal with + | |- context [ Xpd ?n _ _ ] => try apply (pack_valid (@Xpd n ℓ d)) + end. Qed. - Definition xpd_level d ℓ H := - {package (xpd_level_raw ℓ d) #with (valid_xpd_level d ℓ H)}. + Definition xpd_level_sub_psk ℓ d H := + {package (xpd_level_sub_psk_raw ℓ d) #with (valid_xpd_level_sub_psk ℓ d H)}. - Lemma trimmed_xpd_level d ℓ H : + Lemma trimmed_xpd_level_sub_psk ℓ d (H : (ℓ <= d)%nat) : trimmed - (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) XPR) - (xpd_level d ℓ H). + (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) XPR_sub_PSK) + (xpd_level_sub_psk ℓ d H). Proof. intros. apply (trimmed_parallel_raw). @@ -405,21 +573,219 @@ Section XTR_XPD. - repeat split ; apply trimmed_Xpd. Qed. - Definition XPD_packages (d : nat) : - package fset0 ((GET_XPD d :|: SET_XPD d) :|: - [interface #val #[ HASH ] : chHASHinp → chHASHout]) (XPD_n d). + (* Definition xpd_level_psk ℓ d (H : (ℓ.+1 <= d)%nat) : package fset0 (GET_ℓ [RM] ℓ d :|: SET_ℓ [PSK] ℓ.+1 d :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) *) + (* (interface_foreach (fun n => [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout]) [PSK]). *) + (* refine {package Xpd PSK ℓ d #with _}. *) + (* - unfold interface_foreach. *) + (* epose (pack_valid (Xpd PSK ℓ d)). *) + (* unfold GET_ℓ. *) + (* simpl. *) + (* apply v. *) + + Lemma interface_hierarchy_foreach_cons : (forall {A} f a L (d : nat), + interface_hierarchy_foreach f (a :: L) d + = interface_hierarchy (f a) d :|: interface_hierarchy_foreach (A := A) f L d). Proof. - rewrite (interface_hierarchy_trivial [interface #val #[HASH] : chHASHout → chHASHout ] d). - rewrite !interface_hierarchy_U. + intros. + unfold interface_hierarchy_foreach. + rewrite interface_hierarchy_U. + f_equal. + setoid_rewrite interface_foreach_cons. + reflexivity. + Qed. - refine (ℓ_packages d (xpd_level d) _ _). - { - intros. - apply trimmed_xpd_level. + Lemma reindex_interface_hierarchy_PSK : + forall d, + (interface_hierarchy (λ n : nat, [interface #val #[SET PSK n d.+1] : chUNQinp → chXPDout ]) d.+1) + = + ([interface #val #[SET PSK 0 d.+1] : chUNQinp → chXPDout ] :|: interface_hierarchy + (λ n : nat, [interface #val #[SET PSK (n.+1) d.+1] : chUNQinp → chXPDout ]) + d). + Proof. + intros. + symmetry. + set d.+1 at 1 2 3. + generalize dependent n. + induction d ; intros. + - simpl. + reflexivity. + - simpl. + rewrite fsetUA. + rewrite IHd. + reflexivity. + Qed. + + Lemma function_fset_cons_l : + forall {A : eqType} {T} x xs K, (fun (n : A) => fset (x n :: xs n) :|: K) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n) :|: K). + Proof. now intros ; setoid_rewrite <- (fset_cat). Qed. + + Lemma function_fset_cat_l : + forall {A : eqType} {T} ys xs K, (fun (n : A) => fset (ys n ++ xs n) :|: K) = (fun (n : A) => fset (T := T) (ys n) :|: fset (xs n) :|: K). + Proof. now intros ; setoid_rewrite <- (fset_cat). Qed. + + Lemma function_fset_cat_middle : + forall {A : eqType} {T} ys xs L R, (fun (n : A) => L :|: fset (ys n ++ xs n) :|: R) = (fun (n : A) => L :|: fset (T := T) (ys n) :|: fset (xs n) :|: R). + Proof. + intros. + setoid_rewrite fsetUC. + setoid_rewrite <- fsetUA. + setoid_rewrite <- (fset_cat). + reflexivity. + Qed. + + Lemma function_fset_cat : + forall {A : eqType} {T} ys xs, (fun (n : A) => fset (ys n ++ xs n)) = (fun (n : A) => fset (T := T) (ys n) :|: fset (xs n)). + Proof. now setoid_rewrite <- (fset_cat). Qed. + + Lemma set_ℓ_XPR_split : + forall d k, + interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n (ℓ + name_eq n PSK) k ] : chSETinp → chSETout]) XPR d = + interface_hierarchy (fun ℓ => [interface #val #[ SET PSK (ℓ.+1) k ] : chSETinp → chSETout]) d + :|: SET_n XPR_sub_PSK d k + . + Proof. + intros. + + rewrite interface_hierarchy_foreach_cons. + unfold SET_n. + (* set d at 1 3 5 7. *) + generalize dependent k. + induction d ; intros. + - reflexivity. + - simpl. + rewrite (fsetUC _ [interface #val #[SET PSK d.+2 k] : chUNQinp → chXPDout ]). + rewrite fsetUA. + rewrite (fsetUC _ (SET_ℓ XPR_sub_PSK k d.+1)). + rewrite fsetUA. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite <- fsetUA. + rewrite <- IHd. + + simpl (_ + _)%nat. + symmetry. + rewrite fsetUC. + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + rewrite (fsetUC _ [interface #val #[SET PSK d.+2 k] : chUNQinp → chXPDout ]). + rewrite <- !fsetUA. + f_equal ; [ easy | ]. + rewrite fsetUC. + unfold interface_hierarchy_foreach. + unfold interface_hierarchy at 2 ; fold interface_hierarchy. + f_equal. + unfold SET_ℓ. + simpl. + rewrite addn0. + reflexivity. + Qed. + + Lemma XPD_interface_rewrite : + forall d k, + (interface_hierarchy (GET_ℓ XPR_parents k) d :|: (interface_hierarchy (fun ℓ => [interface #val #[ SET PSK (ℓ.+1) k ] : chSETinp → chSETout]) d :|: SET_n XPR_sub_PSK d k) ) :|: + [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] = + interface_hierarchy + (λ n : nat, + [interface #val #[GET (nfto (PrntN PSK).1) n k] : chXPDout → chGETout ] + :|: [interface #val #[SET PSK (n + name_eq PSK PSK) k] : chUNQinp → chXPDout ] + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) d + :|: interface_hierarchy + (λ n : nat, + GET_ℓ XPR_sub_PSK_parents k n :|: SET_ℓ XPR_sub_PSK k n + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) d. + Proof. + intros. + match goal with | |- context [ _ = ?rhs ] => set (RHS := rhs) end. + unfold GET_n. rewrite (functional_extensionality _ _ (xpr_parents_is_f_xpr k)). (* unfold GET_ℓ. *) + unfold SET_n. rewrite <- set_ℓ_XPR_split. (* unfold SET_ℓ. *) + + fold (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET (nfto (PrntN n).1) ℓ k] : chXPDout → chGETout ]) XPR d). + + rewrite interface_hierarchy_foreachU. + rewrite interface_hierarchy_foreach_cons. + + rewrite <- (fsetUid [interface #val #[HASH f_hash] : chHASHout → chHASHout ]). + rewrite fsetUA. + rewrite fsetUC. + rewrite !fsetUA. + rewrite (fsetUC [interface #val #[HASH f_hash] : chHASHout → chHASHout ]). + + rewrite (interface_hierarchy_trivial [interface #val #[HASH f_hash] : chHASHout → chHASHout ] d). + + rewrite interface_hierarchy_U. + rewrite <- fsetUA. + + rewrite <- interface_hierarchy_foreachU. + unfold interface_hierarchy_foreach. + rewrite <- (functional_extensionality _ _ (xpr_sub_psk_parents_is_f_xpr_sub_psk_set k)). + rewrite <- (functional_extensionality _ _ (xpr_sub_psk_parents_is_f_xpr_sub_psk k)). + rewrite interface_hierarchy_U. + rewrite interface_hierarchy_U. + + subst RHS. + reflexivity. + Qed. + + Definition XPD_packages (d k : nat) (H : (d < k)%nat) : + package fset0 ((GET_n XPR_parents d k + :|: (interface_hierarchy (fun ℓ => [interface #val #[ SET PSK (ℓ.+1) k ] : chSETinp → chSETout]) d + :|: SET_n XPR_sub_PSK d k) ) :|: + [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) (XPD_n d k). + Proof. + rewrite XPD_interface_rewrite. + + unfold XPD_n. + rewrite interface_hierarchy_foreach_cons. + + refine {package par _ _ #with _}. + Unshelve. + 2:{ + refine (ℓ_packages d (fun ℓ _ => Xpd PSK ℓ k) _ _). + { + intros. + apply trimmed_package_cons. + apply trimmed_empty_package. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } + } + 2:{ + refine (ℓ_packages d (fun ℓ H_le => xpd_level_sub_psk ℓ k (leq_trans H_le (ltnW H))) _ _). + { + intros. + apply trimmed_xpd_level_sub_psk. + } + { + intros. + apply idents_foreach_disjoint_foreach. + intros. + unfold idents. + solve_imfset_disjoint. + } } { + rewrite <- fsetUid. + eapply valid_par. + 3: apply pack_valid. + 2:{ + rewrite <- function_fset_cat_l. + rewrite <- function_fset_cat. + simpl fset. + + apply pack_valid. + } + rewrite <- trimmed_ℓ_packages. + set (ℓ_packages _). + rewrite <- trimmed_ℓ_packages. + solve_Parable. + apply idents_interface_hierachy3. intros. - apply idents_foreach_disjoint_foreach. + rewrite fdisjointC. + apply idents_interface_hierachy3. intros. unfold idents. solve_imfset_disjoint. @@ -428,22 +794,28 @@ Section XTR_XPD. (** ****************** *) - Definition SET_DH d : Interface := - interface_hierarchy (fun ℓ => [interface #val #[ SET DH ℓ d ] : chSETinp → chSETout]) d. + Definition SET_DH d k : Interface := + interface_hierarchy (fun ℓ => [interface #val #[ SET DH ℓ k ] : chSETinp → chSETout]) d. + + Definition SET_DH_ℓ d ℓ : Interface := + [interface #val #[ SET DH ℓ d ] : chSETinp → chSETout]. - Definition GET_DH d : Interface := - interface_hierarchy (fun ℓ => [interface #val #[ GET DH ℓ d ] : chGETinp → chGETout]) d. + Definition GET_DH d k : Interface := + interface_hierarchy (fun ℓ => [interface #val #[ GET DH ℓ k ] : chGETinp → chGETout]) d. + + Definition GET_DH_ℓ d ℓ : Interface := + [interface #val #[ GET DH ℓ d ] : chGETinp → chGETout]. Definition DH_interface := [interface #val #[DHGEN] : chDHGENout → chDHGENout ; #val #[DHEXP] : chDHEXPinp → chXPDout ]. - Definition DH_package d : + Definition DH_package d k : (* (G : {fset finGroupType}) *) package fset0 - (SET_DH d) + (SET_DH d k) DH_interface. intros. refine [package @@ -460,7 +832,7 @@ Section XTR_XPD. Defined. Fail Next Obligation. - Lemma trimmed_dh d : trimmed DH_interface (pack (DH_package d)). + Lemma trimmed_dh d k : trimmed DH_interface (pack (DH_package d k)). Proof. intros. unfold DH_package. @@ -488,45 +860,54 @@ Section XTR_XPD. intros. unfold trimmed. now rewrite trim_idemp. Qed. - Lemma trimmed_xpd_package : forall (d : nat), - trimmed (XPD_n d) (XPD_packages d). + Lemma trimmed_xpd_package : forall (d k : nat) (H_lt : (d < k)%nat), + trimmed (XPD_n d k) (XPD_packages d k H_lt). Proof. intros. simpl. unfold XPD_packages. unfold eq_rect_r. - destruct (Logic.eq_sym (interface_hierarchy_trivial [interface #val #[HASH] : chHASHout → chHASHout ] d)). unfold eq_rect. destruct (Logic.eq_sym _). - unfold eq_rect. destruct (Logic.eq_sym _). - erewrite <- (ℓ_raw_package_trimmed d ([eta xpd_level] d)). - 2:{ - intros ℓ. - apply (trimmed_xpd_level d ℓ). - } - 2:{ - intros n ℓ ? ?. - apply idents_foreach_disjoint_foreach. + unfold pack. + unfold XPD_n. + rewrite interface_hierarchy_foreach_cons. + apply trimmed_par. + { + apply @parable. + rewrite <- trimmed_ℓ_packages. + set (ℓ_packages _). + rewrite <- (trimmed_ℓ_packages). + solve_Parable. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. intros. unfold idents. solve_imfset_disjoint. } - apply trimmed_trim. + { + apply trimmed_ℓ_packages. + } + { + apply trimmed_ℓ_packages. + } Qed. - Lemma trimmed_xtr_package : forall (d : nat), - trimmed (XTR_n d) (XTR_packages d). + Lemma trimmed_xtr_package : forall (d k : nat) H_lt, + trimmed (XTR_n d k) (XTR_packages d k H_lt). Proof. intros. simpl. unfold XTR_packages. unfold eq_rect_r. destruct (Logic.eq_sym _). - erewrite <- (ℓ_raw_package_trimmed d ([eta xtr_level] d)). + erewrite <- (ℓ_raw_package_trimmed d (fun ℓ H => [eta xtr_level] k ℓ (leq_trans H H_lt))). 2:{ - intros ℓ. - apply (trimmed_xtr_level d ℓ). + intros ℓ ?. + apply (trimmed_xtr_level k ℓ). } 2:{ intros n ℓ ? ?. diff --git a/proofs/ssprove/handwritten/ssp_helper.v b/proofs/ssprove/handwritten/ssp_helper.v index 4355087e..a6dbaafa 100644 --- a/proofs/ssprove/handwritten/ssp_helper.v +++ b/proofs/ssprove/handwritten/ssp_helper.v @@ -146,35 +146,147 @@ Fixpoint sum_accum (fuel : nat) (index : nat) (f : nat -> nat) (accum : nat) : n | S n' => sum_accum n' (index + 1%nat) f (accum + f index) end. -Definition sumR : nat -> nat -> (nat -> R) -> R := - (fun l u f => (List.fold_left (fun y x => y + f x) (iota l u) 0)%R). +Definition sumR : forall (l u : nat), (l <= u)%nat -> (nat -> R) -> R := + (fun l u H f => (List.fold_left (fun y x => y + f x) (iota l (u - l)) 0)%R). -Fixpoint sumR_H_prime (start : nat) (fuel : nat) (f : forall (ℓ : nat), (ℓ <= start + fuel)%nat -> R) {struct fuel} : R. - refine ( +Fixpoint sumR_H_fuel start fuel (f : forall (ℓ : nat), (start <= ℓ)%nat -> (ℓ <= start + fuel)%nat -> R) {struct fuel} : R := match fuel as k return (k <= fuel)%nat -> _ with | O => fun _ => 0 - | S n => fun _ => f start _ + sumR_H_prime (S start) n _ - end _). - - Lia.lia. - - intros. - eapply (f ℓ). - Lia.lia. - - Lia.lia. -Defined. - -Definition sumR_H (l u : nat) (H_ul : (u >= l)%nat) (f : forall (ℓ : nat), (ℓ <= u)%nat -> R) : R. + | S n => + fun H => + let Ht := (eq_ind_r (λ ℓ, (ℓ <= start + fuel)%N) (eq_ind_r [eta is_true] (leq_trans (n:=n.+1) (m:=n) (p:=fuel) (leqnSn n) H) (leq_add2l start n fuel)) (natrDE start n)) in + f (start + n) (leq_addr _ _) Ht + sumR_H_fuel start n (fun ℓ Hstart Hend => f ℓ Hstart (leq_trans Hend Ht)) + end (leqnn fuel). + +Definition sumR_H + (l u : nat) (H_ul : (u >= l)%nat) + (f : forall (ℓ : nat), (ℓ <= u)%nat -> R) : R. Proof. - refine (sumR_H_prime l (u - l) _). - intros. - refine (f ℓ _). - Lia.lia. + apply (sumR_H_fuel l (u - l)). + rewrite subnKC. + - refine (fun ℓ _ H_le => f ℓ H_le). + - apply H_ul. Defined. -Axiom sumR_to_H : forall l u H_ul f, sumR l u f = sumR_H l u H_ul (fun n _ => f n). +Lemma iota_succ : forall l f, (iota l f.+1) = iota l f ++ [(l+f)]. +Proof. + intros. + generalize dependent l. + induction f ; intros. + - simpl. + rewrite addr0. + reflexivity. + - simpl. + specialize (IHf (l.+1)). + setoid_rewrite IHf. + rewrite !natrDE. + rewrite addSn. + rewrite addnS. + reflexivity. +Qed. + +(* H_Sul = (leq_trans H_ul (leqnSn u)) *) +Lemma sumR_succ : forall l u H_ul H_Sul f, sumR l u.+1 H_Sul f = f u + sumR l u H_ul f. +Proof. + intros. + unfold sumR. + + replace (u.+1 - l)%nat with ((u - l).+1)%nat by easy. + rewrite iota_succ. + rewrite List.fold_left_app. + simpl. + rewrite addrC. + f_equal. + f_equal. + now apply subnKC. +Qed. + +Lemma sumR_H_succ : forall l u H_ul H_Sul f, sumR_H l u.+1 H_Sul f = f u (leqnSn u) + sumR_H l u H_ul (fun ℓ H_le => f ℓ (leq_trans H_le (leqnSn u))). +Proof. + intros. + unfold sumR_H. + + unfold eq_rect_r. + unfold eq_rect. + + unfold Logic.eq_sym. + set (subnKC _). + set (subnKC _). + + (* eassert (forall l u f, sumR_H_fuel l (u.+1 - l) f = sumR_H_fuel l (u - l).+1 _). *) + (* { *) + (* clear l u H_ul H_Sul f e e0. *) + (* intros. *) -Axiom sumR_le : forall l u H_ul f g, (forall v Hf Hg, (f v Hf <= g v Hg))%R -> (sumR_H l u H_ul f <= sumR_H l u H_ul g)%R. +Admitted. -Axiom sumR_l : forall {T : Type}, list T -> (T -> R) -> R. +Lemma inequality : + forall l l0 d, (l <= l0 + (d - l0))%N -> (l <= l0 + (d.+1 - l0))%N. +Proof. Lia.lia. Qed. + +Lemma sumR_to_H : forall l u H_ul f, sumR l u H_ul f = sumR_H l u H_ul (fun n _ => f n). +Proof. + intros. + induction u. + { + destruct l ; [ | easy ]. + unfold sumR_H, sumR ; simpl. + reflexivity. + } + { + destruct (l == u.+1) eqn:leqSu ; move: leqSu => /eqP leqSu ; subst. + - unfold sumR, sumR_H. + unfold eq_rect_r, eq_rect. + destruct subnKC. + simpl. + rewrite subnn. + simpl. + rewrite subnn. + simpl. + reflexivity. + - rewrite sumR_succ ; [ easy | ]. + intros. + rewrite IHu. + + unfold sumR_H. + unfold eq_rect_r. + unfold eq_rect. + simpl. + destruct subnKC. + simpl. + destruct subnKC. + simpl. + + rewrite subSn ; [ | easy ]. + simpl. + reflexivity. + } +Qed. + +Lemma sumR_le : forall l u H_ul f g, (forall v Hf Hg, (f v Hf <= g v Hg))%R -> (sumR_H l u H_ul f <= sumR_H l u H_ul g)%R. +Proof. + intros. + induction u. + - unfold sumR_H. + simpl. + easy. + - unfold sumR_H. + unfold eq_rect_r. + unfold eq_rect. + + set (u.+1). + +Admitted. +(* destruct subnKC. *) +(* simpl. *) +(* rewrite <- sumR_to_H. *) +(* Qed. *) + +Fixpoint sumR_l {T : Type} (l : list T) (f : T -> R) : R := + match l with + | [] => 0%R + | (x :: xs) => f x + sumR_l xs f + end. (* Definition sum (l u : nat) (f : nat -> nat) : nat := sum_accum (u - l) l f 0%R. *) Definition max_val : R -> R -> R := From 9f4be82460caedaccaa65bc83aa23246b7099e22 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 20 Feb 2025 18:25:29 +0100 Subject: [PATCH 03/10] Back to core theorem --- proofs/ssprove/handwritten/CoreTheorem.v | 512 +++++--- .../ssprove/handwritten/KeySchedulePackages.v | 36 +- proofs/ssprove/handwritten/MapPackage.v | 1072 +++++++++-------- proofs/ssprove/handwritten/Utility.v | 136 ++- 4 files changed, 1050 insertions(+), 706 deletions(-) diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 0219599d..eec7360f 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -153,23 +153,23 @@ Section CoreTheorem. [interface #val #[ GET DH ℓ d ] : chGETinp → chGETout ] := - {package Nk_package ℓ d H_le ∘ (par (DH_package d) (Ls d [DH] Z erefl)) #with _ }. + {package Nk_package ℓ d H_le ∘ (par (DH_package d d) (Ls d [DH] Z erefl)) #with _ }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_zero d : + Program Definition layer2_zero d k H_lt : package fset0 [interface - #val #[ SET PSK O d ] : chSETinp → chSETout + #val #[ SET PSK O k ] : chSETinp → chSETout ] [interface - #val #[ GET PSK O d ] : chGETinp → chGETout + #val #[ GET PSK O k ] : chGETinp → chGETout ] := - {package Ks d [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. + {package Ks d k H_lt [PSK] false erefl ∘ Ls k [PSK] Z erefl #with _ }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_succ ℓ d (H_le : (ℓ <= d)%nat) : + Program Definition layer2_succ ℓ d k H_lt (H_le : (ℓ <= d)%nat) : package fset0 [interface #val #[ SET PSK ℓ d ] : chSETinp → chSETout @@ -177,176 +177,348 @@ Section CoreTheorem. [interface #val #[ GET PSK ℓ d ] : chGETinp → chGETout ] := - {package Ks d [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. + {package Ks d k H_lt [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_xpd ℓ d (H_le : (ℓ <= d)%nat) : - package fset0 + Program Definition layer2_xpd ℓ k H_lt : + package (L_K :|: L_L) [interface] - (XPD_n_ℓ d ℓ) := - xpd_level d ℓ H_le. - Admit Obligations. + (XPD_n_ℓ k ℓ) := + XPD_ ℓ k H_lt. Fail Next Obligation. Definition layer3 ℓ d (H_le : (ℓ <= d)%nat) := Hash. - Program Definition layer4_salt d : - package fset0 + Program Definition layer4_salt d k H_lt : + package (L_K :|: L_L) [interface] - (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ d ] : chGETinp → chGETout]) d) := - {package Ks d [ZERO_SALT] false erefl ∘ Ls d [ZERO_SALT] Z erefl #with _}. - Admit Obligations. + (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ k ] : chGETinp → chGETout]) d) := + {package Ks d k H_lt [ZERO_SALT] false erefl ∘ Ls k [ZERO_SALT] Z erefl #with _}. + Next Obligation. + intros. + eapply valid_link. + 2: apply pack_valid. + + eapply valid_package_inject_export. + 2: apply pack_valid. + apply fsubsetU. + apply /orP ; right. + unfold interface_hierarchy_foreach. + unfold interface_foreach. + apply fsubsetxx. + Qed. Fail Next Obligation. - Program Definition layer4_ikm d : - package fset0 + Program Definition layer4_ikm d k H_lt : + package (L_K :|: L_L) [interface] - (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ d ] : chGETinp → chGETout]) d) := - {package Ks d [ZERO_IKM] false erefl ∘ Ls d [ZERO_IKM] Z erefl #with _}. - Admit Obligations. + (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ k ] : chGETinp → chGETout]) d) := + {package Ks d k H_lt [ZERO_IKM] false erefl ∘ Ls k [ZERO_IKM] Z erefl #with _}. + Next Obligation. + intros. + eapply valid_link. + 2: apply pack_valid. + + eapply valid_package_inject_export. + 2: apply pack_valid. + apply fsubsetU. + apply /orP ; right. + unfold interface_hierarchy_foreach. + unfold interface_foreach. + apply fsubsetxx. + Qed. Fail Next Obligation. Program Definition layer4_xtr ℓ d H_le : package fset0 - (XTR_n_ℓ d ℓ :|: GET_XTR_ℓ d ℓ) - (SET_XTR_ℓ d ℓ) := xtr_level d ℓ H_le. + (XTR_n_ℓ d ℓ :|: GET_ℓ XTR_names d ℓ) + (SET_ℓ XTR_names d ℓ) := xtr_level d ℓ H_le. Admit Obligations. Fail Next Obligation. - Program Definition layer4_check d : + Program Definition layer4_check d k : package fset0 - (XPD_n d) - (XPD_n d :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. + (XPD_n d k) + (XPD_n d k :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. Admit Obligations. Fail Next Obligation. - Program Definition layer4_xpd d : + Program Definition layer4_xpd d k H_lt : package fset0 - (XPD_n d :|: SET_XPD d) - (GET_XPD d) := {package XPD_packages d ∘ layer4_check d #with _}. + (XPD_n d k :|: SET_n XPR d k) + (GET_n XPR d k) := {package XPD_packages d k H_lt ∘ layer4_check d k #with _}. Admit Obligations. Fail Next Obligation. - Definition core (d : nat) : package fset0 + Definition core (d k : nat) (H_lt : (d < k)%nat) : package fset0 (interface_hierarchy (fun x => [interface]) d) - (GET_O_star d). + (GET_O_star d k). Proof. - refine (ℓ_packages d _ _ _). - Unshelve. - 3:{ - intros n H. - epose (dh := layer1 n d H). - epose (layer2_xpd n d H). - epose (hash := layer3 n d H). - epose (salt0 := layer4_salt d). - epose (ikm0 := layer4_ikm d). - epose (check := layer4_check d). - epose (xtr := layer4_xtr n d H). - epose (xpd := layer4_xpd d). - - epose (T := package fset0 - [interface] - (match n with - | O => [interface] - | S n => (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) all_names n) - end)). - - epose (set_xtr := fun psk (sub_packages : T) => {package - xtr ∘ - parallel_raw [ - pack dh; - pack psk; - pack hash; - pack salt0; - pack ikm0; - pack sub_packages] - #with _} : package fset0 [interface] (SET_XTR_ℓ d n)). - Unshelve. - { - - } + Admitted. + + (* refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. *) + (* 2:{ *) + (* unfold GET_O_star. *) + (* unfold GET_n. *) + (* unfold SET_n. *) + (* rewrite interface_hierarchy_foreachU. *) + + (* apply interface_hierarchy_foreach_subset. *) + (* intros. *) + (* apply interface_hierarchy_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* assert (x \in all_names). *) + (* { *) + (* clear -H. *) + (* rewrite !in_cons in H. *) + (* unfold all_names. *) + (* rewrite !in_cons. *) + (* repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* exists H1. *) + (* exists ℓ, H0. *) + (* apply fsubsetUl. *) + (* } *) + + (* unfold GET_n. *) + (* unfold SET_n. *) + (* rewrite interface_hierarchy_foreachU. *) + + (* refine (ℓ_packages d _ _ _). *) + (* (* 2:{ *) *) + (* (* intros. *) *) + (* (* apply idents_foreach_disjoint_foreach. *) *) + (* (* intros. *) *) + (* (* unfold idents. *) *) + (* (* solve_imfset_disjoint. *) *) + (* (* } *) *) + + (* Unshelve. *) + (* 3:{ *) + (* intros n H. *) - epose (set_xpd := fun psk (sub_packages : T) => {package - xpd ∘ - parallel_raw [ - pack dh; - pack psk; - pack hash; - pack salt0; - pack ikm0; - pack sub_packages] - #with _} : package fset0 [interface] (SET_XPD_ℓ d n)). - - (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) - (* (parallel_raw [ *) - (* pack (set_xtr psk sub_packages); *) - (* pack (set_xpd psk sub_packages); *) - (* pack (Ls d O_star Z _)]) #with _}). *) - epose (output := fun psk - (sub_packages : T) => - {package Ks d all_names false erefl ∘ - (parallel_raw [ - pack (set_xtr psk sub_packages); - pack (set_xpd psk sub_packages); - pack (Ls d all_names Z _)]) #with _}). - - - assert (package fset0 - [interface] - (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) all_names n)). - { - induction n as [ | ℓ ]. - - epose (psk0 := layer2_zero d). - refine (output psk0 _). - unfold GET_XPD_ℓ. - refine {package emptym #with valid_empty_package _ _}. - - epose (pskS := layer2_succ (S ℓ) d H). - refine (output pskS _). - specialize (IHℓ (leq_trans H (leqnSn _))). - apply IHℓ. - } - - Unshelve. - { - simpl. + (* epose (dh := layer1 n d H). *) + (* epose proof (layer2_xpd n k (ltac:(Lia.lia))). *) + (* epose (hash := layer3 n d H). *) + (* epose (salt0 := layer4_salt d k (ltnW H_lt)). *) + (* epose (ikm0 := layer4_ikm d k (ltnW H_lt)). *) + (* epose (check := layer4_check d k). *) + (* epose (xtr := layer4_xtr n d H). *) + (* epose (xpd := layer4_xpd d k H_lt). *) + + (* epose (T := package fset0 *) + (* [interface] *) + (* (match n with *) + (* | O => [interface] *) + (* | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) *) + (* end)). *) + + (* epose (set_xtr := fun psk (sub_packages : T) => {package *) + (* xtr ∘ *) + (* parallel_raw [ *) + (* pack dh; *) + (* pack psk; *) + (* pack hash; *) + (* pack salt0; *) + (* pack ikm0; *) + (* pack sub_packages] *) + (* #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). *) + (* (* Unshelve. *) *) + (* (* { *) *) + + (* (* } *) *) - (* refine {package (pack IHℓ) #with _}. *) - (* apply (pack_valid IHℓ). *) - - (* apply (valid_package_inject_export _ _ _ (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ d] : chDHEXPout → chGETout ]) *) - (* all_names ℓ)). *) - (* 2: apply (pack_valid IHℓ). *) - - (* unfold GET_XPD_ℓ. *) - + (* epose (set_xpd := fun psk (sub_packages : T) => {package *) + (* xpd ∘ *) + (* parallel_raw [ *) + (* pack dh; *) + (* pack psk; *) + (* pack hash; *) + (* pack salt0; *) + (* pack ikm0; *) + (* pack sub_packages] *) + (* #with _} : package fset0 [interface] (SET_ℓ XPR k n)). *) + + (* (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) *) + (* (* (parallel_raw [ *) *) + (* (* pack (set_xtr psk sub_packages); *) *) + (* (* pack (set_xpd psk sub_packages); *) *) + (* (* pack (Ls d O_star Z _)]) #with _}). *) *) + (* epose (output := fun psk *) + (* (sub_packages : T) => *) + (* {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ *) + (* (parallel_raw [ *) + (* pack (set_xtr psk sub_packages); *) + (* pack (set_xpd psk sub_packages); *) + (* pack (Ls d all_names Z _)]) #with _}). *) + + + (* assert (package fset0 *) + (* [interface] *) + (* (interface_foreach (λ name, *) + (* [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). *) + (* { *) + (* induction n as [ | ℓ ]. *) + (* - epose (psk0 := layer2_zero d k (ltnW H_lt)). *) + (* refine (output psk0 _). *) + (* refine {package emptym #with valid_empty_package _ _}. *) + (* - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). *) + (* refine (output pskS _). *) + (* specialize (IHℓ (leq_trans H (leqnSn _))). *) + (* unfold T. *) + (* eapply IHℓ. *) + (* } *) + + (* refine {package X0 #with _}. *) + (* } *) + (* { *) + (* intros. *) + (* unfold pack. *) + (* destruct n. *) + (* - unfold nat_rect. *) + (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) + (* { *) + (* intros. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* unfold parallel_package. *) + (* rewrite <- (trimmed_parallel_raw (f := (λ n : name, *) + (* [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] *) + (* :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) + (* { *) + (* rewrite !link_trim_commut. *) + (* apply trimmed_trim. *) + (* } *) + (* { *) + (* intros. *) + (* unfold idents. *) + (* try rewrite !imfsetU *) + (* ; try rewrite !fdisjointUr *) + (* ; try rewrite !fdisjointUl *) + (* ; try rewrite <- !fset1E *) + (* ; try rewrite !imfset1 *) + (* ; try rewrite !fdisjoints1 *) + (* ; repeat (apply /andP ; split) *) + (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) + (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) + (* (* solve_imfset_disjoint. *) *) + (* } *) + (* { *) + (* reflexivity. *) + (* } *) + (* { *) + (* apply trimmed_pairs_map. *) + (* intros. *) + (* rewrite <- H. *) + (* set (K_package _ _ _ _ _). *) + (* rewrite fsetUC. *) + (* rewrite <- fset1E. *) + (* rewrite <- fset_cons. *) + (* apply trimmed_trim. *) + (* } *) + (* - unfold nat_rect. *) + (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) + (* { *) + (* intros. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* unfold parallel_package. *) + (* rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, *) + (* [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] *) + (* :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) + (* { *) + (* rewrite !link_trim_commut. *) + (* apply trimmed_trim. *) + (* } *) + (* { *) + (* intros. *) + (* unfold idents. *) + (* try rewrite !imfsetU *) + (* ; try rewrite !fdisjointUr *) + (* ; try rewrite !fdisjointUl *) + (* ; try rewrite <- !fset1E *) + (* ; try rewrite !imfset1 *) + (* ; try rewrite !fdisjoints1 *) + (* ; repeat (apply /andP ; split) *) + (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) + (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) + (* (* solve_imfset_disjoint. *) *) + (* } *) + (* { *) + (* reflexivity. *) + (* } *) + (* { *) + (* apply trimmed_pairs_map. *) + (* intros. *) + (* rewrite <- H. *) + (* set (K_package _ _ _ _ _). *) + (* rewrite fsetUC. *) + (* rewrite <- fset1E. *) + (* rewrite <- fset_cons. *) + (* apply trimmed_trim. *) + (* } *) + (* } *) + (* { *) + (* intros. *) + (* apply idents_foreach_disjoint_foreach. *) + (* intros. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* } *) + + (* Unshelve. *) + (* { *) + (* ssprove_valid. *) + (* 1:{ *) + (* eapply valid_package_inject_import. *) + (* 2:{ *) + (* unfold XTR_n_ℓ. *) + (* unfold GET_ℓ. *) + (* rewrite interface_foreach_U. *) + + (* unfold parallel_raw, List.fold_left. *) + (* unfold XTR_names, interface_foreach. *) + + (* (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) *) - - - - - apply - - Unshelve. - { - ssprove_valid. - - epose valid_parable. - - } - - } - Qed. + (* ssprove_valid. *) + (* all: try apply fsubsetxx. *) + (* 1-5: admit. *) + (* admit. *) + (* } *) + (* rewrite <- !fset0E. *) + (* rewrite !fsetU0 ; rewrite !fset0U. *) + (* admit. *) + (* } *) + (* { *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !fsetU0 ; rewrite !fset0U. *) + (* rewrite fsetUid. *) + (* admit. *) + (* } *) + (* } *) + (* all: admit. *) + (* Admitted. *) Lemma core_theorem : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat) H_lt, + forall (Score : Simulator d k), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → + ValidPackage LA (KS_interface d k) A_export A → (AdvantageE - (Gcore_real d) - (Gcore_ideal d Score) (A (* ∘ R d M H *)) + (Gcore_real d k H_lt) + (Gcore_ideal d k (ltnW H_lt) Score) (A (* ∘ R d M H *)) <= sumR_l [R_cr; (R_Z f_hash); R_D] (fun R => Advantage (Gacr f_hash) (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d) (Gcore_ideal d Score) (Ai A i)) + +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d) (Gcore_ideal d k (ltnW H_lt) Score) (Ai A i)) )%R. Proof. intros. @@ -356,79 +528,89 @@ Section CoreTheorem. unfold Gcore_real. unfold pack. - - + + epose Advantage_link. + (* unfold Gacr. *) (* simpl. *) (* simpl. *) Admitted. Lemma equation20_lhs : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat), + forall (Score : Simulator d k), forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → + ValidPackage LA (KS_interface d k) A_export A → (AdvantageE (Gcore_sodh d) (Gcore_hyb d 0) (Ai A i) = 0)%R. - Proof. Admitted. + Proof. + intros. + Admitted. Lemma equation20_rhs : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat), + forall (Score : Simulator d k), forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → - (AdvantageE (Gcore_ki d) (Gcore_hyb d d) (Ai A i) = 0)%R. + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (Gcore_ki d k) (Gcore_hyb d d) (Ai A i) = 0)%R. Proof. intros. Admitted. Lemma hyb_telescope : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat), + forall (Score : Simulator d k), (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → + ValidPackage LA (KS_interface d k) A_export A → (AdvantageE (Gcore_hyb d 0) (Gcore_hyb d d) (Ai A i) - = sumR 0 (d-1) (leq0n (d-1)) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) + = sumR 0 d (leq0n d) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) )%R. Proof. intros. - unfold sumR. - induction d. - - simpl. + set (d) at 1 2 6 7. + generalize dependent n. + induction d ; intros. + - unfold sumR. + simpl. + unfold AdvantageE. + rewrite subrr. + rewrite Num.Theory.normr0. + reflexivity. + - rewrite sumR_succ. (* unfold Gcore_hyb. *) Admitted. Lemma equation20_eq : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat) H_lt, + forall (Score : Simulator d k), (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → - (AdvantageE (Gcore_sodh d) (Gcore_ideal d Score) (Ai A i) - <= AdvantageE (Gcore_ki d) (Gcore_ideal d Score) (Ai A i) - +sumR 0 (d-1) (leq0n (d-1)) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (Gcore_sodh d) (Gcore_ideal d k H_lt Score) (Ai A i) + <= AdvantageE (Gcore_ki d k) (Gcore_ideal d k H_lt Score) (Ai A i) + +sumR 0 d (leq0n d) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) )%R. Proof. intros. eapply Order.le_trans ; [ apply Advantage_triangle | ]. instantiate (1 := (Gcore_hyb d 0)). - rewrite (equation20_lhs d Score). + rewrite (equation20_lhs d k Score). rewrite add0r. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := Gcore_ki d). + instantiate (1 := Gcore_ki d k). rewrite addrC. apply Num.Theory.lerD ; [ easy | ]. eapply Order.le_trans ; [ apply Advantage_triangle | ]. instantiate (1 := (Gcore_hyb d d)). - epose (e := equation20_rhs d Score). + epose (e := equation20_rhs d k Score). setoid_rewrite (Advantage_sym _ _) in e. rewrite e ; clear e. rewrite addr0. diff --git a/proofs/ssprove/handwritten/KeySchedulePackages.v b/proofs/ssprove/handwritten/KeySchedulePackages.v index 27104871..f8c12c57 100644 --- a/proofs/ssprove/handwritten/KeySchedulePackages.v +++ b/proofs/ssprove/handwritten/KeySchedulePackages.v @@ -85,21 +85,21 @@ Section KeySchedulePackages. Context {Dependencies : Dependencies}. Existing Instance Dependencies. - Definition key_schedule_interface d := + Definition key_schedule_interface d k := ([interface - #val #[ SET PSK 0 d ] : chSETinp → chSETout + #val #[ SET PSK 0 k ] : chSETinp → chSETout ] :|: DH_interface (* DHEXP, DHGEN *) - :|: XTR_n d (* {ES,HS,AS}, 0..d *) - :|: XPD_n d (* XPN, 0..d *) - :|: GET_O_star d). + :|: XTR_n d k (* {ES,HS,AS}, 0..d *) + :|: XPD_n d k (* XPN, 0..d *) + :|: GET_O_star d k). - Definition key_schedule_export d := - GET_O_star d :|: SET_O_star d. + Definition key_schedule_export d k := + GET_O_star d k :|: SET_O_star d k. (* Context {ord : chGroup → nat} {E : nat -> nat}. *) - Lemma required_O_subset d : SET_DH d :<=: SET_O_star d :|: GET_O_star d. + Lemma required_O_subset d k : SET_DH d k :<=: SET_O_star d k :|: GET_O_star d k. Proof. (* DH must be in O_star *) unfold SET_DH. @@ -107,8 +107,8 @@ Section KeySchedulePackages. rewrite interface_hierarchy_foreachU. unfold interface_hierarchy_foreach. - set d at 1 3 4. - generalize dependent n. + (* set d at 1 3 4. *) + (* generalize dependent n. *) induction d ; intros. - simpl. unfold interface_hierarchy_foreach. @@ -129,13 +129,13 @@ Section KeySchedulePackages. Qed. (* Fig.11, p.17 *) - Program Definition Gks_real (d : nat) : + Program Definition Gks_real (d k : nat) H_lt : package (L_K :|: L_L) [interface] - (GET_O_star d) := + (GET_O_star d k) := {package - Gcore_real d (* ∘ XPD_DH_XTR *) + Gcore_real d k H_lt (* ∘ XPD_DH_XTR *) #with _ }. @@ -144,15 +144,15 @@ Section KeySchedulePackages. (* Look into the use nominal sets (PR - Markus?)! *) Obligation Tactic := idtac. - Program Definition Gks_ideal d (S : Simulator d) : + Program Definition Gks_ideal d k H_lt (S : Simulator d k) : package L_K - (key_schedule_interface d) - (GET_O_star d) + (key_schedule_interface d k) + (GET_O_star d k) := {package (* (par (par (XPD_packages d) (XTR_packages d)) (DH_package ord E)) ∘ *) - (Ks d O_star true erefl) ∘ S + (Ks d k H_lt O_star true erefl) ∘ S }. Final Obligation. intros. @@ -160,7 +160,7 @@ Section KeySchedulePackages. eapply valid_link_upto. 1:{ eapply valid_package_inject_export. - 2: apply (pack_valid (Ks d O_star true erefl)). + 2: apply (pack_valid (Ks d k H_lt O_star true erefl)). unfold GET_O_star. solve_in_fset. } diff --git a/proofs/ssprove/handwritten/MapPackage.v b/proofs/ssprove/handwritten/MapPackage.v index a2af4661..a01c3ecc 100644 --- a/proofs/ssprove/handwritten/MapPackage.v +++ b/proofs/ssprove/handwritten/MapPackage.v @@ -84,41 +84,41 @@ From KeyScheduleTheorem Require Import KeySchedulePackages. (*** Helper definitions *) -From elpi Require Import elpi. -Elpi Tactic undup. -Elpi Accumulate lp:{{ -/*(*/ - pred same-goal i:sealed-goal, i:sealed-goal. - same-goal (nabla G1) (nabla G2) :- - % TODO: proof variables could be permuted - pi x\ same-goal (G1 x) (G2 x). - same-goal (seal (goal Ctx1 _ Ty1 P1 _) as G1) - (seal (goal Ctx2 _ Ty2 P2 _) as G2) :- - same-ctx Ctx1 Ctx2, - % this is an elpi builtin, aka same_term, which does not - % unify but rather compare two terms without assigning variables - Ty1 == Ty2, - P1 = P2. - - pred same-ctx i:goal-ctx, i:goal-ctx. - same-ctx [] []. - same-ctx [decl V _ T1|C1] [decl V _ T2|C2] :- - % TODO: we could compare up to permutation... - % TODO: we could try to relate def and decl - T1 == T2, - same-ctx C1 C2. - - pred undup i:sealed-goal, i:list sealed-goal, o:list sealed-goal. - undup _ [] []. - undup G [G1|GN] GN :- same-goal G G1. - undup G [G1|GN] [G1|GL] :- undup G GN GL. - - msolve [G1|GS] [G1|GL] :- - % TODO: we could find all duplicates, not just - % copies of the first goal... - undup G1 GS GL. -/*)*/ -}}. +(* From elpi Require Import elpi. *) +(* Elpi Tactic undup. *) +(* Elpi Accumulate lp:{{ *) +(* /*(*/ *) +(* pred same-goal i:sealed-goal, i:sealed-goal. *) +(* same-goal (nabla G1) (nabla G2) :- *) +(* % TODO: proof variables could be permuted *) +(* pi x\ same-goal (G1 x) (G2 x). *) +(* same-goal (seal (goal Ctx1 _ Ty1 P1 _) as G1) *) +(* (seal (goal Ctx2 _ Ty2 P2 _) as G2) :- *) +(* same-ctx Ctx1 Ctx2, *) +(* % this is an elpi builtin, aka same_term, which does not *) +(* % unify but rather compare two terms without assigning variables *) +(* Ty1 == Ty2, *) +(* P1 = P2. *) + +(* pred same-ctx i:goal-ctx, i:goal-ctx. *) +(* same-ctx [] []. *) +(* same-ctx [decl V _ T1|C1] [decl V _ T2|C2] :- *) +(* % TODO: we could compare up to permutation... *) +(* % TODO: we could try to relate def and decl *) +(* T1 == T2, *) +(* same-ctx C1 C2. *) + +(* pred undup i:sealed-goal, i:list sealed-goal, o:list sealed-goal. *) +(* undup _ [] []. *) +(* undup G [G1|GN] GN :- same-goal G G1. *) +(* undup G [G1|GN] [G1|GL] :- undup G GN GL. *) + +(* msolve [G1|GS] [G1|GL] :- *) +(* % TODO: we could find all duplicates, not just *) +(* % copies of the first goal... *) +(* undup G1 GS GL. *) +(* /*)*/ *) +(* }}. *) (*** Package *) @@ -128,41 +128,41 @@ Section MapPackages. Context {DepInstance : Dependencies}. Existing Instance DepInstance. -(* Context {L_M : {fset Location} }. *) -(* Context {PrntIdx : name -> forall (ℓ : bitvec), code fset0 [interface] (chProd chName chName)}. *) -(* Context {PrntN: name -> code fset0 fset0 (chName × chName)}. *) -(* Context {Labels : name -> bool -> code fset0 fset0 chLabel}. *) - -(* Axiom XTR_LABAL_from_index : nat -> name. *) -(* Axiom XPN_LABAL_from_index : nat -> name. *) -Axiom level : chHandle -> code fset0 [interface] (chOption chNat). - -Definition KS_interface d := - ([interface #val #[SET PSK 0 d] : chSETinp → chSETout ] - :|: DH_interface - :|: (XPD_n d :|: XTR_n d) - :|: GET_O_star d - ). - -Notation " 'chXTRinp' " := - (chHandle × chHandle) - (in custom pack_type at level 2). -Notation " 'chXTRout' " := - (chHandle) - (in custom pack_type at level 2). -(* Context {xtr_angle : name -> chHandle -> chHandle -> code fset0 fset0 chHandle}. *) - -(* fig. 29 *) -Definition R_ch_map_XTR_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) : - (n \in XTR_names) -> - (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> - package L_M (interface_hierarchy (XTR_n_ℓ d) ℓ (* ℓ.+1 *)) - [interface - #val #[ XTR n ℓ d (* ℓ.+1 *)] : chXTRinp → chXTRout - ]. -Proof. - intros. - refine [package + (* Context {L_M : {fset Location} }. *) + (* Context {PrntIdx : name -> forall (ℓ : bitvec), code fset0 [interface] (chProd chName chName)}. *) + (* Context {PrntN: name -> code fset0 fset0 (chName × chName)}. *) + (* Context {Labels : name -> bool -> code fset0 fset0 chLabel}. *) + + (* Axiom XTR_LABAL_from_index : nat -> name. *) + (* Axiom XPN_LABAL_from_index : nat -> name. *) + Axiom level : chHandle -> code fset0 [interface] (chOption chNat). + + Definition KS_interface d k := + ([interface #val #[SET PSK 0 k] : chSETinp → chSETout ] + :|: DH_interface + :|: (XPD_n d k :|: XTR_n d k) + :|: GET_O_star d k + ). + + Notation " 'chXTRinp' " := + (chHandle × chHandle) + (in custom pack_type at level 2). + Notation " 'chXTRout' " := + (chHandle) + (in custom pack_type at level 2). + (* Context {xtr_angle : name -> chHandle -> chHandle -> code fset0 fset0 chHandle}. *) + + (* fig. 29 *) + Definition R_ch_map_XTR_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) : + (n \in XTR_names) -> + (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> + package L_M (interface_hierarchy (XTR_n_ℓ d) ℓ (* ℓ.+1 *)) + [interface + #val #[ XTR n ℓ d (* ℓ.+1 *)] : chXTRinp → chXTRout + ]. + Proof. + intros. + refine [package #def #[ XTR n ℓ d (* ℓ.+1 *) ] ('(h1,h2) : chXTRinp) : chXTRout { '(i1,i2) ← PrntIdx n ℓ ;; temp1 ← get_or_fn (M (nfto i1) h1) fin_handle (@fail chHandle ;; ret (chCanonical _)) ;; @@ -190,143 +190,143 @@ Proof. ret h ) } - ]. - ssprove_valid. - { - apply valid_scheme. - apply PrntIdx. - } - { - unfold get_or_fn. - ssprove_valid. - } - { - unfold get_or_fn. + ]. ssprove_valid. - } - { - apply valid_scheme. - apply level. - } - { - apply valid_scheme. - apply level. - } - { - apply valid_scheme. - rewrite <- fset0E. - apply xtr_angle. - } - { - unfold XTR_n_ℓ. - set (o := mkopsig _ _ _) ; pattern x2 in o ; subst o. - apply lower_level_in_interface. - 2: apply x3. - - epose serialize_name_notin. - unfold XTR_names, interface_foreach, List.fold_left. - unfold mkopsig. - rewrite <- !fset1E. - rewrite !in_fsetU. - rewrite !in_fset1. - unfold XTR_names in H. - - rewrite !in_cons in H. - repeat (move: H => /orP [ /eqP H | H ] ; subst). - all: try (repeat (apply /orP ; ((left ; now apply /eqP) || right)) ; now apply /eqP). - } - { - unfold set_at. - ssprove_valid. - } -Defined. -Fail Next Obligation. - -Lemma interface_hierarchy_idemp : - forall d f, - (interface_hierarchy (λ (ℓ : nat), interface_hierarchy f ℓ) d) = - interface_hierarchy f d. -Proof. - intros. - induction d. - - reflexivity. - - simpl. - rewrite IHd. - rewrite fsetUA. - rewrite fsetUid. - reflexivity. -Defined. - -Lemma interface_hierarchy_interface_foreach_swap : - forall {A} (L : list A) d f, - (interface_hierarchy (λ (ℓ : nat), interface_foreach (f ℓ) L) d) = - (interface_foreach (λ n, interface_hierarchy (f^~ n) d) L). -Proof. - intros. - induction d. - - reflexivity. - - simpl. - rewrite IHd. - now rewrite interface_foreach_U. -Defined. - -Lemma interface_hierarchy_foreach_idemp : - forall {A} (L : list A) d f, - (interface_hierarchy_foreach - (λ (_ : A) (ℓ : nat), - interface_hierarchy_foreach f L ℓ) L d) = - interface_hierarchy_foreach f L d. -Proof. - intros. - destruct L. - - simpl. - unfold interface_hierarchy_foreach. - now rewrite interface_hierarchy_empty. - - unfold interface_hierarchy_foreach. - rewrite interface_hierarchy_interface_foreach_swap. - rewrite (interface_hierarchy_idemp d (λ ℓ0 : nat, interface_foreach (f^~ ℓ0) _)). - rewrite interface_hierarchy_interface_foreach_swap. - now rewrite <- interface_foreach_trivial. -Defined. + { + apply valid_scheme. + apply PrntIdx. + } + { + unfold get_or_fn. + ssprove_valid. + } + { + unfold get_or_fn. + ssprove_valid. + } + { + apply valid_scheme. + apply level. + } + { + apply valid_scheme. + apply level. + } + { + apply valid_scheme. + rewrite <- fset0E. + apply xtr_angle. + } + { + unfold XTR_n_ℓ. + set (o := mkopsig _ _ _) ; pattern x2 in o ; subst o. + apply lower_level_in_interface. + 2: apply x3. -Definition R_ch_map_XTR_packages (d : nat) (M : chHandle -> nat) - (H_inLM : name → ∀ s : chHandle, ('option ('fin #|fin_handle|); M s) \in L_M) : - package L_M (XTR_n d) (XTR_n d). -Proof. - unfold XTR_n at 1. - rewrite <- (interface_hierarchy_foreach_idemp XTR_names d (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])). - refine (ℓ_parallel XTR_names XTR_names d - (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) - (fun ℓ H_le a H => R_ch_map_XTR_package d ℓ a (fun _ => M) H H_inLM) - (fun a H => H) - _ _ _ - ). - - intros. - unfold idents. - destruct H ; solve_imfset_disjoint. - - reflexivity. - - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. -Defined. -Fail Next Obligation. + epose serialize_name_notin. + unfold XTR_names, interface_foreach, List.fold_left. + unfold mkopsig. + rewrite <- !fset1E. + rewrite !in_fsetU. + rewrite !in_fset1. + unfold XTR_names in H. -Notation " 'chXPDinp' " := - (chHandle × 'bool × bitvec) - (in custom pack_type at level 2). -Notation " 'chXPDout' " := - (chHandle) - (in custom pack_type at level 2). -(* Context {xpd_angle : name -> chLabel -> chHandle -> bitvec -> code fset0 fset0 chHandle}. *) - -Definition R_ch_map_XPD_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) (M_ℓ : name -> nat -> chHandle -> nat) : - (n \in XPR) -> - (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> - (forall s1 s k, ('option ('fin #|fin_handle|); M_ℓ s1 s k) \in L_M) -> - package L_M (XPD_n_ℓ d ℓ (* ℓ.+1 *)) - [interface - #val #[ XPD n ℓ d (* ℓ.+1 *) ] : chXPDinp → chXPDout - ]. - intros. - refine [package + rewrite !in_cons in H. + repeat (move: H => /orP [ /eqP H | H ] ; subst). + all: try (repeat (apply /orP ; ((left ; now apply /eqP) || right)) ; now apply /eqP). + } + { + unfold set_at. + ssprove_valid. + } + Defined. + Fail Next Obligation. + + Lemma interface_hierarchy_idemp : + forall d f, + (interface_hierarchy (λ (ℓ : nat), interface_hierarchy f ℓ) d) = + interface_hierarchy f d. + Proof. + intros. + induction d. + - reflexivity. + - simpl. + rewrite IHd. + rewrite fsetUA. + rewrite fsetUid. + reflexivity. + Defined. + + Lemma interface_hierarchy_interface_foreach_swap : + forall {A} (L : list A) d f, + (interface_hierarchy (λ (ℓ : nat), interface_foreach (f ℓ) L) d) = + (interface_foreach (λ n, interface_hierarchy (f^~ n) d) L). + Proof. + intros. + induction d. + - reflexivity. + - simpl. + rewrite IHd. + now rewrite interface_foreach_U. + Defined. + + Lemma interface_hierarchy_foreach_idemp : + forall {A} (L : list A) d f, + (interface_hierarchy_foreach + (λ (_ : A) (ℓ : nat), + interface_hierarchy_foreach f L ℓ) L d) = + interface_hierarchy_foreach f L d. + Proof. + intros. + destruct L. + - simpl. + unfold interface_hierarchy_foreach. + now rewrite interface_hierarchy_empty. + - unfold interface_hierarchy_foreach. + rewrite interface_hierarchy_interface_foreach_swap. + rewrite (interface_hierarchy_idemp d (λ ℓ0 : nat, interface_foreach (f^~ ℓ0) _)). + rewrite interface_hierarchy_interface_foreach_swap. + now rewrite <- interface_foreach_trivial. + Defined. + + Definition R_ch_map_XTR_packages (d k : nat) (M : chHandle -> nat) + (H_inLM : name → ∀ s : chHandle, ('option ('fin #|fin_handle|); M s) \in L_M) : + package L_M (XTR_n d k) (XTR_n d k). + Proof. + unfold XTR_n at 1. + rewrite <- (interface_hierarchy_foreach_idemp XTR_names d (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ k] : chXTRinp → chXTRout ])). + refine (ℓ_parallel XTR_names XTR_names d + (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) + (fun ℓ H_le a H => R_ch_map_XTR_package k ℓ a (fun _ => M) H H_inLM) + (fun a H => H) + _ _ _ + ). + - intros. + unfold idents. + destruct H ; solve_imfset_disjoint. + - reflexivity. + - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. + Defined. + Fail Next Obligation. + + Notation " 'chXPDinp' " := + (chHandle × 'bool × bitvec) + (in custom pack_type at level 2). + Notation " 'chXPDout' " := + (chHandle) + (in custom pack_type at level 2). + (* Context {xpd_angle : name -> chLabel -> chHandle -> bitvec -> code fset0 fset0 chHandle}. *) + + Definition R_ch_map_XPD_package d (ℓ : nat) (n : name) (M : name -> chHandle -> nat) (M_ℓ : name -> nat -> chHandle -> nat) : + (n \in XPR) -> + (forall s1 s, ('option ('fin #|fin_handle|); M s1 s) \in L_M) -> + (forall s1 s k, ('option ('fin #|fin_handle|); M_ℓ s1 s k) \in L_M) -> + package L_M (XPD_n_ℓ d ℓ (* ℓ.+1 *)) + [interface + #val #[ XPD n ℓ d (* ℓ.+1 *) ] : chXPDinp → chXPDout + ]. + intros. + refine [package #def #[ XPD n ℓ d (* ℓ.+1 *) ] ('(h1,r,args) : chXPDinp) : chXPDout { '(i1,_) ← PrntIdx n ℓ ;; temp ← get_or_fn (M (nfto i1) h1) fin_handle (@fail chHandle ;; ret (chCanonical chHandle)) ;; @@ -345,139 +345,160 @@ Definition R_ch_map_XPD_package d (ℓ : nat) (n : name) (M : name -> chHandle - #import {sig #[ XPD n ℓ1 d (* ℓ.+1 *) ] : chXPDinp → chXPDout } as XPD_fn ;; h' ← XPD_fn (temp, r, args) ;; - ℓ ← ret (if xpn_eq n PSK then (ℓ + 1)%nat else ℓ) ;; + ℓ ← ret (if name_eq n PSK then (ℓ + 1)%nat else ℓ) ;; set_at (M_ℓ n ℓ h) fin_handle (otf h') ;; ret h ) } ]. - unfold get_or_fn. - unfold set_at. - ssprove_valid. - - apply valid_scheme. - apply PrntIdx. - - apply valid_scheme. - rewrite <- fset0E. - apply Labels. - - apply valid_scheme. - apply level. - - apply valid_scheme. rewrite <- fset0E. apply (prog_valid (xpd_angle _ _ _ _)). - - unfold XPD_n_ℓ. - set (o := mkopsig _ _ _) ; pattern x2 in o ; subst o. - apply lower_level_in_interface. - 2: apply x3. (* Lia.lia. *) - - (* simpl. *) - unfold XPD, serialize_name. - unfold mkopsig. - (* destruct n. *) - (* all: try (unfold XPR in H ; repeat (destruct H ; [ discriminate | ] || contradiction)). *) - - unfold XPR, interface_foreach, List.fold_left, "++". - unfold mkopsig. - rewrite <- !fset1E. - rewrite !in_fsetU. - rewrite !in_fset1. - unfold XPR, "++" in H. - - rewrite !in_cons in H. - repeat (move: H => /orP [ /eqP H | H ] ; subst). - all: (repeat (apply /orP ; ((left ; now apply /eqP) || right)) ; now apply /eqP). -Defined. -Fail Next Obligation. + unfold get_or_fn. + unfold set_at. + ssprove_valid. + - apply valid_scheme. + apply PrntIdx. + - apply valid_scheme. + rewrite <- fset0E. + apply Labels. + - apply valid_scheme. + apply level. + - apply valid_scheme. rewrite <- fset0E. apply (prog_valid (xpd_angle _ _ _ _)). + - unfold XPD_n_ℓ. + set (o := mkopsig _ _ _) ; pattern x2 in o ; subst o. + apply lower_level_in_interface. + 2: apply x3. (* Lia.lia. *) -Lemma trimmed_R_ch_map_XPD_package : forall d n ℓ M1 M2 A B C, trimmed [interface + (* simpl. *) + unfold XPD, serialize_name. + unfold mkopsig. + (* destruct n. *) + (* all: try (unfold XPR in H ; repeat (destruct H ; [ discriminate | ] || contradiction)). *) + + unfold XPR, interface_foreach, List.fold_left, "++". + unfold mkopsig. + rewrite <- !fset1E. + rewrite !in_fsetU. + rewrite !in_fset1. + unfold XPR, "++" in H. + + rewrite !in_cons in H. + rewrite <- !fset1E. + rewrite !in_fset1. + repeat (move: H => /orP [ /eqP H | H ] ; subst) ; [ .. | discriminate ]. + all: rewrite eqxx. + all: simpl. + all: (repeat (apply /orP ; ((left ; reflexivity) || right)) ; reflexivity). + Defined. + Fail Next Obligation. + + Lemma trimmed_R_ch_map_XPD_package : forall d n ℓ M1 M2 A B C, trimmed [interface #val #[ XPD n ℓ d (* d.+1 *) ] : chXPDinp → chXPDout ] (R_ch_map_XPD_package d ℓ n M1 M2 A B C). -Proof. - intros. - - unfold R_ch_map_XPD_package. - unfold pack. - apply trimmed_package_cons. - apply trimmed_empty_package. -Qed. + Proof. + intros. -Lemma trimmed_parallel_raw_R_ch_map_XPD : - forall (d : nat), - forall (M : chHandle → nat), - forall (H_L_M : ∀ s : chHandle, ('option ('fin #|fin_handle|); M s) \in L_M), - trimmed (interface_foreach (fun n => [interface - #val #[ XPD n d d (* d.+1 *) ] : chXPDinp → chXPDout - ]) XPR) (parallel_raw + unfold R_ch_map_XPD_package. + unfold pack. + apply trimmed_package_cons. + apply trimmed_empty_package. + Qed. + + Lemma trimmed_parallel_raw_R_ch_map_XPD : + forall (d : nat), + forall (M : chHandle → nat), + forall (H_L_M : ∀ s : chHandle, ('option ('fin #|fin_handle|); M s) \in L_M), + trimmed (interface_foreach (fun n => [interface + #val #[ XPD n d d (* d.+1 *) ] : chXPDinp → chXPDout + ]) XPR) (parallel_raw (map_with_in_rel XPR XPR (H_in := fun a H0 => H0) (λ (x : name) (H0 : x \in XPR), pack (R_ch_map_XPD_package d d x (λ _ : name, M) (λ (_ : name) (_ : nat), M) H0 (λ _ : name, H_L_M) (λ (_ : name) (_ : nat), H_L_M))))). -Proof. - intros. - - apply trimmed_parallel_raw. - { + Proof. intros. - unfold idents. - solve_imfset_disjoint. - } - { - reflexivity. - } - { - (* unfold XPD, serialize_name, idents. *) - unfold XPR. - unfold "++". - unfold List.map. - unfold map_with_in_rel. - unfold trimmed_pairs. - - repeat split. - all: apply trimmed_R_ch_map_XPD_package. - } -Qed. -Definition R_ch_map_XPD_packages (d : nat) (M : chHandle -> nat) : - (forall s, ('option ('fin #|fin_handle|); M s) \in L_M) -> - package L_M (XPD_n d) (XPD_n d). + apply trimmed_parallel_raw. + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + reflexivity. + } + { + (* unfold XPD, serialize_name, idents. *) + unfold XPR. + unfold "++". + unfold List.map. + unfold map_with_in_rel. + unfold trimmed_pairs. + + repeat split. + all: apply trimmed_R_ch_map_XPD_package. + } + Qed. + + Definition R_ch_map_XPD_packages (d k : nat) (M : chHandle -> nat) : + (forall s, ('option ('fin #|fin_handle|); M s) \in L_M) -> + package L_M (XPD_n d k) (XPD_n d k). + Proof. + intros H_L_M. + unfold XPD_n at 1. + rewrite <- (interface_hierarchy_foreach_idemp XPR d _). + refine (ℓ_parallel XPR XPR d + (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) + (fun ℓ H_le a H => R_ch_map_XPD_package k ℓ a (fun _ => M) (fun _ _ => M) H (fun _ => H_L_M) (fun _ _ => H_L_M)) + (fun a H => H) + _ _ _ + ). + - intros. + unfold idents. + destruct H ; solve_imfset_disjoint. + - reflexivity. + - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. + Defined. + Fail Next Obligation. + + +Lemma serialize_name_notin_smaller_than_start : + forall d, + forall (ℓ : nat), + forall (n : name), + forall (index : nat), + forall k, + (k < 100)%nat -> + serialize_name n ℓ d index <> k. Proof. - intros H_L_M. - unfold XPD_n at 1. - rewrite <- (interface_hierarchy_foreach_idemp XPR d _). - refine (ℓ_parallel XPR XPR d - (* (g := (λ (n : name) (ℓ : nat), [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ])) *) - (fun ℓ H_le a H => R_ch_map_XPD_package d ℓ a (fun _ => M) (fun _ _ => M) H (fun _ => H_L_M) (fun _ _ => H_L_M)) - (fun a H => H) - _ _ _ - ). - - intros. - unfold idents. - destruct H ; solve_imfset_disjoint. - - reflexivity. - - repeat split ; apply trimmed_package_cons ; apply trimmed_empty_package. -Defined. -Fail Next Obligation. - + intros. + unfold serialize_name. + Lia.lia. +Qed. -(* R_ch_map, fig.25, Fig. 27, >> Fig. 29 << *) -(* GET_o_star_ℓ d *) -Definition R_ch_map (d : nat) : - package (L_M :|: (L_K :|: L_L)) - ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: - DH_interface :|: - XTR_n d :|: - XPD_n d) - (KS_interface d) -(* (SET_O_star_ℓ :|: GET_O_star_ℓ) *). -Proof. - refine (let base_package : package L_M - ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: - DH_interface :|: - XTR_n d :|: - XPD_n d) ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) + + + (* R_ch_map, fig.25, Fig. 27, >> Fig. 29 << *) + (* GET_o_star_ℓ d *) + Definition R_ch_map (d k : nat) (H_lt : (d <= k)%nat) : + package (L_M :|: (L_K :|: L_L)) + ([interface #val #[ SET PSK 0 k ] : chSETinp → chSETout] :|: + DH_interface :|: + XTR_n d k :|: + XPD_n d k) + (KS_interface d k) + (* (SET_O_star_ℓ :|: GET_O_star_ℓ) *). + Proof. + refine (let base_package : package L_M + ([interface #val #[ SET PSK 0 k ] : chSETinp → chSETout] :|: + DH_interface :|: + XTR_n d k :|: + XPD_n d k) + ([interface #val #[ SET PSK 0 k ] : chSETinp → chSETout] :|: DH_interface) := [package - #def #[ SET PSK 0 d ] ('(h,hon,k) : chSETinp) : chSETout { - #import {sig #[ SET PSK 0 d ] : chSETinp → chSETout } + #def #[ SET PSK 0 k ] ('(h,hon,key) : chSETinp) : chSETout { + #import {sig #[ SET PSK 0 k ] : chSETinp → chSETout } as set_fn ;; - nh ← set_fn (h, hon, k) ;; + nh ← set_fn (h, hon, key) ;; set_at (H := pos_handle) (M h) fin_handle (otf nh) ;; ret h } ; @@ -500,12 +521,14 @@ Proof. 1: refine ({package par (base_package ) (par (par - (R_ch_map_XPD_packages d M _) - (R_ch_map_XTR_packages d M H)) - (Ks d O_star false erefl ∘ Ls d O_star F erefl) + (R_ch_map_XPD_packages d k M _) + (R_ch_map_XTR_packages d k M H)) + (Ks d k H_lt O_star false erefl ∘ Ls k O_star F erefl) ) }). 1:{ - assert (H_trim_ch_map_XTR : trimmed (XTR_n d) (R_ch_map_XTR_packages d M H)). + epose (R_ch_map_XTR_packages d k M H). + + assert (H_trim_ch_map_XTR : trimmed (XTR_n d k) (R_ch_map_XTR_packages d k M H)). { unfold R_ch_map_XTR_packages. unfold eq_rect. @@ -513,7 +536,7 @@ Proof. apply trimmed_ℓ_packages. } - assert (H_trim_ch_map_XPD : trimmed (XPD_n d) (R_ch_map_XPD_packages d M (H BOT))). + assert (H_trim_ch_map_XPD : trimmed (XPD_n d k) (R_ch_map_XPD_packages d k M (H BOT))). { unfold R_ch_map_XPD_packages. unfold eq_rect. @@ -521,7 +544,7 @@ Proof. apply trimmed_ℓ_packages. } - assert (H_trim_PSK : trimmed ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout] :|: DH_interface) base_package). + assert (H_trim_PSK : trimmed ([interface #val #[ SET PSK 0 k ] : chSETinp → chSETout] :|: DH_interface) base_package). { unfold DH_interface. rewrite <- fset_cat. @@ -624,7 +647,7 @@ Proof. rewrite fdisjointC. apply idents_interface_hierachy3. intros. - rewrite function_fset_cat. + rewrite function_fset_cons. unfold idents. apply idents_foreach_disjoint_foreach_different ; intros. @@ -640,7 +663,7 @@ Proof. apply idents_interface_hierachy3. intros. - rewrite function_fset_cat. + rewrite function_fset_cons. apply idents_foreach_disjoint_foreach_different ; intros. unfold idents. @@ -719,8 +742,8 @@ Proof. rewrite fset1E. rewrite <- fset0E ; rewrite fsetU0. - fold (GET_O_star d). - fold (SET_O_star d). + fold (GET_O_star d k). + fold (SET_O_star d k). solve_in_fset. } } @@ -779,16 +802,16 @@ Time Defined. (* 114.674 secs (104.24u,1.633s) -> 8.862 secs (8.839u,0.01s) *) Fail Next Obligation. Obligation Tactic := (* try timeout 8 *) idtac. -Program Definition Gks_real_map (d : nat) : +Program Definition Gks_real_map (d k : nat) H_lt : package (L_M :|: (L_K :|: L_L)) [interface] (* ([interface #val #[ SET PSK 0 d ] : chSETinp → chSETout]) *) - (GET_O_star d) := + (GET_O_star d k) := {package (* (Ks d O_star false erefl ∘ Ls d O_star F erefl) ∘ *) - R_ch_map d - ∘ (par (XPD_DH_XTR d) (K_package d PSK O erefl false ∘ L_package d PSK F)) }. + R_ch_map d k (ltnW H_lt) + ∘ (par (XPD_DH_XTR d k H_lt) (K_package k PSK O erefl false ∘ L_package k PSK F)) }. Next Obligation. intros. @@ -799,7 +822,7 @@ Next Obligation. (* 2:{ *) (* rewrite <- fsetUid. *) eapply valid_par_upto. - 2: apply (pack_valid (XPD_DH_XTR d)). + 2: apply (pack_valid (XPD_DH_XTR d k H_lt)). 2:{ eapply valid_link. - apply K_package. @@ -815,14 +838,17 @@ Next Obligation. (* assert (trimmed _ (XPD_packages d)). *) + unfold XPD_. unfold XPD_packages. unfold eq_rect_r. unfold eq_rect. destruct (Logic.eq_sym _). destruct (Logic.eq_sym _). - destruct (Logic.eq_sym _). + unfold pack. + (* destruct (Logic.eq_sym _). *) rewrite <- trimmed_ℓ_packages. - rewrite !link_trim_commut. + rewrite <- (trimmed_ℓ_packages d (fun _ _ => xpd_level_sub_psk _ _ _)). + (* rewrite !link_trim_commut. *) rewrite <- trimmed_dh. rewrite !link_trim_commut. @@ -831,57 +857,104 @@ Next Obligation. unfold eq_rect_r. unfold eq_rect. destruct (Logic.eq_sym _). - rewrite <- (trimmed_ℓ_packages d (λ (ℓ : nat) (H : (ℓ <= d)%N), xtr_level d ℓ H)) ; fold (XTR_packages d). + unfold eq_rect. + rewrite <- (trimmed_ℓ_packages d (λ (ℓ : nat) (H : (ℓ <= d)%N), xtr_level k ℓ _)) ; fold (XTR_packages d k). rewrite !link_trim_commut. (* rewrite <- (trimmed_Ks d O_star). *) (* rewrite !link_trim_commut. *) repeat set (trim _ _). - eassert (trimmed _ (par f (par f0 f1))) ; [ | rewrite <- H ; clear H ]. + eassert (trimmed _ (par f f0)) ; [ | rewrite <- H ; clear H ]. { - subst f f0 f1. + subst f f0. repeat eapply trimmed_par ; try apply trimmed_trim ; apply @parable. { solve_Parable. - { - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - unfold DH_interface. - rewrite fset_cons. - apply idents_disjoint_foreach ; intros. - unfold idents. - solve_imfset_disjoint. - } { apply idents_interface_hierachy3. intros. rewrite fdisjointC. apply idents_interface_hierachy3. intros. - (* apply idents_foreach_disjoint_foreach_different ; intros. *) unfold idents. solve_imfset_disjoint. } } + } + + rewrite !link_trim_commut. + + eassert (trimmed _ (par f1 f2)) ; [ | rewrite <- H ; clear H ]. + { + subst f1 f2. + repeat eapply trimmed_par ; try apply trimmed_trim ; apply @parable. { solve_Parable. { - apply idents_interface_hierachy3. - intros. unfold DH_interface. rewrite fset_cons. - apply idents_disjoint_foreach ; intros. + apply idents_interface_hierachy3. + intros. unfold idents. solve_imfset_disjoint. } } } + eassert (trimmed _ (K_package k PSK O erefl false)) by repeat (apply trimmed_empty_package || apply trimmed_package_cons) ; rewrite <- H ; clear H . + rewrite !link_trim_commut. - eassert (trimmed _ (K_package d PSK O erefl false)) by repeat (apply trimmed_empty_package || apply trimmed_package_cons) ; rewrite <- H ; clear H . + set (trim _ _). + set (trim _ _). + + eassert (trimmed _ (par f3 f4)) ; [ | rewrite <- H ; clear H ]. + { + subst f3 f4. + repeat eapply trimmed_par ; try apply trimmed_trim ; apply @parable. + { + solve_Parable. + { + unfold idents. + rewrite imfsetU. + rewrite imfsetU. + rewrite !fdisjointUr. + rewrite !fdisjointUl. + repeat (apply /andP ; split). + - rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold DH_interface. + rewrite fset_cons. + unfold idents. + solve_imfset_disjoint. + - rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + apply idents_disjoint_foreach. + intros. + unfold DH_interface. + rewrite fset_cons. + unfold idents. + solve_imfset_disjoint. + - apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + solve_imfset_disjoint. + - apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + solve_imfset_disjoint. + } + } + } rewrite !link_trim_commut. @@ -893,15 +966,22 @@ Next Obligation. rewrite fdisjointC. apply idents_interface_hierachy3. intros. - apply idents_disjoint_foreach ; intros. - rewrite fset_cons. unfold idents. + rewrite fset_cons. solve_imfset_disjoint. } { + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. rewrite fset_cons. + solve_imfset_disjoint. + } + { unfold DH_interface. rewrite (fset_cons (DHGEN, _)). + rewrite (fset_cons (SET PSK 0 k, _)). unfold idents. solve_imfset_disjoint. } @@ -921,7 +1001,7 @@ Next Obligation. 2:{ eapply valid_package_inject_import. 2:{ - apply (pack_valid (R_ch_map d)). + apply pack_valid. } { solve_in_fset. @@ -934,11 +1014,11 @@ Next Obligation. Defined. Fail Next Obligation. -Program Definition Gks_ideal_map (d : nat) (Score : Simulator d) : +Program Definition Gks_ideal_map (d k : nat) H_lt (Score : Simulator d k) : package fset0 - (KS_interface d) - (GET_O_star d) := {package (R_ch_map d) ∘ Score }. + (KS_interface d k) + (GET_O_star d k) := {package (R_ch_map d k H_lt) ∘ Score }. Next Obligation. admit. Admitted. @@ -1120,28 +1200,29 @@ Proof. Qed. Lemma ℓ_package_getm : - forall {L} (d : nat) + forall {L} (d k : nat) (H_lt : (d <= k)%nat) {g : nat -> Interface} {f : nat -> Interface} - (p : forall (n : nat), (d >= n)%nat → package L (g n) (f n)) - (H_trim_p : forall n, forall (H_ge : (d >= n)%nat), trimmed (f n) (p n H_ge)) + (p : forall (n : nat), (k >= n)%nat → package L (g n) (f n)) + (H_trim_p : forall n, forall (H_ge : (k >= n)%nat), trimmed (f n) (p n H_ge)) (Hdisj : ∀ (n ℓ : nat) , (n > ℓ)%nat -> (d >= n)%nat -> idents (f ℓ) :#: idents (f n)), forall x x0 index, (forall (H_le : (x0 <= d)%nat), - (∀ (n k : nat) (Hk_le : (k <= d)%N), - k ≠ n → (n <= d)%N → getm (pack (p k Hk_le)) (serialize_name x n d index) = None) -> - getm (pack (ℓ_packages d (p) H_trim_p Hdisj)) (serialize_name x x0 d index) = - getm (pack (p x0 H_le)) (serialize_name x x0 d index) + (∀ (n m : nat) (Hm_le : (m <= k)%N), + m ≠ n → (n <= k)%N → getm (pack (p m Hm_le)) (serialize_name x n k index) = None) -> + getm (pack (ℓ_packages d (fun x y => p x (leq_trans y H_lt)) (fun x y => H_trim_p x (leq_trans y H_lt)) Hdisj)) (serialize_name x x0 k index) = + getm (pack (p x0 (leq_trans H_le H_lt))) (serialize_name x x0 k index) ). Proof. intros. unfold ℓ_packages. unfold pack. unfold ℓ_raw_packages. - rewrite (map_with_in_num_upper_getm d d (leqnn d) p x x0 index d). + rewrite (map_with_in_num_upper_getm). (* d d (leqnn d) p x x0 index d). *) - now replace (leq_trans _ _) with (H_le). - - assumption. - - apply H. + - Lia.lia. + - intros. + now apply H. Qed. Lemma getm_parallel_raw : @@ -1208,79 +1289,79 @@ Proof. ++ now apply IHl. Qed. -Lemma ℓ_list : - forall {L I} (d : nat) (l : seq name) (l_uniq : uniq l) - {f : nat -> name -> nat -> Interface} - (p : forall (a : name) (n : nat), (d >= n)%nat → package L (I d a) (f d a n)) - (H_trim_p : forall a n, forall (H_ge : (d >= n)%nat), trimmed (f d a n) (p a n H_ge)) - (Hdisj : ∀ d a y n (ℓ : nat), ((a <> y /\ n = ℓ) \/ (n > ℓ)%nat) -> (d >= n)%nat -> idents (f d a ℓ) :#: idents (f d y n)), - forall x x0 index (_ : x \in l), - (forall (H_le : (x0 <= d)%nat), - (∀ d (a x1 : name) x0 H_le n, - (x0 <= d)%N /\ (n <= d)%N -> - ((a ≠ x1) \/ (a = x1 /\ x0 <> n)) → - getm (pack (p a x0 H_le)) (serialize_name x1 n d index) = None) -> - getm - (pack (ℓ_packages d - (fun n x1 => parallel_package d l - (fun a => p a n x1) - (fun a y H => Hdisj d a y n n (or_introl (conj H erefl)) x1) - (fun a => H_trim_p a n x1) - l_uniq) - (fun n x1 => - trimmed_parallel_raw - (fun x y H => Hdisj d x y n n (or_introl (conj H erefl)) x1) - l_uniq - (trimmed_pairs_map _ _ _ (fun x => H_trim_p _ _ _))) - (fun n ℓ H1 H2 => idents_foreach_disjoint_foreach _ _ l - (fun a b => Hdisj _ _ _ _ _ (or_intror H1) H2 )))) - (serialize_name x x0 d index) = - getm (pack (p x x0 H_le)) (serialize_name x x0 d index) - ). -Proof. - intros. - - set (tp := fun _ _ => _). - (* pattern d in tp. *) - set (ℓp := fun _ _ => _) in tp. - subst tp. - - set (t_trim := fun _ _ => _). - (* pattern d in t_trim. *) - set (ℓ_trim := fun _ _ => _) in t_trim. - subst t_trim. - - set (t_disj := fun _ _ _ _ => _). - (* pattern d in t_disj. *) - set (ℓ_disj := fun _ _ _ _ => _) in t_disj. - subst t_disj. - - rewrite ℓ_package_getm. - - subst ℓp. - apply getm_parallel_raw. - + assumption. - + assumption. - + now intros ; apply H0 ; [ | left]. - - intros. - subst ℓp. - hnf. - rewrite getm_parallel_raw. - + specialize (H0 d x x k Hk_le). - now apply H0 ; [ | right]. - + assumption. - + assumption. - + now intros ; apply H0 ; [ | left ]. - Qed. +(* Lemma ℓ_list : *) +(* forall {L I} (d : nat) (l : seq name) (l_uniq : uniq l) *) +(* {f : nat -> name -> nat -> Interface} *) +(* (p : forall (a : name) (n : nat), (d >= n)%nat → package L (I d a) (f d a n)) *) +(* (H_trim_p : forall a n, forall (H_ge : (d >= n)%nat), trimmed (f d a n) (p a n H_ge)) *) +(* (Hdisj : ∀ d a y n (ℓ : nat), ((a <> y /\ n = ℓ) \/ (n > ℓ)%nat) -> (d >= n)%nat -> idents (f d a ℓ) :#: idents (f d y n)), *) +(* forall x x0 index (_ : x \in l), *) +(* (forall (H_le : (x0 <= d)%nat), *) +(* (∀ d (a x1 : name) x0 H_le n, *) +(* (x0 <= d)%N /\ (n <= d)%N -> *) +(* ((a ≠ x1) \/ (a = x1 /\ x0 <> n)) → *) +(* getm (pack (p a x0 H_le)) (serialize_name x1 n d index) = None) -> *) +(* getm *) +(* (pack (ℓ_packages d *) +(* (fun n x1 => parallel_package d l *) +(* (fun a => p a n x1) *) +(* (fun a y H => Hdisj d a y n n (or_introl (conj H erefl)) x1) *) +(* (fun a => H_trim_p a n x1) *) +(* l_uniq) *) +(* (fun n x1 => *) +(* trimmed_parallel_raw *) +(* (fun x y H => Hdisj d x y n n (or_introl (conj H erefl)) x1) *) +(* l_uniq *) +(* (trimmed_pairs_map _ _ _ (fun x => H_trim_p _ _ _))) *) +(* (fun n ℓ H1 H2 => idents_foreach_disjoint_foreach _ _ l *) +(* (fun a b => Hdisj _ _ _ _ _ (or_intror H1) H2 )))) *) +(* (serialize_name x x0 d index) = *) +(* getm (pack (p x x0 H_le)) (serialize_name x x0 d index) *) +(* ). *) +(* Proof. *) +(* intros. *) + +(* set (tp := fun _ _ => _). *) +(* (* pattern d in tp. *) *) +(* set (ℓp := fun _ _ => _) in tp. *) +(* subst tp. *) + +(* set (t_trim := fun _ _ => _). *) +(* (* pattern d in t_trim. *) *) +(* set (ℓ_trim := fun _ _ => _) in t_trim. *) +(* subst t_trim. *) + +(* set (t_disj := fun _ _ _ _ => _). *) +(* (* pattern d in t_disj. *) *) +(* set (ℓ_disj := fun _ _ _ _ => _) in t_disj. *) +(* subst t_disj. *) + +(* rewrite ℓ_package_getm. *) +(* - subst ℓp. *) +(* apply getm_parallel_raw. *) +(* + assumption. *) +(* + assumption. *) +(* + now intros ; apply H0 ; [ | left]. *) +(* - intros. *) +(* subst ℓp. *) +(* hnf. *) +(* rewrite getm_parallel_raw. *) +(* + specialize (H0 d x x k Hk_le). *) +(* now apply H0 ; [ | right]. *) +(* + assumption. *) +(* + assumption. *) +(* + now intros ; apply H0 ; [ | left ]. *) +(* Qed. *) Lemma map_intro_c2 : - (* forall (d : nat), *) - forall (Score : Simulator d), + forall (d k : nat) H_lt, + forall (Score : Simulator d k), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (GET_O_star d) A_export A → + ValidPackage LA (GET_O_star d k) A_export A → LA :#: L_M :|: (L_K :|: L_L) -> (AdvantageE - (Gks_real d) - (Gks_real_map d) A = 0 + (Gks_real d k H_lt) + (Gks_real_map d k H_lt) A = 0 )%R. Proof. intros. @@ -1300,10 +1381,10 @@ Proof. assert ( exists n ℓ, ((ℓ <= d)%nat /\ (n \in O_star)) - /\ ((id, (S, T)) = (GET n ℓ d, (chHandle, (chProd chKey chBool)))) + /\ ((id, (S, T)) = (GET n ℓ k, (chHandle, (chProd chKey chBool)))) ). { - clear -hin. + clear -hin H_lt. simpl in hin. unfold SET_O_star in hin. @@ -1311,39 +1392,40 @@ Proof. unfold interface_hierarchy_foreach in hin. - set (d) in hin at 1 |- *. - assert (H_le : d <= n) by reflexivity. - generalize dependent n. + (* set (d) in hin at 1 |- *. *) + (* assert (H_le : d <= n) by reflexivity. *) + (* generalize dependent n. *) induction O_star ; intros. - - simpl in hin. + - exfalso. + simpl in hin. induction d. + rewrite in_fset in hin. easy. - + apply IHn0. - 2: Lia.lia. + + apply IHd. + 1: Lia.lia. simpl in hin. rewrite <- fset0E in hin |- *. rewrite fsetU0 in hin. apply hin. - assert (((id, (S, T)) \in interface_hierarchy - (λ ℓ : nat, [interface #val #[GET a ℓ n] : chXPDout → chGETout ]) d) + (λ ℓ : nat, [interface #val #[GET a ℓ k] : chXPDout → chGETout ]) d) \/ ((id, (S, T)) \in interface_hierarchy (λ ℓ : nat, interface_foreach - (λ n0 : name, [interface #val #[GET n0 ℓ n] : chXPDout → chGETout ]) + (λ n0 : name, [interface #val #[GET n0 ℓ k] : chXPDout → chGETout ]) l) d)). { replace ((λ ℓ : nat, interface_foreach - (λ n0 : name, [interface #val #[GET n0 ℓ n] : chXPDout → chGETout ]) + (λ n0 : name, [interface #val #[GET n0 ℓ k] : chXPDout → chGETout ]) (a :: l))) with (λ ℓ : nat, - [interface #val #[GET a ℓ n] : chXPDout → chGETout ] :|: interface_foreach - (λ n0 : name, [interface #val #[GET n0 ℓ n] : chXPDout → chGETout ]) + [interface #val #[GET a ℓ k] : chXPDout → chGETout ] :|: interface_foreach + (λ n0 : name, [interface #val #[GET n0 ℓ k] : chXPDout → chGETout ]) l) in hin by now setoid_rewrite interface_foreach_cons. - clear -hin. + clear -H_lt hin. - rewrite <- interface_hierarchy_U in hin. rewrite in_fset in hin. rewrite mem_cat in hin. @@ -1369,9 +1451,35 @@ Proof. apply (ssrbool.elimT orP) in H. destruct H. { - apply IHn0. - 1: Lia.lia. - apply H. + simpl in H. + exists a. + clear -H. + induction d. + - exists O. split. + 2:{ + simpl in H. + rewrite in_fset in H. + rewrite mem_seq1 in H. + now apply /eqP. + } + split ; [ reflexivity | apply mem_head ]. + - unfold interface_hierarchy in H ; fold interface_hierarchy in H. + (* rewrite fset_cons in H. *) + rewrite <- fset1E in H. + rewrite fsetUC in H. + rewrite in_fset in H. + simpl in H. + rewrite in_cons in H. + move: H => /orP [ /eqP H | H ]. + + exists d.+1. + rewrite H. + split ; [ | reflexivity ]. + split ; [ Lia.lia | apply mem_head ]. + + specialize (IHd H). + destruct IHd as [? []]. + rewrite H1. + exists x. + now split. } { rewrite <- fset1E in H. @@ -1380,7 +1488,7 @@ Proof. rewrite H. do 2 eexists ; split ; [ | reflexivity ] ; split ; [ Lia.lia | apply mem_head ]. } - + specialize (IHl n H H_le). + + specialize (IHl H). destruct IHl as [? [? [[] ?]]]. do 2 eexists ; split ; [ split ; [ apply H0 | ] | easy ]. now rewrite in_cons ; apply /orP ; right. @@ -1394,7 +1502,7 @@ Proof. { - inversion H3 ; subst ; clear H3. - erewrite (lookup_op_spec_inv (Ks d O_star false erefl) (GET x x0 d)). + erewrite (lookup_op_spec_inv (Ks d k (ltnW H_lt) O_star false erefl) (GET x x0 k)). 2:{ unfold Ks. unfold eq_rect_r. @@ -1407,7 +1515,12 @@ Proof. destruct Logic.eq_sym. unfold eq_rect. - rewrite (ℓ_package_getm d). + unfold ℓ_packages. + unfold pack. + unfold ℓ_raw_packages. + rewrite (map_with_in_num_upper_getm). + + (* rewrite (ℓ_package_getm d k). *) - unfold parallel_package. unfold pack. @@ -1421,7 +1534,7 @@ Proof. set ([fmap _ ; _ ]). set (Option_Some _). - assert (getm f (serialize_name a x0 d 1) = o) ; subst f o. + assert (getm f (serialize_name a x0 k 1) = o) ; subst f o. { unfold K_package. rewrite !setmE. @@ -1459,6 +1572,7 @@ Proof. apply IHl. apply H2. + - Lia.lia. - intros. unfold parallel_package. unfold pack. @@ -1490,7 +1604,7 @@ Proof. apply IHl. } - erewrite (lookup_op_spec_inv (R_ch_map d) (GET x x0 d)). + erewrite (lookup_op_spec_inv (R_ch_map d k (ltnW H_lt)) (GET x x0 k)). 2:{ unfold pack. unfold R_ch_map. @@ -1526,7 +1640,8 @@ Proof. set (H_abc := fun _ _ => _). set (H_abcd := fun _ _ => _). - rewrite (ℓ_package_getm d p). + rewrite (map_with_in_num_upper_getm). + (* rewrite (ℓ_package_getm d p). *) - unfold parallel_package. unfold pack. @@ -1566,6 +1681,7 @@ Proof. apply IHl0. * now apply IHl. + - Lia.lia. - intros. subst p. @@ -1627,7 +1743,8 @@ Proof. set (H_abc := fun _ _ => _). set (H_abcd := fun _ _ => _). - rewrite (ℓ_package_getm d p). + rewrite map_with_in_num_upper_getm. + (* rewrite (ℓ_package_getm d p). *) - unfold parallel_package. unfold pack. @@ -1667,6 +1784,7 @@ Proof. apply IHl0. * now apply IHl. + - Lia.lia. - intros. subst p. @@ -1725,8 +1843,8 @@ Proof. eassert (forall H_le, parallel_raw - (List.map (λ y : name, pack (K_package d y x0 H_le false)) O_star) - (serialize_name x x0 d 1) + (List.map (λ y : name, pack (K_package k y x0 H_le false)) O_star) + (serialize_name x x0 k 1) = some (_)). { clear -H2 ; intros. @@ -1741,7 +1859,7 @@ Proof. set ([fmap _ ; _ ]). set (Option_Some _). - assert (getm f (serialize_name a x0 d 1) = o) ; subst f o. + assert (getm f (serialize_name a x0 k 1) = o) ; subst f o. { unfold K_package. rewrite !setmE. @@ -1785,11 +1903,14 @@ Proof. unfold eq_rect. destruct Logic.eq_sym. - (* erewrite (map_with_in_num_upper_getm). *) - erewrite (map_with_in_num_upper_getm d d (leqnn d) (* (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) *) _ x x0 1 d _ H1). + rewrite map_with_in_num_upper_getm. + + (* (* erewrite (map_with_in_num_upper_getm). *) *) + (* erewrite (map_with_in_num_upper_getm k d _ (* (fun d n x1 => parallel_raw (List.map (fun y => pack (K_package d y n x1 false)) O_star)) *) _ x x0 1 k _ _). *) { now rewrite H3. } + { Lia.lia. } { clear ; intros. @@ -1805,7 +1926,7 @@ Proof. unfold ".1", ".2". unfold SET, GET. - destruct (n == k) eqn:n_is_neq_k ; move: n_is_neq_k => /eqP n_is_neq_k ; subst. + destruct (n == k0) eqn:n_is_neq_k ; move: n_is_neq_k => /eqP n_is_neq_k ; subst. * Lia.lia. * replace (_ == _) with false ; [ | symmetry ]. 2: apply /eqP ; solve_imfset_disjoint. @@ -1818,9 +1939,6 @@ Proof. } } - Unshelve. - 2:{ apply H1. } - unfold get_or_fn. unfold bind ; fold @bind. unfold code_link ; fold @code_link. @@ -1848,16 +1966,16 @@ Axiom Gks : forall Names, ). Lemma map_outro_c5 : - forall (d : nat), - forall (Score : Simulator d), + forall (d k : nat) H_lt, + forall (Score : Simulator d k), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → + ValidPackage LA (KS_interface d k) A_export A → (AdvantageE - (Gks_real d) - (Gks_ideal d Score) (A) = + (Gks_real d k H_lt) + (Gks_ideal d k (ltnW H_lt) Score) (A) = AdvantageE - (Gks_real_map d) - (Gks_ideal_map d Score) A + (Gks_real_map d k H_lt) + (Gks_ideal_map d k (ltnW H_lt) Score) A )%R. Proof. intros. @@ -1882,7 +2000,7 @@ Proof. rewrite <- !link_assoc. rewrite <- Advantage_link. - replace (Ks d O_star false erefl) with (Ks d O_star true erefl) by admit. + replace (Ks d k _ O_star false erefl) with (Ks d k (ltnW H_lt) O_star true erefl) by admit. rewrite <- Advantage_link. unfold XPD_DH_XTR. diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index 6c3d161d..d655a664 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -631,6 +631,91 @@ Proof. Lia.lia. Qed. +Definition name_eq (x y : name) : bool := + match x, y with + | BOT, BOT => true + + | ES, ES => true + | EEM, EEM => true + | CET, CET => true + | BIND, BIND => true + | BINDER, BINDER => true + | HS, HS => true + | SHT, SHT => true + | CHT, CHT => true + | HSALT, HSALT => true + | AS, AS => true + | RM, RM => true + | CAT, CAT => true + | SAT, SAT => true + | EAM, EAM => true + | PSK, PSK => true + + | ZERO_SALT, ZERO_SALT => true + | ESALT, ESALT => true + | DH, DH => true + | ZERO_IKM, ZERO_IKM => true + | _, _ => false + end. + +Definition name_equality : + Equality.axiom (T:=name) name_eq. +Proof. + intros ? ?. + destruct x, y. + all: try now apply Bool.ReflectF. + all: now apply Bool.ReflectT. +Qed. + +HB.instance Definition _ : Equality.axioms_ name := + {| + Equality.eqtype_hasDecEq_mixin := + {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} + |}. + +Lemma serialize_name_notin_all : + forall d, + forall (ℓ1 ℓ2 : nat), + forall (n1 n2 : name), + forall (index1 index2 : nat), + (index1 = index2) /\ ((ℓ1 <> ℓ2)%N \/ (n1 <> n2)%N) \/ ((index1 <> index2)%nat /\ (ℓ1 <= d)%N /\ (ℓ2 <= d)%N) -> + serialize_name n1 ℓ1 d index1 <> serialize_name n2 ℓ2 d index2. +Proof. + intros. + destruct H as [[? [ | ]] | ] ; subst. + + now apply serialize_name_notin. + + now apply serialize_name_notin_different_name. + + now apply serialize_name_notin_different_index. +Qed. + +Lemma serialize_name_notin_all_iff : + forall d, + forall (ℓ1 ℓ2 : nat), + forall (n1 n2 : name), + forall (index1 index2 : nat), + (index1 = index2) /\ ((ℓ1 <> ℓ2)%N \/ (n1 <> n2)%N) \/ ((index1 <> index2)%nat /\ (ℓ1 <= d)%N /\ (ℓ2 <= d)%N) <-> + serialize_name n1 ℓ1 d index1 <> serialize_name n2 ℓ2 d index2. +Proof. + intros. + split ; intros. + - destruct H as [[? [ | ]] | ] ; subst. + + now apply serialize_name_notin. + + now apply serialize_name_notin_different_name. + + now apply serialize_name_notin_different_index. + - destruct (index1 == index2) eqn:index_eq ; move: index_eq => /eqP index_eq ; subst. + + left ; split ; [ reflexivity | ]. + destruct (ℓ1 == ℓ2) eqn:l_eq ; move: l_eq => /eqP l_eq ; subst. + * right. + destruct (n1 == n2) eqn:n_eq ; move: n_eq => /eqP n_eq ; subst. + -- contradiction. + -- assumption. + * left. + assumption. + + right ; split ; [ assumption | ]. + + admit. +Admitted. + Ltac solve_imfset_disjoint := (* try rewrite !imfsetU *) (* ; try rewrite !fdisjointUr *) @@ -649,10 +734,11 @@ try rewrite !imfsetU ; try rewrite !fdisjoints1 ; repeat (apply /andP ; split) ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]) -; try (now apply serialize_name_notin) -; try (now apply serialize_name_notin_different_name) -; try (now apply serialize_name_notin_different_index) -; try (now apply serialize_name_notin_smaller_than_start) +; try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])) +(* ; try (now apply serialize_name_notin ; Lia.lia) *) +(* ; try (now apply serialize_name_notin_different_name ; Lia.lia) *) +(* ; try (now apply serialize_name_notin_different_index ; Lia.lia) *) +; try (now apply serialize_name_notin_smaller_than_start ; try Lia.lia) (* ; try (idtac ; [ reflexivity | unfold "\in"; simpl; unfold "\in"; simpl ; Lia.lia.. ]) *) (* ; setoid_rewrite Bool.orb_false_r *) (* ; simpl *) @@ -1669,48 +1755,6 @@ Qed. apply i. Defined. - Definition name_eq (x y : name) : bool := - match x, y with - | BOT, BOT => true - - | ES, ES => true - | EEM, EEM => true - | CET, CET => true - | BIND, BIND => true - | BINDER, BINDER => true - | HS, HS => true - | SHT, SHT => true - | CHT, CHT => true - | HSALT, HSALT => true - | AS, AS => true - | RM, RM => true - | CAT, CAT => true - | SAT, SAT => true - | EAM, EAM => true - | PSK, PSK => true - - | ZERO_SALT, ZERO_SALT => true - | ESALT, ESALT => true - | DH, DH => true - | ZERO_IKM, ZERO_IKM => true - | _, _ => false - end. - -Definition name_equality : - Equality.axiom (T:=name) name_eq. -Proof. - intros ? ?. - destruct x, y. - all: try now apply Bool.ReflectF. - all: now apply Bool.ReflectT. -Qed. - -HB.instance Definition _ : Equality.axioms_ name := - {| - Equality.eqtype_hasDecEq_mixin := - {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} - |}. - Lemma all_idents_disjoint_foreach : (forall {A : eqType} f (L : list A), (forall x y, x <> y -> idents (f x) :#: idents (f y)) -> From 6f50450dfb615a703ece936a290f1fdbf23cc458 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Fri, 21 Feb 2025 14:40:27 +0100 Subject: [PATCH 04/10] Fixed structure all the way through --- proofs/ssprove/_CoqProject | 4 +- proofs/ssprove/handwritten/BertieResult.v | 20 ++- proofs/ssprove/handwritten/Core.v | 7 + proofs/ssprove/handwritten/CoreTheorem.v | 2 +- proofs/ssprove/handwritten/MainTheorem.v | 189 +++++++++------------- proofs/ssprove/handwritten/MapPackage.v | 7 - proofs/ssprove/handwritten/Utility.v | 2 +- proofs/ssprove/handwritten/ssp_helper.v | 12 ++ 8 files changed, 117 insertions(+), 126 deletions(-) diff --git a/proofs/ssprove/_CoqProject b/proofs/ssprove/_CoqProject index 09798e12..0770cc54 100644 --- a/proofs/ssprove/_CoqProject +++ b/proofs/ssprove/_CoqProject @@ -39,9 +39,11 @@ ./handwritten/Core.v ./handwritten/KeySchedulePackages.v -./handwritten/MapPackage.v ./handwritten/CoreTheorem.v + +./handwritten/MapPackage.v + # ./handwritten/ModularTheorem.v ./handwritten/MainTheorem.v diff --git a/proofs/ssprove/handwritten/BertieResult.v b/proofs/ssprove/handwritten/BertieResult.v index 15d82a91..dd49ae58 100644 --- a/proofs/ssprove/handwritten/BertieResult.v +++ b/proofs/ssprove/handwritten/BertieResult.v @@ -275,6 +275,10 @@ Section BertieKeySchedule. Definition Bertie_K_table : chHandle -> nat. Admitted. Definition Bertie_in_K_table : forall x, ('option chK_table; Bertie_K_table x) \in Bertie_L_K. Admitted. + Definition Bertie_L_L : {fset Location}. Admitted. + Definition Bertie_L_table : chHandle -> nat. Admitted. + Definition Bertie_in_L_table : forall x, ('option chL_table; Bertie_L_table x) \in Bertie_L_L. Admitted. + Definition Bertie_L_M : {fset Location}. Admitted. Definition Bertie_M : chHandle -> nat. Admitted. Definition Bertie_H : name → ∀ s : chHandle, ('option ('fin #|fin_handle|); Bertie_M s) \in Bertie_L_M. Admitted. @@ -284,7 +288,7 @@ Section BertieKeySchedule. End BertieKeySchedule. -Instance BertieKeySchedule (d : nat) : Dependencies := +(* Program *) Instance BertieKeySchedule (d : nat) : Dependencies := (* Proof. *) (* econstructor. *) (* - refine (Bertie_PrntN). *) @@ -304,9 +308,9 @@ Instance BertieKeySchedule (d : nat) : Dependencies := (* - refine (Bertie_DHEXP_function). *) { - PrntN := Bertie_PrntN; + (* PrntN := Bertie_PrntN; *) Labels := Bertie_Labels ; - + xpd := Bertie_xpd ; xtr := Bertie_xtr ; xtr_angle := Bertie_xtr_angle ; @@ -315,6 +319,10 @@ Instance BertieKeySchedule (d : nat) : Dependencies := ord := Bertie_ord ; E := Bertie_E ; + L_L := Bertie_L_L ; + L_table := Bertie_L_table ; + in_L_table := Bertie_in_L_table ; + L_K := Bertie_L_K ; K_table := Bertie_K_table ; in_K_table := Bertie_in_K_table ; @@ -329,6 +337,6 @@ Instance BertieKeySchedule (d : nat) : Dependencies := DHEXP_function := Bertie_DHEXP_function ; }. -Definition BertieKeyScheduleCoreSimulator (d : nat) : Simulator (DepInstance := BertieKeySchedule d). Admitted. -Definition BertieKeyScheduleCoreTheorem (d : nat) := - core_theorem (DepInstance := BertieKeySchedule d) (BertieKeyScheduleCoreSimulator d). +Definition BertieKeyScheduleCoreSimulator (d k : nat) : Simulator d k. Admitted. +Definition BertieKeyScheduleCoreTheorem (d k : nat) (H_lt : (d < k)%nat) := + core_theorem (DepInstance := BertieKeySchedule d) d k H_lt (BertieKeyScheduleCoreSimulator d k). diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 1437b19d..69c56761 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -90,6 +90,13 @@ Section Core. (chHandle) (in custom pack_type at level 2). + Definition KS_interface d k := + ([interface #val #[SET PSK 0 k] : chSETinp → chSETout ] + :|: DH_interface + :|: (XPD_n d k :|: XTR_n d k) + :|: GET_O_star d k + ). + Definition Gcore_sodh (d : nat) : package fset0 ([interface diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index eec7360f..44c08f21 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -79,7 +79,7 @@ From KeyScheduleTheorem Require Import KeyPackages. From KeyScheduleTheorem Require Import XTR_XPD. From KeyScheduleTheorem Require Import Core. -From KeyScheduleTheorem Require Import MapPackage. +(* From KeyScheduleTheorem Require Import MapPackage. *) (*** Core theorem *) diff --git a/proofs/ssprove/handwritten/MainTheorem.v b/proofs/ssprove/handwritten/MainTheorem.v index 4e5741b7..b364e3ce 100644 --- a/proofs/ssprove/handwritten/MainTheorem.v +++ b/proofs/ssprove/handwritten/MainTheorem.v @@ -131,20 +131,22 @@ Axiom level : chHandle -> nat. (* Fig 12. the real XPD and XTR games *) Lemma main_reduction : - forall d, - forall (Score : Simulator d), + forall d k H_lt, + forall (Score : Simulator d k), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d) A_export A → + ValidPackage LA (KS_interface d k) A_export A → (AdvantageE - (Gks_real d) - (Gks_ideal d Score) A = + (Gks_real d k H_lt) + (Gks_ideal d k (ltnW H_lt) Score) A = AdvantageE - (Gcore_real d) - (Gcore_ideal d Score) (A ∘ R_ch_map d) + (Gcore_real d k H_lt) + (Gcore_ideal d k (ltnW H_lt) Score) (A ∘ R_ch_map d k (ltnW H_lt)) )%R. Proof. intros. - rewrite (map_outro_c5 d Score LA). + rewrite (map_outro_c5 d k H_lt Score LA). + + unfold Gks_real_map , Gks_ideal_map , pack. unfold Gcore_real. @@ -234,61 +236,62 @@ Axiom Gxtr_hs : nat -> loc_GamePair (* apply fsubsetxx. *) (* Qed. *) -Definition Gxpd : forall (n : name) (ℓ : nat), +(* Goal forall d k (H_lt : (d < k)%nat), True. *) +(* intros. *) +(* epose (pack (XPD_ 1 k _)). *) +(* unfold XPD_n in r. *) +(* unfold interface_hierarchy_foreach in r. *) +(* unfold interface_hierarchy in r. *) +(* unfold XPD_ in r. *) +(* unfold XPD_packages in r. *) +(* unfold eq_rect_r in r. *) +(* unfold eq_rect in r. *) +(* destruct Logic.eq_sym in r. *) +(* unfold pack in r. *) +(* destruct Logic.eq_sym in r. *) +(* destruct Logic.eq_sym in r. *) + +(* unfold ℓ_packages in r. *) +(* unfold ℓ_raw_packages in r. *) +(* unfold map_with_in_num_upper in r. *) + +(* par (par (Xpd PSK 0 k) (Xpd PSK 1 k)) *) +(* (par *) +(* (xpd_level_sub_psk 0 k *) +(* (leq_trans (n:=1) (m:=0) (p:=k) *) +(* (leq_trans (n:=1) (m:=0) (p:=1) (leqnSn 0) (leqnn 1)) *) +(* (ltnW (m:=1) (n:=k) ?H_lt))) *) +(* (xpd_level_sub_psk 1 k *) +(* (leq_trans (n:=1) (m:=1) (p:=k) (leqnn 1) (ltnW (m:=1) (n:=k) ?H_lt))))∘ par *) +(* (Ks 2 k ?H_lt (undup (XPR ++ XPR_parents)) false erefl *) +(* ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) Hash *) + +(* destruct ((XPD_interface_rewrite 0 k)) in p. *) + +Definition Gxpd : forall d k (H_lt : (d < k)%nat) (n : name) (ℓ : nat), (ℓ <= d)%N -> + (n \in XPR) -> loc_GamePair - ([interface #val #[XPD n ℓ d] : ((chSETout) × ('bool)) × (chHASHout) → chSETout ]). + ([interface #val #[XPD n ℓ k] : ((chSETout) × ('bool)) × (chHASHout) → chSETout ]). Proof. intros. refine (fun b => {| locs := L_K :|: L_L ; - locs_pack := {package Xpd n ℓ ∘ ((par (K_package n ℓ H b) hash) ∘ (L_package n F)) } + locs_pack := + {package XPD_ d k H_lt #with _} |}). - eapply valid_link_upto. - 1: apply (pack_valid (Xpd n ℓ (GET := GET n ℓ d) (SET := SET n ℓ d) (HASH := HASH))). - 2: apply fsub0set. - 2: apply fsubsetxx. - eapply valid_link_upto. - 2: apply L_package. - 3: apply fsubsetUr. - 2: apply fsubsetUl. - eapply valid_par_upto. - 3: apply hash. - 3: rewrite fsetU0 ; apply fsubsetxx. - 3: rewrite <- fset0E ; rewrite fsetU0 ; apply fsubsetxx. - 3:{ - do 2 rewrite fset_cons. - rewrite fset1E. - rewrite fset1E. - rewrite fsetUA. + eapply valid_package_inject_export. + 2: apply pack_valid. + { + unfold XPD_n. + apply interface_hierarchy_foreach_subsetR. + 2: easy. + exists n, H0, ℓ, H. apply fsubsetxx. } - 1:{ - assert (trimmed [interface - #val #[ SET n ℓ d ] : chSETinp → chSETout ; - #val #[ GET n ℓ d ] : chGETinp → chGETout - ] (K_package n ℓ H b)). - { - do 2 apply trimmed_package_cons. - apply trimmed_empty_package. - } - rewrite <- H0. - rewrite <- trimmed_hash. - solve_Parable. - unfold idents. - rewrite fset_cons. - solve_imfset_disjoint. - all: unfold HASH, GET, SET, serialize_name ; Lia.lia. - } - rewrite fsetUC. - rewrite <- fset_cat. - apply (pack_valid (K_package n ℓ H b)). + Unshelve. + apply DepInstance. Qed. -(* Axiom Gxpd : name -> nat -> loc_GamePair *) -(* [interface *) -(* (* #val #[ ES ] : 'unit → 'unit *) *) -(* ]. *) - Axiom R_ : name -> nat -> package fset0 [interface] [interface]. Ltac split_advantage O := @@ -299,33 +302,34 @@ Ltac split_advantage O := symmetry ] ; revgoals. Axiom ki_hybrid : - forall (ℓ : nat) (H_le : (ℓ <= d)%nat), + forall d k H_lt (ℓ : nat) (H_le : (ℓ <= d)%nat), forall (LA : {fset Location}) (A : raw_package), forall i, ValidPackage LA ([interface #val #[SET PSK 0 d] : chSETinp → chSETout ; #val #[DHGEN] : 'unit → 'unit ; - #val #[DHEXP] : 'unit → 'unit ] :|: XTR_n_ℓ :|: XPD_n_ℓ) A_export A → - (AdvantageE (Gcore_hyb ℓ) (Gcore_hyb (ℓ + 1)) (Ai (A ∘ R_ch_map) i) <= + #val #[DHEXP] : 'unit → 'unit ] :|: XTR_n_ℓ d k :|: XPD_n_ℓ d k) A_export A → + (AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai (A ∘ R_ch_map d k (ltnW H_lt)) i) <= Advantage (λ x : bool, Gxtr_es ℓ x) (Ai (A) i ∘ R_es ℓ) + Advantage (λ x : bool, Gxtr_hs ℓ x) (Ai (A) i ∘ R_hs ℓ) + - Advantage (λ x : bool, Gxtr_as ℓ x) (Ai (A) i ∘ R_as ℓ) + sumR_l XPR (λ n : name, Advantage (λ x : bool, Gxpd n ℓ H_le x ) (Ai (A) i ∘ R_ n ℓ)))%R. + Advantage (λ x : bool, Gxtr_as ℓ x) (Ai (A) i ∘ R_as ℓ) + sumR_l_in_rel XPR XPR (fun _ H => H) (λ n H_in, Advantage (λ x : bool, Gxpd d k H_lt n ℓ H_le H_in x ) (Ai (A) i ∘ R_ n ℓ)))%R. Lemma key_schedule_theorem : - forall (S : Simulator), + forall d k H_lt, + forall (S : Simulator d k), forall (hash : nat), forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA KS_interface A_export A → - forall (H_ε_acr : (sumR_l [:: R_cr; R_Z; R_D] (λ R : package f_parameter_cursor_loc (fset [::]) (fset [::]), Advantage (λ x : bool, Gacr x) ((A ∘ R_ch_map) ∘ R)) <= ε_acr)%R), - forall (H_ε_sodh_ki : (forall i, Advantage (λ x : bool, Gsodh x) (Ai (A ∘ R_ch_map) i ∘ R_sodh) + AdvantageE Gcore_ki (Gcore_ideal S) (Ai (A ∘ R_ch_map) i) <= ε_sodh_ki i)%R), + ValidPackage LA (KS_interface d k) A_export A → + forall (H_ε_acr : (sumR_l [:: R_cr; R_Z f_hash; R_D] (λ R : package f_parameter_cursor_loc (fset [::]) (fset [::]), Advantage (λ x : bool, Gacr f_hash x) ((A ∘ R_ch_map d k (ltnW H_lt)) ∘ R)) <= ε_acr)%R), + forall (H_ε_sodh_ki : (forall i, Advantage (λ x : bool, Gsodh x) (Ai (A ∘ R_ch_map d k (ltnW H_lt)) i ∘ R_sodh) + AdvantageE (Gcore_ki d k) (Gcore_ideal d k (ltnW H_lt) S) (Ai (A ∘ R_ch_map d k (ltnW H_lt)) i) <= ε_sodh_ki i)%R), (AdvantageE - (Gks_real) - (Gks_ideal S) A <= + (Gks_real d k H_lt) + (Gks_ideal d k (ltnW H_lt) S) A <= ε_acr + maxR (fun i => ε_sodh_ki i - +sumR_H 0 (d-1) (ltac:(easy)) (fun ℓ H => + +sumR_H 0 (d) (ltac:(easy)) (fun ℓ H => Advantage (Gxtr_es ℓ) (Ai A i ∘ R_es ℓ) +Advantage (Gxtr_hs ℓ) (Ai A i ∘ R_hs ℓ) +Advantage (Gxtr_as ℓ) (Ai A i ∘ R_as ℓ) - +sumR_l XPR (fun n => Advantage (Gxpd n ℓ (ltac:(Lia.lia))) (Ai A i ∘ R_ n ℓ) + +sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ H H_in (* (ltac:(Lia.lia)) *)) (Ai A i ∘ R_ n ℓ) ))) )%R. Proof. @@ -340,54 +344,19 @@ Proof. apply H. } 1:{ - epose (pack_valid R_ch_map). - unfold KS_interface. - eapply valid_package_inject_import. - 2: apply v. + 2: apply pack_valid. + unfold KS_interface. solve_in_fset. - - - - - ssprove_valid. - 1:{ epose (pack_valid R_ch_map). - unfold KS_interface. - - apply p. - admit. } - 1,2: apply fsubsetxx. - - - apply Num.Theory.lerD ; [ apply H_ε_acr | ]. - apply max_leq. - intros i. - - eapply Order.le_trans. - + apply Num.Theory.lerD ; [ easy | ]. - eapply (equation20_eq S i). - - ssprove_valid. - 1:{ admit. } - 1,2: apply fsubsetxx. - + rewrite addrA. - apply Num.Theory.lerD ; [ apply H_ε_sodh_ki | ]. - epose sumR_le. - rewrite sumR_to_H. - apply sumR_le. - intros ℓ ? ?. - eapply ki_hybrid. - easy. + } + { + apply fsubsetUl. + } + { + apply fsubsetUr. + } + - admit. Admitted. -(* Qed. *) - -(* (*** Concrete instance *) *) - -(* Theorem Advantage_xtr_es : *) -(* forall A ℓ i ε_dt, *) -(* Advantage (Gxtr_es ℓ) (Ai A i ∘ R_es ℓ) <= ε_dt. *) -(* Proof. *) -(* intros. *) -(* Admitted. *) End MainTheorem. diff --git a/proofs/ssprove/handwritten/MapPackage.v b/proofs/ssprove/handwritten/MapPackage.v index a01c3ecc..ef4dc1ae 100644 --- a/proofs/ssprove/handwritten/MapPackage.v +++ b/proofs/ssprove/handwritten/MapPackage.v @@ -137,13 +137,6 @@ Section MapPackages. (* Axiom XPN_LABAL_from_index : nat -> name. *) Axiom level : chHandle -> code fset0 [interface] (chOption chNat). - Definition KS_interface d k := - ([interface #val #[SET PSK 0 k] : chSETinp → chSETout ] - :|: DH_interface - :|: (XPD_n d k :|: XTR_n d k) - :|: GET_O_star d k - ). - Notation " 'chXTRinp' " := (chHandle × chHandle) (in custom pack_type at level 2). diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index d655a664..4ed3fd0a 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -734,7 +734,7 @@ try rewrite !imfsetU ; try rewrite !fdisjoints1 ; repeat (apply /andP ; split) ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]) -; try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])) +; try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((timeout 5 now right) || (timeout 5 now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])) (* ; try (now apply serialize_name_notin ; Lia.lia) *) (* ; try (now apply serialize_name_notin_different_name ; Lia.lia) *) (* ; try (now apply serialize_name_notin_different_index ; Lia.lia) *) diff --git a/proofs/ssprove/handwritten/ssp_helper.v b/proofs/ssprove/handwritten/ssp_helper.v index a6dbaafa..68d2ac46 100644 --- a/proofs/ssprove/handwritten/ssp_helper.v +++ b/proofs/ssprove/handwritten/ssp_helper.v @@ -146,6 +146,10 @@ Fixpoint sum_accum (fuel : nat) (index : nat) (f : nat -> nat) (accum : nat) : n | S n' => sum_accum n' (index + 1%nat) f (accum + f index) end. +Definition mem_tail : forall {A : eqType} a (l : list A), forall {x}, x \in l -> x \in a :: l := + fun A a l x H => + (eq_ind_r [eta is_true] ([eta introTF (c:=true) orP] (or_intror H)) (in_cons (T:=A) a l x)). + Definition sumR : forall (l u : nat), (l <= u)%nat -> (nat -> R) -> R := (fun l u H f => (List.fold_left (fun y x => y + f x) (iota l (u - l)) 0)%R). @@ -289,6 +293,14 @@ Fixpoint sumR_l {T : Type} (l : list T) (f : T -> R) : R := end. (* Definition sum (l u : nat) (f : nat -> nat) : nat := sum_accum (u - l) l f 0%R. *) +Fixpoint sumR_l_in_rel {T : eqType} (l : list T) (l' : list T) (H_in : forall x, x \in l' -> x \in l) (f : forall (a : T), (a \in l) -> R) : R := + match l' return (forall x, x \in l' -> x \in l) -> _ with + | [] => fun _ => 0%R + | (x :: xs) => + fun H_in => f x (H_in x (mem_head x xs)) + sumR_l_in_rel l xs (fun a H => H_in a (mem_tail x xs H)) f + end H_in. +(* Definition sum (l u : nat) (f : nat -> nat) : nat := sum_accum (u - l) l f 0%R. *) + Definition max_val : R -> R -> R := fun x y => if (x > y)%R From 2a109ea4fd1c337ce70bf6881cf394b2685616a0 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 25 Feb 2025 19:34:40 +0100 Subject: [PATCH 05/10] Core package finally defined --- proofs/ssprove/handwritten/BasePackages.v | 12 + proofs/ssprove/handwritten/Core.v | 901 +++++++++++++++++- proofs/ssprove/handwritten/CoreTheorem.v | 618 ++++++------ proofs/ssprove/handwritten/KeyPackages.v | 73 +- .../ssprove/handwritten/KeySchedulePackages.v | 3 +- proofs/ssprove/handwritten/XTR_XPD.v | 12 - 6 files changed, 1313 insertions(+), 306 deletions(-) diff --git a/proofs/ssprove/handwritten/BasePackages.v b/proofs/ssprove/handwritten/BasePackages.v index 56721146..10232542 100644 --- a/proofs/ssprove/handwritten/BasePackages.v +++ b/proofs/ssprove/handwritten/BasePackages.v @@ -136,3 +136,15 @@ Notation " 'chDHEXPout' " := Definition DHEXP : nat := 12. (* Definition SET_DH : nat := 13. *) + +Definition SET_ℓ Names d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) Names. + +Definition SET_n Names d k : Interface := + interface_hierarchy (SET_ℓ Names k) d. + +Definition GET_ℓ Names d ℓ : Interface := + interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) Names. + +Definition GET_n Names d k : Interface := + interface_hierarchy (GET_ℓ Names k) d. diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 69c56761..beb5c5e3 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -76,6 +76,136 @@ From KeyScheduleTheorem Require Import BasePackages. From KeyScheduleTheorem Require Import KeyPackages. From KeyScheduleTheorem Require Import XTR_XPD. +(*** Helper *) + + Lemma interface_foreach_swap : + (forall {A} (a b : A) l f, interface_foreach f (a :: b :: l) = interface_foreach f (b :: a :: l)). + Proof. + intros. + induction l. + - simpl. + now rewrite fsetUC. + - simpl. + rewrite fsetUA. + rewrite (fsetUC (f a)). + rewrite <- fsetUA. + reflexivity. + Qed. + + Lemma interface_hierarchy_foreach_cat : forall {A} f L1 L2 d, + interface_hierarchy_foreach f (L1 ++ L2) d = + interface_hierarchy_foreach (A := A) f L1 d :|: interface_hierarchy_foreach (A := A) f L2 d. + Proof. + induction L1 ; intros. + - unfold interface_hierarchy_foreach. + simpl. + rewrite <- interface_hierarchy_trivial. + simpl. + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + - rewrite interface_hierarchy_foreach_cons. + rewrite <- fsetUA. + rewrite <- IHL1. + now rewrite <- interface_hierarchy_foreach_cons. + Qed. + + Lemma interface_foreach_condition : + (forall {A : eqType} f (L1 L2 : list A), + (forall x, x \in L1 -> x \in L2) -> + interface_foreach f L1 = + interface_foreach (fun x => if x \in L2 then f x else fset [::]) L1). + Proof. + clear ; intros. + induction L1. + - reflexivity. + - rewrite interface_foreach_cons. + rewrite IHL1. + 2:{ + intros. + apply H. + apply mem_tail. + apply H0. + } + rewrite interface_foreach_cons. + rewrite H. + 2: apply mem_head. + reflexivity. + Qed. + + Lemma interface_foreach_func_if_cons : + forall {A : eqType} a (L1 L2 : seq A) f, + interface_foreach (λ x : A, if x \in (a :: L2)%SEQ then f x else fset [::]) L1 + = + (if a \in L1 then f a else fset [::]) :|: + interface_foreach (λ x : A, if x \in L2%SEQ then f x else fset [::]) L1. + Proof. + induction L1 ; intros. + + now rewrite fsetUid. + + rewrite interface_foreach_cons. + rewrite interface_foreach_cons. + + rewrite IHL1. + rewrite fsetUA. + rewrite fsetUA. + f_equal. + rewrite <- fset0E. + + rewrite !in_cons. + rewrite (eq_sym a). + destruct (a0 == a) eqn:a0a. + * move: a0a => /eqP ? ; subst. + simpl. + destruct (a \in L1), (a \in L2) ; now try rewrite fsetUid ; try rewrite fsetU0. + * simpl. + rewrite fsetUC. + reflexivity. + Qed. + + Lemma interface_foreach_sub_list : forall {A : eqType} f L1 L2, + uniq L1 -> + (forall x, x \in L1 -> x \in L2) -> + interface_foreach f L1 = + interface_foreach (A := A) (fun x => if x \in L1 then f x else [interface]) L2. + Proof. + intros. + + rewrite (interface_foreach_condition f L1 L1 (fun _ H => H)). + induction L1 ; intros. + - simpl. + destruct L2 ; [ easy | ]. + now rewrite <- interface_foreach_trivial. + - rewrite interface_foreach_func_if_cons. + rewrite interface_foreach_func_if_cons. + rewrite mem_head. + rewrite H0. + 2: apply mem_head. + rewrite interface_foreach_cons. + (* destruct (a \in _) ; [ ] *) + rewrite IHL1. + 2:{ + rewrite cons_uniq in H. + now move: H => /andP [? ?] ; subst. + } + 2:{ + intros. + apply H0. + now apply mem_tail. + } + destruct (_ \in _). + { + rewrite fsetUA. + rewrite fsetUid. + reflexivity. + } + { + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + } + Qed. + + (*** Core *) Section Core. @@ -97,15 +227,191 @@ Section Core. :|: GET_O_star d k ). - Definition Gcore_sodh (d : nat) : - package fset0 + (* Fig 8 in conference paper *) + Definition Gcore_sodh (d k : nat) (b : bool) : + package (L_K :|: L_L) ([interface #val #[ DHEXP ] : chDHEXPinp → chDHEXPout ; #val #[ DHGEN ] : chDHGENinp → chDHGENout - ] :|: interface_hierarchy (fun ℓ => [interface #val #[ XTR HS ℓ d ] : chXTRinp → chXTRout]) d) + ] :|: interface_hierarchy (fun ℓ => [interface #val #[ XTR HS ℓ k ] : chXTRinp → chXTRout]) d) [interface]. Proof. - Admitted. + refine + {package + (ℓ_packages 0 (fun ℓ H => Xtr HS ℓ k b) _ _) ∘ + par + (par + (par + (Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) + (DH_package 0 k ∘ Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) + ) + (K_package k ESALT 0 (leq0n k) false ∘ L_package k ESALT F (* R *))) + (K_package k HS 0 (leq0n d) false ∘ L_package k HS F (* D *)) + #with + _ + }. + + rewrite <- fset0U. + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite <- fset0E. + apply fsub0set. + } + + unfold PrntN. + rewrite !nfto_name_to_chName_cancel. + + eapply (valid_par_upto (L_K :|: L_L) _ _ + (L_K :|: L_L) (L_K :|: L_L)). + 2:{ + rewrite <- fsetUid. + apply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: eapply valid_link ; apply pack_valid. + + 2:{ + rewrite <- fset0U. + eapply valid_link. + 2: eapply valid_link ; apply pack_valid. + eapply valid_package_inject_import. + 2: apply pack_valid. + + apply fsubsetUl. + } + + rewrite <- trimmed_dh. + + eassert (trimmed _ (Nk_package 0 k (leq0n k))). + { + unfold Nk_package. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + apply trimmed_ℓ_packages. + } + rewrite <- H at 1 ; clear H. + rewrite !link_trim_commut. + solve_Parable. + + unfold DH_interface. + rewrite fset_cons. + + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + unfold SET_ℓ, GET_ℓ, interface_foreach. + solve_imfset_disjoint. + } + 2: eapply valid_link ; apply pack_valid. + { + eassert (trimmed _ (Nk_package 0 k (leq0n k))). + { + unfold Nk_package. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + apply trimmed_ℓ_packages. + } + rewrite <- H at 1 ; clear H. + + rewrite <- trimmed_dh. + + eassert (trimmed _ (K_package _ _ _ _ _)). + { + do 2 apply trimmed_package_cons. + apply trimmed_empty_package. + } + rewrite <- H ; clear H. + + rewrite !link_trim_commut. + + solve_Parable. + - rewrite fset_cons. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold SET_ℓ, GET_ℓ, interface_foreach. + unfold idents. + solve_imfset_disjoint. + - rewrite fset_cons. + unfold DH_interface. + rewrite (fset_cons (DHGEN , _)). + unfold idents. + solve_imfset_disjoint. + } + } + 2: eapply valid_link ; apply pack_valid. + 2: rewrite fsetUid ; apply fsubsetxx. + 2: solve_in_fset. + 2:{ + unfold SET_DH. + unfold interface_hierarchy. + rewrite fset_cons. + rewrite (fset_cons (SET _ _ _, _)). + rewrite (fset_cons (SET _ _ _, _)). + unfold DH_interface. + + unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. + solve_in_fset. + } + { + eassert (trimmed _ (Nk_package 0 k (leq0n k))). + { + unfold Nk_package. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + apply trimmed_ℓ_packages. + } + rewrite <- H at 1 ; clear H. + + rewrite <- trimmed_dh. + + eassert (trimmed _ (K_package k ESALT _ _ _)). + { + do 2 apply trimmed_package_cons. + apply trimmed_empty_package. + } + rewrite <- H ; clear H. + + eassert (trimmed _ (K_package k HS _ _ _)). + { + do 2 apply trimmed_package_cons. + apply trimmed_empty_package. + } + rewrite <- H ; clear H. + + rewrite !link_trim_commut. + + solve_Parable. + - unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. + rewrite (fset_cons (SET HS _ _, _)). + unfold idents. + solve_imfset_disjoint. + - unfold DH_interface. + rewrite fset_cons. + rewrite (fset_cons (SET HS _ _, _)). + unfold idents. + solve_imfset_disjoint. + - rewrite fset_cons. + rewrite (fset_cons (SET HS _ _, _)). + unfold idents. + solve_imfset_disjoint. + } + + Unshelve. + { apply DepInstance. } + { intros. apply trimmed_package_cons. apply trimmed_empty_package. } + { intros. unfold idents. solve_imfset_disjoint. } + Defined. Definition Gcore_hyb : forall d (ℓ : nat), package f_parameter_cursor_loc @@ -411,8 +717,8 @@ Section Core. eapply valid_link. 2: apply pack_valid. { - unfold GET_n. - unfold GET_ℓ. + (* unfold GET_n. *) + (* unfold GET_ℓ. *) fold (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) XPR_parents). eapply valid_package_inject_export. @@ -423,7 +729,9 @@ Section Core. - rewrite fsubUset. apply /andP. split. - + rewrite interface_hierarchy_foreach_shift. + + unfold SET_n. unfold SET_ℓ. + fold (interface_hierarchy_foreach (λ n ℓ, [interface #val #[SET n ℓ k] : chSETinp → chSETout ]) (undup (XPR ++ XPR_parents))). + rewrite interface_hierarchy_foreach_shift. unfold SET. apply fsubsetU. @@ -496,6 +804,34 @@ Section Core. solve_imfset_disjoint. Qed. + Definition XTR_ (d k : nat) (H_lt : (d <= k)%nat) : package (L_K :|: L_L) (fset [::]) (XTR_n d k). + Proof. + refine {package XTR_packages d k H_lt ∘ + (Ks d k H_lt (undup (XTR_parent_names ++ XTR_names)) false erefl ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl) + #with + _ + }. + Unshelve. + 2-4: apply DepInstance. + rewrite <- fset0U. + + eapply valid_link. + 2: eapply valid_link ; apply pack_valid. + + eapply valid_package_inject_import. + 2: apply pack_valid. + + rewrite undup_id ; [ | easy ]. + rewrite fsetUC. + unfold SET_n, SET_ℓ. + unfold GET_n, GET_ℓ. + fold (interface_hierarchy_foreach (fun n ℓ => [interface #val #[SET n ℓ k] : chUNQinp → chXTRout ]) (XTR_parent_names ++ XTR_names) d). + fold (interface_hierarchy_foreach (fun n ℓ => [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) (XTR_parent_names ++ XTR_names) d). + apply subset_pair ; + rewrite interface_hierarchy_foreach_cat ; + [ apply fsubsetUr | apply fsubsetUl ]. + Defined. + Lemma idents_disjoint_foreach_in : (forall {A: eqType} f g (L : list A), (forall m, (m \in L) -> idents f :#: idents (g m)) -> @@ -726,8 +1062,7 @@ Section Core. - epose (pack_valid (Ks d k H_lt O_star true erefl)). eapply valid_package_inject_export. 2: apply v. - unfold GET_O_star. - solve_in_fset. + apply fsubsetUr. - eapply valid_package_inject_import. 2: apply (pack_valid Score). solve_in_fset. @@ -736,4 +1071,552 @@ Section Core. Defined. Fail Next Obligation. + + + (*** Actual core *) + + + Definition G_check (d k : nat) (H_lt : (d <= k)%nat) : + package (L_K :|: L_L) + (XPD_n d k :|: GET_n [BINDER] d k) + (XPD_n d k). + Proof. + Admitted. + + Definition G_dh (d k : nat) (H_lt : (d <= k)%nat) : + package (L_K :|: L_L) + (SET_ℓ [DH] k 0) + DH_interface. + Proof. + Admitted. + + Definition I_star : seq name := [:: RM; ES; BIND; HS; AS; ESALT; HSALT]. + + Ltac solve_direct_in := rewrite !fsubUset ; repeat (apply /andP ; split) ; repeat (apply fsubsetxx || (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left))). + + Definition G_XTR_XPD (d k : nat) (H_lt : (d < k)%nat) : + package fset0 + ((GET_n [DH] d k + :|: GET_n [PSK] d k + :|: GET_n [ZERO_SALT] d k + :|: GET_n [ZERO_IKM] d k + :|: GET_n I_star d k) + :|: (SET_n I_star d k :|: SET_n O_star d k :|: interface_hierarchy (fun ℓ => [interface #val #[ SET PSK ℓ.+1 k ] : chSETinp → chSETout]) d) + :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] + ) + (XPD_n d k :|: XTR_n d k). + Proof. + refine {package par (XPD_packages d k H_lt) (XTR_packages d k (ltnW H_lt))}. + rewrite <- fsetUid. + eapply valid_par_upto. + - unfold XPD_, XTR_. + unfold pack. + rewrite <- trimmed_xpd_package. + rewrite <- trimmed_xtr_package. + (* rewrite !link_trim_commut. *) + solve_Parable. + unfold XPD_n, XTR_n. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + solve_imfset_disjoint. + - apply pack_valid. + - apply pack_valid. + - apply fsubsetxx. + - rewrite fsubUset. + apply /andP ; split. + + apply subset_pair. + 2: apply fsubsetxx. + apply subset_pair. + * unfold XPR_parents. + unfold I_star. + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + * rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + + apply fsubsetU. + apply /orP ; left. + + apply subset_pair. + * unfold XTR_parent_names. + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + * rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + - apply fsubsetxx. + Defined. + + Lemma interface_foreach_trivial2 : forall {A} i L (* d *), + (L <> [] \/ i = [interface]) -> + i = (interface_foreach (λ (n : A), i) L ). + Proof. + intros. + destruct H. + - destruct L ; [ easy | ]. + clear H. + generalize dependent a. + induction L ; intros. + { + rewrite interface_foreach_cons. + simpl. + rewrite <- fset0E. + rewrite fsetU0. + reflexivity. + } + { + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + } + - rewrite H. + induction L. + + reflexivity. + + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + Qed. + + Definition parallel_ID (L : seq name) (f : name -> Interface) : + (∀ x y, x ≠ y → idents (f x) :#: idents (f y)) -> + (uniq L) -> + (forall x, flat (f x)) -> + package fset0 (interface_foreach f L) (interface_foreach f L) := + fun H H0 H1 => + parallel_package d L + (fun x => {package ID (f x) #with valid_ID _ _ (H1 x)}) H + (fun x => trimmed_ID _) H0. + + Definition combined_ID (d : nat) (L : seq name) (f : name -> nat -> Interface) : + (forall n x y, x ≠ y → idents (f x n) :#: idents (f y n)) -> + (uniq L) -> + (forall n x, flat (f x n)) -> + (forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y, idents (f x ℓ) :#: idents (f y n)) -> + package fset0 (interface_hierarchy_foreach f L d) (interface_hierarchy_foreach f L d). + + intros. + refine (ℓ_packages d (fun x _ => parallel_ID L (f^~ x) _ _ _) _ _). + - intros. + unfold parallel_ID. + apply trimmed_parallel_raw. + + apply H. + + apply H0. + + apply trimmed_pairs_map. + intros. + unfold pack. + apply trimmed_ID. + - intros. + apply idents_foreach_disjoint_foreach. + intros. + now apply H2. + + Unshelve. + + intros. + now apply H. + + apply H0. + + apply H1. + Defined. + + Lemma reindex_interface_hierarchy_PSK2 : + forall d k, + (interface_hierarchy (λ n : nat, [interface #val #[SET PSK n k] : chUNQinp → chXTRout ]) d.+1) + = + ([interface #val #[SET PSK 0 k] : chUNQinp → chXTRout ] :|: interface_hierarchy + (λ n : nat, [interface #val #[SET PSK (n.+1) k] : chUNQinp → chXTRout ]) + d). + Proof. + intros. + symmetry. + induction d ; intros. + - simpl. + reflexivity. + - simpl. + rewrite fsetUA. + rewrite IHd. + reflexivity. + Qed. + + Lemma interface_hierarchy_subset : forall f d K, + (forall (x : nat) (H : (x <= d)%nat), f x :<=: K) -> + interface_hierarchy f d :<=: K. + Proof. + intros. + induction d. + - now apply H. + - simpl. + rewrite fsubUset. + now rewrite H ; [ rewrite IHd | ]. + Qed. + + Lemma interface_hierarchy_subsetR : forall f d K, + (exists (x : nat) (H : (x <= d)%nat), K :<=: f x) -> + K :<=: interface_hierarchy f d. + Proof. + intros. + induction d. + - simpl. destruct H as [? []]. destruct x ; [ | easy ]. apply H. + - simpl. + destruct H as [? []]. + destruct (x == d.+1) eqn:x_is_d ; move: x_is_d => /eqP ? ; subst. + + apply fsubsetU. + now rewrite H. + + apply fsubsetU. + rewrite IHd ; [ easy | ]. + exists x. + eexists. + * Lia.lia. + * apply H. + Qed. + + Definition G_ks (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k). + Proof. + epose (par (G_check d k (ltnW H_lt)) (ID (XTR_n d k))). + + + refine ({package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names false erefl ∘ Ls k all_names Z erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash)) + } : _). + + rewrite <- fsetUid. + eapply valid_link. + 1:{ + eapply valid_par_upto. + 3:{ + apply valid_par. + 2: apply pack_valid. + 2: apply parallel_ID. + admit. + } + 2:{ + eapply valid_link. + 2:{ + apply valid_par. + 3: apply pack_valid. + 2: apply pack_valid. + + eassert (trimmed _ (combined_ID d _ _ _ _ _ _)). + { + apply trimmed_ℓ_packages. + } + rewrite <- H ; clear H. + + unfold G_XTR_XPD. + unfold pack. + rewrite <- trimmed_xpd_package. + rewrite <- trimmed_xtr_package. + solve_Parable. + - unfold XPD_n. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + apply idents_disjoint_foreach_in. + intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. + intros. + unfold idents. + solve_imfset_disjoint. + - unfold XTR_n. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + apply idents_disjoint_foreach_in. + intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. + intros. + unfold idents. + solve_imfset_disjoint. + } + + rewrite fsetUA. + eapply valid_par_upto. + 2: apply pack_valid. + 2:{ + apply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + admit. + } + + 2: rewrite !fsetU0 ; apply fsubsetxx. + 2:{ + fold (XTR_n d k). + fold (GET_n O_star d k). + rewrite fsetUC. + rewrite fsetUA. + rewrite fsubUset. + apply /andP ; split. + 1: solve_in_fset. + + apply fsubsetU. + apply /orP ; left. + + apply fsubsetU. + apply /orP ; left. + + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists. + 1: easy. + apply fsubsetxx. + } + 2: apply fsubsetxx. + (* instantiate (1 := XPD_n d k :|: XTR_n d k :|: GET_n O_star d k). *) + (* fold (XTR_n d k). *) + (* unfold GET_n. *) + (* unfold interface_hierarchy_foreach. *) + (* unfold GET_ℓ. *) + (* solve_in_fset. *) + (* } *) + admit. + } + + 2: solve_in_fset. + { + admit. + } + { + apply fsubsetxx. + } + { + fold (XTR_n d k). + fold (SET_ℓ [:: PSK] k 0). + unfold interface_hierarchy_foreach. + unfold GET_n. + unfold GET_ℓ. + solve_in_fset. + } + } + { + rewrite (fsetUA (interface_hierarchy_foreach _ _ _)). + rewrite <- fsetUA. + rewrite (fsetUC [interface #val #[HASH f_hash] : chHASHout → chHASHout ]). + rewrite fsetUA. + rewrite <- (fsetUid [interface]). + rewrite <- fsetU0. + apply valid_par. + 3: apply pack_valid. + 2:{ + eapply valid_package_inject_export. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + apply valid_par. + 2:{ + eapply valid_link ; apply pack_valid. + } + 2:{ + eapply valid_link ; apply pack_valid. + } + admit. + } + rewrite (fsetUC (SET_n all_names _ _)). + rewrite (fsetUA _ _ (SET_n I_star d k :|: SET_n O_star d k + :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d)). + rewrite <- fsetUA. + + rewrite fset_cons. + rewrite fset1E. + rewrite <- (fsetUA (GET_n all_names d k)). + rewrite (fsetUA (SET_n all_names d k)). + rewrite (fsetUC _ ([interface #val #[GET PSK d.+1 k] : chXTRout → chGETout ])). + rewrite (fsetUA (GET_n all_names d k)). + + apply subset_pair. + - rewrite !interface_hierarchy_U. + rewrite (interface_hierarchy_trivial [interface #val #[GET PSK d.+1 k] : chXTRout → chGETout ] d). + rewrite !interface_hierarchy_U. + + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + - rewrite !interface_hierarchy_U. + + rewrite fsubUset. + apply /andP ; split. + + rewrite <- interface_hierarchy_U. + + rewrite fsubUset. + apply /andP ; split. + * apply fsubsetU. + apply /orP ; left. + + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + * apply interface_hierarchy_subset. + intros. + destruct (x == d) eqn:x_is_d ; move: x_is_d => /eqP ? ; subst. + { + apply fsubsetU. + apply /orP ; right. + apply fsubsetxx. + } + { + apply fsubsetU. + apply /orP ; left. + + eapply interface_hierarchy_subsetR. + exists x.+1. + eexists. + - Lia.lia. + - solve_in_fset. + } + + apply fsubsetU. + apply /orP ; left. + + eapply interface_hierarchy_subsetR. + exists O, (leq0n d). + simpl. + unfold SET_ℓ. + simpl. + rewrite !fsetUA. + solve_direct_in. + } + admit. + } + + Unshelve. + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold flat. + intros. + + rewrite !in_fset in H, H0. + rewrite !(mem_seq1 (n0, _) (XTR x n k, _)) in H, H0. + move: H => /eqP ?. move: H0 => /eqP ?. + easy. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold flat. + intros. + + rewrite !in_fset in H, H0. + rewrite !(mem_seq1 (n0, _) (GET x n k, _)) in H, H0. + move: H => /eqP ?. move: H0 => /eqP ?. + easy. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } +{ + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold flat. + intros. + + rewrite !in_fset in H, H0. + rewrite !(mem_seq1 (n0, _) (GET x n k, _)) in H, H0. + move: H => /eqP ?. move: H0 => /eqP ?. + easy. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold idents. + solve_imfset_disjoint. + } + { + intros. + unfold flat. + intros. + + rewrite !in_fset in H, H0. + rewrite !(mem_seq1 (n, _) (SET x 0 k, _)) in H, H0. + move: H => /eqP H. move: H0 => /eqP H0. + inversion_clear H. inversion_clear H0. + reflexivity. + } + + + Admitted. + Fail Next Obligation. + + + + End Core. diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 44c08f21..6c94d9c8 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -135,17 +135,6 @@ Section CoreTheorem. Axiom Ai : raw_package -> bool -> raw_package. Axiom R_sodh : package fset0 [interface] [interface]. - (* Definition Nk_package (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : *) - (* package *) - (* L_K *) - (* [interface *) - (* #val #[ UNQ DH d ] : chUNQinp → chUNQout ; *) - (* #val #[ SET DH ℓ d ] : chSETinp → chSETout *) - (* ] *) - (* [interface *) - (* #val #[ GET DH ℓ d ] : chGETinp → chGETout *) - (* ]. *) - Obligation Tactic := (* try timeout 8 *) idtac. Program Definition layer1 ℓ d (H_le : (ℓ <= d)%nat) : package fset0 @@ -251,263 +240,362 @@ Section CoreTheorem. Admit Obligations. Fail Next Obligation. - Definition core (d k : nat) (H_lt : (d < k)%nat) : package fset0 - (interface_hierarchy (fun x => [interface]) d) - (GET_O_star d k). + Lemma interface_foreach_cat : forall {A} f L1 L2, + interface_foreach f (L1 ++ L2) = + interface_foreach (A := A) f L1 :|: interface_foreach (A := A) f L2. Proof. - Admitted. + induction L1 ; intros. + - simpl. + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + - rewrite interface_foreach_cons. + rewrite <- fsetUA. + rewrite <- IHL1. + now rewrite <- interface_foreach_cons. + Qed. - (* refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. *) - (* 2:{ *) - (* unfold GET_O_star. *) - (* unfold GET_n. *) - (* unfold SET_n. *) - (* rewrite interface_hierarchy_foreachU. *) - - (* apply interface_hierarchy_foreach_subset. *) - (* intros. *) - (* apply interface_hierarchy_foreach_subsetR. *) - (* 2: easy. *) - (* exists x. *) - (* assert (x \in all_names). *) - (* { *) - (* clear -H. *) - (* rewrite !in_cons in H. *) - (* unfold all_names. *) - (* rewrite !in_cons. *) - (* repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. *) - (* all: now rewrite eqxx. *) - (* } *) - (* exists H1. *) - (* exists ℓ, H0. *) - (* apply fsubsetUl. *) - (* } *) - - (* unfold GET_n. *) - (* unfold SET_n. *) - (* rewrite interface_hierarchy_foreachU. *) - - (* refine (ℓ_packages d _ _ _). *) - (* (* 2:{ *) *) - (* (* intros. *) *) - (* (* apply idents_foreach_disjoint_foreach. *) *) - (* (* intros. *) *) - (* (* unfold idents. *) *) - (* (* solve_imfset_disjoint. *) *) - (* (* } *) *) + Definition xpd_xpr_approximation + (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k :|: XTR_n d k). + Proof. + refine ({package par (XPD_ d k H_lt) (XTR_ d k (ltnW H_lt))}). + unfold XPD_, XTR_. + unfold pack. + + eapply valid_par_upto. + 2: apply XPD_. + 2: apply XTR_. + 2:{ + rewrite fsetUid. + apply fsubsetxx. + } + 3: apply fsubsetxx. + 2:{ + rewrite <- fset0E. + rewrite fsetU0. + apply fsub0set. + } + rewrite <- trimmed_xpd_package. + rewrite <- trimmed_xtr_package. + rewrite !link_trim_commut. + solve_Parable. + unfold XPD_n, XTR_n. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + solve_imfset_disjoint. + Defined. + + Definition core_approximation + (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + (GET_n O_star d k) + (XPD_n d k :|: XTR_n d k). + Proof. + (* epose (Ks d k (ltnW H_lt) O_star false erefl). *) + + refine ({package (par + (XPD_packages d k H_lt + ∘ par + (Ks d.+1 k H_lt (undup (XPR ++ XPR_parents)) false erefl + ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) Hash) + (XTR_packages d k (ltnW (m:=d) (n:=k) H_lt) + ∘ Ks d k (ltnW (m:=d) (n:=k) H_lt) (undup (XTR_parent_names ++ XTR_names)) false erefl + ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl))}). + unfold XPD_, XTR_. + unfold pack. + + eapply valid_par_upto. + 2: apply XPD_. + 2: apply XTR_. + 2:{ + rewrite fsetUid. + apply fsubsetxx. + } + 3: apply fsubsetxx. + 2:{ + rewrite <- fset0E. + rewrite fsetU0. + apply fsub0set. + } + rewrite <- trimmed_xpd_package. + rewrite <- trimmed_xtr_package. + rewrite !link_trim_commut. + + solve_Parable. + unfold XPD_n, XTR_n. + apply idents_interface_hierachy3. + intros. + rewrite fdisjointC. + apply idents_interface_hierachy3. + intros. + unfold idents. + solve_imfset_disjoint. + Defined. + + Definition core (d k : nat) (H_lt : (d < k)%nat) : + package fset0 + (interface_hierarchy (fun x => [interface]) d) + (GET_O_star d k). + Proof. + refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. + 2:{ + unfold GET_O_star. + unfold GET_n. + unfold SET_n. + rewrite interface_hierarchy_foreachU. + + apply interface_hierarchy_foreach_subset. + intros. + apply interface_hierarchy_foreach_subsetR. + 2: easy. + exists x. + assert (x \in all_names). + { + clear -H. + rewrite !in_cons in H. + unfold all_names. + rewrite !in_cons. + repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. + all: now rewrite eqxx. + } + exists H1. + exists ℓ, H0. + apply fsubsetUl. + } + + unfold GET_n. + unfold SET_n. + rewrite interface_hierarchy_foreachU. + + refine (ℓ_packages d _ _ _). + (* 2:{ *) + (* intros. *) + (* apply idents_foreach_disjoint_foreach. *) + (* intros. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* } *) - (* Unshelve. *) - (* 3:{ *) - (* intros n H. *) + Unshelve. + 3:{ + intros n H. - (* epose (dh := layer1 n d H). *) - (* epose proof (layer2_xpd n k (ltac:(Lia.lia))). *) - (* epose (hash := layer3 n d H). *) - (* epose (salt0 := layer4_salt d k (ltnW H_lt)). *) - (* epose (ikm0 := layer4_ikm d k (ltnW H_lt)). *) - (* epose (check := layer4_check d k). *) - (* epose (xtr := layer4_xtr n d H). *) - (* epose (xpd := layer4_xpd d k H_lt). *) - - (* epose (T := package fset0 *) - (* [interface] *) - (* (match n with *) - (* | O => [interface] *) - (* | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) *) - (* end)). *) - - (* epose (set_xtr := fun psk (sub_packages : T) => {package *) - (* xtr ∘ *) - (* parallel_raw [ *) - (* pack dh; *) - (* pack psk; *) - (* pack hash; *) - (* pack salt0; *) - (* pack ikm0; *) - (* pack sub_packages] *) - (* #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). *) - (* (* Unshelve. *) *) - (* (* { *) *) - - (* (* } *) *) + epose (dh := layer1 n d H). + epose proof (layer2_xpd n k (ltac:(Lia.lia))). + epose (hash := layer3 n d H). + epose (salt0 := layer4_salt d k (ltnW H_lt)). + epose (ikm0 := layer4_ikm d k (ltnW H_lt)). + epose (check := layer4_check d k). + epose (xtr := layer4_xtr n d H). + epose (xpd := layer4_xpd d k H_lt). + + epose (T := package fset0 + [interface] + (match n with + | O => [interface] + | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) + end)). + + epose (set_xtr := fun psk (sub_packages : T) => {package + xtr ∘ + parallel_raw [ + pack dh; + pack psk; + pack hash; + pack salt0; + pack ikm0; + pack sub_packages] + #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). + (* Unshelve. *) + (* { *) + + (* } *) - (* epose (set_xpd := fun psk (sub_packages : T) => {package *) - (* xpd ∘ *) - (* parallel_raw [ *) - (* pack dh; *) - (* pack psk; *) - (* pack hash; *) - (* pack salt0; *) - (* pack ikm0; *) - (* pack sub_packages] *) - (* #with _} : package fset0 [interface] (SET_ℓ XPR k n)). *) - - (* (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) *) - (* (* (parallel_raw [ *) *) - (* (* pack (set_xtr psk sub_packages); *) *) - (* (* pack (set_xpd psk sub_packages); *) *) - (* (* pack (Ls d O_star Z _)]) #with _}). *) *) - (* epose (output := fun psk *) - (* (sub_packages : T) => *) - (* {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ *) - (* (parallel_raw [ *) - (* pack (set_xtr psk sub_packages); *) - (* pack (set_xpd psk sub_packages); *) - (* pack (Ls d all_names Z _)]) #with _}). *) - - - (* assert (package fset0 *) - (* [interface] *) - (* (interface_foreach (λ name, *) - (* [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). *) - (* { *) - (* induction n as [ | ℓ ]. *) - (* - epose (psk0 := layer2_zero d k (ltnW H_lt)). *) - (* refine (output psk0 _). *) - (* refine {package emptym #with valid_empty_package _ _}. *) - (* - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). *) - (* refine (output pskS _). *) - (* specialize (IHℓ (leq_trans H (leqnSn _))). *) - (* unfold T. *) - (* eapply IHℓ. *) - (* } *) - - (* refine {package X0 #with _}. *) - (* } *) - (* { *) - (* intros. *) - (* unfold pack. *) - (* destruct n. *) - (* - unfold nat_rect. *) - (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) - (* { *) - (* intros. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_empty_package. *) - (* } *) - (* unfold parallel_package. *) - (* rewrite <- (trimmed_parallel_raw (f := (λ n : name, *) - (* [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] *) - (* :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) - (* { *) - (* rewrite !link_trim_commut. *) - (* apply trimmed_trim. *) - (* } *) - (* { *) - (* intros. *) - (* unfold idents. *) - (* try rewrite !imfsetU *) - (* ; try rewrite !fdisjointUr *) - (* ; try rewrite !fdisjointUl *) - (* ; try rewrite <- !fset1E *) - (* ; try rewrite !imfset1 *) - (* ; try rewrite !fdisjoints1 *) - (* ; repeat (apply /andP ; split) *) - (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) - (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) - (* (* solve_imfset_disjoint. *) *) - (* } *) - (* { *) - (* reflexivity. *) - (* } *) - (* { *) - (* apply trimmed_pairs_map. *) - (* intros. *) - (* rewrite <- H. *) - (* set (K_package _ _ _ _ _). *) - (* rewrite fsetUC. *) - (* rewrite <- fset1E. *) - (* rewrite <- fset_cons. *) - (* apply trimmed_trim. *) - (* } *) - (* - unfold nat_rect. *) - (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) - (* { *) - (* intros. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_empty_package. *) - (* } *) - (* unfold parallel_package. *) - (* rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, *) - (* [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] *) - (* :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) - (* { *) - (* rewrite !link_trim_commut. *) - (* apply trimmed_trim. *) - (* } *) - (* { *) - (* intros. *) - (* unfold idents. *) - (* try rewrite !imfsetU *) - (* ; try rewrite !fdisjointUr *) - (* ; try rewrite !fdisjointUl *) - (* ; try rewrite <- !fset1E *) - (* ; try rewrite !imfset1 *) - (* ; try rewrite !fdisjoints1 *) - (* ; repeat (apply /andP ; split) *) - (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) - (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) - (* (* solve_imfset_disjoint. *) *) - (* } *) - (* { *) - (* reflexivity. *) - (* } *) - (* { *) - (* apply trimmed_pairs_map. *) - (* intros. *) - (* rewrite <- H. *) - (* set (K_package _ _ _ _ _). *) - (* rewrite fsetUC. *) - (* rewrite <- fset1E. *) - (* rewrite <- fset_cons. *) - (* apply trimmed_trim. *) - (* } *) - (* } *) - (* { *) - (* intros. *) - (* apply idents_foreach_disjoint_foreach. *) - (* intros. *) - (* unfold idents. *) - (* solve_imfset_disjoint. *) - (* } *) - - (* Unshelve. *) - (* { *) - (* ssprove_valid. *) - (* 1:{ *) - (* eapply valid_package_inject_import. *) - (* 2:{ *) - (* unfold XTR_n_ℓ. *) - (* unfold GET_ℓ. *) - (* rewrite interface_foreach_U. *) - - (* unfold parallel_raw, List.fold_left. *) - (* unfold XTR_names, interface_foreach. *) - - (* (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) *) + epose (set_xpd := fun psk (sub_packages : T) => {package + xpd ∘ + parallel_raw [ + pack dh; + pack psk; + pack hash; + pack salt0; + pack ikm0; + pack sub_packages] + #with _} : package fset0 [interface] (SET_ℓ XPR k n)). + + (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) + (* (parallel_raw [ *) + (* pack (set_xtr psk sub_packages); *) + (* pack (set_xpd psk sub_packages); *) + (* pack (Ls d O_star Z _)]) #with _}). *) + epose (output := fun psk + (sub_packages : T) => + {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ + (parallel_raw [ + pack (set_xtr psk sub_packages); + pack (set_xpd psk sub_packages); + pack (Ls d all_names Z _)]) #with _}). + + + assert (package fset0 + [interface] + (interface_foreach (λ name, + [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). + { + induction n as [ | ℓ ]. + - epose (psk0 := layer2_zero d k (ltnW H_lt)). + refine (output psk0 _). + refine {package emptym #with valid_empty_package _ _}. + - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). + refine (output pskS _). + specialize (IHℓ (leq_trans H (leqnSn _))). + unfold T. + eapply IHℓ. + } + + refine {package X0 #with _}. + Show Proof. + } + { + intros. + unfold pack. + destruct n. + - unfold nat_rect. + eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). + { + intros. + apply trimmed_package_cons. + apply trimmed_package_cons. + apply trimmed_empty_package. + } + unfold parallel_package. + rewrite <- (trimmed_parallel_raw (f := (λ n : name, + [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] + :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). + { + rewrite !link_trim_commut. + apply trimmed_trim. + } + { + intros. + unfold idents. + try rewrite !imfsetU + ; try rewrite !fdisjointUr + ; try rewrite !fdisjointUl + ; try rewrite <- !fset1E + ; try rewrite !imfset1 + ; try rewrite !fdisjoints1 + ; repeat (apply /andP ; split) + ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). + all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). + (* solve_imfset_disjoint. *) + } + { + reflexivity. + } + { + apply trimmed_pairs_map. + intros. + rewrite <- H. + set (K_package _ _ _ _ _). + rewrite fsetUC. + rewrite <- fset1E. + rewrite <- fset_cons. + apply trimmed_trim. + } + - unfold nat_rect. + eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). + { + intros. + apply trimmed_package_cons. + apply trimmed_package_cons. + apply trimmed_empty_package. + } + unfold parallel_package. + rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, + [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] + :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). + { + rewrite !link_trim_commut. + apply trimmed_trim. + } + { + intros. + unfold idents. + try rewrite !imfsetU + ; try rewrite !fdisjointUr + ; try rewrite !fdisjointUl + ; try rewrite <- !fset1E + ; try rewrite !imfset1 + ; try rewrite !fdisjoints1 + ; repeat (apply /andP ; split) + ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). + all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). + (* solve_imfset_disjoint. *) + } + { + reflexivity. + } + { + apply trimmed_pairs_map. + intros. + rewrite <- H. + set (K_package _ _ _ _ _). + rewrite fsetUC. + rewrite <- fset1E. + rewrite <- fset_cons. + apply trimmed_trim. + } + } + { + intros. + apply idents_foreach_disjoint_foreach. + intros. + unfold idents. + solve_imfset_disjoint. + } + + Unshelve. + { + ssprove_valid. + 1:{ + eapply valid_package_inject_import. + 2:{ + unfold XTR_n_ℓ. + unfold GET_ℓ. + rewrite interface_foreach_U. + + unfold parallel_raw, List.fold_left. + unfold XTR_names, interface_foreach. + + (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) - (* ssprove_valid. *) - (* all: try apply fsubsetxx. *) - (* 1-5: admit. *) - (* admit. *) - (* } *) - (* rewrite <- !fset0E. *) - (* rewrite !fsetU0 ; rewrite !fset0U. *) - (* admit. *) - (* } *) - (* { *) - (* apply fsubsetxx. *) - (* } *) - (* { *) - (* rewrite !fsetU0 ; rewrite !fset0U. *) - (* rewrite fsetUid. *) - (* admit. *) - (* } *) - (* } *) - (* all: admit. *) - (* Admitted. *) + ssprove_valid. + all: try apply fsubsetxx. + 1-5: admit. + admit. + } + rewrite <- !fset0E. + rewrite !fsetU0 ; rewrite !fset0U. + admit. + } + { + apply fsubsetxx. + } + { + rewrite !fsetU0 ; rewrite !fset0U. + rewrite fsetUid. + admit. + } + } + all: admit. + Admitted. Lemma core_theorem : forall (d k : nat) H_lt, @@ -518,7 +606,7 @@ Section CoreTheorem. (Gcore_real d k H_lt) (Gcore_ideal d k (ltnW H_lt) Score) (A (* ∘ R d M H *)) <= sumR_l [R_cr; (R_Z f_hash); R_D] (fun R => Advantage (Gacr f_hash) (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d) (Gcore_ideal d k (ltnW H_lt) Score) (Ai A i)) + +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d k false) (Gcore_ideal d k (ltnW H_lt) Score) (Ai A i)) )%R. Proof. intros. @@ -542,7 +630,7 @@ Section CoreTheorem. forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_sodh d) (Gcore_hyb d 0) (Ai A i) = 0)%R. + (AdvantageE (Gcore_sodh d k false) (Gcore_hyb d 0) (Ai A i) = 0)%R. Proof. intros. Admitted. @@ -590,7 +678,7 @@ Section CoreTheorem. forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_sodh d) (Gcore_ideal d k H_lt Score) (Ai A i) + (AdvantageE (Gcore_sodh d k false) (Gcore_ideal d k H_lt Score) (Ai A i) <= AdvantageE (Gcore_ki d k) (Gcore_ideal d k H_lt Score) (Ai A i) +sumR 0 d (leq0n d) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) )%R. diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index 4ccb0b03..0b0dc632 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -259,8 +259,8 @@ Section KeyPackages. package (L_K) (interface_foreach (fun n => [interface #val #[ UNQ n k ] : chUNQinp → chUNQout]) Names) - (interface_hierarchy_foreach (fun n ℓ => [interface #val #[ SET n ℓ k ] : chSETinp → chSETout]) (Names) d - :|: interface_hierarchy_foreach (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) (Names) d + (SET_n (Names) d k + :|: GET_n (Names) d k ). Proof. intros. @@ -315,35 +315,72 @@ Section KeyPackages. (* Fig 15 *) -Definition Nk_package (ℓ : nat) (d : nat) (_ : (ℓ <= d)%nat) : +Definition Nk_package (d k : nat) (_ : (d <= k)%nat) : package L_K [interface - #val #[ UNQ DH d ] : chUNQinp → chUNQout + #val #[ UNQ DH k ] : chUNQinp → chUNQout ] - [interface - #val #[ SET DH ℓ d ] : chSETinp → chSETout ; - #val #[ GET DH ℓ d ] : chGETinp → chGETout - ]. - refine [package - #def #[ SET DH ℓ d ] ('(h,hon,k) : chSETinp) : chSETout { - #import {sig #[ UNQ DH d ] : chUNQinp → chUNQout } + (SET_n [DH] d k :|: GET_n [DH] d k) + (* [interface *) + (* #val #[ SET DH ℓ k ] : chSETinp → chSETout ; *) + (* #val #[ GET DH ℓ k ] : chGETinp → chGETout *) +(* ] *). + epose ℓ_packages. + unfold SET_n. + unfold GET_n. + rewrite interface_hierarchy_U. + rewrite (interface_hierarchy_trivial [interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ] d). + refine (ℓ_packages d + (fun ℓ _ => + [package + #def #[ SET DH ℓ k ] ('(h,hon,key) : chSETinp) : chSETout { + #import {sig #[ UNQ DH k ] : chUNQinp → chUNQout } as unq_fn ;; - get_or_case_fn (K_table h) fin_K_table chHandle ( - unq_fn (h, hon, k) ;; - set_at (K_table h) fin_K_table (otf k, hon) ;; + get_or_case_fn (K_table h) (H := pos_prod pos_key pos_bool) fin_K_table chHandle ( + unq_fn (h, hon, key) ;; + set_at (K_table h)(H := pos_prod pos_key pos_bool) fin_K_table (otf key, hon) ;; ret h ) (fun _ => ret h) } ; - #def #[ GET DH ℓ d ] (h : chGETinp) : chGETout { - p ← get_or_fail (K_table h) fin_K_table ;; + #def #[ GET DH ℓ k ] (h : chGETinp) : chGETout { + p ← get_or_fail (K_table h) (H := pos_prod pos_key pos_bool) fin_K_table ;; let (k, hon) := (fto (fst (otf p)) , snd (otf p) : 'bool) : (chProd chKey 'bool) in ret (k, hon) } - ]. - + ]) _ _). + { + intros. + unfold SET_ℓ, GET_ℓ. + unfold interface_foreach. + unfold pack. + rewrite <- fset1E. + rewrite <- fset_cons. + apply (trimmed_package_cons). + apply (trimmed_package_cons). + apply (trimmed_empty_package). + } + { + intros. + unfold SET_ℓ, GET_ℓ. + unfold interface_foreach. + unfold idents. + solve_imfset_disjoint. + } + + Unshelve. + all: try apply DepInstance. + + unfold SET_ℓ, GET_ℓ. + unfold interface_foreach. + set ([interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ]). + rewrite <- (fset1E ). + rewrite <- fset_cons. + subst f. + + unfold get_or_fn. unfold get_or_case_fn. unfold get_or_fail. diff --git a/proofs/ssprove/handwritten/KeySchedulePackages.v b/proofs/ssprove/handwritten/KeySchedulePackages.v index f8c12c57..b9664247 100644 --- a/proofs/ssprove/handwritten/KeySchedulePackages.v +++ b/proofs/ssprove/handwritten/KeySchedulePackages.v @@ -161,8 +161,7 @@ Section KeySchedulePackages. 1:{ eapply valid_package_inject_export. 2: apply (pack_valid (Ks d k H_lt O_star true erefl)). - unfold GET_O_star. - solve_in_fset. + apply fsubsetUr. } 1:{ eapply valid_package_inject_import. diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index 19a5bed9..92a0e3b6 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -87,18 +87,6 @@ Section XTR_XPD. Context {DepInstance : Dependencies}. Existing Instance DepInstance. - Definition SET_ℓ Names d ℓ : Interface := - interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) Names. - - Definition SET_n Names d k : Interface := - interface_hierarchy (SET_ℓ Names k) d. - - Definition GET_ℓ Names d ℓ : Interface := - interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) Names. - - Definition GET_n Names d k : Interface := - interface_hierarchy (GET_ℓ Names k) d. - (* p. 5,6 *) (* Context {xtr_angle : name -> chHandle -> chHandle -> code fset0 fset0 chHandle}. *) (* Context {xtr : chKey -> chKey -> code fset0 fset0 chKey}. *) From a53ad007f28751cd971aa3ac2a001bd200d3a04c Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 3 Mar 2025 17:58:44 +0100 Subject: [PATCH 06/10] Most of setup done for core theorem --- proofs/ssprove/handwritten/Core.v | 1202 +++++++++------- proofs/ssprove/handwritten/CoreTheorem.v | 1264 +++++++++++------ proofs/ssprove/handwritten/KeyPackages.v | 185 ++- .../ssprove/handwritten/KeySchedulePackages.v | 186 +-- proofs/ssprove/handwritten/Utility.v | 74 +- proofs/ssprove/handwritten/XTR_XPD.v | 45 +- 6 files changed, 1691 insertions(+), 1265 deletions(-) diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index beb5c5e3..507d378c 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -161,9 +161,9 @@ From KeyScheduleTheorem Require Import XTR_XPD. rewrite fsetUC. reflexivity. Qed. - + Lemma interface_foreach_sub_list : forall {A : eqType} f L1 L2, - uniq L1 -> + uniq L1 -> (forall x, x \in L1 -> x \in L2) -> interface_foreach f L1 = interface_foreach (A := A) (fun x => if x \in L1 then f x else [interface]) L2. @@ -206,6 +206,68 @@ From KeyScheduleTheorem Require Import XTR_XPD. Qed. + Lemma interface_foreach_trivial2 : forall {A} i L (* d *), + (L <> [] \/ i = [interface]) -> + i = (interface_foreach (λ (n : A), i) L ). + Proof. + intros. + destruct H. + - destruct L ; [ easy | ]. + clear H. + generalize dependent a. + induction L ; intros. + { + rewrite interface_foreach_cons. + simpl. + rewrite <- fset0E. + rewrite fsetU0. + reflexivity. + } + { + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + } + - rewrite H. + induction L. + + reflexivity. + + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + Qed. + + Lemma interface_hierarchy_subset : forall f d K, + (forall (x : nat) (H : (x <= d)%nat), f x :<=: K) -> + interface_hierarchy f d :<=: K. + Proof. + intros. + induction d. + - now apply H. + - simpl. + rewrite fsubUset. + now rewrite H ; [ rewrite IHd | ]. + Qed. + + Lemma interface_hierarchy_subsetR : forall f d K, + (exists (x : nat) (H : (x <= d)%nat), K :<=: f x) -> + K :<=: interface_hierarchy f d. + Proof. + intros. + induction d. + - simpl. destruct H as [? []]. destruct x ; [ | easy ]. apply H. + - simpl. + destruct H as [? []]. + destruct (x == d.+1) eqn:x_is_d ; move: x_is_d => /eqP ? ; subst. + + apply fsubsetU. + now rewrite H. + + apply fsubsetU. + rewrite IHd ; [ easy | ]. + exists x. + eexists. + * Lia.lia. + * apply H. + Qed. + (*** Core *) Section Core. @@ -227,218 +289,253 @@ Section Core. :|: GET_O_star d k ). - (* Fig 8 in conference paper *) - Definition Gcore_sodh (d k : nat) (b : bool) : - package (L_K :|: L_L) - ([interface - #val #[ DHEXP ] : chDHEXPinp → chDHEXPout ; - #val #[ DHGEN ] : chDHGENinp → chDHGENout - ] :|: interface_hierarchy (fun ℓ => [interface #val #[ XTR HS ℓ k ] : chXTRinp → chXTRout]) d) - [interface]. - Proof. - refine - {package - (ℓ_packages 0 (fun ℓ H => Xtr HS ℓ k b) _ _) ∘ - par - (par - (par - (Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) - (DH_package 0 k ∘ Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) - ) - (K_package k ESALT 0 (leq0n k) false ∘ L_package k ESALT F (* R *))) - (K_package k HS 0 (leq0n d) false ∘ L_package k HS F (* D *)) - #with - _ - }. - - rewrite <- fset0U. - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite <- fset0E. - apply fsub0set. - } - - unfold PrntN. - rewrite !nfto_name_to_chName_cancel. - - eapply (valid_par_upto (L_K :|: L_L) _ _ - (L_K :|: L_L) (L_K :|: L_L)). - 2:{ - rewrite <- fsetUid. - apply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: eapply valid_link ; apply pack_valid. - - 2:{ - rewrite <- fset0U. - eapply valid_link. - 2: eapply valid_link ; apply pack_valid. - eapply valid_package_inject_import. - 2: apply pack_valid. - - apply fsubsetUl. - } - - rewrite <- trimmed_dh. - - eassert (trimmed _ (Nk_package 0 k (leq0n k))). - { - unfold Nk_package. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - apply trimmed_ℓ_packages. - } - rewrite <- H at 1 ; clear H. - rewrite !link_trim_commut. - solve_Parable. + Definition parallel_ID d (L : seq name) (f : name -> Interface) : + (∀ x y, x ≠ y → idents (f x) :#: idents (f y)) -> + (uniq L) -> + (forall x, flat (f x)) -> + package fset0 (interface_foreach f L) (interface_foreach f L) := + fun H H0 H1 => + parallel_package d L + (fun x => {package ID (f x) #with valid_ID _ _ (H1 x)}) H + (fun x => trimmed_ID _) H0. - unfold DH_interface. - rewrite fset_cons. + Definition combined_ID (d : nat) (L : seq name) (f : name -> nat -> Interface) : + (forall n x y, x ≠ y → idents (f x n) :#: idents (f y n)) -> + (uniq L) -> + (forall n x, flat (f x n)) -> + (forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y, idents (f x ℓ) :#: idents (f y n)) -> + package fset0 (interface_hierarchy_foreach f L d) (interface_hierarchy_foreach f L d). - rewrite fdisjointC. - apply idents_interface_hierachy3. + intros. + refine (ℓ_packages d (fun x _ => parallel_ID d L (f^~ x) _ _ _) _ _). + - intros. + unfold parallel_ID. + apply trimmed_parallel_raw. + + apply H. + + apply H0. + + apply trimmed_pairs_map. intros. - unfold idents. - unfold SET_ℓ, GET_ℓ, interface_foreach. - solve_imfset_disjoint. - } - 2: eapply valid_link ; apply pack_valid. - { - eassert (trimmed _ (Nk_package 0 k (leq0n k))). - { - unfold Nk_package. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - apply trimmed_ℓ_packages. - } - rewrite <- H at 1 ; clear H. - - rewrite <- trimmed_dh. - - eassert (trimmed _ (K_package _ _ _ _ _)). - { - do 2 apply trimmed_package_cons. - apply trimmed_empty_package. - } - rewrite <- H ; clear H. - - rewrite !link_trim_commut. - - solve_Parable. - - rewrite fset_cons. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - unfold SET_ℓ, GET_ℓ, interface_foreach. - unfold idents. - solve_imfset_disjoint. - - rewrite fset_cons. - unfold DH_interface. - rewrite (fset_cons (DHGEN , _)). - unfold idents. - solve_imfset_disjoint. - } - } - 2: eapply valid_link ; apply pack_valid. - 2: rewrite fsetUid ; apply fsubsetxx. - 2: solve_in_fset. - 2:{ - unfold SET_DH. - unfold interface_hierarchy. - rewrite fset_cons. - rewrite (fset_cons (SET _ _ _, _)). - rewrite (fset_cons (SET _ _ _, _)). - unfold DH_interface. - - unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. - solve_in_fset. - } - { - eassert (trimmed _ (Nk_package 0 k (leq0n k))). - { - unfold Nk_package. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - apply trimmed_ℓ_packages. - } - rewrite <- H at 1 ; clear H. - - rewrite <- trimmed_dh. - - eassert (trimmed _ (K_package k ESALT _ _ _)). - { - do 2 apply trimmed_package_cons. - apply trimmed_empty_package. - } - rewrite <- H ; clear H. - - eassert (trimmed _ (K_package k HS _ _ _)). - { - do 2 apply trimmed_package_cons. - apply trimmed_empty_package. - } - rewrite <- H ; clear H. - - rewrite !link_trim_commut. - - solve_Parable. - - unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. - rewrite (fset_cons (SET HS _ _, _)). - unfold idents. - solve_imfset_disjoint. - - unfold DH_interface. - rewrite fset_cons. - rewrite (fset_cons (SET HS _ _, _)). - unfold idents. - solve_imfset_disjoint. - - rewrite fset_cons. - rewrite (fset_cons (SET HS _ _, _)). - unfold idents. - solve_imfset_disjoint. - } + unfold pack. + apply trimmed_ID. + - intros. + apply idents_foreach_disjoint_foreach. + intros. + now apply H2. - Unshelve. - { apply DepInstance. } - { intros. apply trimmed_package_cons. apply trimmed_empty_package. } - { intros. unfold idents. solve_imfset_disjoint. } + Unshelve. + + intros. + now apply H. + + apply H0. + + apply H1. Defined. - Definition Gcore_hyb : forall d (ℓ : nat), - package f_parameter_cursor_loc - ((GET_ℓ XPR d ℓ :|: SET_ℓ XPR d ℓ) - :|: (GET_DH_ℓ d ℓ :|: SET_DH_ℓ d ℓ) - :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] - :|: (GET_ℓ XTR_names d ℓ :|: SET_ℓ XTR_names d ℓ)) - (SET_O_star_ℓ d ℓ :|: GET_O_star_ℓ d ℓ). - Proof. - intros. - epose {package (Ks ℓ d _ O_star false erefl ∘ Ls ℓ O_star F erefl)}. - fold GET. - Admitted. - - Definition Gcore_ki : forall d k, - package f_parameter_cursor_loc - ((GET_n XPR d k :|: SET_n XPR d k) - :|: (GET_DH d k :|: SET_DH d k) - :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] - :|: (GET_n XTR_names d k :|: SET_n XTR_names d k)) - (SET_O_star d k :|: GET_O_star d k). + Lemma reindex_interface_hierarchy_PSK2 : + forall d k, + (interface_hierarchy (λ n : nat, [interface #val #[SET PSK n k] : chUNQinp → chXTRout ]) d.+1) + = + ([interface #val #[SET PSK 0 k] : chUNQinp → chXTRout ] :|: interface_hierarchy + (λ n : nat, [interface #val #[SET PSK (n.+1) k] : chUNQinp → chXTRout ]) + d). Proof. intros. - Admitted. + symmetry. + induction d ; intros. + - simpl. + reflexivity. + - simpl. + rewrite fsetUA. + rewrite IHd. + reflexivity. + Qed. - Axiom Hash : package fset0 [interface] [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. - Lemma trimmed_hash : (trimmed ([interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) Hash). Admitted. + (* (* Fig 8 in conference paper *) *) + (* Definition Gcore_sodh (d k : nat) (b : bool) : *) + (* package (L_K :|: L_L) *) + (* ([interface *) + (* #val #[ DHEXP ] : chDHEXPinp → chDHEXPout ; *) + (* #val #[ DHGEN ] : chDHGENinp → chDHGENout *) + (* ] :|: interface_hierarchy (fun ℓ => [interface #val #[ XTR HS ℓ k ] : chXTRinp → chXTRout]) d) *) + (* [interface]. *) + (* Proof. *) + (* refine *) + (* {package *) + (* (ℓ_packages 0 (fun ℓ H => Xtr HS ℓ k b) _ _) ∘ *) + (* par *) + (* (par *) + (* (par *) + (* (Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) *) + (* (DH_package k ∘ Nk_package 0 k (leq0n k) ∘ (L_package k DH Z)) *) + (* ) *) + (* (K_package k ESALT 0 (leq0n k) false ∘ L_package k ESALT F (* R *))) *) + (* (K_package k HS 0 (leq0n d) false ∘ L_package k HS F (* D *)) *) + (* #with *) + (* _ *) + (* }. *) + + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite <- fset0E. *) + (* apply fsub0set. *) + (* } *) + + (* unfold PrntN. *) + (* rewrite !nfto_name_to_chName_cancel. *) + + (* eapply (valid_par_upto (L_K :|: L_L) _ _ *) + (* (L_K :|: L_L) (L_K :|: L_L)). *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* apply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: eapply valid_link ; apply pack_valid. *) + + (* 2:{ *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* eapply valid_package_inject_import. *) + (* 2: apply pack_valid. *) + + (* apply fsubsetUl. *) + (* } *) + + (* rewrite <- trimmed_dh. *) + + (* eassert (trimmed _ (Nk_package 0 k (leq0n k))). *) + (* { *) + (* unfold Nk_package. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* apply trimmed_ℓ_packages. *) + (* } *) + (* rewrite <- H at 1 ; clear H. *) + (* rewrite !link_trim_commut. *) + (* solve_Parable. *) + + (* unfold DH_interface. *) + (* rewrite fset_cons. *) + + (* rewrite fdisjointC. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* unfold idents. *) + (* unfold SET_ℓ, GET_ℓ, interface_foreach. *) + (* solve_imfset_disjoint. *) + (* } *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* { *) + (* eassert (trimmed _ (Nk_package 0 k (leq0n k))). *) + (* { *) + (* unfold Nk_package. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* apply trimmed_ℓ_packages. *) + (* } *) + (* rewrite <- H at 1 ; clear H. *) + + (* rewrite <- trimmed_dh. *) + + (* eassert (trimmed _ (K_package _ _ _ _ _)). *) + (* { *) + (* do 2 apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* rewrite <- H ; clear H. *) + + (* rewrite !link_trim_commut. *) + + (* solve_Parable. *) + (* - rewrite fset_cons. *) + (* rewrite fdisjointC. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* unfold SET_ℓ, GET_ℓ, interface_foreach. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* - rewrite fset_cons. *) + (* unfold DH_interface. *) + (* rewrite (fset_cons (DHGEN , _)). *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* } *) + (* } *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* 2: rewrite fsetUid ; apply fsubsetxx. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* unfold SET_DH. *) + (* unfold interface_hierarchy. *) + (* rewrite fset_cons. *) + (* rewrite (fset_cons (SET _ _ _, _)). *) + (* rewrite (fset_cons (SET _ _ _, _)). *) + (* unfold DH_interface. *) + + (* unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. *) + (* solve_in_fset. *) + (* } *) + (* { *) + (* eassert (trimmed _ (Nk_package 0 k (leq0n k))). *) + (* { *) + (* unfold Nk_package. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* apply trimmed_ℓ_packages. *) + (* } *) + (* rewrite <- H at 1 ; clear H. *) + + (* rewrite <- trimmed_dh. *) + + (* eassert (trimmed _ (K_package k ESALT _ _ _)). *) + (* { *) + (* do 2 apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* rewrite <- H ; clear H. *) + + (* eassert (trimmed _ (K_package k HS _ _ _)). *) + (* { *) + (* do 2 apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* rewrite <- H ; clear H. *) + + (* rewrite !link_trim_commut. *) + + (* solve_Parable. *) + (* - unfold SET_n, GET_n, SET_ℓ, GET_ℓ, interface_hierarchy, interface_foreach. *) + (* rewrite (fset_cons (SET HS _ _, _)). *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* - unfold DH_interface. *) + (* rewrite fset_cons. *) + (* rewrite (fset_cons (SET HS _ _, _)). *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* - rewrite fset_cons. *) + (* rewrite (fset_cons (SET HS _ _, _)). *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* } *) + + (* Unshelve. *) + (* { apply DepInstance. } *) + (* { intros. apply trimmed_package_cons. apply trimmed_empty_package. } *) + (* { intros. unfold idents. solve_imfset_disjoint. } *) + (* Defined. *) + + Axiom Hash : bool -> package fset0 [interface] [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. + Lemma trimmed_hash (b : bool) : (trimmed ([interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]) (Hash b)). Admitted. Definition Simulator d k := (package @@ -467,8 +564,8 @@ Section Core. apply H. Qed. - Lemma xtr_dh : forall (d k : nat) H_lt, - domm (pack (XTR_packages d k H_lt)) :#: domm (pack (DH_package d k)) = true. + Lemma xtr_dh : forall (d k : nat) b H_lt, + domm (pack (XTR_packages d k b H_lt)) :#: domm (pack (DH_package k)) = true. Proof. intros. unfold pack. @@ -489,7 +586,7 @@ Section Core. Qed. Lemma xpd_dh : forall (d k : nat) H_lt, - domm (pack (XPD_packages d k H_lt)) :#: domm (pack (DH_package d k)) = true. + domm (pack (XPD_packages d k H_lt)) :#: domm (pack (DH_package k)) = true. Proof. intros. unfold pack. @@ -680,12 +777,12 @@ Section Core. reflexivity. Qed. - Program Definition XPD_ d k H_lt : package (L_K :|: L_L) [interface] (XPD_n d k) := + Program Definition XPD_ d k b key_b H_lt : package (L_K :|: L_L) [interface] (XPD_n d k) := {package XPD_packages d k H_lt ∘ (par - (Ks d.+1 k (H_lt) (undup (XPR ++ XPR_parents)) false erefl ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) - Hash) + (Ks d.+1 k (H_lt) (undup (XPR ++ XPR_parents)) key_b erefl ∘ Ls k (undup (XPR ++ XPR_parents)) (fun _ => F) erefl) + (Hash b)) #with _ }. (* Next Obligation. *) @@ -804,10 +901,10 @@ Section Core. solve_imfset_disjoint. Qed. - Definition XTR_ (d k : nat) (H_lt : (d <= k)%nat) : package (L_K :|: L_L) (fset [::]) (XTR_n d k). + Definition XTR_ (d k : nat) (b : name -> bool) (key_b : nat -> name -> bool) (H_lt : (d <= k)%nat) : package (L_K :|: L_L) (fset [::]) (XTR_n d k). Proof. - refine {package XTR_packages d k H_lt ∘ - (Ks d k H_lt (undup (XTR_parent_names ++ XTR_names)) false erefl ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl) + refine {package XTR_packages d k b H_lt ∘ + (Ks d k H_lt (undup (XTR_parent_names ++ XTR_names)) key_b erefl ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) (fun _ => Z) erefl) #with _ }. @@ -859,17 +956,17 @@ Section Core. now right. Qed. - Program Definition XPD_DH_XTR d k H_lt : + Program Definition XPD_DH_XTR d k b_hash b key_b H_lt : package (L_K :|: L_L) [interface] (XPD_n d k :|: (DH_interface :|: XTR_n d k)) := {package (par - (XPD_ d k H_lt) - (par (DH_package d k ∘ (Ks d k (ltnW H_lt) [DH] false erefl ∘ Ls k [DH] F erefl)) - (XTR_packages d k (ltnW H_lt) ∘ (Ks d k (ltnW H_lt) (undup (XTR_names ++ XTR_parent_names)) false erefl ∘ Ls k (undup (XTR_names ++ XTR_parent_names)) Z erefl)))) - ∘ (Ks d k (ltnW H_lt) O_star false erefl ∘ Ls k O_star Z (erefl))}. + (XPD_ d k b_hash key_b H_lt) + (par (DH_package k ∘ (Ks d k (ltnW H_lt) [DH] key_b erefl ∘ Ls k [DH] (fun _ => F) erefl)) + (XTR_packages d k b (ltnW H_lt) ∘ (Ks d k (ltnW H_lt) (undup (XTR_names ++ XTR_parent_names)) key_b erefl ∘ Ls k (undup (XTR_names ++ XTR_parent_names)) (fun _ => Z) erefl)))) + ∘ (Ks d k (ltnW H_lt) O_star key_b erefl ∘ Ls k O_star (fun _ => Z) (erefl))}. Final Obligation. intros. rewrite <- fsetUid. @@ -895,6 +992,11 @@ Section Core. apply fsubsetU. apply /orP. left. + + unfold SET_DH, SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n d). + apply fsubsetxx. } } @@ -1009,92 +1111,228 @@ Section Core. apply fsubsetxx. Defined. - Obligation Tactic := (* try timeout 8 *) idtac. - Program Definition Gcore_real (d k : nat) H_lt : - package (L_K :|: L_L) - [interface] - (* ((GET_XPD :|: SET_XPD) *) - (* :|: DH_Set_interface *) - (* :|: [interface #val #[ HASH ] : chHASHinp → chHASHout] *) - (* :|: (GET_XTR :|: SET_XTR)) *) - ((* SET_O_star_ℓ d :|: *) GET_O_star d k) - (* ([interface #val #[SET_psk 0] : chSETinp → chSETout ; *) - (* #val #[DHGEN] : 'unit → 'unit ; *) - (* #val #[DHEXP] : 'unit → 'unit ] :|: XTR_n_ℓ d :|: XPD_n_ℓ d :|: *) - (* GET_o_star_ℓ d) *) - := - {package (Ks d k (ltnW H_lt) O_star false erefl ∘ Ls k O_star F erefl) ∘ XPD_DH_XTR d k H_lt}. - Final Obligation. - intros. - rewrite <- fsetUid. - eapply valid_link. - 2: apply XPD_DH_XTR. - eapply valid_link. - - eapply valid_package_inject_export. - 2: apply (Ks _ _ _). - unfold GET_O_star. - apply fsubsetU. - apply /orP. - right. - apply fsubsetxx. - - eapply valid_package_inject_import. - 2: apply (Ls _ _ _). - rewrite <- fset0E. - solve_in_fset. - Defined. - Fail Next Obligation. + (* Obligation Tactic := (* try timeout 8 *) idtac. *) + (* Program Definition Gcore_real (d k : nat) b H_lt : *) + (* package (L_K :|: L_L) *) + (* [interface] *) + (* (* ((GET_XPD :|: SET_XPD) *) *) + (* (* :|: DH_Set_interface *) *) + (* (* :|: [interface #val #[ HASH ] : chHASHinp → chHASHout] *) *) + (* (* :|: (GET_XTR :|: SET_XTR)) *) *) + (* ((* SET_O_star_ℓ d :|: *) GET_O_star d k) *) + (* (* ([interface #val #[SET_psk 0] : chSETinp → chSETout ; *) *) + (* (* #val #[DHGEN] : 'unit → 'unit ; *) *) + (* (* #val #[DHEXP] : 'unit → 'unit ] :|: XTR_n_ℓ d :|: XPD_n_ℓ d :|: *) *) + (* (* GET_o_star_ℓ d) *) *) + (* := *) + (* {package (Ks d k (ltnW H_lt) O_star false erefl ∘ Ls k O_star (fun _ => F) erefl) ∘ XPD_DH_XTR d k b (fun _ => b) H_lt}. *) + (* Final Obligation. *) + (* intros. *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 2: apply XPD_DH_XTR. *) + (* eapply valid_link. *) + (* - eapply valid_package_inject_export. *) + (* 2: apply (Ks _ _ _). *) + (* unfold GET_O_star. *) + (* apply fsubsetU. *) + (* apply /orP. *) + (* right. *) + (* apply fsubsetxx. *) + (* - eapply valid_package_inject_import. *) + (* 2: apply (Ls _ _ _). *) + (* rewrite <- fset0E. *) + (* solve_in_fset. *) + (* Defined. *) + (* Fail Next Obligation. *) + + (* Program Definition Gcore_ideal (d k : nat) H_lt (Score : Simulator d k) : *) + (* package *) + (* L_K *) + (* ([interface *) + (* #val #[ SET PSK 0 d ] : chSETinp → chSETout *) + (* ] :|: DH_interface :|: *) + (* XTR_n d k :|: *) + (* XPD_n d k :|: *) + (* GET_O_star d k) *) + (* (GET_O_star d k) := *) + (* {package (Ks d k H_lt O_star true erefl ∘ Score) }. *) + (* Final Obligation. *) + (* intros. *) + (* rewrite <- fsetUid. *) + (* eapply (valid_link_upto L_K _ _ _ (UNQ_O_star k)). *) + (* - epose (pack_valid (Ks d k H_lt O_star true erefl)). *) + (* eapply valid_package_inject_export. *) + (* 2: apply v. *) + (* apply fsubsetUr. *) + (* - eapply valid_package_inject_import. *) + (* 2: apply (pack_valid Score). *) + (* solve_in_fset. *) + (* - solve_in_fset. *) + (* - solve_in_fset. *) + (* Defined. *) + (* Fail Next Obligation. *) - Program Definition Gcore_ideal (d k : nat) H_lt (Score : Simulator d k) : - package - L_K - ([interface - #val #[ SET PSK 0 d ] : chSETinp → chSETout - ] :|: DH_interface :|: - XTR_n d k :|: - XPD_n d k :|: - GET_O_star d k) - (GET_O_star d k) := - {package (Ks d k H_lt O_star true erefl ∘ Score) }. - Final Obligation. - intros. - rewrite <- fsetUid. - eapply (valid_link_upto L_K _ _ _ (UNQ_O_star k)). - - epose (pack_valid (Ks d k H_lt O_star true erefl)). - eapply valid_package_inject_export. - 2: apply v. - apply fsubsetUr. - - eapply valid_package_inject_import. - 2: apply (pack_valid Score). - solve_in_fset. - - solve_in_fset. - - solve_in_fset. - Defined. - Fail Next Obligation. + (*** Actual core *) + Notation " 'chXPDinp' " := + (chHandle × 'bool × bitvec) + (in custom pack_type at level 2). + Notation " 'chXPDout' " := + (chHandle) + (in custom pack_type at level 2). - (*** Actual core *) + Axiom level : chHandle -> nat. + + (* HB.instance Definition _ : ordType chName := *) + (* _. *) + + (* ∀ n ∈ O: the path from psk to n contains an n' ∈ S. *) + (* If there exists a path from dh to an n ∈ O, then it contains an n' ∈ S. *) + Definition seperation_points := [BIND]. + Definition early := [BIND]. + Axiom BinderArgs : bitvec -> code fset0 fset0 chKey. + Axiom BinderHand : chHandle -> bitvec -> code fset0 fset0 chHandle. + + Axiom DhArgs : bitvec -> code fset0 fset0 (chProd chGroup chGroup). + Axiom DhHand : chHandle -> code fset0 fset0 chHandle. + + Axiom sort : (chProd chGroup chGroup) -> (chProd chGroup chGroup). + Axiom dh_angle : (chProd chGroup chGroup) -> chHandle. + + Check chKey. + Definition check d (n : name) (ℓ : nat) : + package fset0 + ([interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout] :|: [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout]) + ([interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]). + Proof. + refine ( + [package + #def #[ XPD n ℓ d ] ('(h1,r,args) : chXPDinp) : chXPDout { + #import {sig #[ GET BINDER ℓ d ] : chGETinp → chGETout } + as get_fn ;; + #import {sig #[ XPD n ℓ d ] : chXPDinp → chXPDout } + as xpd_fn ;; + (if name_eq n BIND + then + if r == false then assert (level h1 == 0) else ret Datatypes.tt ;; + if r == true then assert (level h1 >? 0) else ret Datatypes.tt + else + if name_to_chName n + \in + (fset (List.map name_to_chName seperation_points) + :&: fset (List.map name_to_chName early)) + then + binder ← BinderArgs args ;; + h_bndr ← BinderHand h1 args ;; + '(k, _) ← get_fn h_bndr ;; + assert (binder == k) + else + if n \in seperation_points + then + '(X,Y) ← DhArgs(args) ;; + let X : chGroup := X in + h_dh ← DhHand(h1) ;; + assert (h_dh == dh_angle (sort (X, Y))) ;; + binder ← BinderArgs(args) ;; + h_bndr ← BinderHand h1 args ;; + '(k, _) ← get_fn h_bndr ;; + assert (binder == k) + else ret Datatypes.tt) ;; + h ← xpd_fn (h1, r, args) ;; + ret h + } + ]). + ssprove_valid ; ssprove_valid'_2. + - unfold mkopsig. + rewrite <- fset1E. + rewrite <- fset_cons. + rewrite in_fset. + rewrite !in_cons. + now rewrite eqxx. + - unfold mkopsig. + rewrite <- fset1E. + rewrite <- fset_cons. + rewrite in_fset. + rewrite !in_cons. + now rewrite eqxx. + - unfold mkopsig. + rewrite <- fset1E. + rewrite <- fset_cons. + rewrite in_fset. + rewrite !in_cons. + now rewrite eqxx. + Defined. Definition G_check (d k : nat) (H_lt : (d <= k)%nat) : - package (L_K :|: L_L) + package fset0 (XPD_n d k :|: GET_n [BINDER] d k) (XPD_n d k). Proof. - Admitted. + unfold XPD_n. + unfold GET_n. unfold GET_ℓ. + fold (interface_hierarchy_foreach (λ n ℓ, [interface #val #[GET n ℓ k] : chXPDout → chGETout ]) [::BINDER] d). + + replace (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[XPD n ℓ k] : chXPDinp → chXPDout ]) XPR d + :|: interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXPDout → chGETout ]) [:: BINDER] + d) with (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[XPD n ℓ k] : chXPDinp → chXPDout ] :|: [interface #val #[GET BINDER ℓ k] : chXPDout → chGETout ]) XPR d). + 2:{ + rewrite <- interface_hierarchy_foreachU. + f_equal. + unfold interface_hierarchy_foreach. + f_equal. + apply functional_extensionality. intros. + now rewrite <- interface_foreach_trivial. + } + + refine (ℓ_packages + d + (fun n H_le => + parallel_package d XPR + (f := fun a => [interface #val #[XPD a n k] : chXPDinp → chXPDout ] :|: [interface #val #[GET BINDER n k] : chXPDout → chGETout ]) + (fun a => check k a n) _ _ _ + ) + (fun n H_le => + trimmed_parallel_raw + _ + _ + (trimmed_pairs_map _ _ _ _)) + (fun n ℓ i0 i1 => idents_foreach_disjoint_foreach _ _ XPR _) + ). + - intros. + unfold idents. + solve_imfset_disjoint. + - intros. + apply trimmed_package_cons. + apply trimmed_empty_package. + - reflexivity. + - intros. + unfold idents. + solve_imfset_disjoint. + - reflexivity. + - intros. + apply trimmed_package_cons. + apply trimmed_empty_package. + - intros. + unfold idents. + solve_imfset_disjoint. + Defined. Definition G_dh (d k : nat) (H_lt : (d <= k)%nat) : - package (L_K :|: L_L) + package fset0 (SET_ℓ [DH] k 0) - DH_interface. - Proof. - Admitted. + DH_interface := DH_package k. Definition I_star : seq name := [:: RM; ES; BIND; HS; AS; ESALT; HSALT]. Ltac solve_direct_in := rewrite !fsubUset ; repeat (apply /andP ; split) ; repeat (apply fsubsetxx || (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left))). - - Definition G_XTR_XPD (d k : nat) (H_lt : (d < k)%nat) : + + Definition G_XTR_XPD (d k : nat) (b : name -> bool) (H_lt : (d < k)%nat) : package fset0 ((GET_n [DH] d k :|: GET_n [PSK] d k @@ -1106,7 +1344,7 @@ Section Core. ) (XPD_n d k :|: XTR_n d k). Proof. - refine {package par (XPD_packages d k H_lt) (XTR_packages d k (ltnW H_lt))}. + refine {package par (XPD_packages d k H_lt) (XTR_packages d k b (ltnW H_lt))}. rewrite <- fsetUid. eapply valid_par_upto. - unfold XPD_, XTR_. @@ -1169,128 +1407,131 @@ Section Core. - apply fsubsetxx. Defined. - Lemma interface_foreach_trivial2 : forall {A} i L (* d *), - (L <> [] \/ i = [interface]) -> - i = (interface_foreach (λ (n : A), i) L ). + Definition idents_foreach_disjoint_foreach_in : + forall x y k index T1 T2 (Lf Lg : list name), + (forall x, x \in Lf -> x \notin Lg) -> + idents (interface_foreach (fun a => fset [(serialize_name a x k index, T1)]) Lf) + :#: idents (interface_foreach (fun a => fset [(serialize_name a y k index, T2)]) Lg). Proof. + clear ; intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. intros. - destruct H. - - destruct L ; [ easy | ]. - clear H. - generalize dependent a. - induction L ; intros. - { - rewrite interface_foreach_cons. - simpl. - rewrite <- fset0E. - rewrite fsetU0. - reflexivity. - } - { - rewrite interface_foreach_cons. - rewrite <- IHL. - now rewrite fsetUid. - } - - rewrite H. - induction L. - + reflexivity. - + rewrite interface_foreach_cons. - rewrite <- IHL. - now rewrite fsetUid. - Qed. - - Definition parallel_ID (L : seq name) (f : name -> Interface) : - (∀ x y, x ≠ y → idents (f x) :#: idents (f y)) -> - (uniq L) -> - (forall x, flat (f x)) -> - package fset0 (interface_foreach f L) (interface_foreach f L) := - fun H H0 H1 => - parallel_package d L - (fun x => {package ID (f x) #with valid_ID _ _ (H1 x)}) H - (fun x => trimmed_ID _) H0. - - Definition combined_ID (d : nat) (L : seq name) (f : name -> nat -> Interface) : - (forall n x y, x ≠ y → idents (f x n) :#: idents (f y n)) -> - (uniq L) -> - (forall n x, flat (f x n)) -> - (forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y, idents (f x ℓ) :#: idents (f y n)) -> - package fset0 (interface_hierarchy_foreach f L d) (interface_hierarchy_foreach f L d). - - intros. - refine (ℓ_packages d (fun x _ => parallel_ID L (f^~ x) _ _ _) _ _). - - intros. - unfold parallel_ID. - apply trimmed_parallel_raw. - + apply H. - + apply H0. - + apply trimmed_pairs_map. - intros. - unfold pack. - apply trimmed_ID. - - intros. - apply idents_foreach_disjoint_foreach. - intros. - now apply H2. - - Unshelve. - + intros. - now apply H. - + apply H0. - + apply H1. - Defined. - - Lemma reindex_interface_hierarchy_PSK2 : - forall d k, - (interface_hierarchy (λ n : nat, [interface #val #[SET PSK n k] : chUNQinp → chXTRout ]) d.+1) - = - ([interface #val #[SET PSK 0 k] : chUNQinp → chXTRout ] :|: interface_hierarchy - (λ n : nat, [interface #val #[SET PSK (n.+1) k] : chUNQinp → chXTRout ]) - d). - Proof. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. intros. - symmetry. - induction d ; intros. - - simpl. - reflexivity. - - simpl. - rewrite fsetUA. - rewrite IHd. - reflexivity. + unfold idents. + solve_imfset_disjoint. + apply serialize_name_notin_all. + left ; split ; [ reflexivity | right ]. + red ; intros ; subst. + specialize (H m H0). + now rewrite H1 in H. Qed. - Lemma interface_hierarchy_subset : forall f d K, - (forall (x : nat) (H : (x <= d)%nat), f x :<=: K) -> - interface_hierarchy f d :<=: K. + Ltac solve_idents := + repeat match goal with + | |- context [ idents ?a :#: idents (?b :|: ?c) ] => + unfold idents at 2 + ; rewrite (imfsetU _ b c) + ; fold (idents b) ; fold (idents c) + ; rewrite fdisjointUr + ; apply /andP ; split + | |- context [ idents (?a :|: ?b) :#: idents ?c ] => + unfold idents at 1 + ; rewrite (imfsetU _ a b) + ; fold (idents a) ; fold (idents b) + ; rewrite fdisjointUl + ; apply /andP ; split + | |- context [ idents (fset (?a :: ?b :: _)) ] => rewrite (fset_cons a) + | |- context [ ?K :#: idents (interface_hierarchy ?f ?d) ] => + apply idents_interface_hierachy3 ; intros + | |- context [ idents (interface_hierarchy ?f ?d) :#: ?K ] => + rewrite fdisjointC ; apply idents_interface_hierachy3 ; intros + | |- context [ idents (interface_foreach ?f ?L) :#: idents (interface_foreach ?g ?K) ] => + apply idents_foreach_disjoint_foreach_in + ; let H := fresh in + intros ? H + ; now repeat (move: H => /orP [ /eqP ? | H ]) ; subst + | |- context [ idents ?K :#: idents (interface_foreach ?f ?L) ] => + let H := fresh in + apply idents_disjoint_foreach_in + ; intros ? H + (* ; rewrite in_cons in H *) + (* ; repeat (move: H => /orP [ /eqP ? | H ]) ; subst *) + | |- context [ idents (interface_foreach ?f ?L) :#: ?K ] => + rewrite fdisjointC + end ; unfold idents ; solve_imfset_disjoint. + + Ltac solve_trimmed2 := + repeat match goal with + | |- context [ trimmed _ (trim _ _) ] => + apply trimmed_trim + | |- context [ trimmed ?E (parallel_raw _) ] => + eapply trimmed_parallel_raw + ; [ | | apply trimmed_pairs_map ; intros ] + ; [ | reflexivity | ] + ; [ | solve_trimmed2 ] + ; [ intros ; unfold idents ; solve_imfset_disjoint ] + | |- context [ trimmed _ (pack (ℓ_packages _ _ _ _)) ] => + apply trimmed_ℓ_packages + | |- context [ trimmed ?E (par ?a ?b) ] => + eapply trimmed_par ; [ | solve_trimmed2..] ; solve_idents + | |- context [ trimmed ?E (pack {| pack := _; |}) ] => + unfold pack + | |- context [ trimmed ?E (mkfmap (cons ?a ?b)) ] => + apply trimmed_package_cons + | |- context [ trimmed ?E (mkfmap nil) ] => + apply trimmed_empty_package + | |- context [ trimmed ?E (ID _) ] => + apply trimmed_ID + end. + + Lemma parable_link_l : forall a b c, Parable a b -> Parable (a ∘ c) b. Proof. intros. - induction d. - - now apply H. - - simpl. - rewrite fsubUset. - now rewrite H ; [ rewrite IHd | ]. + unfold Parable. + unfold "∘". + rewrite domm_map. + apply H. Qed. - Lemma interface_hierarchy_subsetR : forall f d K, - (exists (x : nat) (H : (x <= d)%nat), K :<=: f x) -> - K :<=: interface_hierarchy f d. + Lemma parable_link_r : forall a b c, Parable a b -> Parable a (b ∘ c). Proof. intros. - induction d. - - simpl. destruct H as [? []]. destruct x ; [ | easy ]. apply H. - - simpl. - destruct H as [? []]. - destruct (x == d.+1) eqn:x_is_d ; move: x_is_d => /eqP ? ; subst. - + apply fsubsetU. - now rewrite H. - + apply fsubsetU. - rewrite IHd ; [ easy | ]. - exists x. - eexists. - * Lia.lia. - * apply H. + unfold Parable. + unfold "∘". + rewrite domm_map. + apply H. Qed. - Definition G_ks (d k : nat) (H_lt : (d < k)%nat) : + Ltac split_Parable := + repeat match goal with + | |- context [ Parable ?a (par ?b ?c) ] => + apply ssp_helper.parable_par_r + | |- context [ Parable (par ?a ?b) ?c ] => + apply ssp_helper.parable_par_l + | |- context [ Parable ?a (?b ∘ ?c) ] => + apply parable_link_r + | |- context [ Parable (?a ∘ ?b) ?c ] => + apply parable_link_l + end. + + Ltac solve_Parable2 := + split_Parable ; + match goal with + | [ |- context [ Parable ?a ?b ] ] => + let H := fresh in + let H0 := fresh in + eassert (H : trimmed _ a) by solve_trimmed2 + ; rewrite <- H ; clear H + ; eassert (H0 : trimmed _ b) by solve_trimmed2 + ; rewrite <- H0 ; clear H0 + ; solve_Parable + ; solve_idents + end. + + Definition G_core (d k : nat) (b : bool) (H_lt : (d < k)%nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -1299,25 +1540,27 @@ Section Core. :|: XTR_n d k :|: GET_n O_star d k). Proof. - epose (par (G_check d k (ltnW H_lt)) (ID (XTR_n d k))). - - refine ({package (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _)) ∘ (par (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _) - (G_XTR_XPD d k H_lt))) + (G_XTR_XPD d k (fun _ => b) H_lt))) (par (G_dh d k (ltnW H_lt)) - (parallel_ID [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + (parallel_ID d [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names false erefl ∘ Ls k all_names Z erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => b) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt b ∘ L_package k PSK Z)) (Hash b)) } : _). + Unshelve. + all: try now (intros ; solve_idents). + all: try now (intros n x n0 u1 u2 ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?). + all: try now (intros n x u1 u2 ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?). + rewrite <- fsetUid. eapply valid_link. 1:{ @@ -1326,7 +1569,7 @@ Section Core. apply valid_par. 2: apply pack_valid. 2: apply parallel_ID. - admit. + shelve. } 2:{ eapply valid_link. @@ -1335,43 +1578,7 @@ Section Core. 3: apply pack_valid. 2: apply pack_valid. - eassert (trimmed _ (combined_ID d _ _ _ _ _ _)). - { - apply trimmed_ℓ_packages. - } - rewrite <- H ; clear H. - - unfold G_XTR_XPD. - unfold pack. - rewrite <- trimmed_xpd_package. - rewrite <- trimmed_xtr_package. - solve_Parable. - - unfold XPD_n. - apply idents_interface_hierachy3. - intros. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - apply idents_disjoint_foreach_in. - intros. - rewrite fdisjointC. - apply idents_disjoint_foreach_in. - intros. - unfold idents. - solve_imfset_disjoint. - - unfold XTR_n. - apply idents_interface_hierachy3. - intros. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - apply idents_disjoint_foreach_in. - intros. - rewrite fdisjointC. - apply idents_disjoint_foreach_in. - intros. - unfold idents. - solve_imfset_disjoint. + shelve. } rewrite fsetUA. @@ -1381,7 +1588,7 @@ Section Core. apply valid_par. 2: apply pack_valid. 2: apply pack_valid. - admit. + shelve. } 2: rewrite !fsetU0 ; apply fsubsetxx. @@ -1412,19 +1619,12 @@ Section Core. apply fsubsetxx. } 2: apply fsubsetxx. - (* instantiate (1 := XPD_n d k :|: XTR_n d k :|: GET_n O_star d k). *) - (* fold (XTR_n d k). *) - (* unfold GET_n. *) - (* unfold interface_hierarchy_foreach. *) - (* unfold GET_ℓ. *) - (* solve_in_fset. *) - (* } *) - admit. + shelve. } 2: solve_in_fset. { - admit. + shelve. } { apply fsubsetxx. @@ -1459,7 +1659,7 @@ Section Core. 2:{ eapply valid_link ; apply pack_valid. } - admit. + shelve. } rewrite (fsetUC (SET_n all_names _ _)). rewrite (fsetUA _ _ (SET_n I_star d k :|: SET_n O_star d k @@ -1522,7 +1722,7 @@ Section Core. } + apply fsubsetU. apply /orP ; left. - + eapply interface_hierarchy_subsetR. exists O, (leq0n d). simpl. @@ -1531,92 +1731,20 @@ Section Core. rewrite !fsetUA. solve_direct_in. } - admit. + shelve. } Unshelve. - { - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold flat. - intros. - - rewrite !in_fset in H, H0. - rewrite !(mem_seq1 (n0, _) (XTR x n k, _)) in H, H0. - move: H => /eqP ?. move: H0 => /eqP ?. - easy. - } - { - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold flat. - intros. - - rewrite !in_fset in H, H0. - rewrite !(mem_seq1 (n0, _) (GET x n k, _)) in H, H0. - move: H => /eqP ?. move: H0 => /eqP ?. - easy. - } - { - intros. - unfold idents. - solve_imfset_disjoint. - } -{ - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold flat. - intros. - - rewrite !in_fset in H, H0. - rewrite !(mem_seq1 (n0, _) (GET x n k, _)) in H, H0. - move: H => /eqP ?. move: H0 => /eqP ?. - easy. - } - { - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold idents. - solve_imfset_disjoint. - } - { - intros. - unfold flat. - intros. - - rewrite !in_fset in H, H0. - rewrite !(mem_seq1 (n, _) (SET x 0 k, _)) in H, H0. - move: H => /eqP H. move: H0 => /eqP H0. - inversion_clear H. inversion_clear H0. - reflexivity. - } - - - Admitted. + (** Parable *) + all: unfold G_dh, DH_package, combined_ID, parallel_ID, parallel_package. + all: unfold G_XTR_XPD, XPD_packages, XTR_packages, G_check, Ks, combined, eq_rect_r, eq_rect, pack, K_package. + all: repeat destruct Logic.eq_sym. + all: repeat destruct function2_fset_cat. + all: repeat destruct eq_ind. + all: repeat destruct Logic.eq_sym. + all: try rewrite <- trimmed_hash. + all: now solve_Parable2. + Time Defined. (* 36.626 *) Fail Next Obligation. - - - End Core. diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 6c94d9c8..372f00d8 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -88,6 +88,30 @@ Section CoreTheorem. Context {DepInstance : Dependencies}. Existing Instance DepInstance. + (* Definition Gcore_hyb : forall d (ℓ : nat), *) + (* package f_parameter_cursor_loc *) + (* ((GET_ℓ XPR d ℓ :|: SET_ℓ XPR d ℓ) *) + (* :|: (GET_DH_ℓ d ℓ :|: SET_DH_ℓ d ℓ) *) + (* :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] *) + (* :|: (GET_ℓ XTR_names d ℓ :|: SET_ℓ XTR_names d ℓ)) *) + (* (SET_O_star_ℓ d ℓ :|: GET_O_star_ℓ d ℓ). *) + (* Proof. *) + (* intros. *) + (* epose {package (Ks ℓ d _ O_star false erefl ∘ Ls ℓ O_star (fun x => F) erefl)}. *) + (* fold GET. *) + (* Admitted. *) + + (* Definition Gcore_ki : forall d k, *) + (* package f_parameter_cursor_loc *) + (* ((GET_n XPR d k :|: SET_n XPR d k) *) + (* :|: (GET_DH d k :|: SET_DH d k) *) + (* :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] *) + (* :|: (GET_n XTR_names d k :|: SET_n XTR_names d k)) *) + (* (SET_O_star d k :|: GET_O_star d k). *) + (* Proof. *) + (* intros. *) + (* Admitted. *) + Definition Gacr (f : HashFunction) (b : bool) : package fset0 [interface] @@ -136,477 +160,688 @@ Section CoreTheorem. Axiom R_sodh : package fset0 [interface] [interface]. Obligation Tactic := (* try timeout 8 *) idtac. - Program Definition layer1 ℓ d (H_le : (ℓ <= d)%nat) : - package fset0 - [interface] - [interface - #val #[ GET DH ℓ d ] : chGETinp → chGETout - ] := - {package Nk_package ℓ d H_le ∘ (par (DH_package d d) (Ls d [DH] Z erefl)) #with _ }. + (* Program Definition layer1 ℓ d (H_le : (ℓ <= d)%nat) : *) + (* package fset0 *) + (* [interface] *) + (* [interface *) + (* #val #[ GET DH ℓ d ] : chGETinp → chGETout *) + (* ] := *) + (* {package Nk_package ℓ d H_le ∘ (par (DH_package d) (Ls d [DH] Z erefl)) #with _ }. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Program Definition layer2_zero d k H_lt : *) + (* package fset0 *) + (* [interface *) + (* #val #[ SET PSK O k ] : chSETinp → chSETout *) + (* ] *) + (* [interface *) + (* #val #[ GET PSK O k ] : chGETinp → chGETout *) + (* ] := *) + (* {package Ks d k H_lt [PSK] false erefl ∘ Ls k [PSK] Z erefl #with _ }. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Program Definition layer2_succ ℓ d k H_lt (H_le : (ℓ <= d)%nat) : *) + (* package fset0 *) + (* [interface *) + (* #val #[ SET PSK ℓ d ] : chSETinp → chSETout *) + (* ] *) + (* [interface *) + (* #val #[ GET PSK ℓ d ] : chGETinp → chGETout *) + (* ] := *) + (* {package Ks d k H_lt [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Program Definition layer2_xpd ℓ k H_lt : *) + (* package (L_K :|: L_L) *) + (* [interface] *) + (* (XPD_n_ℓ k ℓ) := *) + (* XPD_ ℓ k H_lt. *) + (* Fail Next Obligation. *) + + (* Definition layer3 ℓ d (H_le : (ℓ <= d)%nat) := Hash. *) + + (* Program Definition layer4_salt d k H_lt : *) + (* package (L_K :|: L_L) *) + (* [interface] *) + (* (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ k ] : chGETinp → chGETout]) d) := *) + (* {package Ks d k H_lt [ZERO_SALT] false erefl ∘ Ls k [ZERO_SALT] Z erefl #with _}. *) + (* Next Obligation. *) + (* intros. *) + (* eapply valid_link. *) + (* 2: apply pack_valid. *) + + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* apply fsubsetU. *) + (* apply /orP ; right. *) + (* unfold interface_hierarchy_foreach. *) + (* unfold interface_foreach. *) + (* apply fsubsetxx. *) + (* Qed. *) + (* Fail Next Obligation. *) + + (* Program Definition layer4_ikm d k H_lt : *) + (* package (L_K :|: L_L) *) + (* [interface] *) + (* (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ k ] : chGETinp → chGETout]) d) := *) + (* {package Ks d k H_lt [ZERO_IKM] false erefl ∘ Ls k [ZERO_IKM] Z erefl #with _}. *) + (* Next Obligation. *) + (* intros. *) + (* eapply valid_link. *) + (* 2: apply pack_valid. *) + + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* apply fsubsetU. *) + (* apply /orP ; right. *) + (* unfold interface_hierarchy_foreach. *) + (* unfold interface_foreach. *) + (* apply fsubsetxx. *) + (* Qed. *) + (* Fail Next Obligation. *) + + (* Program Definition layer4_xtr ℓ d b H_le : *) + (* package fset0 *) + (* (XTR_n_ℓ d ℓ :|: GET_ℓ XTR_names d ℓ) *) + (* (SET_ℓ XTR_names d ℓ) := xtr_level d ℓ b H_le. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Program Definition layer4_check d k : *) + (* package fset0 *) + (* (XPD_n d k) *) + (* (XPD_n d k :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Program Definition layer4_xpd d k H_lt : *) + (* package fset0 *) + (* (XPD_n d k :|: SET_n XPR d k) *) + (* (GET_n XPR d k) := {package XPD_packages d k H_lt ∘ layer4_check d k #with _}. *) + (* Admit Obligations. *) + (* Fail Next Obligation. *) + + (* Lemma interface_foreach_cat : forall {A} f L1 L2, *) + (* interface_foreach f (L1 ++ L2) = *) + (* interface_foreach (A := A) f L1 :|: interface_foreach (A := A) f L2. *) + (* Proof. *) + (* induction L1 ; intros. *) + (* - simpl. *) + (* rewrite <- fset0E. *) + (* rewrite fset0U. *) + (* reflexivity. *) + (* - rewrite interface_foreach_cons. *) + (* rewrite <- fsetUA. *) + (* rewrite <- IHL1. *) + (* now rewrite <- interface_foreach_cons. *) + (* Qed. *) + + (* Definition xpd_xpr_approximation *) + (* (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) + (* package (L_K :|: L_L) *) + (* [interface] *) + (* (XPD_n d k :|: XTR_n d k). *) + (* Proof. *) + (* refine ({package par (XPD_ d k H_lt) (XTR_ d k b (ltnW H_lt))}). *) + (* unfold XPD_, XTR_. *) + (* unfold pack. *) + + (* eapply valid_par_upto. *) + (* 2: apply XPD_. *) + (* 2: apply XTR_. *) + (* 2:{ *) + (* rewrite fsetUid. *) + (* apply fsubsetxx. *) + (* } *) + (* 3: apply fsubsetxx. *) + (* 2:{ *) + (* rewrite <- fset0E. *) + (* rewrite fsetU0. *) + (* apply fsub0set. *) + (* } *) + (* rewrite <- trimmed_xpd_package. *) + (* rewrite <- trimmed_xtr_package. *) + (* rewrite !link_trim_commut. *) + (* solve_Parable. *) + (* unfold XPD_n, XTR_n. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* rewrite fdisjointC. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* Defined. *) + + (* Definition core_approximation *) + (* (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) + (* package (L_K :|: L_L) *) + (* (GET_n O_star d k) *) + (* (XPD_n d k :|: XTR_n d k). *) + (* Proof. *) + (* (* epose (Ks d k (ltnW H_lt) O_star false erefl). *) *) + + (* refine ({package (par *) + (* (XPD_packages d k H_lt *) + (* ∘ par *) + (* (Ks d.+1 k H_lt (undup (XPR ++ XPR_parents)) false erefl *) + (* ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) Hash) *) + (* (XTR_packages d k b (ltnW (m:=d) (n:=k) H_lt) *) + (* ∘ Ks d k (ltnW (m:=d) (n:=k) H_lt) (undup (XTR_parent_names ++ XTR_names)) false erefl *) + (* ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl))}). *) + (* unfold XPD_, XTR_. *) + (* unfold pack. *) + + (* eapply valid_par_upto. *) + (* 2: apply XPD_. *) + (* 2: apply XTR_. *) + (* 2:{ *) + (* rewrite fsetUid. *) + (* apply fsubsetxx. *) + (* } *) + (* 3: apply fsubsetxx. *) + (* 2:{ *) + (* rewrite <- fset0E. *) + (* rewrite fsetU0. *) + (* apply fsub0set. *) + (* } *) + (* rewrite <- trimmed_xpd_package. *) + (* rewrite <- trimmed_xtr_package. *) + (* rewrite !link_trim_commut. *) + + (* solve_Parable. *) + (* unfold XPD_n, XTR_n. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* rewrite fdisjointC. *) + (* apply idents_interface_hierachy3. *) + (* intros. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* Defined. *) + + (* Definition core (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) + (* package fset0 *) + (* (interface_hierarchy (fun x => [interface]) d) *) + (* (GET_O_star d k). *) + (* Proof. *) + (* refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. *) + (* 2:{ *) + (* unfold GET_O_star. *) + (* unfold GET_n. *) + (* unfold SET_n. *) + (* rewrite interface_hierarchy_foreachU. *) + + (* apply interface_hierarchy_foreach_subset. *) + (* intros. *) + (* apply interface_hierarchy_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* assert (x \in all_names). *) + (* { *) + (* clear -H. *) + (* rewrite !in_cons in H. *) + (* unfold all_names. *) + (* rewrite !in_cons. *) + (* repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* exists H1. *) + (* exists ℓ, H0. *) + (* apply fsubsetUl. *) + (* } *) + + (* unfold GET_n. *) + (* unfold SET_n. *) + (* rewrite interface_hierarchy_foreachU. *) + + (* refine (ℓ_packages d _ _ _). *) + (* (* 2:{ *) *) + (* (* intros. *) *) + (* (* apply idents_foreach_disjoint_foreach. *) *) + (* (* intros. *) *) + (* (* unfold idents. *) *) + (* (* solve_imfset_disjoint. *) *) + (* (* } *) *) + + (* Unshelve. *) + (* 3:{ *) + (* intros n H. *) + + (* epose (dh := layer1 n d H). *) + (* epose proof (layer2_xpd n k (ltac:(Lia.lia))). *) + (* epose (hash := layer3 n d H). *) + (* epose (salt0 := layer4_salt d k (ltnW H_lt)). *) + (* epose (ikm0 := layer4_ikm d k (ltnW H_lt)). *) + (* epose (check := layer4_check d k). *) + (* epose (xtr := layer4_xtr n d b H). *) + (* epose (xpd := layer4_xpd d k H_lt). *) + + (* epose (T := package fset0 *) + (* [interface] *) + (* (match n with *) + (* | O => [interface] *) + (* | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) *) + (* end)). *) + + (* epose (set_xtr := fun psk (sub_packages : T) => {package *) + (* xtr ∘ *) + (* parallel_raw [ *) + (* pack dh; *) + (* pack psk; *) + (* pack hash; *) + (* pack salt0; *) + (* pack ikm0; *) + (* pack sub_packages] *) + (* #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). *) + (* (* Unshelve. *) *) + (* (* { *) *) + + (* (* } *) *) + + (* epose (set_xpd := fun psk (sub_packages : T) => {package *) + (* xpd ∘ *) + (* parallel_raw [ *) + (* pack dh; *) + (* pack psk; *) + (* pack hash; *) + (* pack salt0; *) + (* pack ikm0; *) + (* pack sub_packages] *) + (* #with _} : package fset0 [interface] (SET_ℓ XPR k n)). *) + + (* (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) *) + (* (* (parallel_raw [ *) *) + (* (* pack (set_xtr psk sub_packages); *) *) + (* (* pack (set_xpd psk sub_packages); *) *) + (* (* pack (Ls d O_star Z _)]) #with _}). *) *) + (* epose (output := fun psk *) + (* (sub_packages : T) => *) + (* {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ *) + (* (parallel_raw [ *) + (* pack (set_xtr psk sub_packages); *) + (* pack (set_xpd psk sub_packages); *) + (* pack (Ls d all_names Z _)]) #with _}). *) + + + (* assert (package fset0 *) + (* [interface] *) + (* (interface_foreach (λ name, *) + (* [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). *) + (* { *) + (* induction n as [ | ℓ ]. *) + (* - epose (psk0 := layer2_zero d k (ltnW H_lt)). *) + (* refine (output psk0 _). *) + (* refine {package emptym #with valid_empty_package _ _}. *) + (* - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). *) + (* refine (output pskS _). *) + (* specialize (IHℓ (leq_trans H (leqnSn _))). *) + (* unfold T. *) + (* eapply IHℓ. *) + (* } *) + + (* refine {package X0 #with _}. *) + (* Show Proof. *) + (* } *) + (* { *) + (* intros. *) + (* unfold pack. *) + (* destruct n. *) + (* - unfold nat_rect. *) + (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) + (* { *) + (* intros. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* unfold parallel_package. *) + (* rewrite <- (trimmed_parallel_raw (f := (λ n : name, *) + (* [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] *) + (* :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) + (* { *) + (* rewrite !link_trim_commut. *) + (* apply trimmed_trim. *) + (* } *) + (* { *) + (* intros. *) + (* unfold idents. *) + (* try rewrite !imfsetU *) + (* ; try rewrite !fdisjointUr *) + (* ; try rewrite !fdisjointUl *) + (* ; try rewrite <- !fset1E *) + (* ; try rewrite !imfset1 *) + (* ; try rewrite !fdisjoints1 *) + (* ; repeat (apply /andP ; split) *) + (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) + (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) + (* (* solve_imfset_disjoint. *) *) + (* } *) + (* { *) + (* reflexivity. *) + (* } *) + (* { *) + (* apply trimmed_pairs_map. *) + (* intros. *) + (* rewrite <- H. *) + (* set (K_package _ _ _ _ _). *) + (* rewrite fsetUC. *) + (* rewrite <- fset1E. *) + (* rewrite <- fset_cons. *) + (* apply trimmed_trim. *) + (* } *) + (* - unfold nat_rect. *) + (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) + (* { *) + (* intros. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_package_cons. *) + (* apply trimmed_empty_package. *) + (* } *) + (* unfold parallel_package. *) + (* rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, *) + (* [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] *) + (* :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) + (* { *) + (* (* set (parallel_raw _). *) *) + (* rewrite (* ! *)link_trim_commut. *) + (* apply trimmed_trim. *) + (* } *) + (* { *) + (* intros. *) + (* unfold idents. *) + (* try rewrite !imfsetU *) + (* ; try rewrite !fdisjointUr *) + (* ; try rewrite !fdisjointUl *) + (* ; try rewrite <- !fset1E *) + (* ; try rewrite !imfset1 *) + (* ; try rewrite !fdisjoints1 *) + (* ; repeat (apply /andP ; split) *) + (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) + (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) + (* (* solve_imfset_disjoint. *) *) + (* } *) + (* { *) + (* reflexivity. *) + (* } *) + (* { *) + (* apply trimmed_pairs_map. *) + (* intros. *) + (* rewrite <- H. *) + (* set (K_package _ _ _ _ _). *) + (* rewrite fsetUC. *) + (* rewrite <- fset1E. *) + (* rewrite <- fset_cons. *) + (* apply trimmed_trim. *) + (* } *) + (* } *) + (* { *) + (* intros. *) + (* apply idents_foreach_disjoint_foreach. *) + (* intros. *) + (* unfold idents. *) + (* solve_imfset_disjoint. *) + (* } *) + + (* Unshelve. *) + (* { *) + (* ssprove_valid. *) + (* 1:{ *) + (* eapply valid_package_inject_import. *) + (* 2:{ *) + (* unfold XTR_n_ℓ. *) + (* unfold GET_ℓ. *) + (* rewrite interface_foreach_U. *) + + (* unfold parallel_raw, List.fold_left. *) + (* unfold XTR_names, interface_foreach. *) + + (* (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) *) + + (* ssprove_valid. *) + (* all: try apply fsubsetxx. *) + (* 1-5: admit. *) + (* admit. *) + (* } *) + (* rewrite <- !fset0E. *) + (* rewrite !fsetU0 ; rewrite !fset0U. *) + (* admit. *) + (* } *) + (* { *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !fsetU0 ; rewrite !fset0U. *) + (* rewrite fsetUid. *) + (* admit. *) + (* } *) + (* } *) + (* all: admit. *) + (* Admitted. *) + + Notation " 'chXTRinp' " := + (chHandle × chHandle) + (in custom pack_type at level 2). + Notation " 'chXTRout' " := + (chHandle) + (in custom pack_type at level 2). + + (* Page 70 *) + Program Definition G_core_Hash (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun _ => false) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_zero d k H_lt : - package fset0 - [interface - #val #[ SET PSK O k ] : chSETinp → chSETout - ] - [interface - #val #[ GET PSK O k ] : chGETinp → chGETout - ] := - {package Ks d k H_lt [PSK] false erefl ∘ Ls k [PSK] Z erefl #with _ }. + Program Definition G_core_D (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun _ => false) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_succ ℓ d k H_lt (H_le : (ℓ <= d)%nat) : - package fset0 - [interface - #val #[ SET PSK ℓ d ] : chSETinp → chSETout - ] - [interface - #val #[ GET PSK ℓ d ] : chGETinp → chGETout - ] := - {package Ks d k H_lt [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. + Program Definition G_core_R_esalt (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun _ => false) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Program Definition layer2_xpd ℓ k H_lt : + Program Definition G_core_SODH (d k : nat) (H_lt : (d < k)%nat) : package (L_K :|: L_L) - [interface] - (XPD_n_ℓ k ℓ) := - XPD_ ℓ k H_lt. + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + (* Gcore_sodh d k false. *) + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. + Admit Obligations. Fail Next Obligation. - Definition layer3 ℓ d (H_le : (ℓ <= d)%nat) := Hash. - - Program Definition layer4_salt d k H_lt : - package (L_K :|: L_L) - [interface] - (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ k ] : chGETinp → chGETout]) d) := - {package Ks d k H_lt [ZERO_SALT] false erefl ∘ Ls k [ZERO_SALT] Z erefl #with _}. - Next Obligation. - intros. - eapply valid_link. - 2: apply pack_valid. - - eapply valid_package_inject_export. - 2: apply pack_valid. - apply fsubsetU. - apply /orP ; right. - unfold interface_hierarchy_foreach. - unfold interface_foreach. - apply fsubsetxx. - Qed. - Fail Next Obligation. +HB.instance Definition _ : Equality.axioms_ name := + {| + Equality.eqtype_hasDecEq_mixin := + {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} + |}. - Program Definition layer4_ikm d k H_lt : + Definition N_star := all_names. (* TODO *) + Program Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : package (L_K :|: L_L) - [interface] - (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ k ] : chGETinp → chGETout]) d) := - {package Ks d k H_lt [ZERO_IKM] false erefl ∘ Ls k [ZERO_IKM] Z erefl #with _}. - Next Obligation. - intros. - eapply valid_link. - 2: apply pack_valid. - - eapply valid_package_inject_export. - 2: apply pack_valid. - apply fsubsetU. - apply /orP ; right. - unfold interface_hierarchy_foreach. - unfold interface_foreach. - apply fsubsetxx. - Qed. - Fail Next Obligation. - - Program Definition layer4_xtr ℓ d H_le : - package fset0 - (XTR_n_ℓ d ℓ :|: GET_ℓ XTR_names d ℓ) - (SET_ℓ XTR_names d ℓ) := xtr_level d ℓ H_le. + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if ℓ >=? i then false else true + else false) erefl + ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) + (K_package k PSK d.+1 H_lt (i == d.+1) ∘ L_package k PSK D)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Program Definition layer4_check d k : - package fset0 - (XPD_n d k) - (XPD_n d k :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. + (* Idealization order (hybridazation argument for a given level) *) + Program Definition G_core_hyb_pred_ℓ_c (d k : nat) (H_lt : (d < k)%nat) (i : nat) (C : list name) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if (ℓ + (name \in C)) >=? i then false else true + else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Program Definition layer4_xpd d k H_lt : - package fset0 - (XPD_n d k :|: SET_n XPR d k) - (GET_n XPR d k) := {package XPD_packages d k H_lt ∘ layer4_check d k #with _}. + (* Idealization order (hybridazation argument for a given level) *) + Program Definition G_core_ki (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d.+1 H_lt true ∘ L_package k PSK D)) (Hash true)) + }. Admit Obligations. Fail Next Obligation. - Lemma interface_foreach_cat : forall {A} f L1 L2, - interface_foreach f (L1 ++ L2) = - interface_foreach (A := A) f L1 :|: interface_foreach (A := A) f L2. - Proof. - induction L1 ; intros. - - simpl. - rewrite <- fset0E. - rewrite fset0U. - reflexivity. - - rewrite interface_foreach_cons. - rewrite <- fsetUA. - rewrite <- IHL1. - now rewrite <- interface_foreach_cons. - Qed. - - Definition xpd_xpr_approximation - (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k :|: XTR_n d k). - Proof. - refine ({package par (XPD_ d k H_lt) (XTR_ d k (ltnW H_lt))}). - unfold XPD_, XTR_. - unfold pack. - - eapply valid_par_upto. - 2: apply XPD_. - 2: apply XTR_. - 2:{ - rewrite fsetUid. - apply fsubsetxx. - } - 3: apply fsubsetxx. - 2:{ - rewrite <- fset0E. - rewrite fsetU0. - apply fsub0set. - } - rewrite <- trimmed_xpd_package. - rewrite <- trimmed_xtr_package. - rewrite !link_trim_commut. - solve_Parable. - unfold XPD_n, XTR_n. - apply idents_interface_hierachy3. - intros. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - unfold idents. - solve_imfset_disjoint. - Defined. - - Definition core_approximation - (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - (GET_n O_star d k) - (XPD_n d k :|: XTR_n d k). - Proof. - (* epose (Ks d k (ltnW H_lt) O_star false erefl). *) - - refine ({package (par - (XPD_packages d k H_lt - ∘ par - (Ks d.+1 k H_lt (undup (XPR ++ XPR_parents)) false erefl - ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) Hash) - (XTR_packages d k (ltnW (m:=d) (n:=k) H_lt) - ∘ Ks d k (ltnW (m:=d) (n:=k) H_lt) (undup (XTR_parent_names ++ XTR_names)) false erefl - ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl))}). - unfold XPD_, XTR_. - unfold pack. - - eapply valid_par_upto. - 2: apply XPD_. - 2: apply XTR_. - 2:{ - rewrite fsetUid. - apply fsubsetxx. - } - 3: apply fsubsetxx. - 2:{ - rewrite <- fset0E. - rewrite fsetU0. - apply fsub0set. - } - rewrite <- trimmed_xpd_package. - rewrite <- trimmed_xtr_package. - rewrite !link_trim_commut. - - solve_Parable. - unfold XPD_n, XTR_n. - apply idents_interface_hierachy3. - intros. - rewrite fdisjointC. - apply idents_interface_hierachy3. - intros. - unfold idents. - solve_imfset_disjoint. - Defined. - - Definition core (d k : nat) (H_lt : (d < k)%nat) : - package fset0 - (interface_hierarchy (fun x => [interface]) d) - (GET_O_star d k). - Proof. - refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. - 2:{ - unfold GET_O_star. - unfold GET_n. - unfold SET_n. - rewrite interface_hierarchy_foreachU. - - apply interface_hierarchy_foreach_subset. - intros. - apply interface_hierarchy_foreach_subsetR. - 2: easy. - exists x. - assert (x \in all_names). - { - clear -H. - rewrite !in_cons in H. - unfold all_names. - rewrite !in_cons. - repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. - all: now rewrite eqxx. - } - exists H1. - exists ℓ, H0. - apply fsubsetUl. - } - - unfold GET_n. - unfold SET_n. - rewrite interface_hierarchy_foreachU. - - refine (ℓ_packages d _ _ _). - (* 2:{ *) - (* intros. *) - (* apply idents_foreach_disjoint_foreach. *) - (* intros. *) - (* unfold idents. *) - (* solve_imfset_disjoint. *) - (* } *) - - Unshelve. - 3:{ - intros n H. - - epose (dh := layer1 n d H). - epose proof (layer2_xpd n k (ltac:(Lia.lia))). - epose (hash := layer3 n d H). - epose (salt0 := layer4_salt d k (ltnW H_lt)). - epose (ikm0 := layer4_ikm d k (ltnW H_lt)). - epose (check := layer4_check d k). - epose (xtr := layer4_xtr n d H). - epose (xpd := layer4_xpd d k H_lt). - - epose (T := package fset0 - [interface] - (match n with - | O => [interface] - | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) - end)). - - epose (set_xtr := fun psk (sub_packages : T) => {package - xtr ∘ - parallel_raw [ - pack dh; - pack psk; - pack hash; - pack salt0; - pack ikm0; - pack sub_packages] - #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). - (* Unshelve. *) - (* { *) - - (* } *) - - epose (set_xpd := fun psk (sub_packages : T) => {package - xpd ∘ - parallel_raw [ - pack dh; - pack psk; - pack hash; - pack salt0; - pack ikm0; - pack sub_packages] - #with _} : package fset0 [interface] (SET_ℓ XPR k n)). - - (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) - (* (parallel_raw [ *) - (* pack (set_xtr psk sub_packages); *) - (* pack (set_xpd psk sub_packages); *) - (* pack (Ls d O_star Z _)]) #with _}). *) - epose (output := fun psk - (sub_packages : T) => - {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ - (parallel_raw [ - pack (set_xtr psk sub_packages); - pack (set_xpd psk sub_packages); - pack (Ls d all_names Z _)]) #with _}). - - - assert (package fset0 - [interface] - (interface_foreach (λ name, - [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). - { - induction n as [ | ℓ ]. - - epose (psk0 := layer2_zero d k (ltnW H_lt)). - refine (output psk0 _). - refine {package emptym #with valid_empty_package _ _}. - - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). - refine (output pskS _). - specialize (IHℓ (leq_trans H (leqnSn _))). - unfold T. - eapply IHℓ. - } - - refine {package X0 #with _}. - Show Proof. - } - { - intros. - unfold pack. - destruct n. - - unfold nat_rect. - eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). - { - intros. - apply trimmed_package_cons. - apply trimmed_package_cons. - apply trimmed_empty_package. - } - unfold parallel_package. - rewrite <- (trimmed_parallel_raw (f := (λ n : name, - [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] - :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). - { - rewrite !link_trim_commut. - apply trimmed_trim. - } - { - intros. - unfold idents. - try rewrite !imfsetU - ; try rewrite !fdisjointUr - ; try rewrite !fdisjointUl - ; try rewrite <- !fset1E - ; try rewrite !imfset1 - ; try rewrite !fdisjoints1 - ; repeat (apply /andP ; split) - ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). - all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). - (* solve_imfset_disjoint. *) - } - { - reflexivity. - } - { - apply trimmed_pairs_map. - intros. - rewrite <- H. - set (K_package _ _ _ _ _). - rewrite fsetUC. - rewrite <- fset1E. - rewrite <- fset_cons. - apply trimmed_trim. - } - - unfold nat_rect. - eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). - { - intros. - apply trimmed_package_cons. - apply trimmed_package_cons. - apply trimmed_empty_package. - } - unfold parallel_package. - rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, - [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] - :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). - { - rewrite !link_trim_commut. - apply trimmed_trim. - } - { - intros. - unfold idents. - try rewrite !imfsetU - ; try rewrite !fdisjointUr - ; try rewrite !fdisjointUl - ; try rewrite <- !fset1E - ; try rewrite !imfset1 - ; try rewrite !fdisjoints1 - ; repeat (apply /andP ; split) - ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). - all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). - (* solve_imfset_disjoint. *) - } - { - reflexivity. - } - { - apply trimmed_pairs_map. - intros. - rewrite <- H. - set (K_package _ _ _ _ _). - rewrite fsetUC. - rewrite <- fset1E. - rewrite <- fset_cons. - apply trimmed_trim. - } - } - { - intros. - apply idents_foreach_disjoint_foreach. - intros. - unfold idents. - solve_imfset_disjoint. - } - - Unshelve. - { - ssprove_valid. - 1:{ - eapply valid_package_inject_import. - 2:{ - unfold XTR_n_ℓ. - unfold GET_ℓ. - rewrite interface_foreach_U. - - unfold parallel_raw, List.fold_left. - unfold XTR_names, interface_foreach. - - (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) - - ssprove_valid. - all: try apply fsubsetxx. - 1-5: admit. - admit. - } - rewrite <- !fset0E. - rewrite !fsetU0 ; rewrite !fset0U. - admit. - } - { - apply fsubsetxx. - } - { - rewrite !fsetU0 ; rewrite !fset0U. - rewrite fsetUid. - admit. - } - } - all: admit. - Admitted. - Lemma core_theorem : forall (d k : nat) H_lt, forall (Score : Simulator d k), forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → (AdvantageE - (Gcore_real d k H_lt) - (Gcore_ideal d k (ltnW H_lt) Score) (A (* ∘ R d M H *)) + (G_ks d k false H_lt) + (G_ks d k true H_lt) (A (* ∘ R d M H *)) <= sumR_l [R_cr; (R_Z f_hash); R_D] (fun R => Advantage (Gacr f_hash) (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (Gcore_sodh d k false) (Gcore_ideal d k (ltnW H_lt) Score) (Ai A i)) + +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (G_core_SODH d k H_lt) (G_ks d k true H_lt) (Ai A i)) )%R. Proof. intros. @@ -614,61 +849,156 @@ Section CoreTheorem. rewrite addr0. rewrite addrA. - unfold Gcore_real. - unfold pack. + (* unfold G_ks. *) + (* unfold pack. *) - epose Advantage_link. + (* epose Advantage_link. *) (* unfold Gacr. *) (* simpl. *) (* simpl. *) Admitted. + Lemma advantage_reflexivity : + forall P A, AdvantageE P P A = 0%R. + Proof. + unfold AdvantageE. + intros. + rewrite subrr. + rewrite Num.Theory.normr0. + reflexivity. + Qed. + Lemma equation20_lhs : - forall (d k : nat), - forall (Score : Simulator d k), + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_sodh d k false) (Gcore_hyb d 0) (Ai A i) = 0)%R. + (AdvantageE (G_core_SODH d k H_lt) (G_core_hyb_ℓ d k H_lt 0) (Ai A i) = 0)%R. Proof. intros. + + unfold G_core_SODH. + unfold G_core_hyb_ℓ. + + unfold pack. + rewrite <- !Advantage_link. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + setoid_rewrite (Advantage_par (Hash true)). + 2,3,4,5,6,7,8: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). + 2,3,4,5,6,7,8: admit. + + replace (λ (ℓ : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) then if ℓ >=? 0%N then false else true else false) + with + (λ (ℓ : nat) (name : ExtraTypes.name), false). + 2:{ + apply functional_extensionality. + intros. + apply functional_extensionality. + intros. + destruct (_ || _) ; [ | reflexivity ]. + now destruct x. + } + + apply advantage_reflexivity. Admitted. Lemma equation20_rhs : - forall (d k : nat), - forall (Score : Simulator d k), + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_ki d k) (Gcore_hyb d d) (Ai A i) = 0)%R. + (AdvantageE (G_core_ki d k H_lt) (G_core_hyb_ℓ d k H_lt d.+1) (Ai A i) = 0)%R. Proof. intros. + + unfold G_core_ki. + unfold G_core_hyb_ℓ. + + unfold pack. + rewrite <- !Advantage_link. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + setoid_rewrite (Advantage_par (Hash true)). + 2,3,4,5,6,7,8: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + rewrite eqxx. + + setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). + 2,3,4,5,6,7,8: admit. + + replace (λ (ℓ : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) then if ℓ >=? d.+1 then false else true else false) + with + (λ (ℓ : nat) (name : ExtraTypes.name), true). + 2:{ + admit. + } + + apply advantage_reflexivity. Admitted. Lemma hyb_telescope : - forall (d k : nat), + forall (d k : nat) H_lt, forall (Score : Simulator d k), (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_hyb d 0) (Gcore_hyb d d) (Ai A i) - = sumR 0 d (leq0n d) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ+1)) (Ai A i)) + (AdvantageE (G_core_hyb_ℓ d k H_lt 0) (G_core_hyb_ℓ d k H_lt d.+1) (Ai A i) + = sumR 0 d.+1 (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ+1)) (Ai A i)) )%R. Proof. intros. - set (d) at 1 2 6 7. + set d in H_lt |- * at 1 2 6 7. generalize dependent n. + generalize dependent (leq0n d). induction d ; intros. - unfold sumR. - simpl. + (* simpl. *) + simpl iota. unfold AdvantageE. - rewrite subrr. - rewrite Num.Theory.normr0. + unfold List.fold_left. + rewrite add0r. + rewrite add0n. reflexivity. + (* rewrite subrr. *) + (* rewrite Num.Theory.normr0. *) + (* reflexivity. *) + - rewrite sumR_succ. - (* unfold Gcore_hyb. *) + epose (IHd _ _ _ _ H_lt). + rewrite <- e. + + admit. Admitted. Lemma equation20_eq : @@ -678,27 +1008,27 @@ Section CoreTheorem. forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (Gcore_sodh d k false) (Gcore_ideal d k H_lt Score) (Ai A i) - <= AdvantageE (Gcore_ki d k) (Gcore_ideal d k H_lt Score) (Ai A i) - +sumR 0 d (leq0n d) (fun ℓ => AdvantageE (Gcore_hyb d ℓ) (Gcore_hyb d (ℓ + 1)) (Ai A i)) + (AdvantageE (G_core_SODH d k H_lt) (G_ks d k true H_lt) (Ai A i) + <= AdvantageE (G_core_ki d k H_lt) (G_ks d k true H_lt) (Ai A i) + +sumR 0 d.+1 (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ + 1)) (Ai A i)) )%R. Proof. intros. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb d 0)). - rewrite (equation20_lhs d k Score). + instantiate (1 := (G_core_hyb_ℓ d k H_lt 0)). + rewrite (equation20_lhs d k H_lt). rewrite add0r. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := Gcore_ki d k). - rewrite addrC. + instantiate (1 := G_core_ki d k H_lt). + rewrite <- (addrC (AdvantageE (G_core_ki d k H_lt) (G_ks d k true H_lt) (Ai A i)))%R. apply Num.Theory.lerD ; [ easy | ]. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (Gcore_hyb d d)). + instantiate (1 := (G_core_hyb_ℓ d k H_lt d.+1)). - epose (e := equation20_rhs d k Score). + epose (e := equation20_rhs d k (* Score *)). setoid_rewrite (Advantage_sym _ _) in e. rewrite e ; clear e. rewrite addr0. diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index 0b0dc632..3b360b70 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -101,7 +101,7 @@ Section KeyPackages. (* Fig 13-14. K key and log *) (* Axiom exists_h_star : (chHandle -> raw_code 'unit) -> raw_code 'unit. *) - Inductive ZAF := | Z | A | F. + Inductive ZAF := | Z | A | F | D | R. (* Axiom level : chHandle -> nat. *) @@ -200,7 +200,7 @@ Section KeyPackages. Defined. Fail Next Obligation. - Definition Ls d (Names : list name) (P : ZAF) : + Definition Ls d (Names : list name) (P : name -> ZAF) : uniq Names -> package (L_L) @@ -213,7 +213,7 @@ Section KeyPackages. destruct Names. - exact ({package emptym #with valid_empty_package L_L [interface]}). - rewrite (interface_foreach_trivial [interface] (n :: Names)) ; [ | easy ]. - refine (parallel_package d (n :: Names) (fun a => L_package _ _ P) _ _ H). + refine (parallel_package d (n :: Names) (fun a => L_package _ _ (P a)) _ _ H). + intros. unfold idents. solve_imfset_disjoint. @@ -222,11 +222,11 @@ Section KeyPackages. apply trimmed_empty_package. Defined. - Lemma trimmed_Ls d (Names : _) : + Lemma trimmed_Ls d (Names : _) P : forall (H : uniq Names), trimmed (interface_foreach (fun n =>[interface #val #[ UNQ n d ] : chUNQinp → chUNQout - ]) Names) (Ls d Names F H). + ]) Names) (Ls d Names P H). Proof. intros. unfold Ls. @@ -254,7 +254,7 @@ Section KeyPackages. forall {A B : eqType} {T} x xs, (fun (a : A) (b : B) => fset (x a b :: xs a b)) = (fun (a : A) (b : B) => fset (T := T) ([x a b]) :|: fset (xs a b)). Proof. now setoid_rewrite <- (fset_cat). Qed. - Definition Ks (d k : nat) (H_lt : (d <= k)%nat) (Names : list name) (b : bool) : + Definition Ks (d k : nat) (H_lt : (d <= k)%nat) (Names : list name) (b : nat -> name -> bool) : uniq Names -> package (L_K) @@ -272,7 +272,7 @@ Section KeyPackages. (λ (n : name) (ℓ : nat), [interface #val #[SET n ℓ k] : chUNQinp → chDHEXPout ; #val #[GET n ℓ k] : chDHEXPout → chGETout]) - Names (fun n H0 y => K_package k y n (leq_trans H0 H_lt) b) _ _ _ H). + Names (fun n H0 y => K_package k y n (leq_trans H0 H_lt) (b n y)) _ _ _ H). - intros. rewrite fset_cons. rewrite fdisjointC. @@ -313,25 +313,24 @@ Section KeyPackages. apply (trimmed_ℓ_packages). Qed. -(* Fig 15 *) - -Definition Nk_package (d k : nat) (_ : (d <= k)%nat) : - package - L_K - [interface - #val #[ UNQ DH k ] : chUNQinp → chUNQout - ] - (SET_n [DH] d k :|: GET_n [DH] d k) + (* Fig 15 *) + Definition Nk_package (d k : nat) (_ : (d <= k)%nat) : + package + L_K + [interface + #val #[ UNQ DH k ] : chUNQinp → chUNQout + ] + (SET_n [DH] d k :|: GET_n [DH] d k) (* [interface *) (* #val #[ SET DH ℓ k ] : chSETinp → chSETout ; *) (* #val #[ GET DH ℓ k ] : chGETinp → chGETout *) (* ] *). - epose ℓ_packages. - unfold SET_n. - unfold GET_n. - rewrite interface_hierarchy_U. - rewrite (interface_hierarchy_trivial [interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ] d). - refine (ℓ_packages d + epose ℓ_packages. + unfold SET_n. + unfold GET_n. + rewrite interface_hierarchy_U. + rewrite (interface_hierarchy_trivial [interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ] d). + refine (ℓ_packages d (fun ℓ _ => [package #def #[ SET DH ℓ k ] ('(h,hon,key) : chSETinp) : chSETout { @@ -351,82 +350,82 @@ Definition Nk_package (d k : nat) (_ : (d <= k)%nat) : ret (k, hon) } ]) _ _). - { - intros. + { + intros. + unfold SET_ℓ, GET_ℓ. + unfold interface_foreach. + unfold pack. + rewrite <- fset1E. + rewrite <- fset_cons. + apply (trimmed_package_cons). + apply (trimmed_package_cons). + apply (trimmed_empty_package). + } + { + intros. + unfold SET_ℓ, GET_ℓ. + unfold interface_foreach. + unfold idents. + solve_imfset_disjoint. + } + + Unshelve. + all: try apply DepInstance. + unfold SET_ℓ, GET_ℓ. unfold interface_foreach. - unfold pack. - rewrite <- fset1E. + set ([interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ]). + rewrite <- (fset1E ). rewrite <- fset_cons. - apply (trimmed_package_cons). - apply (trimmed_package_cons). - apply (trimmed_empty_package). - } - { + subst f. + + + unfold get_or_fn. + unfold get_or_case_fn. + unfold get_or_fail. + unfold set_at. + + ssprove_valid ; try apply (in_K_table _). + solve_imfset_disjoint. + Defined. + Fail Next Obligation. + + (* R-M-Pr-io^xpd - Interesting Fig 45., Fig.51-55 *) + + Notation " 'chKinp' " := + (chHandle × 'bool × chKey) + (in custom pack_type at level 2). + Notation " 'chKout' " := + (chHandle) + (in custom pack_type at level 2). + (* Definition K (n : chName) (ℓ : nat) := 10%nat. *) + + (**** *) + + Definition K_psk_1_0 d := K_package d PSK 0 (ltac:(Lia.lia)) true. + Obligation Tactic := (* try timeout 8 *) idtac. + Program Definition K_psk_0_d d : + package (L_K) [interface #val #[UNQ PSK d] : chKinp → chKout ] + (interface_hierarchy + (λ n : nat, + [interface #val #[SET PSK n d] : chKinp → chKout ; #val #[GET PSK n d] : chKout → chGETout ]) + d) := + (ℓ_packages d (fun n H => K_package d PSK n H false) _ _). + Next Obligation. + intros. + repeat (apply trimmed_empty_package || apply trimmed_package_cons). + Qed. + Next Obligation. intros. - unfold SET_ℓ, GET_ℓ. - unfold interface_foreach. unfold idents. + rewrite fset_cons ; rewrite imfsetU ; rewrite <- fset1E. + rewrite fset_cons ; rewrite imfsetU ; rewrite <- fset1E. solve_imfset_disjoint. - } - - Unshelve. - all: try apply DepInstance. - - unfold SET_ℓ, GET_ℓ. - unfold interface_foreach. - set ([interface #val #[UNQ DH k] : chUNQinp → chDHEXPout ]). - rewrite <- (fset1E ). - rewrite <- fset_cons. - subst f. - - - unfold get_or_fn. - unfold get_or_case_fn. - unfold get_or_fail. - unfold set_at. - - ssprove_valid ; try apply (in_K_table _). - solve_imfset_disjoint. -Defined. -Fail Next Obligation. - -(* R-M-Pr-io^xpd - Interesting Fig 45., Fig.51-55 *) - -Notation " 'chKinp' " := - (chHandle × 'bool × chKey) - (in custom pack_type at level 2). -Notation " 'chKout' " := - (chHandle) - (in custom pack_type at level 2). -(* Definition K (n : chName) (ℓ : nat) := 10%nat. *) - -(**** *) - -Definition K_psk_1_0 d := K_package d PSK 0 (ltac:(Lia.lia)) true. -Obligation Tactic := (* try timeout 8 *) idtac. -Program Definition K_psk_0_d d : - package (L_K) [interface #val #[UNQ PSK d] : chKinp → chKout ] - (interface_hierarchy - (λ n : nat, - [interface #val #[SET PSK n d] : chKinp → chKout ; #val #[GET PSK n d] : chKout → chGETout ]) - d) := - (ℓ_packages d (fun n H => K_package d PSK n H false) _ _). -Next Obligation. - intros. - repeat (apply trimmed_empty_package || apply trimmed_package_cons). -Qed. -Next Obligation. - intros. - unfold idents. - rewrite fset_cons ; rewrite imfsetU ; rewrite <- fset1E. - rewrite fset_cons ; rewrite imfsetU ; rewrite <- fset1E. - solve_imfset_disjoint. -Qed. -Next Obligation. - intros. - now rewrite <- interface_hierarchy_trivial. -Qed. -Fail Next Obligation. + Qed. + Next Obligation. + intros. + now rewrite <- interface_hierarchy_trivial. + Qed. + Fail Next Obligation. End KeyPackages. diff --git a/proofs/ssprove/handwritten/KeySchedulePackages.v b/proofs/ssprove/handwritten/KeySchedulePackages.v index b9664247..11195558 100644 --- a/proofs/ssprove/handwritten/KeySchedulePackages.v +++ b/proofs/ssprove/handwritten/KeySchedulePackages.v @@ -82,98 +82,98 @@ From KeyScheduleTheorem Require Import Core. Section KeySchedulePackages. - Context {Dependencies : Dependencies}. - Existing Instance Dependencies. - - Definition key_schedule_interface d k := - ([interface - #val #[ SET PSK 0 k ] : chSETinp → chSETout - ] - :|: DH_interface (* DHEXP, DHGEN *) - :|: XTR_n d k (* {ES,HS,AS}, 0..d *) - :|: XPD_n d k (* XPN, 0..d *) - :|: GET_O_star d k). - - Definition key_schedule_export d k := - GET_O_star d k :|: SET_O_star d k. - - (* Context {ord : chGroup → nat} {E : nat -> nat}. *) - - Lemma required_O_subset d k : SET_DH d k :<=: SET_O_star d k :|: GET_O_star d k. - Proof. - (* DH must be in O_star *) - unfold SET_DH. - unfold O_star. - rewrite interface_hierarchy_foreachU. - unfold interface_hierarchy_foreach. - - (* set d at 1 3 4. *) - (* generalize dependent n. *) - induction d ; intros. - - simpl. - unfold interface_hierarchy_foreach. - unfold interface_hierarchy. - unfold interface_foreach. - rewrite !fsetUA. - repeat (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left)). - - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsubUset. - apply /andP ; split ; apply fsubsetU ; apply /orP ; [ left | right ]. - + apply IHd. - + simpl. - unfold interface_hierarchy_foreach. - unfold interface_hierarchy. - unfold interface_foreach. - rewrite !fsetUA. - repeat (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left)). - Qed. - - (* Fig.11, p.17 *) - Program Definition Gks_real (d k : nat) H_lt : - package - (L_K :|: L_L) - [interface] - (GET_O_star d k) := - {package - Gcore_real d k H_lt (* ∘ XPD_DH_XTR *) - #with - _ - }. - Fail Next Obligation. - - (* Look into the use nominal sets (PR - Markus?)! *) - - Obligation Tactic := idtac. - Program Definition Gks_ideal d k H_lt (S : Simulator d k) : - package - L_K - (key_schedule_interface d k) - (GET_O_star d k) - := - {package - (* (par (par (XPD_packages d) (XTR_packages d)) (DH_package ord E)) ∘ *) - (Ks d k H_lt O_star true erefl) ∘ S - }. - Final Obligation. - intros. - unfold key_schedule_interface. - eapply valid_link_upto. - 1:{ - eapply valid_package_inject_export. - 2: apply (pack_valid (Ks d k H_lt O_star true erefl)). - apply fsubsetUr. - } - 1:{ - eapply valid_package_inject_import. - 2: apply (pack_valid S). - solve_in_fset. - } - { - solve_in_fset. - } - { - solve_in_fset. - } - Qed. + (* Context {Dependencies : Dependencies}. *) + (* Existing Instance Dependencies. *) + + (* Definition key_schedule_interface d k := *) + (* ([interface *) + (* #val #[ SET PSK 0 k ] : chSETinp → chSETout *) + (* ] *) + (* :|: DH_interface (* DHEXP, DHGEN *) *) + (* :|: XTR_n d k (* {ES,HS,AS}, 0..d *) *) + (* :|: XPD_n d k (* XPN, 0..d *) *) + (* :|: GET_O_star d k). *) + + (* Definition key_schedule_export d k := *) + (* GET_O_star d k :|: SET_O_star d k. *) + + (* (* Context {ord : chGroup → nat} {E : nat -> nat}. *) *) + + (* Lemma required_O_subset d k : SET_DH d k :<=: SET_O_star d k :|: GET_O_star d k. *) + (* Proof. *) + (* (* DH must be in O_star *) *) + (* unfold SET_DH. *) + (* unfold O_star. *) + (* rewrite interface_hierarchy_foreachU. *) + (* unfold interface_hierarchy_foreach. *) + + (* (* set d at 1 3 4. *) *) + (* (* generalize dependent n. *) *) + (* induction d ; intros. *) + (* - simpl. *) + (* unfold interface_hierarchy_foreach. *) + (* unfold interface_hierarchy. *) + (* unfold interface_foreach. *) + (* rewrite !fsetUA. *) + (* repeat (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left)). *) + (* - unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsubUset. *) + (* apply /andP ; split ; apply fsubsetU ; apply /orP ; [ left | right ]. *) + (* + apply IHd. *) + (* + simpl. *) + (* unfold interface_hierarchy_foreach. *) + (* unfold interface_hierarchy. *) + (* unfold interface_foreach. *) + (* rewrite !fsetUA. *) + (* repeat (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left)). *) + (* Qed. *) + + (* (* Fig.11, p.17 *) *) + (* Program Definition Gks_real (d k : nat) H_lt : *) + (* package *) + (* (L_K :|: L_L) *) + (* [interface] *) + (* (GET_O_star d k) := *) + (* {package *) + (* Gcore_real d k false H_lt (* ∘ XPD_DH_XTR *) *) + (* #with *) + (* _ *) + (* }. *) + (* Fail Next Obligation. *) + + (* (* Look into the use nominal sets (PR - Markus?)! *) *) + + (* Obligation Tactic := idtac. *) + (* Program Definition Gks_ideal d k H_lt (S : Simulator d k) : *) + (* package *) + (* L_K *) + (* (key_schedule_interface d k) *) + (* (GET_O_star d k) *) + (* := *) + (* {package *) + (* (* (par (par (XPD_packages d) (XTR_packages d)) (DH_package ord E)) ∘ *) *) + (* (Ks d k H_lt O_star true erefl) ∘ S *) + (* }. *) + (* Final Obligation. *) + (* intros. *) + (* unfold key_schedule_interface. *) + (* eapply valid_link_upto. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply (pack_valid (Ks d k H_lt O_star true erefl)). *) + (* apply fsubsetUr. *) + (* } *) + (* 1:{ *) + (* eapply valid_package_inject_import. *) + (* 2: apply (pack_valid S). *) + (* solve_in_fset. *) + (* } *) + (* { *) + (* solve_in_fset. *) + (* } *) + (* { *) + (* solve_in_fset. *) + (* } *) + (* Qed. *) End KeySchedulePackages. diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index 4ed3fd0a..91ca9b86 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -289,7 +289,7 @@ Qed. Theorem trimmed_par : forall {E1 E2} (p1 : raw_package) (p2 : raw_package) - (Hdisj : domm (p1) :#: domm (p2)) + (H_disj : idents E1 :#: idents E2) (H_trim_p1 : trimmed E1 p1) (H_trim_p2 : trimmed E2 p2), trimmed (E1 :|: E2) (par p1 p2). Proof. @@ -324,17 +324,14 @@ Proof. ((n, (So, To)) \in E2)) (p2))). { rewrite filterm_union. - 2: apply Hdisj. - (* 2:{ *) - (* epose (domm_trimmed E1 p1 H_trim_p1). *) - (* epose (domm_trimmed E2 p2 H_trim_p2). *) - - (* epose proof (fdisjoint_trans i Hdisj). *) - (* rewrite fdisjointC in H. *) - (* epose proof (fdisjoint_trans i0 H). *) - (* rewrite fdisjointC in H0. *) - (* apply H0. *) - (* } *) + 2:{ + apply @parable. + rewrite <- H_trim_p1. + rewrite <- H_trim_p2. + solve_Parable. + + apply H_disj. + } f_equal. { setoid_rewrite H_trim_p1. @@ -739,6 +736,7 @@ try rewrite !imfsetU (* ; try (now apply serialize_name_notin_different_name ; Lia.lia) *) (* ; try (now apply serialize_name_notin_different_index ; Lia.lia) *) ; try (now apply serialize_name_notin_smaller_than_start ; try Lia.lia) +; try (now symmetry ; apply serialize_name_notin_smaller_than_start ; try Lia.lia) (* ; try (idtac ; [ reflexivity | unfold "\in"; simpl; unfold "\in"; simpl ; Lia.lia.. ]) *) (* ; setoid_rewrite Bool.orb_false_r *) (* ; simpl *) @@ -1233,14 +1231,7 @@ Proof. apply trimmed_par. 3: apply IHL ; [ now apply (ssrbool.elimT andP) in H0 as [] ; fold (uniq (s :: I)) in H0 | apply H1 ]. 2: apply H1. - 1:{ - rewrite <- (IHL I _ s) ; [ | now apply (ssrbool.elimT andP) in H0 as [] ; fold (uniq (s :: I)) in H0 | apply H1 ]. - simpl in H0. - rewrite <- (proj1 H1). - apply @parable. - solve_Parable. - now apply idents_interface_foreach_disjoint_same. - } + 1: now apply idents_interface_foreach_disjoint_same. Qed. Lemma parallel_raw_cons : forall n E, @@ -1921,19 +1912,10 @@ Proof. apply trimmed_par. { - apply @parable. - rewrite <- H_trim_p. - unfold ℓ_raw_packages in IHk. - rewrite <- IHk ; try auto. - { - solve_Parable. - clear -K_le Hdisj. - - apply (idents_interface_hierachy). - - Lia.lia. - - intros. - now apply Hdisj. - } + apply (idents_interface_hierachy). + - Lia.lia. + - intros. + now apply Hdisj. } { apply IHk ; auto. @@ -2110,16 +2092,15 @@ Definition ℓ_parallel {A : eqType} {L} {g f} Names l (d : nat) (u : forall ℓ_packages d (λ ℓ H_le, parallel_package_with_in_rel_hierarchy Names l d u H_in H H0 H1 ℓ H_le) (fun a H_le => trimmed_parallel_raw (fun _ _ H_neq => H _ _ _ _ (or_introl H_neq)) H0 (H1 _ _)) - (fun n ℓ H_le H_ge => idents_foreach_disjoint_foreach _ _ _ - (fun _ _ => - H _ _ _ _ - (or_intror - ((eq_ind_r (λ ℓ0 : nat, (ℓ0 < n)%N → False) (λ H_le0 : (n < n)%N, - (eq_ind_r (λ b : bool, b → False) (λ H_le1 : false, - False_ind False (eq_ind false (λ e : bool, if e then False else True) I true H_le1)) (ltnn n)) - H_le0) (y:=ℓ))^~ - H_le - ) + (fun n ℓ H_le H_ge => + idents_foreach_disjoint_foreach _ _ _ + (fun _ _ => + H _ _ _ _ + (or_intror + ((eq_ind_r + (λ ℓ0 : nat, (ℓ0 < n)%N → False) + (λ H_le0 : (n < n)%N, + (eq_ind_r (λ b : bool, b → False) (λ H_le1 : false, False_ind False (eq_ind false (λ e : bool, if e then False else True) I true H_le1)) (ltnn n)) H_le0) (y:=ℓ))^~ H_le) )))). Definition trimmed_ℓ_packages {L} @@ -2143,13 +2124,6 @@ Proof. 2:{ apply H_trim_p. } - apply @parable. - rewrite <- map_with_in_num_upper_trimmed. - 2: intros ; apply H_trim_p. - 2: now intros ; apply Hdisj. - - rewrite <- H_trim_p. - solve_Parable. now apply idents_interface_hierachy. Qed. diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index 92a0e3b6..d0184d83 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -213,26 +213,26 @@ Section XTR_XPD. Definition XTR_n_ℓ d ℓ := interface_foreach (fun n => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names. - Lemma trimmed_Xtr : forall ℓ n d, + Lemma trimmed_Xtr : forall ℓ n d b, trimmed [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ] - (Xtr n ℓ d false). + (Xtr n ℓ d b). Proof. intros. unfold trimmed. trim_is_interface. Qed. - Definition xtr_level_raw (ℓ : nat) (d : nat) := - parallel_raw (List.map (fun n => pack (Xtr n ℓ d false)) XTR_names). + Definition xtr_level_raw (ℓ : nat) (d : nat) (b : name -> bool) := + parallel_raw (List.map (fun n => pack (Xtr n ℓ d (b n))) XTR_names). Lemma valid_xtr_level : - forall d ℓ, + forall d ℓ b, (ℓ <= d)%N -> ValidPackage f_parameter_cursor_loc (GET_ℓ XTR_parent_names d ℓ :|: SET_ℓ XTR_names d ℓ) (interface_foreach (fun n => [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout]) XTR_names) - (xtr_level_raw ℓ d). + (xtr_level_raw ℓ d b). Proof. intros. @@ -247,7 +247,7 @@ Section XTR_XPD. #val #[GET (nfto (snd (PrntN n))) ℓ d] : chXTRout → chGETout] :|: [interface #val #[SET n ℓ d] : chSETinp → chSETout ]) (λ n : name, [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ]) - (λ ℓ (n : name), pack (Xtr n ℓ d false)) + (λ ℓ (n : name), pack (Xtr n ℓ d (b n))) XTR_names d ℓ @@ -274,17 +274,17 @@ Section XTR_XPD. unfold XTR_names, valid_pairs, List.map. repeat split ; match goal with - | |- context [ Xtr ?n _ _ ] => apply (pack_valid (@Xtr _ ℓ d false)) + | |- context [ Xtr ?n _ _ ] => apply (pack_valid (@Xtr _ ℓ d (b n))) end. Qed. - Definition xtr_level d ℓ (H : (ℓ <= d)%N) := - {package (xtr_level_raw ℓ d) #with (valid_xtr_level d ℓ H)}. + Definition xtr_level d ℓ b (H : (ℓ <= d)%N) := + {package (xtr_level_raw ℓ d b) #with (valid_xtr_level d ℓ b H)}. - Lemma trimmed_xtr_level d ℓ (H : (ℓ <= d)%N) : + Lemma trimmed_xtr_level d ℓ b (H : (ℓ <= d)%N) : trimmed (interface_foreach (fun n => [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout]) XTR_names) - (xtr_level d ℓ H). + (xtr_level d ℓ b H). Proof. apply (trimmed_parallel_raw). - intros ; unfold idents ; solve_imfset_disjoint. @@ -292,12 +292,12 @@ Section XTR_XPD. - repeat split ; apply trimmed_Xtr. Qed. - Definition XTR_packages (d k : nat) (H_lt : (d <= k)%nat) : + Definition XTR_packages (d k : nat) (b : name -> bool) (H_lt : (d <= k)%nat) : package fset0 (GET_n XTR_parent_names d k :|: SET_n XTR_names d k) (XTR_n d k). Proof. unfold GET_n. rewrite interface_hierarchy_U. - refine (ℓ_packages d (g := fun ℓ => GET_ℓ XTR_parent_names k ℓ :|: SET_ℓ XTR_names k ℓ) (fun ℓ H => xtr_level k ℓ (leq_trans H H_lt)) _ _). + refine (ℓ_packages d (g := fun ℓ => GET_ℓ XTR_parent_names k ℓ :|: SET_ℓ XTR_names k ℓ) (fun ℓ H => xtr_level k ℓ b (leq_trans H H_lt)) _ _). { intros ℓ ?. apply trimmed_xtr_level. @@ -799,11 +799,11 @@ Section XTR_XPD. #val #[DHGEN] : chDHGENout → chDHGENout ; #val #[DHEXP] : chDHEXPinp → chXPDout ]. - Definition DH_package d k : + Definition DH_package k : (* (G : {fset finGroupType}) *) package fset0 - (SET_DH d k) + (SET_DH 0 k) DH_interface. intros. refine [package @@ -820,7 +820,7 @@ Section XTR_XPD. Defined. Fail Next Obligation. - Lemma trimmed_dh d k : trimmed DH_interface (pack (DH_package d k)). + Lemma trimmed_dh k : trimmed DH_interface (pack (DH_package k)). Proof. intros. unfold DH_package. @@ -863,11 +863,6 @@ Section XTR_XPD. rewrite interface_hierarchy_foreach_cons. apply trimmed_par. { - apply @parable. - rewrite <- trimmed_ℓ_packages. - set (ℓ_packages _). - rewrite <- (trimmed_ℓ_packages). - solve_Parable. apply idents_interface_hierachy3. intros. rewrite fdisjointC. @@ -884,15 +879,15 @@ Section XTR_XPD. } Qed. - Lemma trimmed_xtr_package : forall (d k : nat) H_lt, - trimmed (XTR_n d k) (XTR_packages d k H_lt). + Lemma trimmed_xtr_package : forall (d k : nat) b H_lt, + trimmed (XTR_n d k) (XTR_packages d k b H_lt). Proof. intros. simpl. unfold XTR_packages. unfold eq_rect_r. destruct (Logic.eq_sym _). - erewrite <- (ℓ_raw_package_trimmed d (fun ℓ H => [eta xtr_level] k ℓ (leq_trans H H_lt))). + erewrite <- (ℓ_raw_package_trimmed d (fun ℓ H => [eta xtr_level] k ℓ b (leq_trans H H_lt))). 2:{ intros ℓ ?. apply (trimmed_xtr_level k ℓ). From 4a3b5131f0a07bdd308c8cd240cbaced82e90196 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 4 Mar 2025 17:39:32 +0100 Subject: [PATCH 07/10] Core theorem fully stated, missing lemmas and package definitions --- proofs/ssprove/handwritten/CoreTheorem.v | 651 +++++++++++++++++++---- proofs/ssprove/handwritten/KeyPackages.v | 43 +- 2 files changed, 585 insertions(+), 109 deletions(-) diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 372f00d8..7fb36007 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -112,21 +112,24 @@ Section CoreTheorem. (* intros. *) (* Admitted. *) + Axiom hash : nat -> nat. Definition Gacr (f : HashFunction) (b : bool) : package fset0 [interface] [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. - Proof. - (* refine [package *) - (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) - (* (* get_or_fn _ _ _ *) *) - (* d ← untag (f t) ;; *) - (* if b && d \in Hash *) - (* then fail *) - (* else Hash *) - (* } *) - (* ]. *) - (* Qed. *) + (* Proof. *) + (* refine [package *) + (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) + (* ret fail *) + (* (* (* get_or_fn _ _ _ *) *) *) + (* (* d ← untag (match f with | f_hash | f_xtr => xtr t end) ;; *) *) + (* (* if b && d \in Hash *) *) + (* (* then fail *) *) + (* (* else *) *) + (* (* ret d *) *) + (* } *) + (* ]. *) + (* Qed. *) Admitted. (* Definition Gacr : *) @@ -136,6 +139,13 @@ Section CoreTheorem. (* ]. *) (* (* HASH(t) .. *) *) + Definition R_alg : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + Definition R_cr : package fset0 [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) @@ -148,9 +158,59 @@ Section CoreTheorem. Proof. Admitted. - Axiom R_D : package fset0 [interface] [interface]. + Definition R_D (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_xtr (n : name) (ℓ : nat) : + n \in XTR_names -> + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_xpd (n : name) (ℓ : nat) : + n \in XPR -> + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_pi (L : list name) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. Axiom Gsodh : + forall (d k : nat), + (d < k)%nat -> + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gxtr : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gxpd : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gpi : + forall (d k : nat), + (d < k)%nat -> + forall (L : list name) + (f : ZAF), loc_GamePair [interface (* #val #[ SODH ] : 'unit → 'unit *) @@ -651,7 +711,7 @@ Section CoreTheorem. _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK Z)) (Hash true)) }. Admit Obligations. Fail Next Obligation. @@ -677,7 +737,7 @@ Section CoreTheorem. _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. @@ -703,7 +763,7 @@ Section CoreTheorem. _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. @@ -730,16 +790,16 @@ Section CoreTheorem. _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. -HB.instance Definition _ : Equality.axioms_ name := - {| - Equality.eqtype_hasDecEq_mixin := - {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} - |}. + HB.instance Definition _ : Equality.axioms_ name := + {| + Equality.eqtype_hasDecEq_mixin := + {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} + |}. Definition N_star := all_names. (* TODO *) Program Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : @@ -769,7 +829,7 @@ HB.instance Definition _ : Equality.axioms_ name := if ℓ >=? i then false else true else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) - (K_package k PSK d.+1 H_lt (i == d.+1) ∘ L_package k PSK D)) (Hash true)) + (K_package k PSK d H_lt (i == d) ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. @@ -800,7 +860,7 @@ HB.instance Definition _ : Equality.axioms_ name := if (name \in N_star) || (name == PSK) then if (ℓ + (name \in C)) >=? i then false else true - else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. @@ -827,50 +887,160 @@ HB.instance Definition _ : Equality.axioms_ name := _ erefl _) ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d.+1 H_lt true ∘ L_package k PSK D)) (Hash true)) + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d H_lt true ∘ L_package k PSK D)) (Hash true)) }. Admit Obligations. Fail Next Obligation. - Lemma core_theorem : + Lemma advantage_reflexivity : + forall P A, AdvantageE P P A = 0%R. + Proof. + unfold AdvantageE. + intros. + rewrite subrr. + rewrite Num.Theory.normr0. + reflexivity. + Qed. + + Lemma d2 : forall (d k : nat) H_lt, - forall (Score : Simulator d k), + (* forall (Score : Simulator d k), *) forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE - (G_ks d k false H_lt) - (G_ks d k true H_lt) (A (* ∘ R d M H *)) - <= sumR_l [R_cr; (R_Z f_hash); R_D] (fun R => Advantage (Gacr f_hash) (A ∘ R)) - +maxR (fun i => Advantage Gsodh (Ai A i ∘ R_sodh) + AdvantageE (G_core_SODH d k H_lt) (G_ks d k true H_lt) (Ai A i)) - )%R. + (AdvantageE (G_core d k false H_lt) (G_core d k true H_lt) A + <= Advantage (Gacr f_hash) (A ∘ R_cr) + + AdvantageE (G_core_Hash d k H_lt) (G_core d k true H_lt) A)%R. Proof. intros. - unfold sumR_l. - rewrite addr0. - rewrite addrA. + Admitted. - (* unfold G_ks. *) - (* unfold pack. *) + Lemma d3 : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (G_core_Hash d k H_lt) (G_core_D d k H_lt) A + <= Advantage (Gacr f_xtr) (A ∘ (R_Z f_xtr)) + + Advantage (Gacr f_xpd) (A ∘ (R_Z f_xpd)) + + Advantage (Gacr f_xtr) (A ∘ (R_D f_xtr)) + + Advantage (Gacr f_xpd) (A ∘ (R_D f_xpd)))%R. + Proof. + intros. + Admitted. - (* epose Advantage_link. *) + (* Lemma d4 : *) + (* forall (d k : nat) H_lt, *) + (* (* forall (Score : Simulator d k), *) *) + (* forall (LA : {fset Location}) (A : raw_package), *) + (* ValidPackage LA (KS_interface d k) A_export A → *) + (* (AdvantageE (G_core_R_esalt d k H_lt) (G_core d k true H_lt) A *) + (* >= maxR (fun i => AdvantageE (G_core_Hash d k H_lt) (G_core_D d k H_lt) (Ai A i)))%R. *) + (* Proof. *) + (* intros. *) + (* Admitted. *) - (* unfold Gacr. *) - (* simpl. *) - (* simpl. *) + Lemma d4 : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (G_core_R_esalt d k H_lt) (G_core d k true H_lt) A + <= maxR (fun i => AdvantageE (G_core_D d k H_lt) (G_core d k true H_lt) (Ai A i)))%R. + Proof. + intros. Admitted. - Lemma advantage_reflexivity : - forall P A, AdvantageE P P A = 0%R. + Lemma d5 : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (G_core_R_esalt d k H_lt) (G_core_SODH d k H_lt) A + = Advantage (Gsodh d k H_lt) (A ∘ R_sodh))%R. Proof. - unfold AdvantageE. intros. - rewrite subrr. - rewrite Num.Theory.normr0. - reflexivity. + Admitted. + + (* d6: Hybrid lemma *) + Lemma d6 : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + (* forall (K_table : chHandle -> nat), *) + (* forall i, *) + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + forall ℓ, (ℓ <= d)%nat -> + (AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt ℓ.+1) A + <= Advantage (Gxtr d k H_lt ES ℓ) (A ∘ R_xtr ES ℓ erefl) + + Advantage (Gxtr d k H_lt HS ℓ) (A ∘ R_xtr HS ℓ erefl) + + Advantage (Gxtr d k H_lt AS ℓ) (A ∘ R_xtr AS ℓ erefl) + + sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (A ∘ R_xpd n ℓ H_in))%R + )%R. + Proof. + intros. + Admitted. + + Lemma hyb_telescope : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + (* forall (K_table : chHandle -> nat), *) + forall i, + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (G_core_hyb_ℓ d k H_lt 0) (G_core_hyb_ℓ d k H_lt d) (Ai A i) + <= sumR 0 d (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ+1)) (Ai A i)) + )%R. + Proof. + intros. + + set d in H, H_lt |- * at 1 2 6 7. + generalize dependent n. + generalize dependent (leq0n d). + induction d ; intros. + - unfold sumR. + (* simpl. *) + simpl iota. + unfold AdvantageE. + unfold List.fold_left. + rewrite subrr. + + apply eq_ler. + rewrite Num.Theory.normr0. + reflexivity. + + + (* rewrite add0r. *) + (* rewrite add0n. *) + (* now apply eq_ler. *) + + (* reflexivity. *) + (* rewrite subrr. *) + (* rewrite Num.Theory.normr0. *) + (* reflexivity. *) + + - + + rewrite sumR_succ. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (G_core_hyb_ℓ n k H_lt d)). + + eapply Order.le_trans. + 1:{ + apply Num.Theory.lerD ; [ | easy ]. + eapply (IHd _ _ H_lt). + apply H. + } + + rewrite addrC. + apply Num.Theory.lerD ; [ | easy ]. + rewrite addn1. + easy. Qed. - + Lemma equation20_lhs : forall (d k : nat) H_lt, + (d > 0)%nat -> (* forall (Score : Simulator d k), *) forall i, forall (LA : {fset Location}) (A : raw_package), @@ -900,8 +1070,10 @@ HB.instance Definition _ : Equality.axioms_ name := rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). 2: admit. - setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). - 2,3,4,5,6,7,8: admit. + replace (0 == d)%nat with false by easy. + + (* setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). *) + (* 2,3,4,5,6,7,8: admit. *) replace (λ (ℓ : nat) (name : ExtraTypes.name), if (name \in N_star) || (name == PSK) then if ℓ >=? 0%N then false else true else false) @@ -919,13 +1091,206 @@ HB.instance Definition _ : Equality.axioms_ name := apply advantage_reflexivity. Admitted. + Lemma Advantage_par_emptyR : + ∀ G₀ G₁ A, + AdvantageE (par G₀ emptym) (par G₁ emptym) A = AdvantageE G₀ G₁ A. + Proof. + intros G₀ G₁ A. + unfold AdvantageE. + unfold par. + rewrite !unionm0. + reflexivity. + Qed. + + Lemma Advantage_parR : + ∀ G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁, + ValidPackage L₀ Game_import E₀ G₀ → + ValidPackage L₁ Game_import E₁ G₁ → + ValidPackage L₁' Game_import E₁ G₁' → + flat E₁ → + trimmed E₀ G₀ → + trimmed E₁ G₁ → + trimmed E₁ G₁' → + AdvantageE (par G₁ G₀) (par G₁' G₀) A = + AdvantageE G₁ G₁' (A ∘ par (ID E₁) G₀). + Proof. + intros G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁. + intros Va0 Va1 Va1' Fe0 Te0 Te1 Te1'. + replace (par G₁ G₀) with ((par (ID E₁) G₀) ∘ (par G₁ (ID Game_import) )). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoints0. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + replace (par G₁' G₀) with ((par (ID E₁) G₀) ∘ (par G₁' (ID Game_import))). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoints0. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + rewrite -Advantage_link. + unfold Game_import. rewrite -fset0E. + rewrite Advantage_par_emptyR. + reflexivity. + Unshelve. all: auto. + Qed. + + Lemma L_package_esalt_D_to_R : + forall k A, + AdvantageE + (Ls k all_names (λ _ : name, D) erefl) + (Ls k all_names + (λ name : ExtraTypes.name, + match name as name' return (name' = name → ZAF) with + | BOT => λ _ : BOT = name, D + | ES => λ _ : ES = name, D + | EEM => λ _ : EEM = name, D + | CET => λ _ : CET = name, D + | BIND => λ _ : BIND = name, D + | BINDER => λ _ : BINDER = name, D + | HS => λ _ : HS = name, D + | SHT => λ _ : SHT = name, D + | CHT => λ _ : CHT = name, D + | HSALT => λ _ : HSALT = name, D + | AS => λ _ : AS = name, D + | RM => λ _ : RM = name, D + | CAT => λ _ : CAT = name, D + | SAT => λ _ : SAT = name, D + | EAM => λ _ : EAM = name, D + | PSK => λ _ : PSK = name, D + | ZERO_SALT => λ _ : ZERO_SALT = name, D + | ESALT => λ _ : ESALT = name, R + | DH => λ _ : DH = name, D + | ZERO_IKM => λ _ : ZERO_IKM = name, D + end erefl) erefl) A = 0%R. + Proof. + intros. + unfold Ls. + unfold all_names. + unfold interface_foreach. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold parallel_package. + unfold List.map. + unfold parallel_raw. + unfold List.fold_left. + unfold pack. + + repeat (erewrite (Advantage_parR ) ; [ | admit.. ]). + repeat (erewrite (Advantage_par ) ; [ | admit.. ]). + + eapply eq_rel_perf_ind_eq. + 1,2: apply pack_valid. + 2: admit. + 2,3: admit. + + unfold eq_up_to_inv. + intros. + + rewrite in_fset in H. + rewrite mem_seq1 in H. + move/eqP: H => H ; inversion_clear H. + + unfold get_op_default. + + unfold L_package. + unfold pack. + + (* lookup_op_squeeze. *) + + unfold lookup_op. + rewrite !mkfmapE. + unfold getm_def. + unfold ".1", ".2". + rewrite !eqxx. + + unfold mkdef. + + destruct choice_type_eqP. + 2: apply r_ret ; easy. + + destruct choice_type_eqP. + 2: apply r_ret ; easy. + + subst. + rewrite !cast_fun_K. + + destruct x as [[]]. + + eapply r_bind. + 2:{ + intros. + instantiate (1 := fun '(_, s₀) '(_, s₁) => s₀ = s₁). + hnf. + unfold set_at. + unfold bind. + ssprove_sync_eq. + now apply r_ret. + } + + admit. + Admitted. + + Lemma D_to_R_esalt_is_zero : + forall d k H_lt A, + AdvantageE (G_core_D d k H_lt) (G_core_R_esalt d k H_lt) A = 0%R. + Proof. + intros. + + unfold G_core_D. + unfold G_core_R_esalt. + + unfold pack. + rewrite <- !Advantage_link. + + setoid_rewrite (Advantage_parR (Hash true)). + 2: apply pack_valid. + 2,3,4,5,6,7: admit. + + erewrite <- interchange. + 2,3,4,5,6,7,8: admit. + + erewrite (Advantage_parR ). + 2,3,4,5,6,7,8: admit. + + rewrite <- !Advantage_link. + apply L_package_esalt_D_to_R. + Admitted. + Lemma equation20_rhs : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (G_core_ki d k H_lt) (G_core_hyb_ℓ d k H_lt d.+1) (Ai A i) = 0)%R. + (AdvantageE (G_core_ki d k H_lt) (G_core_hyb_ℓ d k H_lt d) (Ai A i) = 0)%R. Proof. intros. @@ -951,66 +1316,40 @@ HB.instance Definition _ : Equality.axioms_ name := 2: admit. rewrite eqxx. - - setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). - 2,3,4,5,6,7,8: admit. + + (* setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). *) + (* 2,3,4,5,6,7,8: admit. *) replace (λ (ℓ : nat) (name : ExtraTypes.name), - if (name \in N_star) || (name == PSK) then if ℓ >=? d.+1 then false else true else false) + if (name \in N_star) || (name == PSK) then if ℓ >=? d then false else true else false) with (λ (ℓ : nat) (name : ExtraTypes.name), true). 2:{ admit. } - apply advantage_reflexivity. - Admitted. + erewrite (Advantage_par ). + 2,3,4,5,6,7,8: admit. - Lemma hyb_telescope : - forall (d k : nat) H_lt, - forall (Score : Simulator d k), - (* forall (K_table : chHandle -> nat), *) - forall i, - forall (LA : {fset Location}) (A : raw_package), - ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (G_core_hyb_ℓ d k H_lt 0) (G_core_hyb_ℓ d k H_lt d.+1) (Ai A i) - = sumR 0 d.+1 (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ+1)) (Ai A i)) - )%R. - Proof. - intros. - set d in H_lt |- * at 1 2 6 7. - generalize dependent n. - generalize dependent (leq0n d). - induction d ; intros. - - unfold sumR. - (* simpl. *) - simpl iota. - unfold AdvantageE. - unfold List.fold_left. - rewrite add0r. - rewrite add0n. - reflexivity. - (* rewrite subrr. *) - (* rewrite Num.Theory.normr0. *) - (* reflexivity. *) + erewrite <- interchange. + 2,3,4,5,6,7,8: admit. - - rewrite sumR_succ. - epose (IHd _ _ _ _ H_lt). - rewrite <- e. + rewrite <- !Advantage_link. - admit. + apply L_package_esalt_D_to_R. Admitted. Lemma equation20_eq : forall (d k : nat) H_lt, - forall (Score : Simulator d k), + (d > 0)%nat -> + (* forall (Score : Simulator d k), *) (* forall (K_table : chHandle -> nat), *) forall i, forall (LA : {fset Location}) (A : raw_package), ValidPackage LA (KS_interface d k) A_export A → - (AdvantageE (G_core_SODH d k H_lt) (G_ks d k true H_lt) (Ai A i) - <= AdvantageE (G_core_ki d k H_lt) (G_ks d k true H_lt) (Ai A i) - +sumR 0 d.+1 (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ + 1)) (Ai A i)) + (AdvantageE (G_core_SODH d k H_lt) (G_core d k true H_lt) (Ai A i) + <= AdvantageE (G_core_ki d k H_lt) (G_core d k true H_lt) (Ai A i) + +sumR 0 d (leq0n d) (fun ℓ => AdvantageE (G_core_hyb_ℓ d k H_lt ℓ) (G_core_hyb_ℓ d k H_lt (ℓ + 1)) (Ai A i)) )%R. Proof. intros. @@ -1018,22 +1357,144 @@ HB.instance Definition _ : Equality.axioms_ name := eapply Order.le_trans ; [ apply Advantage_triangle | ]. instantiate (1 := (G_core_hyb_ℓ d k H_lt 0)). rewrite (equation20_lhs d k H_lt). + 2: easy. rewrite add0r. eapply Order.le_trans ; [ apply Advantage_triangle | ]. instantiate (1 := G_core_ki d k H_lt). - rewrite <- (addrC (AdvantageE (G_core_ki d k H_lt) (G_ks d k true H_lt) (Ai A i)))%R. + rewrite <- (addrC (AdvantageE (G_core_ki d k H_lt) (G_core d k true H_lt) (Ai A i)))%R. apply Num.Theory.lerD ; [ easy | ]. eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (1 := (G_core_hyb_ℓ d k H_lt d.+1)). + instantiate (1 := (G_core_hyb_ℓ d k H_lt d)). epose (e := equation20_rhs d k (* Score *)). setoid_rewrite (Advantage_sym _ _) in e. + rewrite e ; clear e. rewrite addr0. - setoid_rewrite <- hyb_telescope ; easy. + eapply hyb_telescope. + apply H0. + Qed. + + + Lemma d7 : + forall (d k : nat) H_lt, + (* forall (Score : Simulator d k), *) + (* forall (K_table : chHandle -> nat), *) + forall i, + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (AdvantageE (G_core_ki d k H_lt) (G_core d k true H_lt) (Ai A i) + <= Advantage (λ x : bool, Gpi d k H_lt [:: ESALT] R x) (Ai A i ∘ R_pi [:: ESALT]) + + Advantage (λ x : bool, Gpi d k H_lt O_star R x) (Ai A i ∘ R_pi O_star) + )%R. + Proof. + intros. + Admitted. + + Axiom sumR_leq : forall l u H_range f g, + (forall ℓ, (ℓ <= u)%nat -> f ℓ <= g ℓ)%R -> + (sumR l u H_range f <= sumR l u H_range g)%R. + + Lemma core_theorem : + forall (d k : nat) H_lt (H_gt : (0 < d)%nat), + (* forall (Score : Simulator d k), *) + forall (LA : {fset Location}) (A : raw_package), + ValidPackage LA (KS_interface d k) A_export A → + (forall i, ValidPackage LA (KS_interface d k) A_export (Ai A i)) → + (AdvantageE + (G_core d k false H_lt) + (G_core d k true H_lt) (A (* ∘ R d M H *)) + <= sumR_l [(R_cr, f_hash); (R_Z f_xtr, f_xtr); (R_Z f_xpd, f_xpd); (R_D f_xtr, f_xtr); (R_D f_xpd, f_xpd)] (fun R_hash_fn => Advantage (Gacr (snd R_hash_fn)) (A ∘ (fst R_hash_fn))) + +maxR (fun i => + Advantage (Gsodh d k H_lt) (Ai A i ∘ R_sodh) + + Advantage (Gpi d k H_lt [ESALT] R) (Ai A i ∘ R_pi [ESALT]) + + Advantage (Gpi d k H_lt O_star R) (Ai A i ∘ R_pi O_star) + + sumR 0 d (leq0n d) (fun ℓ => + Advantage (Gxtr d k H_lt ES ℓ) (Ai A i ∘ R_xtr ES ℓ erefl) + + Advantage (Gxtr d k H_lt HS ℓ) (Ai A i ∘ R_xtr HS ℓ erefl) + + Advantage (Gxtr d k H_lt AS ℓ) (Ai A i ∘ R_xtr AS ℓ erefl) + + sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (Ai A i ∘ R_xpd n ℓ H_in))%R) + ))%R. + Proof. + intros. + unfold sumR_l. + rewrite addr0. + rewrite addrA. + + eapply Order.le_trans ; [ eapply d2 ; apply H | ]. + + eapply Order.le_trans. + 1:{ + apply Num.Theory.lerD ; [ easy | ]. + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + apply Num.Theory.lerD ; [ | easy ]. + eapply d3, H. + } + rewrite !addrA. + apply Num.Theory.lerD ; [ easy | ]. + + eapply Order.le_trans. + 1:{ + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (2 := G_core_R_esalt d k H_lt). + rewrite D_to_R_esalt_is_zero. + rewrite add0r. + eapply d4, H. + } + + apply max_leq. + intros i. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + eapply Order.le_trans. + 1:{ + instantiate (2 := (G_core_SODH d k H_lt)). + apply Num.Theory.lerD ; [ | easy ]. + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (2 := (G_core_R_esalt d k H_lt)). + apply Num.Theory.lerD ; [ easy | ]. + (* erewrite D_to_R_esalt_is_zero. *) + (* rewrite add0r. *) + erewrite d5 ; [ | apply H0 ]. + easy. + } + rewrite <- (addrC (Advantage (λ x : bool, Gsodh d k H_lt x) (Ai A i ∘ R_sodh))). + rewrite <- !addrA. + apply Num.Theory.lerD ; [ easy | ]. + rewrite addrA. + + eapply Order.le_trans. + 1:{ + apply Num.Theory.lerD ; [ easy | ]. + eapply Order.le_trans. + 1: eapply equation20_eq, H ; apply H_gt. + + apply Num.Theory.lerD ; [ easy | ]. + apply sumR_leq. + intros. + rewrite addn1. + eapply d6 ; [ apply H0 | ]. + apply H1. + } + + rewrite addrA. + rewrite <- (addrC (AdvantageE (G_core_ki d k H_lt) (G_core d k true H_lt) (Ai A i))). + rewrite <- (addrA (AdvantageE (G_core_ki d k H_lt) (G_core d k true H_lt) (Ai A i))). + apply Num.Theory.lerD. + 1:{ + eapply Order.le_trans. + 1: eapply d7, H. + easy. + } + + rewrite D_to_R_esalt_is_zero. + rewrite add0r. + easy. Qed. End CoreTheorem. + +(* Why does this work with d = 0? *) diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index 3b360b70..0d821199 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -100,10 +100,10 @@ Section KeyPackages. (* Fig 13-14. K key and log *) - (* Axiom exists_h_star : (chHandle -> raw_code 'unit) -> raw_code 'unit. *) + Axiom exists_h_star : (chHandle -> raw_code 'unit) -> code L_L [interface] 'unit. Inductive ZAF := | Z | A | F | D | R. - (* Axiom level : chHandle -> nat. *) + Axiom level : chHandle -> nat. (* Fig 13 *) Definition L_package d (n : name) (P : ZAF) : @@ -117,24 +117,39 @@ Section KeyPackages. Proof. refine [package #def #[ UNQ n d (* n ℓ *) ] ('(h,hon,k) : chUNQinp) : chUNQout { - (* (exists_h_star (fun h_star => *) - (* '(h',hon',k) ← get_or_fn (Log_table h_star) (chHandle × 'bool × chKey) (@fail _ ;; ret (chCanonical (chHandle × 'bool × chKey))) ;; *) - (* r ← ret (level h) ;; *) - (* r' ← ret (level h_star) ;; *) - (* match P with *) - (* | Z => ret Datatypes.tt *) - (* | A => if Datatypes.andb (hon == hon' == false) (r == r' == false) *) - (* then @fail _ ;; ret Datatypes.tt *) - (* else ret Datatypes.tt *) - (* | F => @fail _ ;; ret Datatypes.tt *) - (* end)) ;; *) + (exists_h_star (fun h_star => + temp ← get_or_fail (L_table h_star) fin_L_table ;; + let '(h',hon',k) := (fto (fst (fst (otf temp))) , snd (fst (otf temp)) , snd (otf temp)) : _ in + r ← ret (level h) ;; + r' ← ret (level h_star) ;; + match P with + | Z => ret Datatypes.tt + | A => if Datatypes.andb (hon == hon' == false) (r == r' == false) + then @fail _ ;; ret Datatypes.tt + else ret Datatypes.tt + | F => @fail _ ;; ret Datatypes.tt + | D => if hon == hon' == false then @fail _ ;; ret Datatypes.tt else ret Datatypes.tt + | R => if hon == hon' == false + then @fail _ ;; ret Datatypes.tt (* abort *) + else @fail _ ;; ret Datatypes.tt (* win *) + end)) ;; set_at (L_table h) fin_L_table (otf h, hon, otf k) ;; ret h } ]. unfold set_at. - ssprove_valid ; apply (in_L_table _). + ssprove_valid ; try apply (in_L_table _). + apply prog_valid. + + Unshelve. + 1: apply DepInstance. + 1:{ + apply pos_prod ; [ | apply pos_key ]. + apply pos_prod ; [ | apply pos_bool ]. + apply pos_handle. + } + all: apply 'unit. Defined. Fail Next Obligation. From 5eee2e909330ac2af47d1f0191cb316ebedbff0b Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 11 Mar 2025 15:41:15 +0100 Subject: [PATCH 08/10] Move definitions to Core.v --- proofs/ssprove/_CoqProject | 12 +- proofs/ssprove/handwritten/Core.v | 2477 ++++++++++++++++++++++ proofs/ssprove/handwritten/CoreTheorem.v | 1255 ++++------- proofs/ssprove/handwritten/Utility.v | 625 +++++- proofs/ssprove/handwritten/XTR_XPD.v | 12 - 5 files changed, 3469 insertions(+), 912 deletions(-) diff --git a/proofs/ssprove/_CoqProject b/proofs/ssprove/_CoqProject index 0770cc54..b0978c8f 100644 --- a/proofs/ssprove/_CoqProject +++ b/proofs/ssprove/_CoqProject @@ -25,12 +25,12 @@ # PROOF +./handwritten/ssp_helper.v + ./handwritten/Types.v ./handwritten/ExtraTypes.v ./handwritten/Utility.v -./handwritten/ssp_helper.v - ./handwritten/Dependencies.v ./handwritten/BasePackages.v @@ -42,9 +42,9 @@ ./handwritten/CoreTheorem.v -./handwritten/MapPackage.v +# ./handwritten/MapPackage.v -# ./handwritten/ModularTheorem.v -./handwritten/MainTheorem.v +# # ./handwritten/ModularTheorem.v +# ./handwritten/MainTheorem.v -./handwritten/BertieResult.v \ No newline at end of file +# ./handwritten/BertieResult.v \ No newline at end of file diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 507d378c..5b5f5dcd 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -268,6 +268,77 @@ From KeyScheduleTheorem Require Import XTR_XPD. * apply H. Qed. + Lemma Advantage_par_emptyR : + ∀ G₀ G₁ A, + AdvantageE (par G₀ emptym) (par G₁ emptym) A = AdvantageE G₀ G₁ A. + Proof. + intros G₀ G₁ A. + unfold AdvantageE. + unfold par. + rewrite !unionm0. + reflexivity. + Qed. + + Lemma Advantage_parR : + ∀ G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁, + ValidPackage L₀ Game_import E₀ G₀ → + ValidPackage L₁ Game_import E₁ G₁ → + ValidPackage L₁' Game_import E₁ G₁' → + flat E₁ → + trimmed E₀ G₀ → + trimmed E₁ G₁ → + trimmed E₁ G₁' → + AdvantageE (par G₁ G₀) (par G₁' G₀) A = + AdvantageE G₁ G₁' (A ∘ par (ID E₁) G₀). + Proof. + intros G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁. + intros Va0 Va1 Va1' Fe0 Te0 Te1 Te1'. + replace (par G₁ G₀) with ((par (ID E₁) G₀) ∘ (par G₁ (ID Game_import) )). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoints0. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + replace (par G₁' G₀) with ((par (ID E₁) G₀) ∘ (par G₁' (ID Game_import))). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoints0. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + rewrite -Advantage_link. + unfold Game_import. rewrite -fset0E. + rewrite Advantage_par_emptyR. + reflexivity. + Unshelve. all: auto. + Qed. + + (*** Core *) Section Core. @@ -1747,4 +1818,2410 @@ Section Core. Time Defined. (* 36.626 *) Fail Next Obligation. + Definition Gacr (f : HashFunction) (b : bool) : + package fset0 + [interface] + [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. + (* Proof. *) + (* refine [package *) + (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) + (* ret fail *) + (* (* (* get_or_fn _ _ _ *) *) *) + (* (* d ← untag (match f with | f_hash | f_xtr => xtr t end) ;; *) *) + (* (* if b && d \in Hash *) *) + (* (* then fail *) *) + (* (* else *) *) + (* (* ret d *) *) + (* } *) + (* ]. *) + (* Qed. *) + Admitted. + + Definition R_alg : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + + Definition R_cr : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + + Definition R_Z (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_D (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_xtr (n : name) (ℓ : nat) : + n \in XTR_names -> + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_xpd (n : name) (ℓ : nat) : + n \in XPR -> + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_pi (L : list name) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Axiom Gsodh : + forall (d k : nat), + (d < k)%nat -> + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gxtr : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gxpd : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gpi : + forall (d k : nat), + (d < k)%nat -> + forall (L : list name) + (f : ZAF), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Ai : raw_package -> bool -> raw_package. + Axiom R_sodh : package fset0 [interface] [interface]. + + Obligation Tactic := (* try timeout 8 *) idtac. + + Notation " 'chXTRinp' " := + (chHandle × chHandle) + (in custom pack_type at level 2). + Notation " 'chXTRout' " := + (chHandle) + (in custom pack_type at level 2). + + Program Definition KeysAndHash (d k : nat) (H_lt : (d < k)%nat) f_ks f_ls : package (L_K :|: L_L) [interface] ((SET_n all_names d k :|: SET_ℓ [PSK] k d.+1 :|: GET_n all_names d k):|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) := + {package (par (par (Ks d k (ltnW H_lt) all_names f_ks erefl ∘ Ls k all_names f_ls erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true))}. + Next Obligation. + intros. + eapply valid_par_upto. + 2:{ + eapply valid_par. + 2: eapply valid_link. + 2: eapply pack_valid. + 2: eapply pack_valid. + 2:{ + eapply valid_link. + 1: eapply pack_valid. + 1: eapply pack_valid. + } + unfold Ks. + unfold K_package. + + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym, function2_fset_cat. + unfold combined. + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym. + solve_Parable2. + } + 2: eapply pack_valid. + 2: rewrite fsetUid fsetU0; apply fsubsetxx. + 2: rewrite !fsetUid ; apply fsubsetxx. + 2:{ + rewrite (fset_cons (SET PSK d.+1 k, _)). + rewrite fset1E. + unfold SET_ℓ. + unfold interface_foreach. + solve_in_fset. + } + + rewrite <- trimmed_hash. + unfold Ks. + unfold K_package. + + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym, function2_fset_cat. + unfold combined. + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym. + solve_Parable2. + Qed. + Fail Next Obligation. + + Lemma subset_all (d k : nat) (H_lt : (d < k)%nat) : + interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_n I_star d k :|: SET_n O_star d k + :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + :|: (SET_ℓ [:: DH] k 0 + :|: interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK]) + :<=: SET_n all_names d k :|: SET_ℓ [:: PSK] k d.+1 :|: GET_n all_names d k + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]. + Proof. + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + apply subset_pair ; [ | apply fsubsetxx ]. + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite <- fsetUA. + rewrite <- (fsetUC (GET_n all_names d k)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + + rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + Qed. + + Program Definition G_check_XTR_XPD (d k : nat) (H_lt : (d < k)%nat) f_XTR_XPD : + package fset0 (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_n I_star d k :|: SET_n O_star d k + :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ])) (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k) := + {package (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k f_XTR_XPD H_lt)))}. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Next Obligation. + intros. + { + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + Qed. + + (* Page 70 *) + Program Definition G_core_Hash (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (G_check_XTR_XPD d k H_lt (fun _ => false)) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (KeysAndHash d k H_lt (fun _ _ => false) (fun _ => Z)) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true)) *) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Next Obligation. + intros. + + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + eapply valid_package_inject_export. + 2: apply pack_valid. + now apply subset_all. + } + + Unshelve. + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold G_check_XTR_XPD. + unfold pack. + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + Program Definition G_core_D (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun _ => false) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + + Program Definition G_core_R_esalt (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun _ => false) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + Time Optimize Heap. + + Program Definition G_core_SODH (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + (* Gcore_sodh d k false. *) + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + HB.instance Definition _ : Equality.axioms_ name := + {| + Equality.eqtype_hasDecEq_mixin := + {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} + |}. + + Definition N_star := [ES; EEM; CET; BIND; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM; ZERO_SALT; ESALT; ZERO_IKM]. + Lemma N_star_correct : + (forall x, (x \in all_names /\ x \notin [PSK; DH]) <-> x \in N_star). + Proof. + intros. + split. + - intros []. + rewrite !in_cons in H |- *. + now repeat (move /orP: H => [/eqP ? | H] ; subst) ; [ subst .. | discriminate ]. + - intros. + rewrite !in_cons in H |- *. + now repeat (move /orP: H => [/eqP ? | H] ; subst) ; [ subst .. | discriminate ] ; simpl. + Qed. + + Program Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if ℓ >=? i then false else true + else false) erefl + ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) + (K_package k PSK d.+1 H_lt (i == d) ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + Time Optimize Heap. + + (* Idealization order (hybridazation argument for a given level) *) + Program Definition G_core_hyb_pred_ℓ_c (d k : nat) (H_lt : (d < k)%nat) (i : nat) (C : list name) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if (ℓ + (name \in C)) >=? i then false else true + else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + + (* Idealization order (hybridazation argument for a given level) *) + Program Definition G_core_ki (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + {package + (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) + _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _)) ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) + _ erefl _ _) + (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) + _ erefl _) + + ) ) ∘ + (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d.+1 H_lt true ∘ L_package k PSK D)) (Hash true)) + }. + Solve Obligations with intros ; solve_idents. + Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. + Solve Obligations with easy. + Next Obligation. + intros. + rewrite <- fset0U. + eapply valid_link. + 1:{ + rewrite <- fset0U. + replace + (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) + with + (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). + 2:{ + rewrite <- !fsetUA. + f_equal. + rewrite (fsetUC (GET_n _ _ _)). + rewrite !fsetUA. + f_equal. + rewrite (fsetUC (XTR_n _ _)). + rewrite <- !fsetUA. + f_equal. + rewrite fsetUC. + reflexivity. + } + eapply valid_par. + 2:{ + rewrite <- fsetUid. + eapply valid_link. + 1:{ + rewrite <- fsetUid. + rewrite <- !(fsetUA (XPD_n d k)). + eapply valid_par. + 2: apply pack_valid. + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2: apply pack_valid. + 2: apply pack_valid. + shelve. + } + shelve. + } + { + (* rewrite <- fsetUid. *) + (* rewrite fsetUA. *) + (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) + eapply valid_par_upto. + 2: apply pack_valid. + 2: apply pack_valid. + 2: solve_in_fset. + 2:{ + (* TODO: SET PSK ℓ.+1 ? *) + apply fsubsetxx. + + } + 2:{ + rewrite <- fsetUA. + rewrite fsetUC. + rewrite (fsetUC (XPD_n _ _)). + rewrite !fsetUA. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite (fsetUC (GET_n _ _ _)). + rewrite <- fsetUA. + rewrite fsetUC. + apply subset_pair ; [ | apply fsubsetxx ]. + rewrite fsubUset. + rewrite fsubsetxx. + rewrite Bool.andb_true_r. + unfold GET_n. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + apply interface_foreach_subsetR. + 2: easy. + exists BINDER. + eexists ; [ easy | ]. + apply fsubsetxx. + } + shelve. + } + } + 2:{ + rewrite <- fsetUid. + eapply valid_par. + 2:apply pack_valid. + 2:apply pack_valid. + shelve. + } + shelve. + } + { + rewrite <- fsetU0. + + replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with + (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d + :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k + :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k + :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) + ) + :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) + [:: PSK] :|: interface_hierarchy + (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) + :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) + ). + 2:{ + rewrite !fsetUA. + repeat set (interface_hierarchy_foreach _ _ _). + repeat set (interface_hierarchy _ _). + repeat set (interface_foreach _ _). + repeat set (GET_n _ _ _). + repeat set (SET_n _ _ _). + solve_fset_eq. + } + + unfold interface_foreach. + rewrite <- (reindex_interface_hierarchy_PSK2 d k). + unfold interface_hierarchy ; fold interface_hierarchy. + rewrite fsetUA. + + rewrite <- (fsetUid [interface]). + eapply valid_par. + 2:{ + rewrite <- fsetUid. + rewrite <- (fsetUid [interface]). + eapply valid_par. + 3:{ + eapply valid_package_inject_export. + 2: eapply valid_link ; apply pack_valid. + solve_in_fset. + } + 2:{ + eapply valid_link. + 1:{ + eapply valid_package_inject_export. + 2: apply pack_valid. + rewrite fsetUA. + rewrite <- fsetUA. + rewrite (fsetUC (SET_n all_names _ _)). + apply subset_pair. + - rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold GET_ℓ. + rewrite <- !interface_foreach_cat. + unfold cat ; fold (cat O_star). + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + - rewrite <- !fsetUA. + rewrite fsubUset. + rewrite !fsetUA. + apply /andP ; split. + { + unfold SET_n. + apply interface_hierarchy_subsetR. + exists O, (leq0n _). + unfold SET_ℓ. + apply interface_foreach_subset. + intros. + rewrite mem_seq1 in H. + move: H => /eqP H ; subst. + apply interface_foreach_subsetR. + 2: easy. + exists DH. + eexists ; [ easy | ]. + apply fsubsetxx. + } + { + rewrite !interface_hierarchy_U. + apply interface_hierarchy_subset_pairs. + intros. + unfold SET_ℓ. + rewrite <- !interface_foreach_cat. + rewrite fsubUset. + apply /andP ; split. + { + apply interface_foreach_subset. + intros. + apply interface_foreach_subsetR. + 2: easy. + exists x. + eexists. + 2: apply fsubsetxx. + rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. + all: now rewrite eqxx. + } + { + apply interface_foreach_subsetR. + 2: easy. + exists PSK. + eexists ; [ easy | ]. + apply fsubsetxx. + } + } + } + 1: apply pack_valid. + } + shelve. + } + 2: apply pack_valid. + shelve. + } + + Unshelve. + 1:{ + unfold combined_ID. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + 1:{ + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + solve_Parable2. + } + 1:{ + unfold combined_ID. + unfold G_check. + unfold eq_rect. + destruct eq_ind. + unfold G_dh. + unfold DH_package. + unfold parallel_ID. + unfold parallel_package. + unfold combined_ID. + unfold G_XTR_XPD. + unfold XPD_packages. + unfold XTR_packages. + unfold pack. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + destruct Logic.eq_sym. + solve_Parable2. + } + { + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + { + rewrite <- trimmed_hash. + unfold Ks. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + destruct function2_fset_cat. + unfold combined. + unfold eq_rect_r. + unfold eq_rect. + destruct Logic.eq_sym. + unfold K_package. + solve_Parable2. + } + Time Qed. + Fail Next Obligation. + End Core. diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 7fb36007..609f405f 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -81,6 +81,8 @@ From KeyScheduleTheorem Require Import XTR_XPD. From KeyScheduleTheorem Require Import Core. (* From KeyScheduleTheorem Require Import MapPackage. *) +(*** Helper *) + (*** Core theorem *) Section CoreTheorem. @@ -88,819 +90,8 @@ Section CoreTheorem. Context {DepInstance : Dependencies}. Existing Instance DepInstance. - (* Definition Gcore_hyb : forall d (ℓ : nat), *) - (* package f_parameter_cursor_loc *) - (* ((GET_ℓ XPR d ℓ :|: SET_ℓ XPR d ℓ) *) - (* :|: (GET_DH_ℓ d ℓ :|: SET_DH_ℓ d ℓ) *) - (* :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] *) - (* :|: (GET_ℓ XTR_names d ℓ :|: SET_ℓ XTR_names d ℓ)) *) - (* (SET_O_star_ℓ d ℓ :|: GET_O_star_ℓ d ℓ). *) - (* Proof. *) - (* intros. *) - (* epose {package (Ks ℓ d _ O_star false erefl ∘ Ls ℓ O_star (fun x => F) erefl)}. *) - (* fold GET. *) - (* Admitted. *) - - (* Definition Gcore_ki : forall d k, *) - (* package f_parameter_cursor_loc *) - (* ((GET_n XPR d k :|: SET_n XPR d k) *) - (* :|: (GET_DH d k :|: SET_DH d k) *) - (* :|: [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout] *) - (* :|: (GET_n XTR_names d k :|: SET_n XTR_names d k)) *) - (* (SET_O_star d k :|: GET_O_star d k). *) - (* Proof. *) - (* intros. *) - (* Admitted. *) - - Axiom hash : nat -> nat. - Definition Gacr (f : HashFunction) (b : bool) : - package fset0 - [interface] - [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. - (* Proof. *) - (* refine [package *) - (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) - (* ret fail *) - (* (* (* get_or_fn _ _ _ *) *) *) - (* (* d ← untag (match f with | f_hash | f_xtr => xtr t end) ;; *) *) - (* (* if b && d \in Hash *) *) - (* (* then fail *) *) - (* (* else *) *) - (* (* ret d *) *) - (* } *) - (* ]. *) - (* Qed. *) - Admitted. - - (* Definition Gacr : *) - (* loc_GamePair *) - (* [interface *) - (* (* #val #[ ACR ] : 'unit → 'unit *) *) - (* ]. *) - (* (* HASH(t) .. *) *) - - Definition R_alg : - package fset0 - [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) - [interface]. - Proof. - Admitted. - - Definition R_cr : - package fset0 - [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) - [interface]. - Proof. - Admitted. - - Definition R_Z (f : HashFunction) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_D (f : HashFunction) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_xtr (n : name) (ℓ : nat) : - n \in XTR_names -> - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_xpd (n : name) (ℓ : nat) : - n \in XPR -> - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_pi (L : list name) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Axiom Gsodh : - forall (d k : nat), - (d < k)%nat -> - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gxtr : - forall (d k : nat), - (d < k)%nat -> - forall (n : name) (ℓ : nat), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gxpd : - forall (d k : nat), - (d < k)%nat -> - forall (n : name) (ℓ : nat), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gpi : - forall (d k : nat), - (d < k)%nat -> - forall (L : list name) - (f : ZAF), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Ai : raw_package -> bool -> raw_package. - Axiom R_sodh : package fset0 [interface] [interface]. - - Obligation Tactic := (* try timeout 8 *) idtac. - (* Program Definition layer1 ℓ d (H_le : (ℓ <= d)%nat) : *) - (* package fset0 *) - (* [interface] *) - (* [interface *) - (* #val #[ GET DH ℓ d ] : chGETinp → chGETout *) - (* ] := *) - (* {package Nk_package ℓ d H_le ∘ (par (DH_package d) (Ls d [DH] Z erefl)) #with _ }. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Program Definition layer2_zero d k H_lt : *) - (* package fset0 *) - (* [interface *) - (* #val #[ SET PSK O k ] : chSETinp → chSETout *) - (* ] *) - (* [interface *) - (* #val #[ GET PSK O k ] : chGETinp → chGETout *) - (* ] := *) - (* {package Ks d k H_lt [PSK] false erefl ∘ Ls k [PSK] Z erefl #with _ }. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Program Definition layer2_succ ℓ d k H_lt (H_le : (ℓ <= d)%nat) : *) - (* package fset0 *) - (* [interface *) - (* #val #[ SET PSK ℓ d ] : chSETinp → chSETout *) - (* ] *) - (* [interface *) - (* #val #[ GET PSK ℓ d ] : chGETinp → chGETout *) - (* ] := *) - (* {package Ks d k H_lt [PSK] false erefl ∘ Ls d [PSK] Z erefl #with _ }. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Program Definition layer2_xpd ℓ k H_lt : *) - (* package (L_K :|: L_L) *) - (* [interface] *) - (* (XPD_n_ℓ k ℓ) := *) - (* XPD_ ℓ k H_lt. *) - (* Fail Next Obligation. *) - - (* Definition layer3 ℓ d (H_le : (ℓ <= d)%nat) := Hash. *) - - (* Program Definition layer4_salt d k H_lt : *) - (* package (L_K :|: L_L) *) - (* [interface] *) - (* (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_SALT ℓ k ] : chGETinp → chGETout]) d) := *) - (* {package Ks d k H_lt [ZERO_SALT] false erefl ∘ Ls k [ZERO_SALT] Z erefl #with _}. *) - (* Next Obligation. *) - (* intros. *) - (* eapply valid_link. *) - (* 2: apply pack_valid. *) - - (* eapply valid_package_inject_export. *) - (* 2: apply pack_valid. *) - (* apply fsubsetU. *) - (* apply /orP ; right. *) - (* unfold interface_hierarchy_foreach. *) - (* unfold interface_foreach. *) - (* apply fsubsetxx. *) - (* Qed. *) - (* Fail Next Obligation. *) - - (* Program Definition layer4_ikm d k H_lt : *) - (* package (L_K :|: L_L) *) - (* [interface] *) - (* (interface_hierarchy (fun ℓ => [interface #val #[ GET ZERO_IKM ℓ k ] : chGETinp → chGETout]) d) := *) - (* {package Ks d k H_lt [ZERO_IKM] false erefl ∘ Ls k [ZERO_IKM] Z erefl #with _}. *) - (* Next Obligation. *) - (* intros. *) - (* eapply valid_link. *) - (* 2: apply pack_valid. *) - - (* eapply valid_package_inject_export. *) - (* 2: apply pack_valid. *) - (* apply fsubsetU. *) - (* apply /orP ; right. *) - (* unfold interface_hierarchy_foreach. *) - (* unfold interface_foreach. *) - (* apply fsubsetxx. *) - (* Qed. *) - (* Fail Next Obligation. *) - - (* Program Definition layer4_xtr ℓ d b H_le : *) - (* package fset0 *) - (* (XTR_n_ℓ d ℓ :|: GET_ℓ XTR_names d ℓ) *) - (* (SET_ℓ XTR_names d ℓ) := xtr_level d ℓ b H_le. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Program Definition layer4_check d k : *) - (* package fset0 *) - (* (XPD_n d k) *) - (* (XPD_n d k :|: interface_hierarchy (fun ℓ => [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout ]) d) := _. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Program Definition layer4_xpd d k H_lt : *) - (* package fset0 *) - (* (XPD_n d k :|: SET_n XPR d k) *) - (* (GET_n XPR d k) := {package XPD_packages d k H_lt ∘ layer4_check d k #with _}. *) - (* Admit Obligations. *) - (* Fail Next Obligation. *) - - (* Lemma interface_foreach_cat : forall {A} f L1 L2, *) - (* interface_foreach f (L1 ++ L2) = *) - (* interface_foreach (A := A) f L1 :|: interface_foreach (A := A) f L2. *) - (* Proof. *) - (* induction L1 ; intros. *) - (* - simpl. *) - (* rewrite <- fset0E. *) - (* rewrite fset0U. *) - (* reflexivity. *) - (* - rewrite interface_foreach_cons. *) - (* rewrite <- fsetUA. *) - (* rewrite <- IHL1. *) - (* now rewrite <- interface_foreach_cons. *) - (* Qed. *) - - (* Definition xpd_xpr_approximation *) - (* (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) - (* package (L_K :|: L_L) *) - (* [interface] *) - (* (XPD_n d k :|: XTR_n d k). *) - (* Proof. *) - (* refine ({package par (XPD_ d k H_lt) (XTR_ d k b (ltnW H_lt))}). *) - (* unfold XPD_, XTR_. *) - (* unfold pack. *) - - (* eapply valid_par_upto. *) - (* 2: apply XPD_. *) - (* 2: apply XTR_. *) - (* 2:{ *) - (* rewrite fsetUid. *) - (* apply fsubsetxx. *) - (* } *) - (* 3: apply fsubsetxx. *) - (* 2:{ *) - (* rewrite <- fset0E. *) - (* rewrite fsetU0. *) - (* apply fsub0set. *) - (* } *) - (* rewrite <- trimmed_xpd_package. *) - (* rewrite <- trimmed_xtr_package. *) - (* rewrite !link_trim_commut. *) - (* solve_Parable. *) - (* unfold XPD_n, XTR_n. *) - (* apply idents_interface_hierachy3. *) - (* intros. *) - (* rewrite fdisjointC. *) - (* apply idents_interface_hierachy3. *) - (* intros. *) - (* unfold idents. *) - (* solve_imfset_disjoint. *) - (* Defined. *) - - (* Definition core_approximation *) - (* (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) - (* package (L_K :|: L_L) *) - (* (GET_n O_star d k) *) - (* (XPD_n d k :|: XTR_n d k). *) - (* Proof. *) - (* (* epose (Ks d k (ltnW H_lt) O_star false erefl). *) *) - - (* refine ({package (par *) - (* (XPD_packages d k H_lt *) - (* ∘ par *) - (* (Ks d.+1 k H_lt (undup (XPR ++ XPR_parents)) false erefl *) - (* ∘ Ls k (undup (XPR ++ XPR_parents)) F erefl) Hash) *) - (* (XTR_packages d k b (ltnW (m:=d) (n:=k) H_lt) *) - (* ∘ Ks d k (ltnW (m:=d) (n:=k) H_lt) (undup (XTR_parent_names ++ XTR_names)) false erefl *) - (* ∘ Ls k (undup (XTR_parent_names ++ XTR_names)) Z erefl))}). *) - (* unfold XPD_, XTR_. *) - (* unfold pack. *) - - (* eapply valid_par_upto. *) - (* 2: apply XPD_. *) - (* 2: apply XTR_. *) - (* 2:{ *) - (* rewrite fsetUid. *) - (* apply fsubsetxx. *) - (* } *) - (* 3: apply fsubsetxx. *) - (* 2:{ *) - (* rewrite <- fset0E. *) - (* rewrite fsetU0. *) - (* apply fsub0set. *) - (* } *) - (* rewrite <- trimmed_xpd_package. *) - (* rewrite <- trimmed_xtr_package. *) - (* rewrite !link_trim_commut. *) - - (* solve_Parable. *) - (* unfold XPD_n, XTR_n. *) - (* apply idents_interface_hierachy3. *) - (* intros. *) - (* rewrite fdisjointC. *) - (* apply idents_interface_hierachy3. *) - (* intros. *) - (* unfold idents. *) - (* solve_imfset_disjoint. *) - (* Defined. *) - - (* Definition core (d k : nat) (b : bool) (H_lt : (d < k)%nat) : *) - (* package fset0 *) - (* (interface_hierarchy (fun x => [interface]) d) *) - (* (GET_O_star d k). *) - (* Proof. *) - (* refine {package (pack _) #with valid_package_inject_export _ _ _ (GET_n all_names d k :|: SET_n all_names d k) _ _ _}. *) - (* 2:{ *) - (* unfold GET_O_star. *) - (* unfold GET_n. *) - (* unfold SET_n. *) - (* rewrite interface_hierarchy_foreachU. *) - - (* apply interface_hierarchy_foreach_subset. *) - (* intros. *) - (* apply interface_hierarchy_foreach_subsetR. *) - (* 2: easy. *) - (* exists x. *) - (* assert (x \in all_names). *) - (* { *) - (* clear -H. *) - (* rewrite !in_cons in H. *) - (* unfold all_names. *) - (* rewrite !in_cons. *) - (* repeat (move: H => /orP [ /eqP ? | H ]) ; [ subst.. | discriminate ]. *) - (* all: now rewrite eqxx. *) - (* } *) - (* exists H1. *) - (* exists ℓ, H0. *) - (* apply fsubsetUl. *) - (* } *) - - (* unfold GET_n. *) - (* unfold SET_n. *) - (* rewrite interface_hierarchy_foreachU. *) - - (* refine (ℓ_packages d _ _ _). *) - (* (* 2:{ *) *) - (* (* intros. *) *) - (* (* apply idents_foreach_disjoint_foreach. *) *) - (* (* intros. *) *) - (* (* unfold idents. *) *) - (* (* solve_imfset_disjoint. *) *) - (* (* } *) *) - - (* Unshelve. *) - (* 3:{ *) - (* intros n H. *) - - (* epose (dh := layer1 n d H). *) - (* epose proof (layer2_xpd n k (ltac:(Lia.lia))). *) - (* epose (hash := layer3 n d H). *) - (* epose (salt0 := layer4_salt d k (ltnW H_lt)). *) - (* epose (ikm0 := layer4_ikm d k (ltnW H_lt)). *) - (* epose (check := layer4_check d k). *) - (* epose (xtr := layer4_xtr n d b H). *) - (* epose (xpd := layer4_xpd d k H_lt). *) - - (* epose (T := package fset0 *) - (* [interface] *) - (* (match n with *) - (* | O => [interface] *) - (* | S n => (interface_foreach (λ name, [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names) *) - (* end)). *) - - (* epose (set_xtr := fun psk (sub_packages : T) => {package *) - (* xtr ∘ *) - (* parallel_raw [ *) - (* pack dh; *) - (* pack psk; *) - (* pack hash; *) - (* pack salt0; *) - (* pack ikm0; *) - (* pack sub_packages] *) - (* #with _} : package fset0 [interface] (SET_ℓ XTR_names k n)). *) - (* (* Unshelve. *) *) - (* (* { *) *) - - (* (* } *) *) - - (* epose (set_xpd := fun psk (sub_packages : T) => {package *) - (* xpd ∘ *) - (* parallel_raw [ *) - (* pack dh; *) - (* pack psk; *) - (* pack hash; *) - (* pack salt0; *) - (* pack ikm0; *) - (* pack sub_packages] *) - (* #with _} : package fset0 [interface] (SET_ℓ XPR k n)). *) - - (* (* epose (output := fun psk sub_packages => {package Ks d O_star false erefl ∘ *) *) - (* (* (parallel_raw [ *) *) - (* (* pack (set_xtr psk sub_packages); *) *) - (* (* pack (set_xpd psk sub_packages); *) *) - (* (* pack (Ls d O_star Z _)]) #with _}). *) *) - (* epose (output := fun psk *) - (* (sub_packages : T) => *) - (* {package (parallel_package d all_names (fun name => K_package k name n _ false) _ _ _) ∘ *) - (* (parallel_raw [ *) - (* pack (set_xtr psk sub_packages); *) - (* pack (set_xpd psk sub_packages); *) - (* pack (Ls d all_names Z _)]) #with _}). *) - - - (* assert (package fset0 *) - (* [interface] *) - (* (interface_foreach (λ name, *) - (* [interface #val #[GET name n k] : chDHEXPout → chGETout ] :|: [interface #val #[SET name n k] : chSETinp → chSETout ]) all_names)). *) - (* { *) - (* induction n as [ | ℓ ]. *) - (* - epose (psk0 := layer2_zero d k (ltnW H_lt)). *) - (* refine (output psk0 _). *) - (* refine {package emptym #with valid_empty_package _ _}. *) - (* - epose (pskS := layer2_succ (S ℓ) k k (leqnn k) _). *) - (* refine (output pskS _). *) - (* specialize (IHℓ (leq_trans H (leqnSn _))). *) - (* unfold T. *) - (* eapply IHℓ. *) - (* } *) - - (* refine {package X0 #with _}. *) - (* Show Proof. *) - (* } *) - (* { *) - (* intros. *) - (* unfold pack. *) - (* destruct n. *) - (* - unfold nat_rect. *) - (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) - (* { *) - (* intros. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_empty_package. *) - (* } *) - (* unfold parallel_package. *) - (* rewrite <- (trimmed_parallel_raw (f := (λ n : name, *) - (* [interface #val #[GET n 0 k] : chDHEXPout → chGETout ] *) - (* :|: [interface #val #[SET n 0 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) - (* { *) - (* rewrite !link_trim_commut. *) - (* apply trimmed_trim. *) - (* } *) - (* { *) - (* intros. *) - (* unfold idents. *) - (* try rewrite !imfsetU *) - (* ; try rewrite !fdisjointUr *) - (* ; try rewrite !fdisjointUl *) - (* ; try rewrite <- !fset1E *) - (* ; try rewrite !imfset1 *) - (* ; try rewrite !fdisjoints1 *) - (* ; repeat (apply /andP ; split) *) - (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) - (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) - (* (* solve_imfset_disjoint. *) *) - (* } *) - (* { *) - (* reflexivity. *) - (* } *) - (* { *) - (* apply trimmed_pairs_map. *) - (* intros. *) - (* rewrite <- H. *) - (* set (K_package _ _ _ _ _). *) - (* rewrite fsetUC. *) - (* rewrite <- fset1E. *) - (* rewrite <- fset_cons. *) - (* apply trimmed_trim. *) - (* } *) - (* - unfold nat_rect. *) - (* eassert (forall n l d H0 H1, trimmed _ (K_package d n l H0 H1)). *) - (* { *) - (* intros. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_package_cons. *) - (* apply trimmed_empty_package. *) - (* } *) - (* unfold parallel_package. *) - (* rewrite <- (trimmed_parallel_raw (f := (λ n0 : name, *) - (* [interface #val #[GET n0 n.+1 k] : chDHEXPout → chGETout ] *) - (* :|: [interface #val #[SET n0 n.+1 k] : chUNQinp → chDHEXPout ])) (I := all_names)). *) - (* { *) - (* (* set (parallel_raw _). *) *) - (* rewrite (* ! *)link_trim_commut. *) - (* apply trimmed_trim. *) - (* } *) - (* { *) - (* intros. *) - (* unfold idents. *) - (* try rewrite !imfsetU *) - (* ; try rewrite !fdisjointUr *) - (* ; try rewrite !fdisjointUl *) - (* ; try rewrite <- !fset1E *) - (* ; try rewrite !imfset1 *) - (* ; try rewrite !fdisjoints1 *) - (* ; repeat (apply /andP ; split) *) - (* ; try (rewrite (ssrbool.introF (fset1P _ _)) ; [ reflexivity | ]). *) - (* all : try (now apply serialize_name_notin_all ; (now left ; split ; [ reflexivity | ((now right) || (now left)) ]) || (now right ; split ; [ discriminate | split ; [ Lia.lia | Lia.lia ] ])). *) - (* (* solve_imfset_disjoint. *) *) - (* } *) - (* { *) - (* reflexivity. *) - (* } *) - (* { *) - (* apply trimmed_pairs_map. *) - (* intros. *) - (* rewrite <- H. *) - (* set (K_package _ _ _ _ _). *) - (* rewrite fsetUC. *) - (* rewrite <- fset1E. *) - (* rewrite <- fset_cons. *) - (* apply trimmed_trim. *) - (* } *) - (* } *) - (* { *) - (* intros. *) - (* apply idents_foreach_disjoint_foreach. *) - (* intros. *) - (* unfold idents. *) - (* solve_imfset_disjoint. *) - (* } *) - - (* Unshelve. *) - (* { *) - (* ssprove_valid. *) - (* 1:{ *) - (* eapply valid_package_inject_import. *) - (* 2:{ *) - (* unfold XTR_n_ℓ. *) - (* unfold GET_ℓ. *) - (* rewrite interface_foreach_U. *) - - (* unfold parallel_raw, List.fold_left. *) - (* unfold XTR_names, interface_foreach. *) - - (* (* apply (valid_parable [:: pack dh; pack psk; pack hash; pack salt0; pack ikm0; pack sub_packages]). *) *) - - (* ssprove_valid. *) - (* all: try apply fsubsetxx. *) - (* 1-5: admit. *) - (* admit. *) - (* } *) - (* rewrite <- !fset0E. *) - (* rewrite !fsetU0 ; rewrite !fset0U. *) - (* admit. *) - (* } *) - (* { *) - (* apply fsubsetxx. *) - (* } *) - (* { *) - (* rewrite !fsetU0 ; rewrite !fset0U. *) - (* rewrite fsetUid. *) - (* admit. *) - (* } *) - (* } *) - (* all: admit. *) - (* Admitted. *) - - Notation " 'chXTRinp' " := - (chHandle × chHandle) - (in custom pack_type at level 2). - Notation " 'chXTRout' " := - (chHandle) - (in custom pack_type at level 2). - - (* Page 70 *) - Program Definition G_core_Hash (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun _ => false) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK Z)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - Program Definition G_core_D (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun _ => false) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - Program Definition G_core_R_esalt (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun _ => false) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - Program Definition G_core_SODH (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - (* Gcore_sodh d k false. *) - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - HB.instance Definition _ : Equality.axioms_ name := - {| - Equality.eqtype_hasDecEq_mixin := - {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} - |}. - - Definition N_star := all_names. (* TODO *) - Program Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => - if (name \in N_star) || (name == PSK) - then - if ℓ >=? i then false else true - else false) erefl - ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) - (K_package k PSK d H_lt (i == d) ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - (* Idealization order (hybridazation argument for a given level) *) - Program Definition G_core_hyb_pred_ℓ_c (d k : nat) (H_lt : (d < k)%nat) (i : nat) (C : list name) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => - if (name \in N_star) || (name == PSK) - then - if (ℓ + (name \in C)) >=? i then false else true - else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - (* Idealization order (hybridazation argument for a given level) *) - Program Definition G_core_ki (d k : nat) (H_lt : (d < k)%nat) : - package (L_K :|: L_L) - [interface] - (XPD_n d k - :|: DH_interface - :|: SET_ℓ [PSK] k 0 - :|: XTR_n d k - :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d H_lt true ∘ L_package k PSK D)) (Hash true)) - }. - Admit Obligations. - Fail Next Obligation. - - Lemma advantage_reflexivity : - forall P A, AdvantageE P P A = 0%R. - Proof. - unfold AdvantageE. - intros. - rewrite subrr. - rewrite Num.Theory.normr0. - reflexivity. - Qed. + Time Optimize Heap. + Time Optimize Heap. Lemma d2 : forall (d k : nat) H_lt, @@ -961,7 +152,191 @@ Section CoreTheorem. intros. Admitted. + Definition SblngN (n : name) : list name := + filter (fun n' => + (nfto (fst (PrntN n)) == nfto (fst (PrntN n'))) + && (nfto (snd (PrntN n)) == nfto (snd (PrntN n')))) all_names. + + Fixpoint idealization_loop (fuel : nat) (io : list (list name)) {struct fuel} : list (list name) := + match fuel with + | O => io + | S fuel => + let ioc := last [] io in + if ioc != all_names + then + match (filter (fun n => (n \notin ioc) && (let (n1, n2) := PrntN n in ((nfto n1 \in ioc) || (nfto n1 == BOT)) && ((nfto n2 \in ioc) || (nfto n2 == BOT)) && (all (fun sn => sn \notin ioc) (SblngN n)))) all_names) with + | [] => io + | (x :: xs) => + let n_c := x + in idealization_loop fuel (io ++ [ioc ++ SblngN n_c]) + end + else io + end. + + Lemma idealization_order_one_iter : + forall fuel io, + idealization_loop fuel.+1 io = + (let ioc := last [] io in + if ioc != all_names + then + match (filter (fun n => (n \notin ioc) && (let (n1, n2) := PrntN n in ((nfto n1 \in ioc) || (nfto n1 == BOT)) && ((nfto n2 \in ioc) || (nfto n2 == BOT)) && (all (fun sn => sn \notin ioc) (SblngN n)))) all_names) with + | [] => io + | (x :: xs) => + let n_c := x + in idealization_loop fuel (io ++ [ioc ++ SblngN n_c]) + end + else io). + Proof. reflexivity. Qed. + + Lemma filter_cons : forall {A} f (a : A) x, + filter f (a :: x) = + if (f a) + then a :: filter f x + else filter f x. + Proof. reflexivity. Qed. + + Definition IdealizationOrder := + let io := [[PSK; ZERO_SALT; DH; ZERO_IKM]] in + let fuel := List.length all_names in + idealization_loop fuel io. + + Definition IdealizationOrderPreCompute := + [:: [:: PSK; ZERO_SALT; DH; ZERO_IKM]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT; AS]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM]]. + + Lemma compute_eq : (IdealizationOrder = IdealizationOrderPreCompute). + Proof. + unfold IdealizationOrder. + + repeat (rewrite idealization_order_one_iter ; + unfold last ; simpl (_ != _) ; hnf ; + unfold all_names ; + + repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter ; + + unfold SblngN at 1 ; + unfold all_names ; + + repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter ; + rewrite eqxx ; + + unfold all ; + simpl (if _ then _ else _) ; + hnf ; + unfold SblngN ; + unfold all_names ; + repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter ; + rewrite eqxx ; + + simpl cat). + + do 1 (rewrite idealization_order_one_iter ; + unfold last ; simpl (_ != _) ; hnf ; + unfold all_names ; + + repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter). + + reflexivity. + + (* Time Qed. *) Admitted. + + Lemma d10_helper : forall j, + (j.+1 <= List.length IdealizationOrderPreCompute)%nat -> + forall x, + x \in nth all_names IdealizationOrderPreCompute j -> + x \in nth all_names IdealizationOrderPreCompute j.+1. + Proof. + intros. + unfold IdealizationOrderPreCompute in H |- *. + do 8 (destruct j ; [ simpl in H0 |- *; rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ] ; easy | ]). + discriminate. + Qed. + + Lemma d10 : forall i j, + (i < j)%nat -> + (j <= List.length IdealizationOrderPreCompute)%nat -> + forall x, + x \in nth all_names IdealizationOrderPreCompute i -> + x \in nth all_names IdealizationOrderPreCompute j. + Proof. + intros. + induction j. + - destruct i ; [ | discriminate ]. + apply H1. + - destruct (i == j) eqn:i_is_j. + 2: now apply d10_helper, IHj. + { + clear H IHj. + move /eqP: i_is_j => i_is_j. + subst. + now apply d10_helper. + } + Qed. + + Lemma d11 : + forall d k H_lt ℓ c A, + ((c == O)%nat || (PSK \notin nth [] IdealizationOrderPreCompute c.-1)) -> + PSK \in nth [] IdealizationOrderPreCompute c -> + (AdvantageE + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) + A + <= + Advantage (Gxtr d k H_lt ES ℓ) (A ∘ R_xtr ES ℓ erefl))%R. + Proof. + intros. + Admitted. + + Lemma d12 : + forall d k H_lt ℓ c A, + ((c == O)%nat || (ESALT \notin nth [] IdealizationOrderPreCompute c.-1)) -> + ESALT \in nth [] IdealizationOrderPreCompute c -> + (AdvantageE + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) + A + <= + Advantage (Gxtr d k H_lt HS ℓ) (A ∘ R_xtr HS ℓ erefl))%R. + Proof. + intros. + Admitted. + + Lemma d13 : + forall d k H_lt ℓ c A, + ((c == O)%nat || (HSALT \notin nth [] IdealizationOrderPreCompute c.-1)) -> + HSALT \in nth [] IdealizationOrderPreCompute c -> + (AdvantageE + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) + A + <= + Advantage (Gxtr d k H_lt AS ℓ) (A ∘ R_xtr AS ℓ erefl))%R. + Proof. + intros. + Admitted. + + Lemma d14 : + forall d k H_lt ℓ c A n (H_in_xpr : n \in XPR), + (nfto (fst (PrntN n)) \notin nth [] IdealizationOrderPreCompute c.-1) -> + nfto (fst (PrntN n)) \in nth [] IdealizationOrderPreCompute c.+1 -> + (AdvantageE + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) + A + <= + Advantage (Gxtr d k H_lt n ℓ) (A ∘ R_xpd n ℓ H_in_xpr))%R. + Proof. + intros. + Admitted. + (* d6: Hybrid lemma *) + (* Dependends on idealization order *) Lemma d6 : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -978,8 +353,190 @@ Section CoreTheorem. )%R. Proof. intros. - Admitted. + eapply Order.le_trans. + 1:{ + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (2 := (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute 0))). + + apply Num.Theory.lerD. + { + instantiate (1 := 0%R). + + unfold G_core_hyb_ℓ. + unfold G_core_hyb_pred_ℓ_c. + + unfold pack. + rewrite <- !Advantage_link. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + rewrite <- (par_commut (Hash true)). + 2: admit. + + setoid_rewrite (Advantage_par (Hash true)). + 2,3,4,5,6,7,8: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). + 2: admit. + + destruct (ℓ == d). + 2:{ + + setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). + 2,3,4,5,6,7,8: admit. + + rewrite <- !Advantage_link. + + replace (G_core_hyb_ℓ_obligation_50 d k H_lt ℓ) with (G_core_hyb_pred_ℓ_c_obligation_50 d k H_lt ℓ (nth [::] IdealizationOrderPreCompute 0)) by admit. + (* destruct ( _ == _ ). *) + (* 2:{ *) + (* erewrite (Advantage_par). *) + (* 2-8: admit. *) + + (* replace () *) + + (* rewrite <- Advantage_link. *) + + (* apply advantage_reflexivity. *) + } + + admit. + } + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (2 := (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute (List.length IdealizationOrderPreCompute - 1)))). + + apply Num.Theory.lerD. + 2:{ + instantiate (1 := 0%R). + admit. + } + + easy. + } + + rewrite add0r addr0. + + eapply Order.le_trans. + 1:{ + instantiate (1 := + sumR 0 (List.length IdealizationOrderPreCompute - 1) _ + (fun c => AdvantageE + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] IdealizationOrderPreCompute c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] IdealizationOrderPreCompute c.+1)) + A)). + + induction (Datatypes.length _). + - unfold sumR. + simpl iota. + unfold List.fold_left. + now rewrite advantage_reflexivity. + - destruct n ; [ apply IHn | ]. + rewrite sumR_succ. + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] IdealizationOrderPreCompute n))). + set (_ + _)%R at 2. + rewrite addrC. + subst s. + + apply Num.Theory.lerD ; [ easy | ]. + + assert (n = n.+1 - 1)%nat by Lia.lia. + rewrite H1. + apply IHn. + } + + unfold sumR. + simpl iota. + unfold List.fold_left. + rewrite add0r. + + eapply Order.le_trans. + { + repeat apply Num.Theory.lerD. + 6:{ + refine (d13 d k H_lt ℓ 5 A _ erefl). + apply /orP. + right. + easy. + } + 3:{ + refine (d12 d k H_lt ℓ 2 A _ erefl). + apply /orP. + right. + easy. + } + 1:{ + refine (d11 d k H_lt ℓ O A _ erefl). + apply /orP. + left. + apply (eqxx O). + } + { + refine (d14 d k H_lt ℓ 1 A EEM erefl _ _). + 2:{ + simpl. + rewrite nfto_name_to_chName_cancel. + easy. + } + { + apply /orP. + rewrite nfto_name_to_chName_cancel. + easy. + } + } + { + refine (d14 d k H_lt ℓ 3 A CHT erefl _ _). + 2:{ + simpl. + rewrite nfto_name_to_chName_cancel. + easy. + } + { + apply /orP. + rewrite nfto_name_to_chName_cancel. + simpl. + easy. + } + } + { + refine (d14 d k H_lt ℓ 4 A CHT erefl _ _). + 2:{ + simpl. + rewrite nfto_name_to_chName_cancel. + easy. + } + { + apply /orP. + rewrite nfto_name_to_chName_cancel. + simpl. + easy. + } + } + { + refine (d14 d k H_lt ℓ 6 A CAT erefl _ _). + 2:{ + simpl. + rewrite nfto_name_to_chName_cancel. + easy. + } + { + apply /orP. + rewrite nfto_name_to_chName_cancel. + simpl. + easy. + } + } + } + + (* easy *) + Admitted. + Lemma hyb_telescope : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -1091,76 +648,6 @@ Section CoreTheorem. apply advantage_reflexivity. Admitted. - Lemma Advantage_par_emptyR : - ∀ G₀ G₁ A, - AdvantageE (par G₀ emptym) (par G₁ emptym) A = AdvantageE G₀ G₁ A. - Proof. - intros G₀ G₁ A. - unfold AdvantageE. - unfold par. - rewrite !unionm0. - reflexivity. - Qed. - - Lemma Advantage_parR : - ∀ G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁, - ValidPackage L₀ Game_import E₀ G₀ → - ValidPackage L₁ Game_import E₁ G₁ → - ValidPackage L₁' Game_import E₁ G₁' → - flat E₁ → - trimmed E₀ G₀ → - trimmed E₁ G₁ → - trimmed E₁ G₁' → - AdvantageE (par G₁ G₀) (par G₁' G₀) A = - AdvantageE G₁ G₁' (A ∘ par (ID E₁) G₀). - Proof. - intros G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁. - intros Va0 Va1 Va1' Fe0 Te0 Te1 Te1'. - replace (par G₁ G₀) with ((par (ID E₁) G₀) ∘ (par G₁ (ID Game_import) )). - 2:{ - erewrite <- interchange. - all: ssprove_valid. - 4:{ - ssprove_valid. - rewrite domm_ID_fset. - rewrite -fset0E. - apply fdisjoints0. - } - 2:{ unfold Game_import. rewrite -fset0E. discriminate. } - 2: apply trimmed_ID. - rewrite link_id. - 2:{ unfold Game_import. rewrite -fset0E. discriminate. } - 2: assumption. - rewrite id_link. - 2: assumption. - reflexivity. - } - replace (par G₁' G₀) with ((par (ID E₁) G₀) ∘ (par G₁' (ID Game_import))). - 2:{ - erewrite <- interchange. - all: ssprove_valid. - 4:{ - ssprove_valid. - rewrite domm_ID_fset. - rewrite -fset0E. - apply fdisjoints0. - } - 2:{ unfold Game_import. rewrite -fset0E. discriminate. } - 2: apply trimmed_ID. - rewrite link_id. - 2:{ unfold Game_import. rewrite -fset0E. discriminate. } - 2: assumption. - rewrite id_link. - 2: assumption. - reflexivity. - } - rewrite -Advantage_link. - unfold Game_import. rewrite -fset0E. - rewrite Advantage_par_emptyR. - reflexivity. - Unshelve. all: auto. - Qed. - Lemma L_package_esalt_D_to_R : forall k A, AdvantageE diff --git a/proofs/ssprove/handwritten/Utility.v b/proofs/ssprove/handwritten/Utility.v index 91ca9b86..a80340e4 100644 --- a/proofs/ssprove/handwritten/Utility.v +++ b/proofs/ssprove/handwritten/Utility.v @@ -68,6 +68,7 @@ Import PackageNotation. From KeyScheduleTheorem Require Import Types. From KeyScheduleTheorem Require Import ExtraTypes. +From KeyScheduleTheorem Require Import ssp_helper. (*** Utility *) @@ -192,7 +193,6 @@ Definition tag : chHash -> chName -> chKey (* TODO: should be key *) := (*** Helper definitions *) -From KeyScheduleTheorem Require Import ssp_helper. Fixpoint map_with_in {A: eqType} {B} (l : list A) (f : forall (x : A), (x \in l) -> B) : list B := match l as k return (k = l -> _) with @@ -805,15 +805,6 @@ Proof. reflexivity. Qed. -Lemma interface_hierarchy_foreach_subset : forall {A} f L d, - interface_hierarchy_foreach f L d :<=: interface_hierarchy_foreach (A := A) f L d. -Proof. - intros. - unfold interface_hierarchy_foreach. - simpl. - apply fsubsetxx. -Qed. - Lemma lower_level_in_interface : forall (f : name -> nat -> Interface) (l : list name) d ℓ (p : nat -> _), p ℓ \in interface_foreach (f^~ ℓ) l -> @@ -1009,6 +1000,22 @@ Proof. reflexivity. Qed. +Lemma interface_foreach_cat : forall {A} f E1 E2, + interface_foreach f (E1 ++ E2) = interface_foreach (A := A) f E1 :|: interface_foreach (A := A) f E2. +Proof. + induction E1; intros. + - simpl. + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + - rewrite interface_foreach_cons. + rewrite <- List.app_comm_cons. + rewrite interface_foreach_cons. + rewrite IHE1. + rewrite fsetUA. + reflexivity. +Qed. + Lemma interface_foreach_U : forall {A} f g E, interface_foreach f E :|: interface_foreach g E = interface_foreach (A := A) (fun n => f n :|: g n) E. @@ -2145,3 +2152,601 @@ Proof. + intros. apply H. Lia.lia. Qed. + + +(*** Ltac Tactics *) + + Lemma idents_disjoint_foreach_in : + (forall {A: eqType} f g (L : list A), + (forall m, (m \in L) -> idents f :#: idents (g m)) -> + idents f :#: idents (interface_foreach g L)). + Proof. + intros. + induction L. + + simpl. + rewrite <- fset0E. + unfold idents. + rewrite imfset0. + apply fdisjoints0. + + rewrite interface_foreach_cons. + unfold idents. + rewrite !imfsetU. + rewrite fdisjointUr. + rewrite IHL ; clear IHL. + * rewrite Bool.andb_true_r. + apply H. + apply mem_head. + * intros. + apply H. + rewrite in_cons. + apply /orP. + now right. + Qed. + + Definition idents_foreach_disjoint_foreach_in : + forall x y k index T1 T2 (Lf Lg : list name), + (forall x, x \in Lf -> x \notin Lg) -> + idents (interface_foreach (fun a => fset [(serialize_name a x k index, T1)]) Lf) + :#: idents (interface_foreach (fun a => fset [(serialize_name a y k index, T2)]) Lg). + Proof. + clear ; intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. + intros. + rewrite fdisjointC. + apply idents_disjoint_foreach_in. + intros. + unfold idents. + solve_imfset_disjoint. + apply serialize_name_notin_all. + left ; split ; [ reflexivity | right ]. + red ; intros ; subst. + specialize (H m H0). + now rewrite H1 in H. + Qed. + + Lemma interface_hierarchy_foreach_shift : + forall d k {index p} L, + interface_hierarchy_foreach (fun n ℓ => (fset [(serialize_name n ℓ k index, p)])) L d.+1 = + interface_foreach (fun n => fset [(serialize_name n O k index, p)]) L + :|: interface_hierarchy_foreach (fun n ℓ => fset [(serialize_name n (ℓ.+1) k index,p ) ]) L d + . + Proof. + intros. + induction d. + - simpl. reflexivity. + - unfold interface_hierarchy_foreach at 2. + unfold interface_hierarchy ; fold interface_hierarchy. + fold (interface_hierarchy_foreach (λ n ℓ, fset [(serialize_name n ℓ.+1 k index, p)]) L). + rewrite fsetUA. + rewrite fsetUC. + rewrite <- IHd. + rewrite fsetUC. + reflexivity. + Qed. + + Lemma subset_pair : forall {A : ordType} (x : {fset A}) y Lx Ly, + x :<=: y -> + Lx :<=: Ly -> + x :|: Lx :<=: y :|: Ly. + Proof. + intros. + rewrite fsubUset ; apply /andP ; split. + * rewrite fsubsetU ; [ easy | ]. + apply /orP ; left. + apply H. + * rewrite fsubsetU ; [ easy | ]. + apply /orP ; right. + apply H0. + Qed. + + Lemma interface_foreach_subset_pairs : forall {A: eqType} f g (L : seq A), + (forall (x : A), (x \in L) -> f x :<=: g x) -> + interface_foreach f L :<=: interface_foreach g L. + Proof. + intros. + induction L. + + apply fsubsetxx. + + rewrite !interface_foreach_cons. + apply subset_pair. + * apply H. + apply mem_head. + * apply IHL. + intros. + apply H. + rewrite in_cons. + now apply /orP ; right. + Qed. + + Lemma interface_hierarchy_subset_pairs : forall f g d, + (forall ℓ, (ℓ <= d)%nat -> f ℓ :<=: g ℓ) -> + interface_hierarchy f d :<=: interface_hierarchy g d. + Proof. + intros. + induction d. + + now apply H. + + simpl. + apply subset_pair. + * apply IHd. + now intros ; apply H. + * now apply H. + Qed. + + Lemma interface_hierarchy_foreach_subset_pairs : forall {A: eqType} f g (L : seq A) d, + (forall (x : A), (x \in L) -> forall ℓ, (ℓ <= d)%nat -> f x ℓ :<=: g x ℓ) -> + interface_hierarchy_foreach f L d :<=: interface_hierarchy_foreach (A := A) g L d. + Proof. + intros. + unfold interface_hierarchy_foreach. + apply interface_hierarchy_subset_pairs. + intros. + now apply interface_foreach_subset_pairs. + Qed. + + Lemma interface_foreach_subset : forall {A: eqType} f (L : seq A) K, + (forall (x : A), (x \in L) -> f x :<=: K) -> + interface_foreach f L :<=: K. + Proof. + intros. + induction L. + + simpl. rewrite <- fset0E. apply fsub0set. + + rewrite interface_foreach_cons. + rewrite fsubUset. + apply /andP ; split. + * apply H. + apply mem_head. + * apply IHL. + intros. + apply H. + rewrite in_cons. + now apply /orP ; right. + Qed. + + Lemma interface_foreach_subsetR : forall {A: eqType} f (L : seq A) K, + (exists (x : A) (H_in : x \in L), K :<=: f x) -> + L <> [] -> + K :<=: interface_foreach f L. + Proof. + intros. + induction L ; [ easy | ]. + unfold interface_hierarchy. + rewrite interface_foreach_cons. + rewrite fsubsetU ; [ easy | ]. + apply /orP. + + destruct H as [? []]. + rewrite in_cons in x0. + move: x0 => /orP [/eqP ? | x0 ] ; subst. + + now left. + + right. + apply IHL. + 2: destruct L ; easy. + exists x, x0. + apply H. + Qed. + + Lemma interface_hierarchy_foreach_subset : forall {A: eqType} f (L : seq A) d K, + (forall (x : A), (x \in L) -> forall ℓ, (ℓ <= d)%nat -> f x ℓ :<=: K) -> + interface_hierarchy_foreach f L d :<=: K. + Proof. + intros. + unfold interface_hierarchy_foreach. + induction d in H |- * at 1. + - now apply interface_foreach_subset. + - simpl. + rewrite fsubUset. + apply /andP ; split. + + now apply IHn. + + now apply interface_foreach_subset. + Qed. + + Lemma interface_hierarchy_foreach_subsetR : forall {A: eqType} f (L : seq A) d K, + (exists (x : A) (H_in : x \in L) ℓ (H_le : (ℓ <= d)%nat), K :<=: f x ℓ) -> + L <> [] -> + K :<=: interface_hierarchy_foreach f L d. + Proof. + intros. + unfold interface_hierarchy_foreach. + induction d in H |- * at 1. + - destruct H as [? [? [? []]]]. + apply interface_foreach_subsetR. + 2: easy. + exists x, x0. + destruct x1 ; [ | easy ]. + apply H. + - simpl. + rewrite fsubsetU ; [ easy | ]. + apply /orP. + + destruct H as [? [? [? []]]]. + destruct (x1 == n.+1) eqn:x_eq ; move: x_eq => /eqP x_eq ; subst. + + right. + clear IHn. + apply interface_foreach_subsetR. + 2: easy. + exists x, x0. + apply H. + + left. + apply IHn. + exists x, x0, x1. + eexists ; [ Lia.lia | ]. + apply H. + Qed. + + Lemma idents_interface_hierachy2 : + forall g f d, + (forall x, idents g :#: idents (f x)) -> + idents g :#: idents (interface_hierarchy f d). + Proof. + clear ; intros. + unfold idents. + induction d ; simpl. + - apply H. + - rewrite imfsetU. + rewrite fdisjointUr. + rewrite IHd. + apply H. + Qed. + + Definition parallel_ID d (L : seq name) (f : name -> Interface) : + (∀ x y, x ≠ y → idents (f x) :#: idents (f y)) -> + (uniq L) -> + (forall x, flat (f x)) -> + package fset0 (interface_foreach f L) (interface_foreach f L) := + fun H H0 H1 => + parallel_package d L + (fun x => {package ID (f x) #with valid_ID _ _ (H1 x)}) H + (fun x => trimmed_ID _) H0. + + Definition combined_ID (d : nat) (L : seq name) (f : name -> nat -> Interface) : + (forall n x y, x ≠ y → idents (f x n) :#: idents (f y n)) -> + (uniq L) -> + (forall n x, flat (f x n)) -> + (forall n ℓ, (ℓ < n)%nat -> (n <= d)%nat -> ∀ x y, idents (f x ℓ) :#: idents (f y n)) -> + package fset0 (interface_hierarchy_foreach f L d) (interface_hierarchy_foreach f L d). + + intros. + refine (ℓ_packages d (fun x _ => parallel_ID d L (f^~ x) _ _ _) _ _). + - intros. + unfold parallel_ID. + apply trimmed_parallel_raw. + + apply H. + + apply H0. + + apply trimmed_pairs_map. + intros. + unfold pack. + apply trimmed_ID. + - intros. + apply idents_foreach_disjoint_foreach. + intros. + now apply H2. + + Unshelve. + + intros. + now apply H. + + apply H0. + + apply H1. + Defined. + + Lemma interface_foreach_swap : + (forall {A} (a b : A) l f, interface_foreach f (a :: b :: l) = interface_foreach f (b :: a :: l)). + Proof. + intros. + induction l. + - simpl. + now rewrite fsetUC. + - simpl. + rewrite fsetUA. + rewrite (fsetUC (f a)). + rewrite <- fsetUA. + reflexivity. + Qed. + + Lemma interface_hierarchy_foreach_cons : (forall {A} f a L (d : nat), + interface_hierarchy_foreach f (a :: L) d + = interface_hierarchy (f a) d :|: interface_hierarchy_foreach (A := A) f L d). + Proof. + intros. + unfold interface_hierarchy_foreach. + rewrite interface_hierarchy_U. + f_equal. + setoid_rewrite interface_foreach_cons. + reflexivity. + Qed. + + Lemma interface_hierarchy_foreach_cat : forall {A} f L1 L2 d, + interface_hierarchy_foreach f (L1 ++ L2) d = + interface_hierarchy_foreach (A := A) f L1 d :|: interface_hierarchy_foreach (A := A) f L2 d. + Proof. + induction L1 ; intros. + - unfold interface_hierarchy_foreach. + simpl. + rewrite <- interface_hierarchy_trivial. + simpl. + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + - rewrite interface_hierarchy_foreach_cons. + rewrite <- fsetUA. + rewrite <- IHL1. + now rewrite <- interface_hierarchy_foreach_cons. + Qed. + + Lemma interface_foreach_condition : + (forall {A : eqType} f (L1 L2 : list A), + (forall x, x \in L1 -> x \in L2) -> + interface_foreach f L1 = + interface_foreach (fun x => if x \in L2 then f x else fset [::]) L1). + Proof. + clear ; intros. + induction L1. + - reflexivity. + - rewrite interface_foreach_cons. + rewrite IHL1. + 2:{ + intros. + apply H. + apply mem_tail. + apply H0. + } + rewrite interface_foreach_cons. + rewrite H. + 2: apply mem_head. + reflexivity. + Qed. + + Lemma interface_foreach_func_if_cons : + forall {A : eqType} a (L1 L2 : seq A) f, + interface_foreach (λ x : A, if x \in (a :: L2)%SEQ then f x else fset [::]) L1 + = + (if a \in L1 then f a else fset [::]) :|: + interface_foreach (λ x : A, if x \in L2%SEQ then f x else fset [::]) L1. + Proof. + induction L1 ; intros. + + now rewrite fsetUid. + + rewrite interface_foreach_cons. + rewrite interface_foreach_cons. + + rewrite IHL1. + rewrite fsetUA. + rewrite fsetUA. + f_equal. + rewrite <- fset0E. + + rewrite !in_cons. + rewrite (eq_sym a). + destruct (a0 == a) eqn:a0a. + * move: a0a => /eqP ? ; subst. + simpl. + destruct (a \in L1), (a \in L2) ; now try rewrite fsetUid ; try rewrite fsetU0. + * simpl. + rewrite fsetUC. + reflexivity. + Qed. + + Lemma interface_foreach_sub_list : forall {A : eqType} f L1 L2, + uniq L1 -> + (forall x, x \in L1 -> x \in L2) -> + interface_foreach f L1 = + interface_foreach (A := A) (fun x => if x \in L1 then f x else [interface]) L2. + Proof. + intros. + + rewrite (interface_foreach_condition f L1 L1 (fun _ H => H)). + induction L1 ; intros. + - simpl. + destruct L2 ; [ easy | ]. + now rewrite <- interface_foreach_trivial. + - rewrite interface_foreach_func_if_cons. + rewrite interface_foreach_func_if_cons. + rewrite mem_head. + rewrite H0. + 2: apply mem_head. + rewrite interface_foreach_cons. + (* destruct (a \in _) ; [ ] *) + rewrite IHL1. + 2:{ + rewrite cons_uniq in H. + now move: H => /andP [? ?] ; subst. + } + 2:{ + intros. + apply H0. + now apply mem_tail. + } + destruct (_ \in _). + { + rewrite fsetUA. + rewrite fsetUid. + reflexivity. + } + { + rewrite <- fset0E. + rewrite fset0U. + reflexivity. + } + Qed. + + + Lemma interface_foreach_trivial2 : forall {A} i L (* d *), + (L <> [] \/ i = [interface]) -> + i = (interface_foreach (λ (n : A), i) L ). + Proof. + intros. + destruct H. + - destruct L ; [ easy | ]. + clear H. + generalize dependent a. + induction L ; intros. + { + rewrite interface_foreach_cons. + simpl. + rewrite <- fset0E. + rewrite fsetU0. + reflexivity. + } + { + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + } + - rewrite H. + induction L. + + reflexivity. + + rewrite interface_foreach_cons. + rewrite <- IHL. + now rewrite fsetUid. + Qed. + + Lemma interface_hierarchy_subset : forall f d K, + (forall (x : nat) (H : (x <= d)%nat), f x :<=: K) -> + interface_hierarchy f d :<=: K. + Proof. + intros. + induction d. + - now apply H. + - simpl. + rewrite fsubUset. + now rewrite H ; [ rewrite IHd | ]. + Qed. + + Lemma interface_hierarchy_subsetR : forall f d K, + (exists (x : nat) (H : (x <= d)%nat), K :<=: f x) -> + K :<=: interface_hierarchy f d. + Proof. + intros. + induction d. + - simpl. destruct H as [? []]. destruct x ; [ | easy ]. apply H. + - simpl. + destruct H as [? []]. + destruct (x == d.+1) eqn:x_is_d ; move: x_is_d => /eqP ? ; subst. + + apply fsubsetU. + now rewrite H. + + apply fsubsetU. + rewrite IHd ; [ easy | ]. + exists x. + eexists. + * Lia.lia. + * apply H. + Qed. + + Lemma trimmed_trim : forall I p, trimmed I (trim I p). + Proof. + intros. unfold trimmed. now rewrite trim_idemp. + Qed. + + Ltac solve_direct_in := rewrite !fsubUset ; repeat (apply /andP ; split) ; repeat (apply fsubsetxx || (apply fsubsetU ; apply /orP ; ((right ; apply fsubsetxx) || left))). + + +Ltac solve_idents := + repeat match goal with + | |- context [ idents ?a :#: idents (?b :|: ?c) ] => + unfold idents at 2 + ; rewrite (imfsetU _ b c) + ; fold (idents b) ; fold (idents c) + ; rewrite fdisjointUr + ; apply /andP ; split + | |- context [ idents (?a :|: ?b) :#: idents ?c ] => + unfold idents at 1 + ; rewrite (imfsetU _ a b) + ; fold (idents a) ; fold (idents b) + ; rewrite fdisjointUl + ; apply /andP ; split + | |- context [ idents (fset (?a :: ?b :: _)) ] => rewrite (fset_cons a) + | |- context [ ?K :#: idents (interface_hierarchy ?f ?d) ] => + apply idents_interface_hierachy3 ; intros + | |- context [ idents (interface_hierarchy ?f ?d) :#: ?K ] => + rewrite fdisjointC ; apply idents_interface_hierachy3 ; intros + | |- context [ idents (interface_foreach ?f ?L) :#: idents (interface_foreach ?g ?K) ] => + apply idents_foreach_disjoint_foreach_in + ; let H := fresh in + intros ? H + ; now repeat (move: H => /orP [ /eqP ? | H ]) ; subst + | |- context [ idents ?K :#: idents (interface_foreach ?f ?L) ] => + let H := fresh in + apply idents_disjoint_foreach_in + ; intros ? H + (* ; rewrite in_cons in H *) + (* ; repeat (move: H => /orP [ /eqP ? | H ]) ; subst *) + | |- context [ idents (interface_foreach ?f ?L) :#: ?K ] => + rewrite fdisjointC + end ; unfold idents ; solve_imfset_disjoint. + +Ltac solve_trimmed2 := + repeat match goal with + | |- context [ trimmed _ (trim _ _) ] => + apply trimmed_trim + | |- context [ trimmed ?E (parallel_raw _) ] => + eapply trimmed_parallel_raw + ; [ | | apply trimmed_pairs_map ; intros ] + ; [ | reflexivity | ] + ; [ | solve_trimmed2 ] + ; [ intros ; unfold idents ; solve_imfset_disjoint ] + | |- context [ trimmed _ (pack (ℓ_packages _ _ _ _)) ] => + apply trimmed_ℓ_packages + | |- context [ trimmed ?E (par ?a ?b) ] => + eapply trimmed_par ; [ | solve_trimmed2..] ; solve_idents + | |- context [ trimmed ?E (pack {| pack := _; |}) ] => + unfold pack + | |- context [ trimmed ?E (mkfmap (cons ?a ?b)) ] => + apply trimmed_package_cons + | |- context [ trimmed ?E (mkfmap nil) ] => + apply trimmed_empty_package + | |- context [ trimmed ?E (ID _) ] => + apply trimmed_ID + end. + + Lemma domm_trim_disjoint_is_ident : + forall E1 E2 p1 p2, idents E1 :#: idents E2 -> domm (trim E1 p1) :#: domm (trim E2 p2). + Proof. + intros. + eapply fdisjoint_trans. + 1: apply domm_trim. + rewrite fdisjointC. + eapply fdisjoint_trans. + 1: apply domm_trim. + rewrite fdisjointC. + apply H. + Qed. + + Lemma function_fset_cons_l : + forall {A : eqType} {T} x xs K, (fun (n : A) => fset (x n :: xs n) :|: K) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n) :|: K). + Proof. now intros ; setoid_rewrite <- (fset_cat). Qed. + + Lemma function_fset_cat_l : + forall {A : eqType} {T} ys xs K, (fun (n : A) => fset (ys n ++ xs n) :|: K) = (fun (n : A) => fset (T := T) (ys n) :|: fset (xs n) :|: K). + Proof. now intros ; setoid_rewrite <- (fset_cat). Qed. + + Lemma function_fset_cat_middle : + forall {A : eqType} {T} ys xs L R, (fun (n : A) => L :|: fset (ys n ++ xs n) :|: R) = (fun (n : A) => L :|: fset (T := T) (ys n) :|: fset (xs n) :|: R). + Proof. + intros. + setoid_rewrite fsetUC. + setoid_rewrite <- fsetUA. + setoid_rewrite <- (fset_cat). + reflexivity. + Qed. + + Lemma function_fset_cat : + forall {A : eqType} {T} ys xs, (fun (n : A) => fset (ys n ++ xs n)) = (fun (n : A) => fset (T := T) (ys n) :|: fset (xs n)). + Proof. now setoid_rewrite <- (fset_cat). Qed. + + Lemma function_fset_cons : + forall {A : eqType} {T} x xs, (fun (n : A) => fset (x n :: xs n)) = (fun (n : A) => fset (T := T) ([x n]) :|: fset (xs n)). + Proof. now setoid_rewrite <- (fset_cat). Qed. + + Lemma function2_fset_cat : + forall {A B : eqType} {T} x xs, (fun (a : A) (b : B) => fset (x a b :: xs a b)) = (fun (a : A) (b : B) => fset (T := T) ([x a b]) :|: fset (xs a b)). + Proof. now setoid_rewrite <- (fset_cat). Qed. + + Lemma advantage_reflexivity : + forall P A, AdvantageE P P A = 0%R. + Proof. + unfold AdvantageE. + intros. + rewrite subrr. + rewrite Num.Theory.normr0. + reflexivity. + Qed. + + diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index d0184d83..ca6f684f 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -570,18 +570,6 @@ Section XTR_XPD. (* simpl. *) (* apply v. *) - Lemma interface_hierarchy_foreach_cons : (forall {A} f a L (d : nat), - interface_hierarchy_foreach f (a :: L) d - = interface_hierarchy (f a) d :|: interface_hierarchy_foreach (A := A) f L d). - Proof. - intros. - unfold interface_hierarchy_foreach. - rewrite interface_hierarchy_U. - f_equal. - setoid_rewrite interface_foreach_cons. - reflexivity. - Qed. - Lemma reindex_interface_hierarchy_PSK : forall d, (interface_hierarchy (λ n : nat, [interface #val #[SET PSK n d.+1] : chUNQinp → chXPDout ]) d.+1) From 6c4093d37de3648646ef4256e0d72e2db1dbf570 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 17 Mar 2025 13:38:49 +0100 Subject: [PATCH 09/10] Last couple of sub-theorem remain of core theorem --- proofs/ssprove/handwritten/Core.v | 3840 +++++++++++----------- proofs/ssprove/handwritten/CoreTheorem.v | 331 +- 2 files changed, 2178 insertions(+), 1993 deletions(-) diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 5b5f5dcd..8df9ccdf 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -2188,8 +2188,7 @@ Section Core. } Qed. - (* Page 70 *) - Program Definition G_core_Hash (d k : nat) (H_lt : (d < k)%nat) : + Program Definition G_core_package_construction (d k : nat) (H_lt : (d < k)%nat) G_check_XTR_XPD_f KeysAndHash_Kf KeysAndHash_Lf : package (L_K :|: L_L) [interface] (XPD_n d k @@ -2198,15 +2197,13 @@ Section Core. :|: XTR_n d k :|: GET_n O_star d k) := {package - (par (G_check_XTR_XPD d k H_lt (fun _ => false)) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (KeysAndHash d k H_lt (fun _ _ => false) (fun _ => Z)) - (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true)) *) + (par + (G_check_XTR_XPD d k H_lt G_check_XTR_XPD_f) + (par + (G_dh d k (ltnW H_lt)) + (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) _ erefl _) + ) + ) ∘ (KeysAndHash d k H_lt KeysAndHash_Kf KeysAndHash_Lf) }. Solve Obligations with intros ; solve_idents. Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. @@ -2284,7 +2281,8 @@ Section Core. Time Qed. Fail Next Obligation. - Program Definition G_core_D (d k : nat) (H_lt : (d < k)%nat) : + (* Page 70 *) + Definition G_core_Hash (d k : nat) (H_lt : (d < k)%nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -2292,317 +2290,95 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun _ => false) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. - - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. - - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } - - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. - - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + G_core_package_construction d k H_lt (fun _ => false) (fun _ _ => false) (fun _ => Z) + (* {package *) + (* (par (G_check_XTR_XPD d k H_lt (fun _ => false)) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (KeysAndHash d k H_lt (fun _ _ => false) (fun _ => Z)) *) + (* (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => Z) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true)) *) *) + (* } *). + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Next Obligation. *) + (* intros. *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* now apply subset_all. *) + (* } *) + (* Unshelve. *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_check_XTR_XPD. *) + (* unfold pack. *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) - Program Definition G_core_R_esalt (d k : nat) (H_lt : (d < k)%nat) : + Definition G_core_D (d k : nat) (H_lt : (d < k)%nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -2610,318 +2386,318 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun _ => false) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) + G_core_package_construction d k H_lt (fun _ => false) (fun _ _ => false) (fun _ => D). + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun _ => false) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun _ => D) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. - - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } - - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. - - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) - Time Optimize Heap. - Program Definition G_core_SODH (d k : nat) (H_lt : (d < k)%nat) : + Definition G_core_R_esalt (d k : nat) (H_lt : (d < k)%nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -2929,315 +2705,636 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - (* Gcore_sodh d k false. *) - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. + G_core_package_construction d k H_lt (fun _ => false) (fun _ _ => false) (fun name => match name with | ESALT => R | _ => D end). + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun _ => false) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + (* Time Optimize Heap. *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + Definition G_core_SODH (d k : nat) (H_lt : (d < k)%nat) : + package (L_K :|: L_L) + [interface] + (XPD_n d k + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k) := + G_core_package_construction d k H_lt (fun name => match name with HS => true | _ => false end) (fun _ _ => false) (fun name => match name with | ESALT => R | _ => D end). + (* (* Gcore_sodh d k false. *) *) + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) + + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) + + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) HB.instance Definition _ : Equality.axioms_ name := {| @@ -3259,7 +3356,7 @@ Section Core. now repeat (move /orP: H => [/eqP ? | H] ; subst) ; [ subst .. | discriminate ] ; simpl. Qed. - Program Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : + Definition G_core_hyb_ℓ (d k : nat) (H_lt : (d < k)%nat) (i : nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -3267,325 +3364,331 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => - if (name \in N_star) || (name == PSK) - then - if ℓ >=? i then false else true - else false) erefl - ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) - (K_package k PSK d.+1 H_lt (i == d) ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. - - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. - - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } - - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. - - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + G_core_package_construction d k H_lt + (fun name => match name with HS => true | _ => false end) + (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if (i <=? ℓ)%nat then false else true + else false) + (fun name => match name with | ESALT => R | _ => D end). + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => *) + (* if (name \in N_star) || (name == PSK) *) + (* then *) + (* if ℓ >=? i then false else true *) + (* else false) erefl *) + (* ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) *) + (* (K_package k PSK d.+1 H_lt (i == d.+1) ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) - Time Optimize Heap. + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) (* Idealization order (hybridazation argument for a given level) *) - Program Definition G_core_hyb_pred_ℓ_c (d k : nat) (H_lt : (d < k)%nat) (i : nat) (C : list name) : + Definition G_core_hyb_pred_ℓ_c (d k : nat) (H_lt : (d < k)%nat) (i : nat) (C : list name) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -3593,321 +3696,329 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => - if (name \in N_star) || (name == PSK) - then - if (ℓ + (name \in C)) >=? i then false else true - else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. - - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. - - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } + G_core_package_construction d k H_lt + (fun name => match name with HS => true | _ => false end) + (fun ℓ name => + if (name \in N_star) || (name == PSK) + then + if (i + (name \in C) <=? ℓ)%nat then false else true + else false) + (fun name => match name with | ESALT => R | _ => D end). + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun ℓ name => *) + (* if (name \in N_star) || (name == PSK) *) + (* then *) + (* if (ℓ + (name \in C))%nat >=? i then false else true *) + (* else false) erefl ∘ Ls k all_names (fun name => match name with | ESALT => R | _ => D end) erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) (* Idealization order (hybridazation argument for a given level) *) - Program Definition G_core_ki (d k : nat) (H_lt : (d < k)%nat) : + Definition G_core_ki (d k : nat) (H_lt : (d < k)%nat) : package (L_K :|: L_L) [interface] (XPD_n d k @@ -3915,313 +4026,318 @@ Section Core. :|: SET_ℓ [PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) := - {package - (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) - (par - (G_dh d k (ltnW H_lt)) - (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) - _ erefl _) - - ) ) ∘ - (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d.+1 H_lt true ∘ L_package k PSK D)) (Hash true)) - }. - Solve Obligations with intros ; solve_idents. - Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. - Solve Obligations with easy. - Next Obligation. - intros. - rewrite <- fset0U. - eapply valid_link. - 1:{ - rewrite <- fset0U. - replace - (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) - with - (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). - 2:{ - rewrite <- !fsetUA. - f_equal. - rewrite (fsetUC (GET_n _ _ _)). - rewrite !fsetUA. - f_equal. - rewrite (fsetUC (XTR_n _ _)). - rewrite <- !fsetUA. - f_equal. - rewrite fsetUC. - reflexivity. - } - eapply valid_par. - 2:{ - rewrite <- fsetUid. - eapply valid_link. - 1:{ - rewrite <- fsetUid. - rewrite <- !(fsetUA (XPD_n d k)). - eapply valid_par. - 2: apply pack_valid. - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2: apply pack_valid. - 2: apply pack_valid. - shelve. - } - shelve. - } - { - (* rewrite <- fsetUid. *) - (* rewrite fsetUA. *) - (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) - eapply valid_par_upto. - 2: apply pack_valid. - 2: apply pack_valid. - 2: solve_in_fset. - 2:{ - (* TODO: SET PSK ℓ.+1 ? *) - apply fsubsetxx. - - } - 2:{ - rewrite <- fsetUA. - rewrite fsetUC. - rewrite (fsetUC (XPD_n _ _)). - rewrite !fsetUA. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite (fsetUC (GET_n _ _ _)). - rewrite <- fsetUA. - rewrite fsetUC. - apply subset_pair ; [ | apply fsubsetxx ]. - rewrite fsubUset. - rewrite fsubsetxx. - rewrite Bool.andb_true_r. - unfold GET_n. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - apply interface_foreach_subsetR. - 2: easy. - exists BINDER. - eexists ; [ easy | ]. - apply fsubsetxx. - } - shelve. - } - } - 2:{ - rewrite <- fsetUid. - eapply valid_par. - 2:apply pack_valid. - 2:apply pack_valid. - shelve. - } - shelve. - } - { - rewrite <- fsetU0. - - replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with - (interface_hierarchy_foreach - (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d - :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k - :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k - :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) - ) - :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) - [:: PSK] :|: interface_hierarchy - (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) - :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) - ). - 2:{ - rewrite !fsetUA. - repeat set (interface_hierarchy_foreach _ _ _). - repeat set (interface_hierarchy _ _). - repeat set (interface_foreach _ _). - repeat set (GET_n _ _ _). - repeat set (SET_n _ _ _). - solve_fset_eq. - } + G_core_package_construction d k H_lt + (fun name => match name with HS => true | _ => false end) + (fun _ _ => true) + (fun name => D). + + (* {package *) + (* (par (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) *) + (* _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _)) ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) *) + (* _ erefl _ _) *) + (* (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) *) + (* _ erefl _) *) + + (* ) ) ∘ *) + (* (par (par (Ks d k (ltnW H_lt) all_names (fun _ _ => true) erefl ∘ Ls k all_names (fun name => D) erefl) (K_package k PSK d.+1 H_lt true ∘ L_package k PSK D)) (Hash true)) *) + (* }. *) + (* Solve Obligations with intros ; solve_idents. *) + (* Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. *) + (* Solve Obligations with easy. *) + (* Next Obligation. *) + (* intros. *) + (* rewrite <- fset0U. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fset0U. *) + (* replace *) + (* (XPD_n d k :|: DH_interface :|: SET_ℓ [:: PSK] k 0 :|: XTR_n d k :|: GET_n O_star d k) *) + (* with *) + (* (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k :|: (DH_interface :|: SET_ℓ [:: PSK] k 0)). *) + (* 2:{ *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite !fsetUA. *) + (* f_equal. *) + (* rewrite (fsetUC (XTR_n _ _)). *) + (* rewrite <- !fsetUA. *) + (* f_equal. *) + (* rewrite fsetUC. *) + (* reflexivity. *) + (* } *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_link. *) + (* 1:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- !(fsetUA (XPD_n d k)). *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* (* rewrite <- fsetUid. *) *) + (* (* rewrite fsetUA. *) *) + (* (* rewrite <- (fsetUC (interface_hierarchy_foreach _ O_star _)). *) *) + (* eapply valid_par_upto. *) + (* 2: apply pack_valid. *) + (* 2: apply pack_valid. *) + (* 2: solve_in_fset. *) + (* 2:{ *) + (* (* TODO: SET PSK ℓ.+1 ? *) *) + (* apply fsubsetxx. *) + + (* } *) + (* 2:{ *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* rewrite (fsetUC (XPD_n _ _)). *) + (* rewrite !fsetUA. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite (fsetUC (GET_n _ _ _)). *) + (* rewrite <- fsetUA. *) + (* rewrite fsetUC. *) + (* apply subset_pair ; [ | apply fsubsetxx ]. *) + (* rewrite fsubUset. *) + (* rewrite fsubsetxx. *) + (* rewrite Bool.andb_true_r. *) + (* unfold GET_n. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists BINDER. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* shelve. *) + (* } *) + (* } *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* eapply valid_par. *) + (* 2:apply pack_valid. *) + (* 2:apply pack_valid. *) + (* shelve. *) + (* } *) + (* shelve. *) + (* } *) + (* { *) + (* rewrite <- fsetU0. *) + + (* replace (interface_hierarchy_foreach _ _ _ :|: _ :|: _) with *) + (* (interface_hierarchy_foreach *) + (* (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXTRout → chGETout ]) O_star d *) + (* :|: (GET_n [:: DH] d k :|: GET_n [:: PSK] d k :|: GET_n [:: ZERO_SALT] d k *) + (* :|: GET_n [:: ZERO_IKM] d k :|: GET_n I_star d k *) + (* :|: (SET_ℓ [:: DH] k 0 :|: SET_n I_star d k :|: SET_n O_star d k) *) + (* ) *) + (* :|: (interface_foreach (λ n : name, [interface #val #[SET n 0 k] : chUNQinp → chXTRout ]) *) + (* [:: PSK] :|: interface_hierarchy *) + (* (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) *) + (* :|: ([interface #val #[HASH f_hash] : chHASHout → chHASHout ]) *) + (* ). *) + (* 2:{ *) + (* rewrite !fsetUA. *) + (* repeat set (interface_hierarchy_foreach _ _ _). *) + (* repeat set (interface_hierarchy _ _). *) + (* repeat set (interface_foreach _ _). *) + (* repeat set (GET_n _ _ _). *) + (* repeat set (SET_n _ _ _). *) + (* solve_fset_eq. *) + (* } *) - unfold interface_foreach. - rewrite <- (reindex_interface_hierarchy_PSK2 d k). - unfold interface_hierarchy ; fold interface_hierarchy. - rewrite fsetUA. + (* unfold interface_foreach. *) + (* rewrite <- (reindex_interface_hierarchy_PSK2 d k). *) + (* unfold interface_hierarchy ; fold interface_hierarchy. *) + (* rewrite fsetUA. *) - rewrite <- (fsetUid [interface]). - eapply valid_par. - 2:{ - rewrite <- fsetUid. - rewrite <- (fsetUid [interface]). - eapply valid_par. - 3:{ - eapply valid_package_inject_export. - 2: eapply valid_link ; apply pack_valid. - solve_in_fset. - } - 2:{ - eapply valid_link. - 1:{ - eapply valid_package_inject_export. - 2: apply pack_valid. - rewrite fsetUA. - rewrite <- fsetUA. - rewrite (fsetUC (SET_n all_names _ _)). - apply subset_pair. - - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold GET_ℓ. - rewrite <- !interface_foreach_cat. - unfold cat ; fold (cat O_star). - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - - rewrite <- !fsetUA. - rewrite fsubUset. - rewrite !fsetUA. - apply /andP ; split. - { - unfold SET_n. - apply interface_hierarchy_subsetR. - exists O, (leq0n _). - unfold SET_ℓ. - apply interface_foreach_subset. - intros. - rewrite mem_seq1 in H. - move: H => /eqP H ; subst. - apply interface_foreach_subsetR. - 2: easy. - exists DH. - eexists ; [ easy | ]. - apply fsubsetxx. - } - { - rewrite !interface_hierarchy_U. - apply interface_hierarchy_subset_pairs. - intros. - unfold SET_ℓ. - rewrite <- !interface_foreach_cat. - rewrite fsubUset. - apply /andP ; split. - { - apply interface_foreach_subset. - intros. - apply interface_foreach_subsetR. - 2: easy. - exists x. - eexists. - 2: apply fsubsetxx. - rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. - all: now rewrite eqxx. - } - { - apply interface_foreach_subsetR. - 2: easy. - exists PSK. - eexists ; [ easy | ]. - apply fsubsetxx. - } - } - } - 1: apply pack_valid. - } - shelve. - } - 2: apply pack_valid. - shelve. - } + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 2:{ *) + (* rewrite <- fsetUid. *) + (* rewrite <- (fsetUid [interface]). *) + (* eapply valid_par. *) + (* 3:{ *) + (* eapply valid_package_inject_export. *) + (* 2: eapply valid_link ; apply pack_valid. *) + (* solve_in_fset. *) + (* } *) + (* 2:{ *) + (* eapply valid_link. *) + (* 1:{ *) + (* eapply valid_package_inject_export. *) + (* 2: apply pack_valid. *) + (* rewrite fsetUA. *) + (* rewrite <- fsetUA. *) + (* rewrite (fsetUC (SET_n all_names _ _)). *) + (* apply subset_pair. *) + (* - rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold GET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* unfold cat ; fold (cat O_star). *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* - rewrite <- !fsetUA. *) + (* rewrite fsubUset. *) + (* rewrite !fsetUA. *) + (* apply /andP ; split. *) + (* { *) + (* unfold SET_n. *) + (* apply interface_hierarchy_subsetR. *) + (* exists O, (leq0n _). *) + (* unfold SET_ℓ. *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* rewrite mem_seq1 in H. *) + (* move: H => /eqP H ; subst. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists DH. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* { *) + (* rewrite !interface_hierarchy_U. *) + (* apply interface_hierarchy_subset_pairs. *) + (* intros. *) + (* unfold SET_ℓ. *) + (* rewrite <- !interface_foreach_cat. *) + (* rewrite fsubUset. *) + (* apply /andP ; split. *) + (* { *) + (* apply interface_foreach_subset. *) + (* intros. *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists x. *) + (* eexists. *) + (* 2: apply fsubsetxx. *) + (* rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ]. *) + (* all: now rewrite eqxx. *) + (* } *) + (* { *) + (* apply interface_foreach_subsetR. *) + (* 2: easy. *) + (* exists PSK. *) + (* eexists ; [ easy | ]. *) + (* apply fsubsetxx. *) + (* } *) + (* } *) + (* } *) + (* 1: apply pack_valid. *) + (* } *) + (* shelve. *) + (* } *) + (* 2: apply pack_valid. *) + (* shelve. *) + (* } *) - Unshelve. - 1:{ - unfold combined_ID. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - 1:{ - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - solve_Parable2. - } - 1:{ - unfold combined_ID. - unfold G_check. - unfold eq_rect. - destruct eq_ind. - unfold G_dh. - unfold DH_package. - unfold parallel_ID. - unfold parallel_package. - unfold combined_ID. - unfold G_XTR_XPD. - unfold XPD_packages. - unfold XTR_packages. - unfold pack. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - destruct Logic.eq_sym. - solve_Parable2. - } - { - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - { - rewrite <- trimmed_hash. - unfold Ks. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - destruct function2_fset_cat. - unfold combined. - unfold eq_rect_r. - unfold eq_rect. - destruct Logic.eq_sym. - unfold K_package. - solve_Parable2. - } - Time Qed. - Fail Next Obligation. + (* Unshelve. *) + (* 1:{ *) + (* unfold combined_ID. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* solve_Parable2. *) + (* } *) + (* 1:{ *) + (* unfold combined_ID. *) + (* unfold G_check. *) + (* unfold eq_rect. *) + (* destruct eq_ind. *) + (* unfold G_dh. *) + (* unfold DH_package. *) + (* unfold parallel_ID. *) + (* unfold parallel_package. *) + (* unfold combined_ID. *) + (* unfold G_XTR_XPD. *) + (* unfold XPD_packages. *) + (* unfold XTR_packages. *) + (* unfold pack. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* destruct Logic.eq_sym. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* { *) + (* rewrite <- trimmed_hash. *) + (* unfold Ks. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* destruct function2_fset_cat. *) + (* unfold combined. *) + (* unfold eq_rect_r. *) + (* unfold eq_rect. *) + (* destruct Logic.eq_sym. *) + (* unfold K_package. *) + (* solve_Parable2. *) + (* } *) + (* Time Qed. *) + (* Fail Next Obligation. *) End Core. diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 609f405f..93c5369f 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -90,9 +90,6 @@ Section CoreTheorem. Context {DepInstance : Dependencies}. Existing Instance DepInstance. - Time Optimize Heap. - Time Optimize Heap. - Lemma d2 : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -157,35 +154,32 @@ Section CoreTheorem. (nfto (fst (PrntN n)) == nfto (fst (PrntN n'))) && (nfto (snd (PrntN n)) == nfto (snd (PrntN n')))) all_names. - Fixpoint idealization_loop (fuel : nat) (io : list (list name)) {struct fuel} : list (list name) := + Fixpoint idealization_loop (fuel : nat) (ioc : list name) {struct fuel} : list (list name) := match fuel with - | O => io + | O => [] | S fuel => - let ioc := last [] io in if ioc != all_names then match (filter (fun n => (n \notin ioc) && (let (n1, n2) := PrntN n in ((nfto n1 \in ioc) || (nfto n1 == BOT)) && ((nfto n2 \in ioc) || (nfto n2 == BOT)) && (all (fun sn => sn \notin ioc) (SblngN n)))) all_names) with - | [] => io - | (x :: xs) => - let n_c := x - in idealization_loop fuel (io ++ [ioc ++ SblngN n_c]) + | [] => [] + | (n_c :: xs) => + [ioc ++ SblngN n_c] ++ idealization_loop fuel (ioc ++ SblngN n_c) end - else io + else [] end. Lemma idealization_order_one_iter : - forall fuel io, - idealization_loop fuel.+1 io = - (let ioc := last [] io in - if ioc != all_names + forall fuel ioc, + idealization_loop fuel.+1 ioc = + (if ioc != all_names then match (filter (fun n => (n \notin ioc) && (let (n1, n2) := PrntN n in ((nfto n1 \in ioc) || (nfto n1 == BOT)) && ((nfto n2 \in ioc) || (nfto n2 == BOT)) && (all (fun sn => sn \notin ioc) (SblngN n)))) all_names) with - | [] => io - | (x :: xs) => - let n_c := x - in idealization_loop fuel (io ++ [ioc ++ SblngN n_c]) + | [] => [] + | (n_c :: xs) => + let snc := SblngN n_c in + [ioc ++ snc] ++ idealization_loop fuel (ioc ++ snc) end - else io). + else []). Proof. reflexivity. Qed. Lemma filter_cons : forall {A} f (a : A) x, @@ -196,12 +190,13 @@ Section CoreTheorem. Proof. reflexivity. Qed. Definition IdealizationOrder := - let io := [[PSK; ZERO_SALT; DH; ZERO_IKM]] in + let ioc0 := [PSK; ZERO_SALT; DH; ZERO_IKM] in let fuel := List.length all_names in - idealization_loop fuel io. + ([::] :: [ioc0] ++ idealization_loop fuel ioc0). Definition IdealizationOrderPreCompute := - [:: [:: PSK; ZERO_SALT; DH; ZERO_IKM]; + [:: [::]; + [:: PSK; ZERO_SALT; DH; ZERO_IKM]; [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES]; [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT]; [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER]; @@ -209,11 +204,76 @@ Section CoreTheorem. [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT]; [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT; AS]; [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES; EEM; CET; BIND; ESALT; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM]]. + + Definition smpl_PrntN (n : name) : name * name := + let (a,b) := + match n with + | ES => (ZERO_SALT, PSK) + | EEM | CET | ESALT | BIND => (ES, BOT) + | BINDER => (BIND, BOT) + | HS => (ESALT, DH) + | SHT | CHT | HSALT => (HS, BOT) + | AS => (HSALT, ZERO_IKM) + | CAT | SAT | RM | EAM => (AS, BOT) + | PSK => (RM, BOT) + | _ => (BOT, BOT) + end + in (a,b). + + Lemma PrntN_project_to_smpl_PrntN + : (forall n, nfto (PrntN n).1 = (smpl_PrntN n).1 /\ nfto (PrntN n).2 = (smpl_PrntN n).2). + { + intros. + unfold PrntN. + destruct n. + all: now rewrite !nfto_name_to_chName_cancel. + } + Qed. + (* Lemma filter_slow : *) + (* let ioc := [:: PSK; ZERO_SALT; DH; ZERO_IKM] in *) + (* [:: ES] = filter (fun n => (n \notin ioc) && (let (n1, n2) := PrntN n in ((nfto n1 \in ioc) || (nfto n1 == BOT)) && ((nfto n2 \in ioc) || (nfto n2 == BOT)) && (all (fun sn => sn \notin ioc) (SblngN n)))) all_names. *) + (* intros. *) + (* unfold SblngN. *) + (* unfold PrntN. *) + (* unfold all_names. *) + (* unfold filter. *) + (* Admitted. *) + + (* Lemma idealization_order_0 : *) + (* forall n, *) + (* idealization_loop n.+1 [:: PSK; ZERO_SALT; DH; ZERO_IKM] = *) + (* [[:: PSK; ZERO_SALT; DH; ZERO_IKM; ES]] ++ *) + (* idealization_loop n [:: PSK; ZERO_SALT; DH; ZERO_IKM; ES]. *) + (* Proof. *) + (* intros. *) + (* rewrite idealization_order_one_iter. *) + (* unfold PrntN. *) + (* unfold last ; simpl (_ != _) ; hnf ; unfold all_names. *) + + (* replace (filter _ _) with [ES]. *) + (* 2:{ *) + (* repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf). *) + + (* unfold all ; *) + (* simpl (if _ then _ else _) ; *) + (* hnf ; *) + (* unfold SblngN ; *) + (* unfold all_names ; *) + + (* repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf). *) + + (* rewrite eqxx. *) + (* simpl. *) + (* reflexivity. *) + (* } *) + (* Show Proof. *) + (* Time Qed. *) + Lemma compute_eq : (IdealizationOrder = IdealizationOrderPreCompute). Proof. unfold IdealizationOrder. - + unfold IdealizationOrderPreCompute. repeat (rewrite idealization_order_one_iter ; unfold last ; simpl (_ != _) ; hnf ; unfold all_names ; @@ -240,11 +300,18 @@ Section CoreTheorem. unfold last ; simpl (_ != _) ; hnf ; unfold all_names ; - repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter). + repeat (rewrite filter_cons ; simpl (_ && _) ; try rewrite !nfto_name_to_chName_cancel ; simpl (_ && _) ; hnf) ; unfold filter). + simpl. reflexivity. - (* Time Qed. *) Admitted. + Unshelve. + (* Grab Existential Variables. *) + Fail idtac. + all: fail. + Admitted. (* Time Qed. *) + + (* Show Match name. *) Lemma d10_helper : forall j, (j.+1 <= List.length IdealizationOrderPreCompute)%nat -> @@ -254,7 +321,7 @@ Section CoreTheorem. Proof. intros. unfold IdealizationOrderPreCompute in H |- *. - do 8 (destruct j ; [ simpl in H0 |- *; rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ] ; easy | ]). + do 9 (destruct j ; [ simpl in H0 |- *; rewrite !in_cons in H0 |- * ; repeat move /orP: H0 => [ /eqP ? | H0 ] ; [ subst .. | discriminate ] ; easy | ]). discriminate. Qed. @@ -291,6 +358,8 @@ Section CoreTheorem. Advantage (Gxtr d k H_lt ES ℓ) (A ∘ R_xtr ES ℓ erefl))%R. Proof. intros. + + Admitted. Lemma d12 : @@ -324,7 +393,7 @@ Section CoreTheorem. Lemma d14 : forall d k H_lt ℓ c A n (H_in_xpr : n \in XPR), (nfto (fst (PrntN n)) \notin nth [] IdealizationOrderPreCompute c.-1) -> - nfto (fst (PrntN n)) \in nth [] IdealizationOrderPreCompute c.+1 -> + ((c == 0) || (nfto (fst (PrntN n)) \in nth [] IdealizationOrderPreCompute c.+1)) -> (AdvantageE (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) @@ -357,7 +426,7 @@ Section CoreTheorem. eapply Order.le_trans. 1:{ eapply Order.le_trans ; [ apply Advantage_triangle | ]. - instantiate (2 := (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute 0))). + instantiate (2 := (G_core_hyb_pred_ℓ_c d k H_lt ℓ [])). apply Num.Theory.lerD. { @@ -365,47 +434,27 @@ Section CoreTheorem. unfold G_core_hyb_ℓ. unfold G_core_hyb_pred_ℓ_c. - - unfold pack. - rewrite <- !Advantage_link. - - rewrite <- (par_commut (Hash true)). - 2: admit. - rewrite <- (par_commut (Hash true)). - 2: admit. - - setoid_rewrite (Advantage_par (Hash true)). - 2,3,4,5,6,7,8: admit. - - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. - - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. - - destruct (ℓ == d). + replace + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + _ <=? ℓ0)%N then false else true + else false) + with + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ <=? ℓ0)%nat then false else true + else false). 2:{ - - setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). - 2,3,4,5,6,7,8: admit. - - rewrite <- !Advantage_link. - - replace (G_core_hyb_ℓ_obligation_50 d k H_lt ℓ) with (G_core_hyb_pred_ℓ_c_obligation_50 d k H_lt ℓ (nth [::] IdealizationOrderPreCompute 0)) by admit. - (* destruct ( _ == _ ). *) - (* 2:{ *) - (* erewrite (Advantage_par). *) - (* 2-8: admit. *) - - (* replace () *) - - (* rewrite <- Advantage_link. *) - - (* apply advantage_reflexivity. *) + apply functional_extensionality. + intros. + apply functional_extensionality. + intros. + replace (ℓ + (_ \in [::]))%nat with (ℓ + false)%nat by reflexivity. + now rewrite addn0. } - admit. + now rewrite advantage_reflexivity. } eapply Order.le_trans ; [ apply Advantage_triangle | ]. @@ -414,7 +463,39 @@ Section CoreTheorem. apply Num.Theory.lerD. 2:{ instantiate (1 := 0%R). - admit. + + unfold G_core_hyb_ℓ. + unfold G_core_hyb_pred_ℓ_c. + + replace ((λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then + if + (ℓ + _ <=? ℓ0)%nat + then false + else true + else false)) + with + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) then if (ℓ.+1 <=? ℓ0)%nat then false else true else false). + 2:{ + apply functional_extensionality. + intros. + apply functional_extensionality. + intros. + + destruct ( _ || _ ) eqn:x0_or ; [ | reflexivity ]. + { + rewrite !in_cons in x0_or. + rewrite orbC in x0_or. + unfold IdealizationOrderPreCompute. + simpl. + repeat move: x0_or => /orP [ /eqP ? | x0_or ] ; [ subst .. | discriminate ]. + all: now simpl ; rewrite addn1. + } + } + + now rewrite advantage_reflexivity. } easy. @@ -425,16 +506,20 @@ Section CoreTheorem. eapply Order.le_trans. 1:{ instantiate (1 := - sumR 0 (List.length IdealizationOrderPreCompute - 1) _ + sumR 0 (List.length (IdealizationOrderPreCompute) - 1)%nat _ (fun c => AdvantageE - (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] IdealizationOrderPreCompute c)) - (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] IdealizationOrderPreCompute c.+1)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] (IdealizationOrderPreCompute) c)) + (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [::] (IdealizationOrderPreCompute) c.+1)) A)). induction (Datatypes.length _). - unfold sumR. + replace ( _ - _)%nat with O%nat by now cbn. simpl iota. unfold List.fold_left. + unfold IdealizationOrderPreCompute. + unfold nth. + now rewrite advantage_reflexivity. - destruct n ; [ apply IHn | ]. rewrite sumR_succ. @@ -459,26 +544,32 @@ Section CoreTheorem. eapply Order.le_trans. { repeat apply Num.Theory.lerD. - 6:{ - refine (d13 d k H_lt ℓ 5 A _ erefl). + 7:{ + refine (d13 d k H_lt ℓ 6 A _ erefl). apply /orP. right. easy. } - 3:{ - refine (d12 d k H_lt ℓ 2 A _ erefl). + 4:{ + refine (d12 d k H_lt ℓ 3 A _ erefl). apply /orP. right. easy. } - 1:{ - refine (d11 d k H_lt ℓ O A _ erefl). + 2:{ + refine (d11 d k H_lt ℓ 1 A _ erefl). apply /orP. - left. - apply (eqxx O). + right. + easy. } { - refine (d14 d k H_lt ℓ 1 A EEM erefl _ _). + refine (d14 d k H_lt ℓ 0 A PSK _ _ _). + { easy. } + 1: easy. + 1: easy. + } + { + refine (d14 d k H_lt ℓ 2 A EEM erefl _ _). 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -491,7 +582,7 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 3 A CHT erefl _ _). + refine (d14 d k H_lt ℓ 4 A CHT erefl _ _). 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -505,7 +596,7 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 4 A CHT erefl _ _). + refine (d14 d k H_lt ℓ 5 A CHT erefl _ _). 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -519,7 +610,7 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 6 A CAT erefl _ _). + refine (d14 d k H_lt ℓ 7 A CAT erefl _ _). 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -534,9 +625,10 @@ Section CoreTheorem. } } - (* easy *) + (* easy. Lia.lia. *) + (* Qed. *) Admitted. - + Lemma hyb_telescope : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -609,33 +701,8 @@ Section CoreTheorem. unfold G_core_SODH. unfold G_core_hyb_ℓ. - unfold pack. - rewrite <- !Advantage_link. - - rewrite <- (par_commut (Hash true)). - 2: admit. - - rewrite <- (par_commut (Hash true)). - 2: admit. - - setoid_rewrite (Advantage_par (Hash true)). - 2,3,4,5,6,7,8: admit. - - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. - - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. - - replace (0 == d)%nat with false by easy. - - (* setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). *) - (* 2,3,4,5,6,7,8: admit. *) - replace (λ (ℓ : nat) (name : ExtraTypes.name), - if (name \in N_star) || (name == PSK) then if ℓ >=? 0%N then false else true else false) - with - (λ (ℓ : nat) (name : ExtraTypes.name), false). + if (name \in N_star) || (name == PSK) then if (0 <=? ℓ)%N then false else true else false) with (λ (_ : nat) (_ : name), false). 2:{ apply functional_extensionality. intros. @@ -646,7 +713,7 @@ Section CoreTheorem. } apply advantage_reflexivity. - Admitted. + Qed. Lemma L_package_esalt_D_to_R : forall k A, @@ -753,6 +820,7 @@ Section CoreTheorem. unfold G_core_D. unfold G_core_R_esalt. + unfold G_core_package_construction. unfold pack. rewrite <- !Advantage_link. @@ -761,14 +829,14 @@ Section CoreTheorem. 2: apply pack_valid. 2,3,4,5,6,7: admit. - erewrite <- interchange. - 2,3,4,5,6,7,8: admit. + (* erewrite <- interchange. *) + (* 2,3,4,5,6,7,8: admit. *) erewrite (Advantage_parR ). 2,3,4,5,6,7,8: admit. rewrite <- !Advantage_link. - apply L_package_esalt_D_to_R. + (* apply L_package_esalt_D_to_R. *) Admitted. Lemma equation20_rhs : @@ -783,26 +851,27 @@ Section CoreTheorem. unfold G_core_ki. unfold G_core_hyb_ℓ. + unfold G_core_package_construction. unfold pack. rewrite <- !Advantage_link. - rewrite <- (par_commut (Hash true)). - 2: admit. + (* rewrite <- (par_commut (Hash true)). *) + (* 2: admit. *) - rewrite <- (par_commut (Hash true)). - 2: admit. + (* rewrite <- (par_commut (Hash true)). *) + (* 2: admit. *) - setoid_rewrite (Advantage_par (Hash true)). - 2,3,4,5,6,7,8: admit. + (* setoid_rewrite (Advantage_par (Hash true)). *) + (* 2,3,4,5,6,7,8: admit. *) - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. + (* rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). *) + (* 2: admit. *) - rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). - 2: admit. + (* rewrite <- (par_commut (K_package k PSK _ _ _ ∘ _)). *) + (* 2: admit. *) - rewrite eqxx. + (* rewrite eqxx. *) (* setoid_rewrite (Advantage_par (K_package k PSK _ _ _ ∘ _)). *) (* 2,3,4,5,6,7,8: admit. *) @@ -815,15 +884,15 @@ Section CoreTheorem. admit. } - erewrite (Advantage_par ). - 2,3,4,5,6,7,8: admit. + (* erewrite (Advantage_par ). *) + (* 2,3,4,5,6,7,8: admit. *) - erewrite <- interchange. - 2,3,4,5,6,7,8: admit. + (* erewrite <- interchange. *) + (* 2,3,4,5,6,7,8: admit. *) - rewrite <- !Advantage_link. + (* rewrite <- !Advantage_link. *) - apply L_package_esalt_D_to_R. + (* apply L_package_esalt_D_to_R. *) Admitted. Lemma equation20_eq : From 7b2452020fca901bf438e40a3ab34857f5ef9629 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 18 Mar 2025 20:27:59 +0100 Subject: [PATCH 10/10] Another sub-theorem (d6) done --- proofs/ssprove/handwritten/BasePackages.v | 6 + proofs/ssprove/handwritten/Core.v | 208 ++++------ proofs/ssprove/handwritten/CoreTheorem.v | 465 +++++++++++++++++++++- proofs/ssprove/handwritten/KeyPackages.v | 3 +- proofs/ssprove/handwritten/XTR_XPD.v | 21 +- 5 files changed, 543 insertions(+), 160 deletions(-) diff --git a/proofs/ssprove/handwritten/BasePackages.v b/proofs/ssprove/handwritten/BasePackages.v index 10232542..81050cb4 100644 --- a/proofs/ssprove/handwritten/BasePackages.v +++ b/proofs/ssprove/handwritten/BasePackages.v @@ -137,14 +137,20 @@ Definition DHEXP : nat := 12. (* Definition SET_DH : nat := 13. *) +(* Definition SET_ℓ_f d n ℓ := [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]. *) + Definition SET_ℓ Names d ℓ : Interface := interface_foreach (fun n => [interface #val #[ SET n ℓ d ] : chSETinp → chSETout]) Names. +(* SET_ℓ_f d n ℓ *) Definition SET_n Names d k : Interface := interface_hierarchy (SET_ℓ Names k) d. +(* Definition GET_ℓ_f d n ℓ := [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]. *) + Definition GET_ℓ Names d ℓ : Interface := interface_foreach (fun n => [interface #val #[ GET n ℓ d ] : chGETinp → chGETout]) Names. +(* GET_ℓ_f d n ℓ *) Definition GET_n Names d k : Interface := interface_hierarchy (GET_ℓ Names k) d. diff --git a/proofs/ssprove/handwritten/Core.v b/proofs/ssprove/handwritten/Core.v index 8df9ccdf..db133540 100644 --- a/proofs/ssprove/handwritten/Core.v +++ b/proofs/ssprove/handwritten/Core.v @@ -650,10 +650,9 @@ Section Core. intros. unfold DH_interface. rewrite (fset_cons (DHGEN, (chGroup, chGroup))). unfold idents. - unfold DHEXP, DHGEN, XTR, serialize_name. + unfold DHEXP, DHGEN, XTR, serialize_name, XTR_n_ℓ_f. simpl. solve_imfset_disjoint. - all: Lia.lia. Qed. Lemma xpd_dh : forall (d k : nat) H_lt, @@ -672,10 +671,9 @@ Section Core. intros. unfold DH_interface. rewrite (fset_cons (DHGEN, (chGroup, chGroup))). unfold idents. - unfold DHEXP, DHGEN, XPD, XPR, serialize_name. + unfold DHEXP, DHGEN, XPD, XPR, serialize_name, XPD_n_ℓ_f. simpl. solve_imfset_disjoint. - all: Lia.lia. Qed. Lemma subset_pair : forall {A : ordType} (x : {fset A}) y Lx Ly, @@ -1127,7 +1125,7 @@ Section Core. apply idents_interface_hierachy3. intros. rewrite fset_cons. - unfold idents. + unfold idents, XTR_n_ℓ_f. solve_imfset_disjoint. } } @@ -1146,7 +1144,7 @@ Section Core. intros. unfold DH_interface. rewrite fset_cons. - unfold idents. + unfold idents, XPD_n_ℓ_f. solve_imfset_disjoint. } { @@ -1160,7 +1158,7 @@ Section Core. rewrite fdisjointC. apply idents_disjoint_foreach_in. intros. - unfold idents. + unfold idents, XPD_n_ℓ_f, XTR_n_ℓ_f. solve_imfset_disjoint. rewrite !in_cons in H1. @@ -1273,11 +1271,10 @@ Section Core. Axiom sort : (chProd chGroup chGroup) -> (chProd chGroup chGroup). Axiom dh_angle : (chProd chGroup chGroup) -> chHandle. - Check chKey. Definition check d (n : name) (ℓ : nat) : package fset0 - ([interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout] :|: [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout]) - ([interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]). + (XPD_n_ℓ_f d n ℓ :|: [interface #val #[ GET BINDER ℓ d ] : chGETinp → chGETout]) + (XPD_n_ℓ_f d n ℓ). Proof. refine ( [package @@ -1318,18 +1315,21 @@ Section Core. ]). ssprove_valid ; ssprove_valid'_2. - unfold mkopsig. + unfold XPD_n_ℓ_f. rewrite <- fset1E. rewrite <- fset_cons. rewrite in_fset. rewrite !in_cons. now rewrite eqxx. - unfold mkopsig. + unfold XPD_n_ℓ_f. rewrite <- fset1E. rewrite <- fset_cons. rewrite in_fset. rewrite !in_cons. now rewrite eqxx. - unfold mkopsig. + unfold XPD_n_ℓ_f. rewrite <- fset1E. rewrite <- fset_cons. rewrite in_fset. @@ -1361,11 +1361,27 @@ Section Core. now rewrite <- interface_foreach_trivial. } + replace (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET n ℓ k] : chXPDout → chGETout ]) [:: BINDER] + d) with (interface_hierarchy_foreach + (λ (n : name) (ℓ : nat), [interface #val #[GET BINDER ℓ k] : chXPDout → chGETout ]) XPR + d). + 2:{ + unfold interface_hierarchy_foreach. + f_equal. + apply functional_extensionality ; intros. + unfold XPR, interface_foreach, XPR_sub_PSK. + simpl. + now rewrite !fsetUid. + } + + rewrite interface_hierarchy_foreachU. + refine (ℓ_packages d (fun n H_le => parallel_package d XPR - (f := fun a => [interface #val #[XPD a n k] : chXPDinp → chXPDout ] :|: [interface #val #[GET BINDER n k] : chXPDout → chGETout ]) + (f := fun a => XPD_n_ℓ_f k a n :|: [interface #val #[GET BINDER n k] : chXPDout → chGETout ]) (fun a => check k a n) _ _ _ ) (fun n H_le => @@ -1377,6 +1393,7 @@ Section Core. ). - intros. unfold idents. + unfold XPD_n_ℓ_f. solve_imfset_disjoint. - intros. apply trimmed_package_cons. @@ -1384,6 +1401,7 @@ Section Core. - reflexivity. - intros. unfold idents. + unfold XPD_n_ℓ_f. solve_imfset_disjoint. - reflexivity. - intros. @@ -1391,6 +1409,7 @@ Section Core. apply trimmed_empty_package. - intros. unfold idents. + unfold XPD_n_ℓ_f. solve_imfset_disjoint. Defined. @@ -1431,6 +1450,7 @@ Section Core. apply idents_interface_hierachy3. intros. unfold idents. + unfold XTR_n_ℓ_f, XPD_n_ℓ_f. solve_imfset_disjoint. - apply pack_valid. - apply pack_valid. @@ -1664,11 +1684,14 @@ Section Core. 2: rewrite !fsetU0 ; apply fsubsetxx. 2:{ + fold (XTR_n_ℓ_f k). fold (XTR_n d k). + fold (GET_n O_star d k). rewrite fsetUC. rewrite fsetUA. rewrite fsubUset. + apply /andP ; split. 1: solve_in_fset. @@ -1701,6 +1724,7 @@ Section Core. apply fsubsetxx. } { + fold (XTR_n_ℓ_f k). fold (XTR_n d k). fold (SET_ℓ [:: PSK] k 0). unfold interface_hierarchy_foreach. @@ -1808,114 +1832,30 @@ Section Core. Unshelve. (** Parable *) all: unfold G_dh, DH_package, combined_ID, parallel_ID, parallel_package. - all: unfold G_XTR_XPD, XPD_packages, XTR_packages, G_check, Ks, combined, eq_rect_r, eq_rect, pack, K_package. + all: unfold G_XTR_XPD, XPD_packages, XTR_packages, G_check, Ks. + all: unfold XTR_n_ℓ_f, XPD_n_ℓ_f. + all: unfold XTR_n. + all: unfold XPD_n. + all: unfold combined, eq_rect_r, eq_rect, pack, K_package. + all: unfold XTR_n_ℓ_f, XPD_n_ℓ_f. + (* all: repeat destruct eq_trans. *) all: repeat destruct Logic.eq_sym. all: repeat destruct function2_fset_cat. all: repeat destruct eq_ind. all: repeat destruct Logic.eq_sym. + (* all: unfold eq_trans. *) all: try rewrite <- trimmed_hash. - all: now solve_Parable2. - Time Defined. (* 36.626 *) - Fail Next Obligation. - - Definition Gacr (f : HashFunction) (b : bool) : - package fset0 - [interface] - [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. - (* Proof. *) - (* refine [package *) - (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) - (* ret fail *) - (* (* (* get_or_fn _ _ _ *) *) *) - (* (* d ← untag (match f with | f_hash | f_xtr => xtr t end) ;; *) *) - (* (* if b && d \in Hash *) *) - (* (* then fail *) *) - (* (* else *) *) - (* (* ret d *) *) - (* } *) - (* ]. *) - (* Qed. *) - Admitted. - - Definition R_alg : - package fset0 - [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) - [interface]. - Proof. - Admitted. - - Definition R_cr : - package fset0 - [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) - [interface]. - Proof. - Admitted. - - Definition R_Z (f : HashFunction) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_D (f : HashFunction) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Definition R_xtr (n : name) (ℓ : nat) : - n \in XTR_names -> - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. + all: try now solve_Parable2. + (* all: unfold f_equal. *) - Definition R_xpd (n : name) (ℓ : nat) : - n \in XPR -> - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. + all: unfold eq_trans. + all: unfold f_equal. + all: repeat destruct functional_extensionality. + all: repeat destruct Logic.eq_sym. - Definition R_pi (L : list name) : - package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. - Proof. - Admitted. - - Axiom Gsodh : - forall (d k : nat), - (d < k)%nat -> - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gxtr : - forall (d k : nat), - (d < k)%nat -> - forall (n : name) (ℓ : nat), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gxpd : - forall (d k : nat), - (d < k)%nat -> - forall (n : name) (ℓ : nat), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Gpi : - forall (d k : nat), - (d < k)%nat -> - forall (L : list name) - (f : ZAF), - loc_GamePair - [interface - (* #val #[ SODH ] : 'unit → 'unit *) - ]. - - Axiom Ai : raw_package -> bool -> raw_package. - Axiom R_sodh : package fset0 [interface] [interface]. + all: try now solve_Parable2. + Time Defined. (* 36.626 *) + Fail Next Obligation. Obligation Tactic := (* try timeout 8 *) idtac. @@ -1926,8 +1866,12 @@ Section Core. (chHandle) (in custom pack_type at level 2). - Program Definition KeysAndHash (d k : nat) (H_lt : (d < k)%nat) f_ks f_ls : package (L_K :|: L_L) [interface] ((SET_n all_names d k :|: SET_ℓ [PSK] k d.+1 :|: GET_n all_names d k):|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) := - {package (par (par (Ks d k (ltnW H_lt) all_names f_ks erefl ∘ Ls k all_names f_ls erefl) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true))}. + Program Definition KeysAndHash (d k : nat) (H_lt : (d < k)%nat) f_ks f_ls Names (Names_uniq : uniq Names) + : package + (L_K :|: L_L) + [interface] + ((SET_n Names d k :|: SET_ℓ [PSK] k d.+1 :|: GET_n Names d k) :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ]) := + {package (par (par (Ks d k (ltnW H_lt) Names f_ks Names_uniq ∘ Ls k Names f_ls Names_uniq) (K_package k PSK d.+1 H_lt false ∘ L_package k PSK Z)) (Hash true))}. Next Obligation. intros. eapply valid_par_upto. @@ -2098,12 +2042,16 @@ Section Core. :|: interface_hierarchy (λ ℓ : nat, [interface #val #[SET PSK ℓ.+1 k] : chUNQinp → chXTRout ]) d) :|: [interface #val #[HASH f_hash] : chHASHout → chHASHout ])) (XPD_n d k :|: XTR_n d k :|: GET_n O_star d k) := - {package (par (G_check d k (ltnW H_lt)) (par (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) - _ erefl _ _) (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _)) ∘ (par - (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) - _ erefl _ _) - (G_XTR_XPD d k f_XTR_XPD H_lt)))}. + {package + (par + (G_check d k (ltnW H_lt)) + (par + (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) _ erefl _ _) + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _)) + ∘ (par + (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _) + (G_XTR_XPD d k f_XTR_XPD H_lt))) + }. Solve Obligations with intros ; solve_idents. Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. Next Obligation. @@ -2170,7 +2118,11 @@ Section Core. unfold combined_ID. unfold G_check. unfold eq_rect. - destruct eq_ind. + unfold eq_trans, f_equal. + destruct functional_extensionality. + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym. + unfold XPD_n_ℓ_f. solve_Parable2. } 1:{ @@ -2203,7 +2155,7 @@ Section Core. (G_dh d k (ltnW H_lt)) (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) _ erefl _) ) - ) ∘ (KeysAndHash d k H_lt KeysAndHash_Kf KeysAndHash_Lf) + ) ∘ (KeysAndHash d k H_lt KeysAndHash_Kf KeysAndHash_Lf all_names erefl) }. Solve Obligations with intros ; solve_idents. Solve Obligations with intros ; now intros ? ? ? ; rewrite !in_fset !(mem_seq1 _ _) => /eqP ? /eqP ?. @@ -2261,7 +2213,11 @@ Section Core. unfold combined_ID. unfold G_check. unfold eq_rect. - destruct eq_ind. + unfold eq_trans, f_equal. + destruct functional_extensionality. + unfold eq_rect_r, eq_rect. + destruct Logic.eq_sym. + unfold XPD_n_ℓ_f. unfold G_dh. unfold DH_package. unfold parallel_ID. @@ -3336,12 +3292,6 @@ Section Core. (* Time Qed. *) (* Fail Next Obligation. *) - HB.instance Definition _ : Equality.axioms_ name := - {| - Equality.eqtype_hasDecEq_mixin := - {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} - |}. - Definition N_star := [ES; EEM; CET; BIND; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM; ZERO_SALT; ESALT; ZERO_IKM]. Lemma N_star_correct : (forall x, (x \in all_names /\ x \notin [PSK; DH]) <-> x \in N_star). diff --git a/proofs/ssprove/handwritten/CoreTheorem.v b/proofs/ssprove/handwritten/CoreTheorem.v index 93c5369f..ded4965d 100644 --- a/proofs/ssprove/handwritten/CoreTheorem.v +++ b/proofs/ssprove/handwritten/CoreTheorem.v @@ -90,6 +90,195 @@ Section CoreTheorem. Context {DepInstance : Dependencies}. Existing Instance DepInstance. + + Definition Gacr (f : HashFunction) (b : bool) : + package fset0 + [interface] + [interface #val #[ HASH f_hash ] : chHASHinp → chHASHout]. + (* Proof. *) + (* refine [package *) + (* #def #[ HASH ] (t : chHASHinp) : chHASHout { *) + (* ret fail *) + (* (* (* get_or_fn _ _ _ *) *) *) + (* (* d ← untag (match f with | f_hash | f_xtr => xtr t end) ;; *) *) + (* (* if b && d \in Hash *) *) + (* (* then fail *) *) + (* (* else *) *) + (* (* ret d *) *) + (* } *) + (* ]. *) + (* Qed. *) + Admitted. + + Definition R_alg : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + + Definition R_cr : + package fset0 + [interface] (* #val #[ HASH ] : chHASHinp → chHASHout] *) + [interface]. + Proof. + Admitted. + + Definition R_Z (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_D (f : HashFunction) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition R_xtr (n : name) (ℓ : nat) : + n \in XTR_names -> + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Definition SblngN (n : name) : list name := + filter (fun n' => + (nfto (fst (PrntN n)) == nfto (fst (PrntN n'))) + && (nfto (snd (PrntN n)) == nfto (snd (PrntN n')))) all_names. + + Definition ChldrN (n : name) : list name := + filter (fun n' => (n == nfto (fst (PrntN n'))) || (n == nfto (snd (PrntN n')))) all_names. + + Inductive POp := + | base_op + | xtr_op + | xpd_op + | out_op. + Definition PrntOp (n : name) : POp := + match (nfto (fst (PrntN n)), nfto (snd (PrntN n))) with + | (BOT, BOT) => base_op + | (_, BOT) => xpd_op + | _ => xtr_op + end. + + Definition ChldrOp (n : name) : POp := + match ChldrN n with + | [] => out_op + | (x :: _) => PrntOp x + end. + + HB.instance Definition _ : Equality.axioms_ name := + {| + Equality.eqtype_hasDecEq_mixin := + {| hasDecEq.eq_op := name_eq; hasDecEq.eqP := name_equality |} + |}. + + Definition n1 n := nfto (fst (PrntN n)). + Definition CN n := ChldrN (n1 n). + Definition E n := n1 n :: CN n. + Definition eN_star n := filter (fun x => x \notin E n) (N_star). + Definition eI_star n := filter (fun x => x \notin E n) (I_star). + Definition eO_star n := filter (fun x => x \notin E n) (O_star). + Definition eXPN n := filter (fun x => x \notin CN n) (XTR_names). + + (* R_{n,ℓ}, n \ in XPN \ (PSK,ESALT) (Fig. 34 p. 79) *) + Definition R_xpd d k (H_lt : (d < k)%nat) (n : name) (ℓ : nat) : + n \in XPR -> + (* n \notin [PSK; ESALT] -> *) + package (L_K :|: L_L) + ([interface #val #[HASH f_hash] : chHASHout → chHASHout ] :|: (interface_foreach (fun n => XPD_n_ℓ_f k n ℓ) (CN n)) :|: GET_ℓ (CN n) k ℓ :|: SET_ℓ [(n1 n)] k ℓ) + (((interface_hierarchy_foreach (XPD_n_ℓ_f k) XPR (ℓ.-1)) :|: (interface_hierarchy_foreach (fun n ℓ_off => XPD_n_ℓ_f k n (ℓ.+1 + ℓ_off)) XPR (d - (ℓ.+1)))) + :|: DH_interface + :|: SET_ℓ [PSK] k 0 + :|: XTR_n d k + :|: GET_n O_star d k). + Proof. + (* intros. *) + + (* epose (G_check_XTR_XPD := *) + (* {package *) + (* (par *) + (* (G_check d k (ltnW H_lt)) *) + (* (par *) + (* (combined_ID d XTR_names (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) _ erefl _ _) *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _)) *) + (* ∘ (par *) + (* (combined_ID d O_star (fun n ℓ => [interface #val #[ GET n ℓ k ] : chGETinp → chGETout]) _ erefl _ _) *) + (* (G_XTR_XPD d k (fun name => match name with HS => true | _ => false end) H_lt))) *) + (* }). *) + + (* epose {package *) + (* (par *) + (* (G_check_XTR_XPD) *) + (* (par *) + (* (G_dh d k (ltnW H_lt)) *) + (* (parallel_ID k [:: PSK] (fun n => [interface #val #[ SET n 0 k ] : chSETinp → chSETout]) _ erefl _) *) + (* ) *) + (* ) ∘ (KeysAndHash d k H_lt (fun ℓ_i name => *) + (* if (name \in XTR_names) *) + (* then *) + (* if (ℓ_i.+1 <=? ℓ)%nat then false else true *) + (* else false) *) + (* (fun name => match name with | ESALT => R | _ => D end) all_names erefl) *) + (* }. *) + Admitted. + + (* Definition R_xpd (n : name) (ℓ : nat) : *) + (* n \in XPR -> *) + (* package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. *) + (* Proof. *) + (* Admitted. *) + + Definition R_pi (L : list name) : + package fset0 [interface] (* [#val #[ HASH_ f ] : chHASHinp → chHASHout] *) [interface]. + Proof. + Admitted. + + Axiom Gsodh : + forall (d k : nat), + (d < k)%nat -> + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Gxtr : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + (* Fig. 24(a), p. 40 *) + Definition Gxpd : + forall (d k : nat), + (d < k)%nat -> + forall (n : name) (ℓ : nat), + loc_GamePair + ([interface #val #[HASH f_hash] : chHASHout → chHASHout ] + :|: [interface #val #[ UNQ (n1 n) k ] : chUNQinp → chUNQout] + :|: SET_ℓ [n1 n] k ℓ + :|: interface_foreach (fun n => XPD_n_ℓ_f k n ℓ) (CN n) + :|: GET_ℓ (CN n) k ℓ + :|: interface_foreach (fun n => [interface #val #[ UNQ n k ] : chUNQinp → chUNQout]) (CN n) + ). + Proof. + Admitted. + + Axiom Gpi : + forall (d k : nat), + (d < k)%nat -> + forall (L : list name) + (f : ZAF), + loc_GamePair + [interface + (* #val #[ SODH ] : 'unit → 'unit *) + ]. + + Axiom Ai : raw_package -> bool -> raw_package. + Axiom R_sodh : package fset0 [interface] [interface]. + Lemma d2 : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -149,11 +338,6 @@ Section CoreTheorem. intros. Admitted. - Definition SblngN (n : name) : list name := - filter (fun n' => - (nfto (fst (PrntN n)) == nfto (fst (PrntN n'))) - && (nfto (snd (PrntN n)) == nfto (snd (PrntN n')))) all_names. - Fixpoint idealization_loop (fuel : nat) (ioc : list name) {struct fuel} : list (list name) := match fuel with | O => [] @@ -391,17 +575,161 @@ Section CoreTheorem. Admitted. Lemma d14 : - forall d k H_lt ℓ c A n (H_in_xpr : n \in XPR), - (nfto (fst (PrntN n)) \notin nth [] IdealizationOrderPreCompute c.-1) -> - ((c == 0) || (nfto (fst (PrntN n)) \in nth [] IdealizationOrderPreCompute c.+1)) -> + forall d k H_lt ℓ c A n (_ : ChldrOp (nfto (fst (PrntN n))) = xpd_op) (H_in_xpr : n \in XPR) (* (H_notin : n \notin [PSK; ESALT]) *), + ((nfto (fst (PrntN n))) \notin nth [] IdealizationOrderPreCompute c.-1) -> + ((c == O) || ((nfto (fst (PrntN n))) \in nth [] IdealizationOrderPreCompute c.+1)) -> (AdvantageE (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c)) (G_core_hyb_pred_ℓ_c d k H_lt ℓ (nth [] IdealizationOrderPreCompute c.+1)) A <= - Advantage (Gxtr d k H_lt n ℓ) (A ∘ R_xpd n ℓ H_in_xpr))%R. + Advantage (Gxpd d k H_lt n ℓ) (A ∘ R_xpd d k H_lt n ℓ H_in_xpr))%R. Proof. intros. + + unfold G_core_hyb_pred_ℓ_c. + unfold G_core_package_construction. + unfold pack. + + unfold IdealizationOrderPreCompute. + unfold G_core_hyb_pred_ℓ_c. + unfold G_core_package_construction. + unfold pack. + + simpl in H0. + + move /orP: H1 => [ /eqP ? | H1 ] ; subst. + - unfold nth. + rewrite <- !Advantage_link. + rewrite Advantage_E. + + eassert ( + forall (P : seq ExtraTypes.name) (Q : seq ExtraTypes.name) (Z : seq ExtraTypes.name) + (H_uniq : uniq (P ++ Q)) + (H_uniq_P : uniq P) + (H_uniq_Q : uniq Q) + A, + AdvantageE + (KeysAndHash d k H_lt (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in Z) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) (P ++ Q) H_uniq) + (par + (KeysAndHash d k H_lt (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in Z) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) P H_uniq_P) + (KeysAndHash d k H_lt (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in [::]) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) Q H_uniq_Q) + ) + A = 0)%R. + 1: admit. + + eassert ( + forall (A : seq ExtraTypes.name) (B : seq ExtraTypes.name) P + (H_eq : forall x, x \in A <-> x \in B) + (H_uniq_A : uniq A) + (H_uniq_B : uniq B) + Adv, + AdvantageE + (KeysAndHash d k H_lt (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in P) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) A H_uniq_A) + (KeysAndHash d k H_lt (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in P) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) B H_uniq_B) + Adv = 0)%R. + 1: admit. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (KeysAndHash d k H_lt + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in []) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) ([:: PSK; ZERO_SALT; DH; ZERO_IKM] ++ [ES; EEM; CET; BIND; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM; ESALT]) erefl)). + + rewrite H2. + 2:{ admit. } + rewrite add0r. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + eapply Order.le_trans. + 1:{ + apply Num.Theory.lerD ; [ | easy ]. + erewrite H1. + now apply eq_ler. + } + rewrite add0r. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (KeysAndHash d k H_lt + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in [:: PSK; ZERO_SALT; DH; ZERO_IKM]) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) ([:: PSK; ZERO_SALT; DH; ZERO_IKM] ++ [ES; EEM; CET; BIND; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM; ESALT]) erefl)). + + rewrite H2. + 2:{ admit. } + rewrite addr0. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + instantiate (1 := (KeysAndHash d k H_lt + (λ (ℓ0 : nat) (name : ExtraTypes.name), + if (name \in N_star) || (name == PSK) + then if (ℓ + (name \in [:: PSK; ZERO_SALT; DH; ZERO_IKM]) <=? ℓ0)%N then false else true + else false) (λ name : ExtraTypes.name, match name with + | ESALT => R + | _ => D + end) ([:: PSK; ZERO_SALT; DH; ZERO_IKM] ++ [ES; EEM; CET; BIND; BINDER; HS; SHT; CHT; HSALT; AS; RM; CAT; SAT; EAM; ESALT]) erefl)). + + rewrite H2. + 2:{ admit. } + rewrite addr0. + + eapply Order.le_trans ; [ apply Advantage_triangle | ]. + eapply Order.le_trans. + 1:{ + apply Num.Theory.lerD ; [ easy | ]. + rewrite (Advantage_sym _ _). + erewrite H1. + now apply eq_ler. + } + rewrite addr0. + erewrite (Advantage_parR ). + 2: admit. + 2: admit. + 2: admit. + 2: admit. + 2: admit. + 2: admit. + 2: admit. + + try timeout 5 rewrite advantage_reflexivity. Admitted. (* d6: Hybrid lemma *) @@ -418,7 +746,7 @@ Section CoreTheorem. <= Advantage (Gxtr d k H_lt ES ℓ) (A ∘ R_xtr ES ℓ erefl) + Advantage (Gxtr d k H_lt HS ℓ) (A ∘ R_xtr HS ℓ erefl) + Advantage (Gxtr d k H_lt AS ℓ) (A ∘ R_xtr AS ℓ erefl) + - sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (A ∘ R_xpd n ℓ H_in))%R + sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (A ∘ R_xpd d k H_lt n ℓ H_in))%R )%R. Proof. intros. @@ -563,13 +891,34 @@ Section CoreTheorem. easy. } { - refine (d14 d k H_lt ℓ 0 A PSK _ _ _). - { easy. } - 1: easy. + refine (d14 d k H_lt ℓ 0 A ESALT _ erefl _ _). + { + unfold ChldrOp. unfold ChldrN. unfold all_names. + + repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with false by easy). + + (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with true by easy ; hnf). + + unfold PrntOp. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + } + 1:{ unfold XPR. unfold XPR_sub_PSK. easy. } 1: easy. } { - refine (d14 d k H_lt ℓ 2 A EEM erefl _ _). + refine (d14 d k H_lt ℓ 2 A EEM _ erefl _ _). + 1:{ + unfold ChldrOp. unfold ChldrN. unfold all_names. + + repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with false by easy). + + (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with true by easy ; hnf). + + unfold PrntOp. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + } 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -582,7 +931,18 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 4 A CHT erefl _ _). + refine (d14 d k H_lt ℓ 4 A SHT _ erefl _ _). + 1:{ + unfold ChldrOp. unfold ChldrN. unfold all_names. + + repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with false by easy). + + (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with true by easy ; hnf). + + unfold PrntOp. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + } 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -596,7 +956,18 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 5 A CHT erefl _ _). + refine (d14 d k H_lt ℓ 5 A CHT _ erefl _ _). + 1:{ + unfold ChldrOp. unfold ChldrN. unfold all_names. + + repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with false by easy). + + (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with true by easy ; hnf). + + unfold PrntOp. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + } 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -610,7 +981,18 @@ Section CoreTheorem. } } { - refine (d14 d k H_lt ℓ 7 A CAT erefl _ _). + refine (d14 d k H_lt ℓ 7 A RM _ erefl _ _). + 1:{ + unfold ChldrOp. unfold ChldrN. unfold all_names. + + repeat (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with false by easy). + + (rewrite filter_cons ; rewrite !nfto_name_to_chName_cancel ; simpl (( _ == _) || (_ == _)) ; replace (_ == _) with true by easy ; hnf). + + unfold PrntOp. + rewrite !nfto_name_to_chName_cancel. + reflexivity. + } 2:{ simpl. rewrite nfto_name_to_chName_cancel. @@ -625,10 +1007,49 @@ Section CoreTheorem. } } - (* easy. Lia.lia. *) - (* Qed. *) - Admitted. - + unfold XPR, XPR_sub_PSK. + unfold sumR_l_in_rel ; fold @sumR_l_in_rel. + simpl ([:: ESALT] ++ _). + unfold sumR_l_in_rel ; fold @sumR_l_in_rel. + + replace (mem_tail _ _ _) with (erefl : ESALT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : EEM \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : CET \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : BIND \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : BINDER \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : SHT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : CHT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : HSALT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : RM \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : CAT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : SAT \in XPR) by easy. + replace (mem_tail _ _ _) with (erefl : EAM \in XPR) by easy. + + rewrite <- !addrA. + rewrite addrC. + rewrite <- !addrA. + + apply Num.Theory.lerD ; [ easy | ]. + + rewrite addrC. + rewrite <- !addrA. + + apply Num.Theory.lerD ; [ easy | ]. + + rewrite addrC. + rewrite <- !addrA. + + rewrite addrC. + rewrite <- !addrA. + + apply Num.Theory.lerD ; [ easy | ]. + + rewrite <- addrC. + rewrite <- !addrA. + + now repeat ((apply Num.Theory.ler_wpDr ; [ | easy ]) || (apply Num.Theory.lerD ; [ easy | ]) || (apply Num.Theory.ler_wpDl ; [ apply Num.Theory.normr_ge0 | ])). + Qed. + Lemma hyb_telescope : forall (d k : nat) H_lt, (* forall (Score : Simulator d k), *) @@ -972,7 +1393,7 @@ Section CoreTheorem. Advantage (Gxtr d k H_lt ES ℓ) (Ai A i ∘ R_xtr ES ℓ erefl) + Advantage (Gxtr d k H_lt HS ℓ) (Ai A i ∘ R_xtr HS ℓ erefl) + Advantage (Gxtr d k H_lt AS ℓ) (Ai A i ∘ R_xtr AS ℓ erefl) + - sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (Ai A i ∘ R_xpd n ℓ H_in))%R) + sumR_l_in_rel XPR XPR (fun _ H => H) (fun n H_in => Advantage (Gxpd d k H_lt n ℓ) (Ai A i ∘ R_xpd d k H_lt n ℓ H_in))%R) ))%R. Proof. intros. diff --git a/proofs/ssprove/handwritten/KeyPackages.v b/proofs/ssprove/handwritten/KeyPackages.v index 0d821199..320329e9 100644 --- a/proofs/ssprove/handwritten/KeyPackages.v +++ b/proofs/ssprove/handwritten/KeyPackages.v @@ -169,6 +169,7 @@ Section KeyPackages. #val #[ GET n ℓ d ] : chGETinp → chGETout ]. Proof. + intros. refine [package #def #[ SET n ℓ d ] ('(h,hon,k_star) : chSETinp) : chSETout { #import {sig #[ UNQ n d ] : chUNQinp → chUNQout } @@ -280,7 +281,7 @@ Section KeyPackages. Proof. intros. rewrite interface_hierarchy_foreachU. - + rewrite <- function2_fset_cat. refine (combined _ d L_K (λ n : name, [interface #val #[UNQ n k] : chUNQinp → chUNQout ]) diff --git a/proofs/ssprove/handwritten/XTR_XPD.v b/proofs/ssprove/handwritten/XTR_XPD.v index ca6f684f..57706b5d 100644 --- a/proofs/ssprove/handwritten/XTR_XPD.v +++ b/proofs/ssprove/handwritten/XTR_XPD.v @@ -207,19 +207,22 @@ Section XTR_XPD. (* Definition SET_XTR d : Interface := *) (* interface_hierarchy (SET_XTR_ℓ d) d. *) + Definition XTR_n_ℓ_f d n ℓ := [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]. + Definition XTR_n d k := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XTR n ℓ k ] : chXTRinp → chXTRout]) XTR_names d. + interface_hierarchy_foreach (XTR_n_ℓ_f k) XTR_names d. Definition XTR_n_ℓ d ℓ := - interface_foreach (fun n => [interface #val #[ XTR n ℓ d ] : chXTRinp → chXTRout]) XTR_names. + interface_foreach (fun n => XTR_n_ℓ_f d n ℓ) XTR_names. Lemma trimmed_Xtr : forall ℓ n d b, trimmed - [interface #val #[XTR n ℓ d] : chXTRinp → chXTRout ] + (XTR_n_ℓ_f d n ℓ) (Xtr n ℓ d b). Proof. intros. unfold trimmed. + unfold XTR_n_ℓ_f. trim_is_interface. Qed. @@ -464,12 +467,13 @@ Section XTR_XPD. reflexivity. Qed. + Definition XPD_n_ℓ_f d n ℓ := [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]. + Definition XPD_n (d k : nat) := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ k ] : chXPDinp → chXPDout - ]) XPR d. + interface_hierarchy_foreach (XPD_n_ℓ_f k) XPR d. Definition XPD_n_ℓ d ℓ := - interface_hierarchy_foreach (fun n ℓ => [interface #val #[ XPD n ℓ d ] : chXPDinp → chXPDout]) XPR ℓ. + interface_hierarchy_foreach (XPD_n_ℓ_f d) XPR ℓ. (* Definition GET_XPD_ℓ d ℓ : Interface := *) (* interface_foreach (fun n => [interface #val #[ GET (nfto (fst (PrntN n))) ℓ d ] : chGETinp → chGETout]) (XPR). *) @@ -486,11 +490,12 @@ Section XTR_XPD. Lemma trimmed_Xpd : forall n ℓ d, trimmed - [interface #val #[XPD n ℓ d] : chXPDinp → chXPDout ] + (XPD_n_ℓ_f d n ℓ) (Xpd n ℓ d). Proof. intros. unfold trimmed. + unfold XPD_n_ℓ_f. trim_is_interface. Qed. @@ -856,7 +861,7 @@ Section XTR_XPD. rewrite fdisjointC. apply idents_interface_hierachy3. intros. - unfold idents. + unfold idents ; unfold XPD_n_ℓ_f. solve_imfset_disjoint. } {