commit dbbb5ca340e0155fcd75f1a6582e59e353dd87f4 Author: Achim D. Brucker Date: Sat May 23 15:19:23 2020 +0100 Initial commit, based on AFP entry dated 2020-05-22. diff --git a/CITATION b/CITATION new file mode 100644 index 0000000..6713418 --- /dev/null +++ b/CITATION @@ -0,0 +1,38 @@ +To cite the use of this formal theory, please use + + Andreas V. Hess, Sebastian Mödersheim, and Achim D. Brucker. Stateful + Protocol Composition and Typing. In Archive of Formal Proofs, 2020. + http://www.isa-afp.org/entries/tateful_Protocol_Composition_and_Typing.html, + Formal proof development + +A BibTeX entry for LaTeX users is +@Article{ hess.ea:stateful:2020, + abstract= {We provide in this AFP entry several relative soundness + results for security protocols. In particular, we prove + typing and compositionality results for stateful protocols + (i.e., protocols with mutable state that may span several + sessions), and that focuses on reachability properties. Such + results are useful to simplify protocol verification by + reducing it to a simpler problem: Typing results give + conditions under which it is safe to verify a protocol in a + typed model where only "well-typed" attacks can occur whereas + compositionality results allow us to verify a composed protocol + by only verifying the component protocols in isolation. The + conditions on the protocols under which the results hold are + furthermore syntactic in nature allowing for full automation. + The foundation presented here is used in another entry to + provide fully automated and formalized security proofs of + stateful protocols.}, + author = {Andreas V. Hess and Sebastian M{\"o}dersheim and Achim D. Brucker}, + date = {2020-04-08}, + file = {https://www.brucker.ch/bibliography/download/2020/hess.ea-stateful-outline-2020.pdf}, + filelabel= {Outline}, + issn = {2150-914x}, + journal = {Archive of Formal Proofs}, + month = {apr}, + note = {\url{http://www.isa-afp.org/entries/tateful_Protocol_Composition_and_Typing.html}, Formal proof development}, + pdf = {https://www.brucker.ch/bibliography/download/2020/hess.ea-stateful-2020.pdf}, + title = {Stateful Protocol Composition and Typing}, + url = {https://www.brucker.ch/bibliography/abstract/hess.ea-stateful-2020}, + year = {2020}, +} diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..71b7f9f --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015-2020 Technical University Denmark, Denmark + 2017-2019 The University of Sheffield, UK + 2019-2020 University of Exeter, UK +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..607ebac --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# Stateful Protocol Composition and Typing ( + +This git repository contains a local mirror of +[Stateful Protocol Composition and Typing](https://www.isa-afp.org/entries/Stateful_Protocol_Composition_and_Typing.html) +entry of the +[Archive of Formal Proofs (AFP)](https://www.isa-afp.org). + +The official AFP releases are tagged. Additionally, this repository +may contain extensions (i.e., a development version) that may be +submitted (as an update of the Stateful Protocol Composition and Typing entry) at a later stage. + +## Installation + +```console +achim@logicalhacking:~$ isabelle build -D Stateful_Protocol_Composition_and_Typing.html +``` + +## Authors + +* Andreas V. Hess +* [Sebastian Mödersheim](https://people.compute.dtu.dk/samo/) +* [Achim D. Brucker](http://www.brucker.ch/) + +## License + +This project is licensed under a 3-clause BSD-style license. + +SPDX-License-Identifier: BSD-3-Clause + +## Master Repository + +The master git repository for this project is hosted by the [Software +Assurance & Security Research Team](https://logicalhacking.com) at +. + +## Publications + +* Andreas V. Hess, Sebastian Mödersheim, and Achim D. Brucker. Stateful + Protocol Composition and Typing. In Archive of Formal Proofs, 2020. + http://www.isa-afp.org/entries/tateful_Protocol_Composition_and_Typing.html, + Formal proof development +* Andreas V. Hess, Sebastian A. Mödersheim, and Achim D. Brucker. Stateful + Protocol Composition. In ESORICS. Lecture Notes in Computer Science (11098), + pages 427-446, Springer-Verlag, 2018. doi:[10.1007/978-3-319-99073-6](https://dx.doi.org/10.1007/978-3-319-99073-6) diff --git a/Stateful_Protocol_Composition_and_Typing/Examples.thy b/Stateful_Protocol_Composition_and_Typing/Examples.thy new file mode 100644 index 0000000..2981834 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Examples.thy @@ -0,0 +1,5 @@ +theory Examples + imports "examples/Example_Keyserver" + "examples/Example_TLS" +begin +end diff --git a/Stateful_Protocol_Composition_and_Typing/Intruder_Deduction.thy b/Stateful_Protocol_Composition_and_Typing/Intruder_Deduction.thy new file mode 100644 index 0000000..5a3fc8e --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Intruder_Deduction.thy @@ -0,0 +1,1200 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Intruder_Deduction.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Dolev-Yao Intruder Model\ +theory Intruder_Deduction +imports Messages More_Unification +begin + +subsection \Syntax for the Intruder Deduction Relations\ +consts INTRUDER_SYNTH::"('f,'v) terms \ ('f,'v) term \ bool" (infix "\\<^sub>c" 50) +consts INTRUDER_DEDUCT::"('f,'v) terms \ ('f,'v) term \ bool" (infix "\" 50) + + +subsection \Intruder Model Locale\ +text \ + The intruder model is parameterized over arbitrary function symbols (e.g, cryptographic operators) + and variables. It requires three functions: + - \arity\ that assigns an arity to each function symbol. + - \public\ that partitions the function symbols into those that will be available to the intruder + and those that will not. + - \Ana\, the analysis interface, that defines how messages can be decomposed (e.g., decryption). +\ +locale intruder_model = + fixes arity :: "'fun \ nat" + and public :: "'fun \ bool" + and Ana :: "('fun,'var) term \ (('fun,'var) term list \ ('fun,'var) term list)" + assumes Ana_keys_fv: "\t K R. Ana t = (K,R) \ fv\<^sub>s\<^sub>e\<^sub>t (set K) \ fv t" + and Ana_keys_wf: "\t k K R f T. + Ana t = (K,R) \ (\g S. Fun g S \ t \ length S = arity g) + \ k \ set K \ Fun f T \ k \ length T = arity f" + and Ana_var[simp]: "\x. Ana (Var x) = ([],[])" + and Ana_fun_subterm: "\f T K R. Ana (Fun f T) = (K,R) \ set R \ set T" + and Ana_subst: "\t \ K R. \Ana t = (K,R); K \ [] \ R \ []\ \ Ana (t \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,R \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +begin + +lemma Ana_subterm: assumes "Ana t = (K,T)" shows "set T \ subterms t" +using assms +by (cases t) + (simp add: psubsetI, + metis Ana_fun_subterm Fun_gt_params UN_I term.order_refl + params_subterms psubsetI subset_antisym subset_trans) + +lemma Ana_subterm': "s \ set (snd (Ana t)) \ s \ t" +using Ana_subterm by (cases "Ana t") auto + +lemma Ana_vars: assumes "Ana t = (K,M)" shows "fv\<^sub>s\<^sub>e\<^sub>t (set K) \ fv t" "fv\<^sub>s\<^sub>e\<^sub>t (set M) \ fv t" +by (rule Ana_keys_fv[OF assms]) (use Ana_subterm[OF assms] subtermeq_vars_subset in auto) + +abbreviation \ where "\ \ UNIV::'var set" +abbreviation \n ("\\<^sup>_") where "\\<^sup>n \ {f::'fun. arity f = n}" +abbreviation \npub ("\\<^sub>p\<^sub>u\<^sub>b\<^sup>_") where "\\<^sub>p\<^sub>u\<^sub>b\<^sup>n \ {f. public f} \ \\<^sup>n" +abbreviation \npriv ("\\<^sub>p\<^sub>r\<^sub>i\<^sub>v\<^sup>_") where "\\<^sub>p\<^sub>r\<^sub>i\<^sub>v\<^sup>n \ {f. \public f} \ \\<^sup>n" +abbreviation \\<^sub>p\<^sub>u\<^sub>b where "\\<^sub>p\<^sub>u\<^sub>b \ (\n. \\<^sub>p\<^sub>u\<^sub>b\<^sup>n)" +abbreviation \\<^sub>p\<^sub>r\<^sub>i\<^sub>v where "\\<^sub>p\<^sub>r\<^sub>i\<^sub>v \ (\n. \\<^sub>p\<^sub>r\<^sub>i\<^sub>v\<^sup>n)" +abbreviation \ where "\ \ (\n. \\<^sup>n)" +abbreviation \ where "\ \ \\<^sup>0" +abbreviation \\<^sub>p\<^sub>u\<^sub>b where "\\<^sub>p\<^sub>u\<^sub>b \ {f. public f} \ \" +abbreviation \\<^sub>p\<^sub>r\<^sub>i\<^sub>v where "\\<^sub>p\<^sub>r\<^sub>i\<^sub>v \ {f. \public f} \ \" +abbreviation \\<^sub>f where "\\<^sub>f \ \ - \" +abbreviation \\<^sub>f\<^sub>p\<^sub>u\<^sub>b where "\\<^sub>f\<^sub>p\<^sub>u\<^sub>b \ \\<^sub>f \ \\<^sub>p\<^sub>u\<^sub>b" +abbreviation \\<^sub>f\<^sub>p\<^sub>r\<^sub>i\<^sub>v where "\\<^sub>f\<^sub>p\<^sub>r\<^sub>i\<^sub>v \ \\<^sub>f \ \\<^sub>p\<^sub>r\<^sub>i\<^sub>v" + +lemma disjoint_fun_syms: "\\<^sub>f \ \ = {}" by auto +lemma id_union_univ: "\\<^sub>f \ \ = UNIV" "\ = UNIV" by auto +lemma const_arity_eq_zero[dest]: "c \ \ \ arity c = 0" by simp +lemma const_pub_arity_eq_zero[dest]: "c \ \\<^sub>p\<^sub>u\<^sub>b \ arity c = 0 \ public c" by simp +lemma const_priv_arity_eq_zero[dest]: "c \ \\<^sub>p\<^sub>r\<^sub>i\<^sub>v \ arity c = 0 \ \public c" by simp +lemma fun_arity_gt_zero[dest]: "f \ \\<^sub>f \ arity f > 0" by fastforce +lemma pub_fun_public[dest]: "f \ \\<^sub>f\<^sub>p\<^sub>u\<^sub>b \ public f" by fastforce +lemma pub_fun_arity_gt_zero[dest]: "f \ \\<^sub>f\<^sub>p\<^sub>u\<^sub>b \ arity f > 0" by fastforce + +lemma \\<^sub>f_unfold: "\\<^sub>f = {f::'fun. arity f > 0}" by auto +lemma \_unfold: "\ = {f::'fun. arity f = 0}" by auto +lemma \pub_unfold: "\\<^sub>p\<^sub>u\<^sub>b = {f::'fun. arity f = 0 \ public f}" by auto +lemma \priv_unfold: "\\<^sub>p\<^sub>r\<^sub>i\<^sub>v = {f::'fun. arity f = 0 \ \public f}" by auto +lemma \npub_unfold: "(\\<^sub>p\<^sub>u\<^sub>b\<^sup>n) = {f::'fun. arity f = n \ public f}" by auto +lemma \npriv_unfold: "(\\<^sub>p\<^sub>r\<^sub>i\<^sub>v\<^sup>n) = {f::'fun. arity f = n \ \public f}" by auto +lemma \fpub_unfold: "\\<^sub>f\<^sub>p\<^sub>u\<^sub>b = {f::'fun. arity f > 0 \ public f}" by auto +lemma \fpriv_unfold: "\\<^sub>f\<^sub>p\<^sub>r\<^sub>i\<^sub>v = {f::'fun. arity f > 0 \ \public f}" by auto +lemma \n_m_eq: "\(\\<^sup>n) \ {}; (\\<^sup>n) = (\\<^sup>m)\ \ n = m" by auto + + +subsection \Term Well-formedness\ +definition "wf\<^sub>t\<^sub>r\<^sub>m t \ \f T. Fun f T \ t \ length T = arity f" + +abbreviation "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s T \ \t \ T. wf\<^sub>t\<^sub>r\<^sub>m t" + +lemma Ana_keys_wf': "Ana t = (K,T) \ wf\<^sub>t\<^sub>r\<^sub>m t \ k \ set K \ wf\<^sub>t\<^sub>r\<^sub>m k" +using Ana_keys_wf unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by metis + +lemma wf_trm_Var[simp]: "wf\<^sub>t\<^sub>r\<^sub>m (Var x)" unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by simp + +lemma wf_trm_subst_range_Var[simp]: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" by simp + +lemma wf_trm_subst_range_iff: "(\x. wf\<^sub>t\<^sub>r\<^sub>m (\ x)) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +by force + +lemma wf_trm_subst_rangeD: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ wf\<^sub>t\<^sub>r\<^sub>m (\ x)" +by (metis wf_trm_subst_range_iff) + +lemma wf_trm_subst_rangeI[intro]: + "(\x. wf\<^sub>t\<^sub>r\<^sub>m (\ x)) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +by (metis wf_trm_subst_range_iff) + +lemma wf_trmI[intro]: + assumes "\t. t \ set T \ wf\<^sub>t\<^sub>r\<^sub>m t" "length T = arity f" + shows "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" +using assms unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + +lemma wf_trm_subterm: "\wf\<^sub>t\<^sub>r\<^sub>m t; s \ t\ \ wf\<^sub>t\<^sub>r\<^sub>m s" +unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by (induct t) auto + +lemma wf_trm_subtermeq: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "s \ t" + shows "wf\<^sub>t\<^sub>r\<^sub>m s" +proof (cases "s = t") + case False thus "wf\<^sub>t\<^sub>r\<^sub>m s" using assms(2) wf_trm_subterm[OF assms(1)] by simp +qed (metis assms(1)) + +lemma wf_trm_param: + assumes "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" "t \ set T" + shows "wf\<^sub>t\<^sub>r\<^sub>m t" +by (meson assms subtermeqI'' wf_trm_subtermeq) + +lemma wf_trm_param_idx: + assumes "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" + and "i < length T" + shows "wf\<^sub>t\<^sub>r\<^sub>m (T ! i)" +using wf_trm_param[OF assms(1), of "T ! i"] assms(2) +by fastforce + +lemma wf_trm_subst: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m t = wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" +proof + show "wf\<^sub>t\<^sub>r\<^sub>m t \ wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" + proof (induction t) + case (Fun f T) + hence "\t. t \ set T \ wf\<^sub>t\<^sub>r\<^sub>m t" + by (meson wf\<^sub>t\<^sub>r\<^sub>m_def Fun_param_is_subterm term.order_trans) + hence "\t. t \ set T \ wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" using Fun.IH by auto + moreover have "length (map (\t. t \ \) T) = arity f" + using Fun.prems unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + ultimately show ?case by fastforce + qed (simp add: wf_trm_subst_rangeD[OF assms]) + + show "wf\<^sub>t\<^sub>r\<^sub>m (t \ \) \ wf\<^sub>t\<^sub>r\<^sub>m t" + proof (induction t) + case (Fun f T) + hence "wf\<^sub>t\<^sub>r\<^sub>m t" when "t \ set (map (\s. s \ \) T)" for t + by (metis that wf\<^sub>t\<^sub>r\<^sub>m_def Fun_param_is_subterm term.order_trans subst_apply_term.simps(2)) + hence "wf\<^sub>t\<^sub>r\<^sub>m t" when "t \ set T" for t using that Fun.IH by auto + moreover have "length (map (\t. t \ \) T) = arity f" + using Fun.prems unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + ultimately show ?case by fastforce + qed (simp add: assms) +qed + +lemma wf_trm_subst_singleton: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" shows "wf\<^sub>t\<^sub>r\<^sub>m (t \ Var(v := t'))" +proof - + have "wf\<^sub>t\<^sub>r\<^sub>m ((Var(v := t')) w)" for w using assms(2) unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by simp + thus ?thesis using assms(1) wf_trm_subst[of "Var(v := t')" t, OF wf_trm_subst_rangeI] by simp +qed + +lemma wf_trm_subst_rm_vars: + assumes "wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m (t \ rm_vars X \)" +using assms +proof (induction t) + case (Fun f T) + have "wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" when "t \ set T" for t + using that wf_trm_param[of f "map (\t. t \ \) T"] Fun.prems + by auto + hence "wf\<^sub>t\<^sub>r\<^sub>m (t \ rm_vars X \)" when "t \ set T" for t using that Fun.IH by simp + moreover have "length T = arity f" using Fun.prems unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + ultimately show ?case unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto +qed simp + +lemma wf_trm_subst_rm_vars': "wf\<^sub>t\<^sub>r\<^sub>m (\ v) \ wf\<^sub>t\<^sub>r\<^sub>m (rm_vars X \ v)" +by auto + +lemma wf_trms_subst: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (M \\<^sub>s\<^sub>e\<^sub>t \)" +by (metis (no_types, lifting) assms imageE wf_trm_subst) + +lemma wf_trms_subst_rm_vars: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (M \\<^sub>s\<^sub>e\<^sub>t \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (M \\<^sub>s\<^sub>e\<^sub>t rm_vars X \)" +using assms wf_trm_subst_rm_vars by blast + +lemma wf_trms_subst_rm_vars': + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (rm_vars X \))" +using assms by force + +lemma wf_trms_subst_compose: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" +using assms subst_img_comp_subset' wf_trm_subst by blast + +lemma wf_trm_subst_compose: + fixes \::"('fun, 'v) subst" + assumes "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" "\x. wf\<^sub>t\<^sub>r\<^sub>m (\ x)" + shows "wf\<^sub>t\<^sub>r\<^sub>m ((\ \\<^sub>s \) x)" +using wf_trm_subst[of \ "\ x", OF wf_trm_subst_rangeI[OF assms(2)]] assms(1) + subst_subst_compose[of "Var x" \ \] + subst_apply_term.simps(1)[of x \] + subst_apply_term.simps(1)[of x "\ \\<^sub>s \"] +by argo + +lemma wf_trms_Var_range: + assumes "subst_range \ \ range Var" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +using assms by fastforce + +lemma wf_trms_subst_compose_Var_range: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and "subst_range \ \ range Var" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" +using assms wf_trms_subst_compose wf_trms_Var_range by metis+ + +lemma wf_trm_subst_inv: "wf\<^sub>t\<^sub>r\<^sub>m (t \ \) \ wf\<^sub>t\<^sub>r\<^sub>m t" +unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by (induct t) auto + +lemma wf_trms_subst_inv: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (M \\<^sub>s\<^sub>e\<^sub>t \) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" +using wf_trm_subst_inv by fast + +lemma wf_trm_subterms: "wf\<^sub>t\<^sub>r\<^sub>m t \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subterms t)" +using wf_trm_subterm by blast + +lemma wf_trms_subterms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subterms\<^sub>s\<^sub>e\<^sub>t M)" +using wf_trm_subterms by blast + +lemma wf_trm_arity: "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T) \ length T = arity f" +unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by blast + +lemma wf_trm_subterm_arity: "wf\<^sub>t\<^sub>r\<^sub>m t \ Fun f T \ t \ length T = arity f" +unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by blast + +lemma unify_list_wf_trm: + assumes "Unification.unify E B = Some U" "\(s,t) \ set E. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" + and "\(v,t) \ set B. wf\<^sub>t\<^sub>r\<^sub>m t" + shows "\(v,t) \ set U. wf\<^sub>t\<^sub>r\<^sub>m t" +using assms +proof (induction E B arbitrary: U rule: Unification.unify.induct) + case (1 B U) thus ?case by auto +next + case (2 f T g S E B U) + have wf_fun: "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun g S)" using "2.prems"(2) by auto + from "2.prems"(1) obtain E' where *: "decompose (Fun f T) (Fun g S) = Some E'" + and [simp]: "f = g" "length T = length S" "E' = zip T S" + and **: "Unification.unify (E'@E) B = Some U" + by (auto split: option.splits) + hence "t \ Fun f T" "t' \ Fun g S" when "(t,t') \ set E'" for t t' + using that by (metis zip_arg_subterm(1), metis zip_arg_subterm(2)) + hence "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" when "(t,t') \ set E'" for t t' + using wf_trm_subterm wf_fun \f = g\ that by blast+ + thus ?case using "2.IH"[OF * ** _ "2.prems"(3)] "2.prems"(2) by fastforce +next + case (3 v t E B) + hence *: "\(w,x) \ set ((v, t) # B). wf\<^sub>t\<^sub>r\<^sub>m x" + and **: "\(s,t) \ set E. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t" + by auto + + show ?case + proof (cases "t = Var v") + case True thus ?thesis using "3.prems" "3.IH"(1) by auto + next + case False + hence "v \ fv t" using "3.prems"(1) by auto + hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U" + using \t \ Var v\ "3.prems"(1) by auto + moreover have "\(s, t) \ set (subst_list (subst v t) E). wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" + using wf_trm_subst_singleton[OF _ \wf\<^sub>t\<^sub>r\<^sub>m t\] "3.prems"(2) + unfolding subst_list_def subst_def by auto + ultimately show ?thesis using "3.IH"(2)[OF \t \ Var v\ \v \ fv t\ _ _ *] by metis + qed +next + case (4 f T v E B U) + hence *: "\(w,x) \ set ((v, Fun f T) # B). wf\<^sub>t\<^sub>r\<^sub>m x" + and **: "\(s,t) \ set E. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" + by auto + + have "v \ fv (Fun f T)" using "4.prems"(1) by force + hence "Unification.unify (subst_list (subst v (Fun f T)) E) ((v, Fun f T)#B) = Some U" + using "4.prems"(1) by auto + moreover have "\(s, t) \ set (subst_list (subst v (Fun f T)) E). wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" + using wf_trm_subst_singleton[OF _ \wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)\] "4.prems"(2) + unfolding subst_list_def subst_def by auto + ultimately show ?case using "4.IH"[OF \v \ fv (Fun f T)\ _ _ *] by metis +qed + +lemma mgu_wf_trm: + assumes "mgu s t = Some \" "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" + shows "wf\<^sub>t\<^sub>r\<^sub>m (\ v)" +proof - + from assms obtain \' where "subst_of \' = \" "\(v,t) \ set \'. wf\<^sub>t\<^sub>r\<^sub>m t" + using unify_list_wf_trm[of "[(s,t)]" "[]"] by (auto split: option.splits) + thus ?thesis + proof (induction \' arbitrary: \ v rule: List.rev_induct) + case (snoc x \' \ v) + define \ where "\ = subst_of \'" + hence "wf\<^sub>t\<^sub>r\<^sub>m (\ v)" for v using snoc.prems(2) snoc.IH[of \] by fastforce + moreover obtain w t where x: "x = (w,t)" by (metis surj_pair) + hence \: "\ = Var(w := t) \\<^sub>s \" using snoc.prems(1) by (simp add: subst_def \_def) + moreover have "wf\<^sub>t\<^sub>r\<^sub>m t" using snoc.prems(2) x by auto + ultimately show ?case using wf_trm_subst[of _ t] unfolding subst_compose_def by auto + qed (simp add: wf\<^sub>t\<^sub>r\<^sub>m_def) +qed + +lemma mgu_wf_trms: + assumes "mgu s t = Some \" "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +using mgu_wf_trm[OF assms] by simp + +subsection \Definitions: Intruder Deduction Relations\ +text \ + A standard Dolev-Yao intruder. +\ +inductive intruder_deduct::"('fun,'var) terms \ ('fun,'var) term \ bool" +where + Axiom[simp]: "t \ M \ intruder_deduct M t" +| Compose[simp]: "\length T = arity f; public f; \t. t \ set T \ intruder_deduct M t\ + \ intruder_deduct M (Fun f T)" +| Decompose: "\intruder_deduct M t; Ana t = (K, T); \k. k \ set K \ intruder_deduct M k; + t\<^sub>i \ set T\ + \ intruder_deduct M t\<^sub>i" + +text \ + A variant of the intruder relation which limits the intruder to composition only. +\ +inductive intruder_synth::"('fun,'var) terms \ ('fun,'var) term \ bool" +where + AxiomC[simp]: "t \ M \ intruder_synth M t" +| ComposeC[simp]: "\length T = arity f; public f; \t. t \ set T \ intruder_synth M t\ + \ intruder_synth M (Fun f T)" + +adhoc_overloading INTRUDER_DEDUCT intruder_deduct +adhoc_overloading INTRUDER_SYNTH intruder_synth + +lemma intruder_deduct_induct[consumes 1, case_names Axiom Compose Decompose]: + assumes "M \ t" "\t. t \ M \ P M t" + "\T f. \length T = arity f; public f; + \t. t \ set T \ M \ t; + \t. t \ set T \ P M t\ \ P M (Fun f T)" + "\t K T t\<^sub>i. \M \ t; P M t; Ana t = (K, T); \k. k \ set K \ M \ k; + \k. k \ set K \ P M k; t\<^sub>i \ set T\ \ P M t\<^sub>i" + shows "P M t" +using assms by (induct rule: intruder_deduct.induct) blast+ + +lemma intruder_synth_induct[consumes 1, case_names AxiomC ComposeC]: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "M \\<^sub>c t" "\t. t \ M \ P M t" + "\T f. \length T = arity f; public f; + \t. t \ set T \ M \\<^sub>c t; + \t. t \ set T \ P M t\ \ P M (Fun f T)" + shows "P M t" +using assms by (induct rule: intruder_synth.induct) auto + + +subsection \Definitions: Analyzed Knowledge and Public Ground Well-formed Terms (PGWTs)\ +definition analyzed::"('fun,'var) terms \ bool" where + "analyzed M \ \t. M \ t \ M \\<^sub>c t" + +definition analyzed_in where + "analyzed_in t M \ \K R. (Ana t = (K,R) \ (\k \ set K. M \\<^sub>c k)) \ (\r \ set R. M \\<^sub>c r)" + +definition decomp_closure::"('fun,'var) terms \ ('fun,'var) terms \ bool" where + "decomp_closure M M' \ \t. M \ t \ (\t' \ M. t \ t') \ t \ M'" + +inductive public_ground_wf_term::"('fun,'var) term \ bool" where + PGWT[simp]: "\public f; arity f = length T; + \t. t \ set T \ public_ground_wf_term t\ + \ public_ground_wf_term (Fun f T)" + +abbreviation "public_ground_wf_terms \ {t. public_ground_wf_term t}" + +lemma public_const_deduct: + assumes "c \ \\<^sub>p\<^sub>u\<^sub>b" + shows "M \ Fun c []" "M \\<^sub>c Fun c []" +proof - + have "arity c = 0" "public c" using const_arity_eq_zero \c \ \\<^sub>p\<^sub>u\<^sub>b\ by auto + thus "M \ Fun c []" "M \\<^sub>c Fun c []" + using intruder_synth.ComposeC[OF _ \public c\, of "[]"] + intruder_deduct.Compose[OF _ \public c\, of "[]"] + by auto +qed + +lemma public_const_deduct'[simp]: + assumes "arity c = 0" "public c" + shows "M \ Fun c []" "M \\<^sub>c Fun c []" +using intruder_deduct.Compose[of "[]" c] intruder_synth.ComposeC[of "[]" c] assms by simp_all + +lemma private_fun_deduct_in_ik: + assumes t: "M \ t" "Fun f T \ subterms t" + and f: "\public f" + shows "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t M" +using t +proof (induction t rule: intruder_deduct.induct) + case Decompose thus ?case by (meson Ana_subterm psubsetD term.order_trans) +qed (auto simp add: f in_subterms_Union) + +lemma private_fun_deduct_in_ik': + assumes t: "M \ Fun f T" + and f: "\public f" + and M: "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t M \ Fun f T \ M" + shows "Fun f T \ M" +by (rule M[OF private_fun_deduct_in_ik[OF t term.order_refl f]]) + +lemma pgwt_public: "\public_ground_wf_term t; Fun f T \ t\ \ public f" +by (induct t rule: public_ground_wf_term.induct) auto + +lemma pgwt_ground: "public_ground_wf_term t \ fv t = {}" +by (induct t rule: public_ground_wf_term.induct) auto + +lemma pgwt_fun: "public_ground_wf_term t \ \f T. t = Fun f T" +using pgwt_ground[of t] by (cases t) auto + +lemma pgwt_arity: "\public_ground_wf_term t; Fun f T \ t\ \ arity f = length T" +by (induct t rule: public_ground_wf_term.induct) auto + +lemma pgwt_wellformed: "public_ground_wf_term t \ wf\<^sub>t\<^sub>r\<^sub>m t" +by (induct t rule: public_ground_wf_term.induct) auto + +lemma pgwt_deducible: "public_ground_wf_term t \ M \\<^sub>c t" +by (induct t rule: public_ground_wf_term.induct) auto + +lemma pgwt_is_empty_synth: "public_ground_wf_term t \ {} \\<^sub>c t" +proof - + { fix M::"('fun,'var) term set" assume "M \\<^sub>c t" "M = {}" hence "public_ground_wf_term t" + by (induct t rule: intruder_synth.induct) auto + } + thus ?thesis using pgwt_deducible by auto +qed + +lemma ideduct_synth_subst_apply: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "{} \\<^sub>c t" "\v. M \\<^sub>c \ v" + shows "M \\<^sub>c t \ \" +proof - + { fix M'::"('fun,'var) term set" assume "M' \\<^sub>c t" "M' = {}" hence "M \\<^sub>c t \ \" + proof (induction t rule: intruder_synth.induct) + case (ComposeC T f M') + hence "length (map (\t. t \ \) T) = arity f" "\x. x \ set (map (\t. t \ \) T) \ M \\<^sub>c x" + by auto + thus ?case using intruder_synth.ComposeC[of "map (\t. t \ \) T" f M] \public f\ by fastforce + qed simp + } + thus ?thesis using assms by metis +qed + + +subsection \Lemmata: Monotonicity, deduction private constants, etc.\ +context +begin +lemma ideduct_mono: + "\M \ t; M \ M'\ \ M' \ t" +proof (induction rule: intruder_deduct.induct) + case (Decompose M t K T t\<^sub>i) + have "\k. k \ set K \ M' \ k" using Decompose.IH \M \ M'\ by simp + moreover have "M' \ t" using Decompose.IH \M \ M'\ by simp + ultimately show ?case using Decompose.hyps intruder_deduct.Decompose by blast +qed auto + +lemma ideduct_synth_mono: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + shows "\M \\<^sub>c t; M \ M'\ \ M' \\<^sub>c t" +by (induct rule: intruder_synth.induct) auto + +lemma ideduct_reduce: + "\M \ M' \ t; \t'. t' \ M' \ M \ t'\ \ M \ t" +proof (induction rule: intruder_deduct_induct) + case Decompose thus ?case using intruder_deduct.Decompose by blast +qed auto + +lemma ideduct_synth_reduce: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + shows "\M \ M' \\<^sub>c t; \t'. t' \ M' \ M \\<^sub>c t'\ \ M \\<^sub>c t" +by (induct rule: intruder_synth_induct) auto + +lemma ideduct_mono_eq: + assumes "\t. M \ t \ M' \ t" shows "M \ N \ t \ M' \ N \ t" +proof + show "M \ N \ t \ M' \ N \ t" + proof (induction t rule: intruder_deduct_induct) + case (Axiom t) thus ?case + proof (cases "t \ M") + case True + hence "M \ t" using intruder_deduct.Axiom by metis + thus ?thesis using assms ideduct_mono[of M' t "M' \ N"] by simp + qed auto + next + case (Compose T f) thus ?case using intruder_deduct.Compose by auto + next + case (Decompose t K T t\<^sub>i) thus ?case using intruder_deduct.Decompose[of "M' \ N" t K T] by auto + qed + + show "M' \ N \ t \ M \ N \ t" + proof (induction t rule: intruder_deduct_induct) + case (Axiom t) thus ?case + proof (cases "t \ M'") + case True + hence "M' \ t" using intruder_deduct.Axiom by metis + thus ?thesis using assms ideduct_mono[of M t "M \ N"] by simp + qed auto + next + case (Compose T f) thus ?case using intruder_deduct.Compose by auto + next + case (Decompose t K T t\<^sub>i) thus ?case using intruder_deduct.Decompose[of "M \ N" t K T] by auto + qed +qed + +lemma deduct_synth_subterm: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "M \\<^sub>c t" "s \ subterms t" "\m \ M. \s \ subterms m. M \\<^sub>c s" + shows "M \\<^sub>c s" +using assms by (induct t rule: intruder_synth.induct) auto + +lemma deduct_if_synth[intro, dest]: "M \\<^sub>c t \ M \ t" +by (induct rule: intruder_synth.induct) auto + +private lemma ideduct_ik_eq: assumes "\t \ M. M' \ t" shows "M' \ t \ M' \ M \ t" +by (meson assms ideduct_mono ideduct_reduce sup_ge1) + +private lemma synth_if_deduct_empty: "{} \ t \ {} \\<^sub>c t" +proof (induction t rule: intruder_deduct_induct) + case (Decompose t K M m) + then obtain f T where "t = Fun f T" "m \ set T" + using Ana_fun_subterm Ana_var by (cases t) fastforce+ + with Decompose.IH(1) show ?case by (induction rule: intruder_synth_induct) auto +qed auto + +private lemma ideduct_deduct_synth_mono_eq: + assumes "\t. M \ t \ M' \\<^sub>c t" "M \ M'" + and "\t. M' \ N \ t \ M' \ N \ D \\<^sub>c t" + shows "M \ N \ t \ M' \ N \ D \\<^sub>c t" +proof - + have "\m \ M'. M \ m" using assms(1) by auto + hence "\t. M \ t \ M' \ t" by (metis assms(1,2) deduct_if_synth ideduct_reduce sup.absorb2) + hence "\t. M' \ N \ t \ M \ N \ t" by (meson ideduct_mono_eq) + thus ?thesis by (meson assms(3)) +qed + +lemma ideduct_subst: "M \ t \ M \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" +proof (induction t rule: intruder_deduct_induct) + case (Compose T f) + hence "length (map (\t. t \ \) T) = arity f" "\t. t \ set T \ M \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" by auto + thus ?case using intruder_deduct.Compose[OF _ Compose.hyps(2), of "map (\t. t \ \) T"] by auto +next + case (Decompose t K M' m') + hence "Ana (t \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M' \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + "\k. k \ set (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \) \ M \\<^sub>s\<^sub>e\<^sub>t \ \ k" + "m' \ \ \ set (M' \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + using Ana_subst[OF Decompose.hyps(2)] by fastforce+ + thus ?case using intruder_deduct.Decompose[OF Decompose.IH(1)] by metis +qed simp + +lemma ideduct_synth_subst: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" and \::"('fun,'var) subst" + shows "M \\<^sub>c t \ M \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" +proof (induction t rule: intruder_synth_induct) + case (ComposeC T f) + hence "length (map (\t. t \ \) T) = arity f" "\t. t \ set T \ M \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" by auto + thus ?case using intruder_synth.ComposeC[OF _ ComposeC.hyps(2), of "map (\t. t \ \) T"] by auto +qed simp + +lemma ideduct_vars: + assumes "M \ t" + shows "fv t \ fv\<^sub>s\<^sub>e\<^sub>t M" +using assms +proof (induction t rule: intruder_deduct_induct) + case (Decompose t K T t\<^sub>i) thus ?case + using Ana_vars(2) fv_subset by blast +qed auto + +lemma ideduct_synth_vars: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "M \\<^sub>c t" + shows "fv t \ fv\<^sub>s\<^sub>e\<^sub>t M" +using assms by (induct t rule: intruder_synth_induct) auto + +lemma ideduct_synth_priv_fun_in_ik: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "M \\<^sub>c t" "f \ funs_term t" "\public f" + shows "f \ \(funs_term ` M)" +using assms by (induct t rule: intruder_synth_induct) auto + +lemma ideduct_synth_priv_const_in_ik: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "M \\<^sub>c Fun c []" "\public c" + shows "Fun c [] \ M" +using intruder_synth.cases[OF assms(1)] assms(2) by fast + +lemma ideduct_synth_ik_replace: + fixes M::"('fun,'var) terms" and t::"('fun,'var) term" + assumes "\t \ M. N \\<^sub>c t" + and "M \\<^sub>c t" + shows "N \\<^sub>c t" +using assms(2,1) by (induct t rule: intruder_synth.induct) auto +end + +subsection \Lemmata: Analyzed Intruder Knowledge Closure\ +lemma deducts_eq_if_analyzed: "analyzed M \ M \ t \ M \\<^sub>c t" +unfolding analyzed_def by auto + +lemma closure_is_superset: "decomp_closure M M' \ M \ M'" +unfolding decomp_closure_def by force + +lemma deduct_if_closure_deduct: "\M' \ t; decomp_closure M M'\ \ M \ t" +proof (induction t rule: intruder_deduct.induct) + case (Decompose M' t K T t\<^sub>i) + thus ?case using intruder_deduct.Decompose[OF _ \Ana t = (K,T)\ _ \t\<^sub>i \ set T\] by simp +qed (auto simp add: decomp_closure_def) + +lemma deduct_if_closure_synth: "\decomp_closure M M'; M' \\<^sub>c t\ \ M \ t" +using deduct_if_closure_deduct by blast + +lemma decomp_closure_subterms_composable: + assumes "decomp_closure M M'" + and "M' \\<^sub>c t'" "M' \ t" "t \ t'" + shows "M' \\<^sub>c t" +using \M' \\<^sub>c t'\ assms +proof (induction t' rule: intruder_synth.induct) + case (AxiomC t' M') + have "M \ t" using \M' \ t\ deduct_if_closure_deduct AxiomC.prems(1) by blast + moreover + { have "\s \ M. t' \ s" using \t' \ M'\ AxiomC.prems(1) unfolding decomp_closure_def by blast + hence "\s \ M. t \ s" using \t \ t'\ term.order_trans by auto + } + ultimately have "t \ M'" using AxiomC.prems(1) unfolding decomp_closure_def by blast + thus ?case by simp +next + case (ComposeC T f M') + let ?t' = "Fun f T" + { assume "t = ?t'" have "M' \\<^sub>c t" using \M' \\<^sub>c ?t'\ \t = ?t'\ by simp } + moreover + { assume "t \ ?t'" + have "\x \ set T. t \ x" using \t \ ?t'\ \t \ ?t'\ by simp + hence "M' \\<^sub>c t" using ComposeC.IH ComposeC.prems(1,3) ComposeC.hyps(3) by blast + } + ultimately show ?case using cases_simp[of "t = ?t'" "M' \\<^sub>c t"] by simp +qed + +lemma decomp_closure_analyzed: + assumes "decomp_closure M M'" + shows "analyzed M'" +proof - + { fix t assume "M' \ t" have "M' \\<^sub>c t" using \M' \ t\ assms + proof (induction t rule: intruder_deduct.induct) + case (Decompose M' t K T t\<^sub>i) + hence "M' \ t\<^sub>i" using Decompose.hyps intruder_deduct.Decompose by blast + moreover have "t\<^sub>i \ t" + using Decompose.hyps(4) Ana_subterm[OF Decompose.hyps(2)] by blast + moreover have "M' \\<^sub>c t" using Decompose.IH(1) Decompose.prems by blast + ultimately show "M' \\<^sub>c t\<^sub>i" using decomp_closure_subterms_composable Decompose.prems by blast + qed auto + } + moreover have "\t. M \\<^sub>c t \ M \ t" by auto + ultimately show ?thesis by (auto simp add: decomp_closure_def analyzed_def) +qed + +lemma analyzed_if_all_analyzed_in: + assumes M: "\t \ M. analyzed_in t M" + shows "analyzed M" +proof (unfold analyzed_def, intro allI iffI) + fix t + assume t: "M \ t" + thus "M \\<^sub>c t" + proof (induction t rule: intruder_deduct_induct) + case (Decompose t K T t\<^sub>i) + { assume "t \ M" + hence ?case + using M Decompose.IH(2) Decompose.hyps(2,4) + unfolding analyzed_in_def by fastforce + } moreover { + fix f S assume "t = Fun f S" "\s. s \ set S \ M \\<^sub>c s" + hence ?case using Ana_fun_subterm[of f S] Decompose.hyps(2,4) by blast + } ultimately show ?case using intruder_synth.cases[OF Decompose.IH(1), of ?case] by blast + qed simp_all +qed auto + +lemma analyzed_is_all_analyzed_in: + "(\t \ M. analyzed_in t M) \ analyzed M" +proof + show "analyzed M \ \t \ M. analyzed_in t M" + unfolding analyzed_in_def analyzed_def + by (auto intro: intruder_deduct.Decompose[OF intruder_deduct.Axiom]) +qed (rule analyzed_if_all_analyzed_in) + +lemma ik_has_synth_ik_closure: + fixes M :: "('fun,'var) terms" + shows "\M'. (\t. M \ t \ M' \\<^sub>c t) \ decomp_closure M M' \ (finite M \ finite M')" +proof - + let ?M' = "{t. M \ t \ (\t' \ M. t \ t')}" + + have M'_closes: "decomp_closure M ?M'" unfolding decomp_closure_def by simp + hence "M \ ?M'" using closure_is_superset by simp + + have "\t. ?M' \\<^sub>c t \ M \ t" using deduct_if_closure_synth[OF M'_closes] by blast + moreover have "\t. M \ t \ ?M' \ t" using ideduct_mono[OF _ \M \ ?M'\] by simp + moreover have "analyzed ?M'" using decomp_closure_analyzed[OF M'_closes] . + ultimately have "\t. M \ t \ ?M' \\<^sub>c t" unfolding analyzed_def by blast + moreover have "finite M \ finite ?M'" by auto + ultimately show ?thesis using M'_closes by blast +qed + + +subsection \Intruder Variants: Numbered and Composition-Restricted Intruder Deduction Relations\ +text \ + A variant of the intruder relation which restricts composition to only those terms that satisfy + a given predicate Q. +\ +inductive intruder_deduct_restricted:: + "('fun,'var) terms \ (('fun,'var) term \ bool) \ ('fun,'var) term \ bool" + ("\_;_\ \\<^sub>r _" 50) +where + AxiomR[simp]: "t \ M \ \M; Q\ \\<^sub>r t" +| ComposeR[simp]: "\length T = arity f; public f; \t. t \ set T \ \M; Q\ \\<^sub>r t; Q (Fun f T)\ + \ \M; Q\ \\<^sub>r Fun f T" +| DecomposeR: "\\M; Q\ \\<^sub>r t; Ana t = (K, T); \k. k \ set K \ \M; Q\ \\<^sub>r k; t\<^sub>i \ set T\ + \ \M; Q\ \\<^sub>r t\<^sub>i" + +text \ + A variant of the intruder relation equipped with a number representing the heigth of the + derivation tree (i.e., \\M; k\ \\<^sub>n t\ iff k is the maximum number of applications of the compose + an decompose rules in any path of the derivation tree for \M \ t\). +\ +inductive intruder_deduct_num:: + "('fun,'var) terms \ nat \ ('fun,'var) term \ bool" + ("\_; _\ \\<^sub>n _" 50) +where + AxiomN[simp]: "t \ M \ \M; 0\ \\<^sub>n t" +| ComposeN[simp]: "\length T = arity f; public f; \t. t \ set T \ \M; steps t\ \\<^sub>n t\ + \ \M; Suc (Max (insert 0 (steps ` set T)))\ \\<^sub>n Fun f T" +| DecomposeN: "\\M; n\ \\<^sub>n t; Ana t = (K, T); \k. k \ set K \ \M; steps k\ \\<^sub>n k; t\<^sub>i \ set T\ + \ \M; Suc (Max (insert n (steps ` set K)))\ \\<^sub>n t\<^sub>i" + +lemma intruder_deduct_restricted_induct[consumes 1, case_names AxiomR ComposeR DecomposeR]: + assumes "\M; Q\ \\<^sub>r t" "\t. t \ M \ P M Q t" + "\T f. \length T = arity f; public f; + \t. t \ set T \ \M; Q\ \\<^sub>r t; + \t. t \ set T \ P M Q t; Q (Fun f T) + \ \ P M Q (Fun f T)" + "\t K T t\<^sub>i. \\M; Q\ \\<^sub>r t; P M Q t; Ana t = (K, T); \k. k \ set K \ \M; Q\ \\<^sub>r k; + \k. k \ set K \ P M Q k; t\<^sub>i \ set T\ \ P M Q t\<^sub>i" + shows "P M Q t" +using assms by (induct t rule: intruder_deduct_restricted.induct) blast+ + +lemma intruder_deduct_num_induct[consumes 1, case_names AxiomN ComposeN DecomposeN]: + assumes "\M; n\ \\<^sub>n t" "\t. t \ M \ P M 0 t" + "\T f steps. + \length T = arity f; public f; + \t. t \ set T \ \M; steps t\ \\<^sub>n t; + \t. t \ set T \ P M (steps t) t\ + \ P M (Suc (Max (insert 0 (steps ` set T)))) (Fun f T)" + "\t K T t\<^sub>i steps n. + \\M; n\ \\<^sub>n t; P M n t; Ana t = (K, T); + \k. k \ set K \ \M; steps k\ \\<^sub>n k; + t\<^sub>i \ set T; \k. k \ set K \ P M (steps k) k\ + \ P M (Suc (Max (insert n (steps ` set K)))) t\<^sub>i" + shows "P M n t" +using assms by (induct rule: intruder_deduct_num.induct) blast+ + +lemma ideduct_restricted_mono: + "\\M; P\ \\<^sub>r t; M \ M'\ \ \M'; P\ \\<^sub>r t" +proof (induction rule: intruder_deduct_restricted_induct) + case (DecomposeR t K T t\<^sub>i) + have "\k. k \ set K \ \M'; P\ \\<^sub>r k" using DecomposeR.IH \M \ M'\ by simp + moreover have "\M'; P\ \\<^sub>r t" using DecomposeR.IH \M \ M'\ by simp + ultimately show ?case + using DecomposeR + intruder_deduct_restricted.DecomposeR[OF _ DecomposeR.hyps(2) _ DecomposeR.hyps(4)] + by blast +qed auto + + +subsection \Lemmata: Intruder Deduction Equivalences\ +lemma deduct_if_restricted_deduct: "\M;P\ \\<^sub>r m \ M \ m" +proof (induction m rule: intruder_deduct_restricted_induct) + case (DecomposeR t K T t\<^sub>i) thus ?case using intruder_deduct.Decompose by blast +qed simp_all + +lemma restricted_deduct_if_restricted_ik: + assumes "\M;P\ \\<^sub>r m" "\m \ M. P m" + and P: "\t t'. P t \ t' \ t \ P t'" + shows "P m" +using assms(1) +proof (induction m rule: intruder_deduct_restricted_induct) + case (DecomposeR t K T t\<^sub>i) + obtain f S where "t = Fun f S" using Ana_var \t\<^sub>i \ set T\ \Ana t = (K, T)\ by (cases t) auto + thus ?case using DecomposeR assms(2) P Ana_subterm by blast +qed (simp_all add: assms(2)) + +lemma deduct_restricted_if_synth: + assumes P: "P m" "\t t'. P t \ t' \ t \ P t'" + and m: "M \\<^sub>c m" + shows "\M; P\ \\<^sub>r m" +using m P(1) +proof (induction m rule: intruder_synth_induct) + case (ComposeC T f) + hence "\M; P\ \\<^sub>r t" when t: "t \ set T" for t + using t P(2) subtermeqI''[of _ T f] + by fastforce + thus ?case + using intruder_deduct_restricted.ComposeR[OF ComposeC.hyps(1,2)] ComposeC.prems(1) + by metis +qed simp + +lemma deduct_zero_in_ik: + assumes "\M; 0\ \\<^sub>n t" shows "t \ M" +proof - + { fix k assume "\M; k\ \\<^sub>n t" hence "k > 0 \ t \ M" by (induct t) auto + } thus ?thesis using assms by auto +qed + +lemma deduct_if_deduct_num: "\M; k\ \\<^sub>n t \ M \ t" +by (induct t rule: intruder_deduct_num.induct) + (metis intruder_deduct.Axiom, + metis intruder_deduct.Compose, + metis intruder_deduct.Decompose) + +lemma deduct_num_if_deduct: "M \ t \ \k. \M; k\ \\<^sub>n t" +proof (induction t rule: intruder_deduct_induct) + case (Compose T f) + then obtain steps where *: "\t \ set T. \M; steps t\ \\<^sub>n t" by moura + then obtain n where "\t \ set T. steps t \ n" + using finite_nat_set_iff_bounded_le[of "steps ` set T"] + by auto + thus ?case using ComposeN[OF Compose.hyps(1,2), of M steps] * by force +next + case (Decompose t K T t\<^sub>i) + hence "\u. u \ insert t (set K) \ \k. \M; k\ \\<^sub>n u" by auto + then obtain steps where *: "\M; steps t\ \\<^sub>n t" "\t \ set K. \M; steps t\ \\<^sub>n t" by moura + then obtain n where "steps t \ n" "\t \ set K. steps t \ n" + using finite_nat_set_iff_bounded_le[of "steps ` insert t (set K)"] + by auto + thus ?case using DecomposeN[OF _ Decompose.hyps(2) _ Decompose.hyps(4), of M _ steps] * by force +qed (metis AxiomN) + +lemma deduct_normalize: + assumes M: "\m \ M. \f T. Fun f T \ m \ P f T" + and t: "\M; k\ \\<^sub>n t" "Fun f T \ t" "\P f T" + shows "\l \ k. (\M; l\ \\<^sub>n Fun f T) \ (\t \ set T. \j < l. \M; j\ \\<^sub>n t)" +using t +proof (induction t rule: intruder_deduct_num_induct) + case (AxiomN t) thus ?case using M by auto +next + case (ComposeN T' f' steps) thus ?case + proof (cases "Fun f' T' = Fun f T") + case True + hence "\M; Suc (Max (insert 0 (steps ` set T')))\ \\<^sub>n Fun f T" "T = T'" + using intruder_deduct_num.ComposeN[OF ComposeN.hyps] by auto + moreover have "\t. t \ set T \ \M; steps t\ \\<^sub>n t" + using True ComposeN.hyps(3) by auto + moreover have "\t. t \ set T \ steps t < Suc (Max (insert 0 (steps ` set T)))" + using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"] + by auto + ultimately show ?thesis by auto + next + case False + then obtain t' where t': "t' \ set T'" "Fun f T \ t'" using ComposeN by auto + hence "\l \ steps t'. (\M; l\ \\<^sub>n Fun f T) \ (\t \ set T. \j < l. \M; j\ \\<^sub>n t)" + using ComposeN.IH[OF _ _ ComposeN.prems(2)] by auto + moreover have "steps t' < Suc (Max (insert 0 (steps ` set T')))" + using Max_less_iff[of "insert 0 (steps ` set T')" "Suc (Max (insert 0 (steps ` set T')))"] + using t'(1) by auto + ultimately show ?thesis using ComposeN.hyps(3)[OF t'(1)] + by (meson Suc_le_eq le_Suc_eq le_trans) + qed +next + case (DecomposeN t K T' t\<^sub>i steps n) + hence *: "Fun f T \ t" + using term.order_trans[of "Fun f T" t\<^sub>i t] Ana_subterm[of t K T'] + by blast + have "\l \ n. (\M; l\ \\<^sub>n Fun f T) \ (\t' \ set T. \j < l. \M; j\ \\<^sub>n t')" + using DecomposeN.IH(1)[OF * DecomposeN.prems(2)] by auto + moreover have "n < Suc (Max (insert n (steps ` set K)))" + using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"] + by auto + ultimately show ?case using DecomposeN.hyps(4) by (meson Suc_le_eq le_Suc_eq le_trans) +qed + +lemma deduct_inv: + assumes "\M; n\ \\<^sub>n t" + shows "t \ M \ + (\f T. t = Fun f T \ public f \ length T = arity f \ (\t \ set T. \l < n. \M; l\ \\<^sub>n t)) \ + (\m \ subterms\<^sub>s\<^sub>e\<^sub>t M. + (\l < n. \M; l\ \\<^sub>n m) \ (\k \ set (fst (Ana m)). \l < n. \M; l\ \\<^sub>n k) \ + t \ set (snd (Ana m)))" + (is "?P t n \ ?Q t n \ ?R t n") +using assms +proof (induction n arbitrary: t rule: nat_less_induct) + case (1 n t) thus ?case + proof (cases n) + case 0 + hence "t \ M" using deduct_zero_in_ik "1.prems"(1) by metis + thus ?thesis by auto + next + case (Suc n') + hence "\M; Suc n'\ \\<^sub>n t" + "\m < Suc n'. \x. (\M; m\ \\<^sub>n x) \ ?P x m \ ?Q x m \ ?R x m" + using "1.prems" "1.IH" by blast+ + hence "?P t (Suc n') \ ?Q t (Suc n') \ ?R t (Suc n')" + proof (induction t rule: intruder_deduct_num_induct) + case (AxiomN t) thus ?case by simp + next + case (ComposeN T f steps) + have "\t. t \ set T \ steps t < Suc (Max (insert 0 (steps ` set T)))" + using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"] + by auto + thus ?case using ComposeN.hyps by metis + next + case (DecomposeN t K T t\<^sub>i steps n) + have 0: "n < Suc (Max (insert n (steps ` set K)))" + "\k. k \ set K \ steps k < Suc (Max (insert n (steps ` set K)))" + using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"] + by auto + + have IH1: "?P t j \ ?Q t j \ ?R t j" when jt: "j < n" "\M; j\ \\<^sub>n t" for j t + using jt DecomposeN.prems(1) 0(1) + by simp + + have IH2: "?P t n \ ?Q t n \ ?R t n" + using DecomposeN.IH(1) IH1 + by simp + + have 1: "\k \ set (fst (Ana t)). \l < Suc (Max (insert n (steps ` set K))). \M; l\ \\<^sub>n k" + using DecomposeN.hyps(1,2,3) 0(2) + by auto + + have 2: "t\<^sub>i \ set (snd (Ana t))" + using DecomposeN.hyps(2,4) + by fastforce + + have 3: "t \ subterms\<^sub>s\<^sub>e\<^sub>t M" when "t \ set (snd (Ana m))" "m \\<^sub>s\<^sub>e\<^sub>t M" for m + using that(1) Ana_subterm[of m _ "snd (Ana m)"] in_subterms_subset_Union[OF that(2)] + by (metis (no_types, lifting) prod.collapse psubsetD subsetCE subsetD) + + have 4: "?R t\<^sub>i (Suc (Max (insert n (steps ` set K))))" when "?R t n" + using that 0(1) 1 2 3 DecomposeN.hyps(1) + by (metis (no_types, lifting)) + + have 5: "?R t\<^sub>i (Suc (Max (insert n (steps ` set K))))" when "?P t n" + using that 0(1) 1 2 DecomposeN.hyps(1) + by blast + + have 6: ?case when *: "?Q t n" + proof - + obtain g S where g: + "t = Fun g S" "public g" "length S = arity g" "\t \ set S. \l < n. \M; l\ \\<^sub>n t" + using * by moura + then obtain l where l: "l < n" "\M; l\ \\<^sub>n t\<^sub>i" + using 0(1) DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T] by blast + + have **: "l < Suc (Max (insert n (steps ` set K)))" using l(1) 0(1) by simp + + show ?thesis using IH1[OF l] less_trans[OF _ **] by fastforce + qed + + show ?case using IH2 4 5 6 by argo + qed + thus ?thesis using Suc by fast + qed +qed + +lemma restricted_deduct_if_deduct: + assumes M: "\m \ M. \f T. Fun f T \ m \ P (Fun f T)" + and P_subterm: "\f T t. M \ Fun f T \ P (Fun f T) \ t \ set T \ P t" + and P_Ana_key: "\t K T k. M \ t \ P t \ Ana t = (K, T) \ M \ k \ k \ set K \ P k" + and m: "M \ m" "P m" + shows "\M; P\ \\<^sub>r m" +proof - + { fix k assume "\M; k\ \\<^sub>n m" + hence ?thesis using m(2) + proof (induction k arbitrary: m rule: nat_less_induct) + case (1 n m) thus ?case + proof (cases n) + case 0 + hence "m \ M" using deduct_zero_in_ik "1.prems"(1) by metis + thus ?thesis by auto + next + case (Suc n') + hence "\M; Suc n'\ \\<^sub>n m" + "\m < Suc n'. \x. (\M; m\ \\<^sub>n x) \ P x \ \M;P\ \\<^sub>r x" + using "1.prems" "1.IH" by blast+ + thus ?thesis using "1.prems"(2) + proof (induction m rule: intruder_deduct_num_induct) + case (ComposeN T f steps) + have *: "steps t < Suc (Max (insert 0 (steps ` set T)))" when "t \ set T" for t + using Max_less_iff[of "insert 0 (steps ` set T)"] that + by blast + + have **: "P t" when "t \ set T" for t + using P_subterm ComposeN.prems(2) that + Fun_param_is_subterm[OF that] + intruder_deduct.Compose[OF ComposeN.hyps(1,2)] + deduct_if_deduct_num[OF ComposeN.hyps(3)] + by blast + + have "\M; P\ \\<^sub>r t" when "t \ set T" for t + using ComposeN.prems(1) ComposeN.hyps(3)[OF that] *[OF that] **[OF that] + by blast + thus ?case + by (metis intruder_deduct_restricted.ComposeR[OF ComposeN.hyps(1,2)] ComposeN.prems(2)) + next + case (DecomposeN t K T t\<^sub>i steps l) + show ?case + proof (cases "P t") + case True + hence "\k. k \ set K \ P k" + using P_Ana_key DecomposeN.hyps(1,2,3) deduct_if_deduct_num + by blast + moreover have + "\k m x. k \ set K \ m < steps k \ \M; m\ \\<^sub>n x \ P x \ \M;P\ \\<^sub>r x" + proof - + fix k m x assume *: "k \ set K" "m < steps k" "\M; m\ \\<^sub>n x" "P x" + have "steps k \ insert l (steps ` set K)" using *(1) by simp + hence "m < Suc (Max (insert l (steps ` set K)))" + using less_trans[OF *(2), of "Suc (Max (insert l (steps ` set K)))"] + Max_less_iff[of "insert l (steps ` set K)" + "Suc (Max (insert l (steps ` set K)))"] + by auto + thus "\M;P\ \\<^sub>r x" using DecomposeN.prems(1) *(3,4) by simp + qed + ultimately have "\k. k \ set K \ \M; P\ \\<^sub>r k" + using DecomposeN.IH(2) by auto + moreover have "\M; P\ \\<^sub>r t" + using True DecomposeN.prems(1) DecomposeN.hyps(1) le_imp_less_Suc + Max_less_iff[of "insert l (steps ` set K)" "Suc (Max (insert l (steps ` set K)))"] + by blast + ultimately show ?thesis + using intruder_deduct_restricted.DecomposeR[OF _ DecomposeN.hyps(2) + _ DecomposeN.hyps(4)] + by metis + next + case False + obtain g S where gS: "t = Fun g S" using DecomposeN.hyps(2,4) by (cases t) moura+ + hence *: "Fun g S \ t" "\P (Fun g S)" using False by force+ + have "\jM; j\ \\<^sub>n t\<^sub>i" + using gS DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T] + deduct_normalize[of M "\f T. P (Fun f T)", OF M DecomposeN.hyps(1) *] + by force + hence "\jM; j\ \\<^sub>n t\<^sub>i" + using Max_less_iff[of "insert l (steps ` set K)" + "Suc (Max (insert l (steps ` set K)))"] + less_trans[of _ l "Suc (Max (insert l (steps ` set K)))"] + by blast + thus ?thesis using DecomposeN.prems(1,2) by meson + qed + qed auto + qed + qed + } thus ?thesis using deduct_num_if_deduct m(1) by metis +qed + +lemma restricted_deduct_if_deduct': + assumes "\m \ M. P m" + and "\t t'. P t \ t' \ t \ P t'" + and "\t K T k. P t \ Ana t = (K, T) \ k \ set K \ P k" + and "M \ m" "P m" + shows "\M; P\ \\<^sub>r m" +using restricted_deduct_if_deduct[of M P m] assms +by blast + +lemma private_const_deduct: + assumes c: "\public c" "M \ (Fun c []::('fun,'var) term)" + shows "Fun c [] \ M \ + (\m \ subterms\<^sub>s\<^sub>e\<^sub>t M. M \ m \ (\k \ set (fst (Ana m)). M \ m) \ + Fun c [] \ set (snd (Ana m)))" +proof - + obtain n where "\M; n\ \\<^sub>n Fun c []" + using c(2) deduct_num_if_deduct by moura + hence "Fun c [] \ M \ + (\m \ subterms\<^sub>s\<^sub>e\<^sub>t M. + (\l < n. \M; l\ \\<^sub>n m) \ + (\k \ set (fst (Ana m)). \l < n. \M; l\ \\<^sub>n k) \ Fun c [] \ set (snd (Ana m)))" + using deduct_inv[of M n "Fun c []"] c(1) by fast + thus ?thesis using deduct_if_deduct_num[of M] by blast +qed + +lemma private_fun_deduct_in_ik'': + assumes t: "M \ Fun f T" "Fun c [] \ set T" "\m \ subterms\<^sub>s\<^sub>e\<^sub>t M. Fun f T \ set (snd (Ana m))" + and c: "\public c" "Fun c [] \ M" "\m \ subterms\<^sub>s\<^sub>e\<^sub>t M. Fun c [] \ set (snd (Ana m))" + shows "Fun f T \ M" +proof - + have *: "\n. \M; n\ \\<^sub>n Fun c []" + using private_const_deduct[OF c(1)] c(2,3) deduct_if_deduct_num + by blast + + obtain n where n: "\M; n\ \\<^sub>n Fun f T" + using t(1) deduct_num_if_deduct + by blast + + show ?thesis + using deduct_inv[OF n] t(2,3) * + by blast +qed + +end + +subsection \Executable Definitions for Code Generation\ +fun intruder_synth' where + "intruder_synth' pu ar M (Var x) = (Var x \ M)" +| "intruder_synth' pu ar M (Fun f T) = ( + Fun f T \ M \ (pu f \ length T = ar f \ list_all (intruder_synth' pu ar M) T))" + +definition "wf\<^sub>t\<^sub>r\<^sub>m' ar t \ (\s \ subterms t. is_Fun s \ ar (the_Fun s) = length (args s))" + +definition "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' ar M \ (\t \ M. wf\<^sub>t\<^sub>r\<^sub>m' ar t)" + +definition "analyzed_in' An pu ar t M \ (case An t of + (K,T) \ (\k \ set K. intruder_synth' pu ar M k) \ (\s \ set T. intruder_synth' pu ar M s))" + +lemma (in intruder_model) intruder_synth'_induct[consumes 1, case_names Var Fun]: + assumes "intruder_synth' public arity M t" + "\x. intruder_synth' public arity M (Var x) \ P (Var x)" + "\f T. (\z. z \ set T \ intruder_synth' public arity M z \ P z) \ + intruder_synth' public arity M (Fun f T) \ P (Fun f T) " + shows "P t" +using assms by (induct public arity M t rule: intruder_synth'.induct) auto + +lemma (in intruder_model) wf\<^sub>t\<^sub>r\<^sub>m_code[code_unfold]: + "wf\<^sub>t\<^sub>r\<^sub>m t = wf\<^sub>t\<^sub>r\<^sub>m' arity t" +unfolding wf\<^sub>t\<^sub>r\<^sub>m_def wf\<^sub>t\<^sub>r\<^sub>m'_def +by auto + +lemma (in intruder_model) wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[code_unfold]: + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M = wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity M" +using wf\<^sub>t\<^sub>r\<^sub>m_code +unfolding wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s'_def +by auto + +lemma (in intruder_model) intruder_synth_code[code_unfold]: + "intruder_synth M t = intruder_synth' public arity M t" + (is "?A \ ?B") +proof + show "?A \ ?B" + proof (induction t rule: intruder_synth_induct) + case (AxiomC t) thus ?case by (cases t) auto + qed (fastforce simp add: list_all_iff) + + show "?B \ ?A" + proof (induction t rule: intruder_synth'_induct) + case (Fun f T) thus ?case + proof (cases "Fun f T \ M") + case False + hence "public f" "length T = arity f" "list_all (intruder_synth' public arity M) T" + using Fun.hyps by fastforce+ + thus ?thesis + using Fun.IH intruder_synth.ComposeC[of T f M] Ball_set[of T] + by blast + qed simp + qed simp +qed + +lemma (in intruder_model) analyzed_in_code[code_unfold]: + "analyzed_in t M = analyzed_in' Ana public arity t M" +using intruder_synth_code[of M] +unfolding analyzed_in_def analyzed_in'_def +by fastforce + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Labeled_Stateful_Strands.thy b/Stateful_Protocol_Composition_and_Typing/Labeled_Stateful_Strands.thy new file mode 100644 index 0000000..a7fe4d4 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Labeled_Stateful_Strands.thy @@ -0,0 +1,906 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Labeled_Stateful_Strands.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Labeled Stateful Strands\ +theory Labeled_Stateful_Strands +imports Stateful_Strands Labeled_Strands +begin + +subsection \Definitions\ +text\Syntax for stateful strand labels\ +abbreviation Star_step ("\\, _\") where + "\\, (s::('a,'b) stateful_strand_step)\ \ (\, s)" + +abbreviation LabelN_step ("\_, _\") where + "\(l::'a), (s::('b,'c) stateful_strand_step)\ \ (ln l, s)" + + +text\Database projection\ +abbreviation dbproj where "dbproj l D \ filter (\d. fst d = l) D" + +text\The type of labeled stateful strands\ +type_synonym ('a,'b,'c) labeled_stateful_strand_step = "'c strand_label \ ('a,'b) stateful_strand_step" +type_synonym ('a,'b,'c) labeled_stateful_strand = "('a,'b,'c) labeled_stateful_strand_step list" + +text\Dual strands\ +fun dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p::"('a,'b,'c) labeled_stateful_strand_step \ ('a,'b,'c) labeled_stateful_strand_step" +where + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,send\t\) = (l,receive\t\)" +| "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,receive\t\) = (l,send\t\)" +| "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = x" + +definition dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t::"('a,'b,'c) labeled_stateful_strand \ ('a,'b,'c) labeled_stateful_strand" +where + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ map dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p" + +text\Substitution application\ +fun subst_apply_labeled_stateful_strand_step:: + "('a,'b,'c) labeled_stateful_strand_step \ ('a,'b) subst \ + ('a,'b,'c) labeled_stateful_strand_step" + (infix "\\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p" 51) where + "(l,s) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = (l,s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + +definition subst_apply_labeled_stateful_strand:: + "('a,'b,'c) labeled_stateful_strand \ ('a,'b) subst \ ('a,'b,'c) labeled_stateful_strand" + (infix "\\<^sub>l\<^sub>s\<^sub>s\<^sub>t" 51) where + "S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ map (\x. x \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) S" + +text\Definitions lifted from stateful strands\ +abbreviation wfrestrictedvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "wfrestrictedvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t (unlabel S)" + +abbreviation ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ ik\<^sub>s\<^sub>s\<^sub>t (unlabel S)" + +abbreviation db\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ db\<^sub>s\<^sub>s\<^sub>t (unlabel S)" +abbreviation db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ db'\<^sub>s\<^sub>s\<^sub>t (unlabel S)" + +abbreviation trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel S)" +abbreviation trms_proj\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "trms_proj\<^sub>l\<^sub>s\<^sub>s\<^sub>t n S \ trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n S)" + +abbreviation vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ vars\<^sub>s\<^sub>s\<^sub>t (unlabel S)" +abbreviation vars_proj\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "vars_proj\<^sub>l\<^sub>s\<^sub>s\<^sub>t n S \ vars\<^sub>s\<^sub>s\<^sub>t (proj_unl n S)" + +abbreviation bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel S)" +abbreviation fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t where "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel S)" + +text\Labeled set-operations\ +fun setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,insert\t,s\) = {(i,t,s)}" +| "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,delete\t,s\) = {(i,t,s)}" +| "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,\_: t \ s\) = {(i,t,s)}" +| "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,\_\\\: _ \\: F'\) = ((\(t,s). (i,t,s)) ` set F')" +| "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p _ = {}" + +definition setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t where + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ \(setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ` set S)" + + +subsection \Minor Lemmata\ +lemma subst_lsst_nil[simp]: "[] \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = []" +by (simp add: subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_cons: "a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)#(A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +by (simp add: subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_singleton: "[(l,s)] \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = [(l,s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)]" +by (simp add: subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_append: "A@B \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)@(B \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +by (simp add: subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_append_inv: + assumes "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B1@B2" + shows "\A1 A2. A = A1@A2 \ A1 \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B1 \ A2 \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B2" +using assms +proof (induction A arbitrary: B1 B2) + case (Cons a A) + note prems = Cons.prems + note IH = Cons.IH + show ?case + proof (cases B1) + case Nil + then obtain b B3 where "B2 = b#B3" "a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = b" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B3" + using prems subst_lsst_cons by fastforce + thus ?thesis by (simp add: Nil subst_apply_labeled_stateful_strand_def) + next + case (Cons b B3) + hence "a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = b" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B3@B2" + using prems by (simp_all add: subst_lsst_cons) + thus ?thesis by (metis Cons_eq_appendI Cons IH subst_lsst_cons) + qed +qed (metis append_is_Nil_conv subst_lsst_nil) + +lemma subst_lsst_member[intro]: "x \ set A \ x \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ set (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +by (metis image_eqI set_map subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_unlabel_cons: "unlabel ((l,b)#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)#(unlabel (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \))" +by (simp add: subst_apply_labeled_stateful_strand_def) + +lemma subst_lsst_unlabel: "unlabel (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = unlabel A \\<^sub>s\<^sub>s\<^sub>t \" +proof (induction A) + case (Cons a A) + then obtain l b where "a = (l,b)" by (metis surj_pair) + thus ?case + using Cons + by (simp add: subst_apply_labeled_stateful_strand_def subst_apply_stateful_strand_def) +qed simp + +lemma subst_lsst_unlabel_member[intro]: + assumes "x \ set (unlabel A)" + shows "x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ set (unlabel (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \))" +proof - + obtain l where x: "(l,x) \ set A" using assms unfolding unlabel_def by moura + thus ?thesis + using subst_lsst_member + by (metis unlabel_def in_set_zipE subst_apply_labeled_stateful_strand_step.simps zip_map_fst_snd) +qed + +lemma subst_lsst_prefix: + assumes "prefix B (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + shows "\C. C \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B \ prefix C A" +using assms +proof (induction A rule: List.rev_induct) + case (snoc a A) thus ?case + proof (cases "B = A@[a] \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \") + case False thus ?thesis + using snoc by (auto simp add: subst_lsst_append[of A] subst_lsst_cons) + qed auto +qed simp + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_nil[simp]: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] = []" +by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_Cons[simp]: + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,send\t\)#A) = (l,receive\t\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,receive\t\)#A) = (l,send\t\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,\a: t \ s\)#A) = (l,\a: t \ s\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,insert\t,s\)#A) = (l,insert\t,s\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,delete\t,s\)#A) = (l,delete\t,s\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,\a: t \ s\)#A) = (l,\a: t \ s\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,\X\\\: F \\: G\)#A) = (l,\X\\\: F \\: G\)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" +by (simp_all add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append[simp]: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" +by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" +proof - + obtain l x where s: "s = (l,x)" by moura + thus ?thesis by (cases x) (auto simp add: subst_apply_labeled_stateful_strand_def) +qed + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \" +proof (induction S) + case (Cons s S) thus ?case + using Cons dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[of s \] + by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def) +qed (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_unlabel: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) = unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \\<^sub>s\<^sub>s\<^sub>t \" +by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst subst_lsst_unlabel) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_cons: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)#(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \))" +by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst list.simps(9) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_append: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t B) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \" +by (metis (no_types) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_snoc: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)@[dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \]" +by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_cons list.map(1) map_append + subst_apply_labeled_stateful_strand_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_memberD: + assumes "(l,a) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + shows "\b. (l,b) \ set A \ dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,b) = (l,a)" + using assms +proof (induction A) + case (Cons c A) + hence "(l,a) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \ dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p c = (l,a)" unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by force + thus ?case + proof + assume "(l,a) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" thus ?case using Cons.IH by auto + next + assume a: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p c = (l,a)" + obtain i b where b: "c = (i,b)" by (metis surj_pair) + thus ?case using a by (cases b) auto + qed +qed simp + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_inv: + assumes "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l, a) = (k, b)" + shows "l = k" + and "a = receive\t\ \ b = send\t\" + and "a = send\t\ \ b = receive\t\" + and "(\t. a = receive\t\ \ a = send\t\) \ b = a" +proof - + show "l = k" using assms by (cases a) auto + show "a = receive\t\ \ b = send\t\" using assms by (cases a) auto + show "a = send\t\ \ b = receive\t\" using assms by (cases a) auto + show "(\t. a = receive\t\ \ a = send\t\) \ b = a" using assms by (cases a) auto +qed + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_self_inverse: "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = A" +proof (induction A) + case (Cons a A) + obtain l b where "a = (l,b)" by (metis surj_pair) + thus ?case using Cons by (cases b) auto +qed simp + +lemma vars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons.IH by (cases b) auto +qed simp + +lemma fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons.IH by (cases b) auto +qed simp + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons.IH by (cases b) simp+ +qed simp + +lemma vars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons: "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,b)#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +by (metis unlabel_Cons(1) vars\<^sub>s\<^sub>s\<^sub>t_Cons) + +lemma fv\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,b)#A) = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +by (metis unlabel_Cons(1) fv\<^sub>s\<^sub>s\<^sub>t_Cons) + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,b)#A) = set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b) \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +by (metis unlabel_Cons(1) bvars\<^sub>s\<^sub>s\<^sub>t_Cons) + +lemma bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +by (metis subst_lsst_unlabel bvars\<^sub>s\<^sub>s\<^sub>t_subst) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_member: + assumes "(l,x) \ set A" + and "\is_Receive x" "\is_Send x" + shows "(l,x) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" +using assms +proof (induction A) + case (Cons a A) thus ?case using assms(2,3) by (cases x) (auto simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) +qed simp + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_member: + assumes "x \ set (unlabel A)" + and "\is_Receive x" "\is_Send x" + shows "x \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" +using assms dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_member[of _ _ A] + by (meson unlabel_in unlabel_mem_has_label) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff: + "(l,send\t\) \ set A \ (l,receive\t\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,receive\t\) \ set A \ (l,send\t\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,\c: t \ s\) \ set A \ (l,\c: t \ s\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,insert\t,s\) \ set A \ (l,insert\t,s\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,delete\t,s\) \ set A \ (l,delete\t,s\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,\c: t \ s\) \ set A \ (l,\c: t \ s\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + "(l,\X\\\: F \\: G\) \ set A \ (l,\X\\\: F \\: G\) \ set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" +proof (induction A) + case (Cons a A) + obtain j b where a: "a = (j,b)" by (metis surj_pair) + { case 1 thus ?case by (cases b) (simp_all add: Cons.IH(1) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 2 thus ?case by (cases b) (simp_all add: Cons.IH(2) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 3 thus ?case by (cases b) (simp_all add: Cons.IH(3) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 4 thus ?case by (cases b) (simp_all add: Cons.IH(4) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 5 thus ?case by (cases b) (simp_all add: Cons.IH(5) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 6 thus ?case by (cases b) (simp_all add: Cons.IH(6) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } + { case 7 thus ?case by (cases b) (simp_all add: Cons.IH(7) a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) } +qed (simp_all add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff: + "send\t\ \ set (unlabel A) \ receive\t\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "receive\t\ \ set (unlabel A) \ send\t\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "\c: t \ s\ \ set (unlabel A) \ \c: t \ s\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "insert\t,s\ \ set (unlabel A) \ insert\t,s\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "delete\t,s\ \ set (unlabel A) \ delete\t,s\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "\c: t \ s\ \ set (unlabel A) \ \c: t \ s\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "\X\\\: F \\: G\ \ set (unlabel A) \ \X\\\: F \\: G\ \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" +using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1,2)[of _ t A] + dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(3,6)[of _ c t s A] + dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(4,5)[of _ t s A] + dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(7)[of _ X F G A] +by (meson unlabel_in unlabel_mem_has_label)+ + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all: + "list_all is_Receive (unlabel A) \ list_all is_Send (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Send (unlabel A) \ list_all is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Equality (unlabel A) \ list_all is_Equality (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Insert (unlabel A) \ list_all is_Insert (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Delete (unlabel A) \ list_all is_Delete (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_InSet (unlabel A) \ list_all is_InSet (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_NegChecks (unlabel A) \ list_all is_NegChecks (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Assignment (unlabel A) \ list_all is_Assignment (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Check (unlabel A) \ list_all is_Check (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + "list_all is_Update (unlabel A) \ list_all is_Update (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" +proof (induct A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + { case 1 thus ?case using Cons.hyps(1) a by (cases b) auto } + { case 2 thus ?case using Cons.hyps(2) a by (cases b) auto } + { case 3 thus ?case using Cons.hyps(3) a by (cases b) auto } + { case 4 thus ?case using Cons.hyps(4) a by (cases b) auto } + { case 5 thus ?case using Cons.hyps(5) a by (cases b) auto } + { case 6 thus ?case using Cons.hyps(6) a by (cases b) auto } + { case 7 thus ?case using Cons.hyps(7) a by (cases b) auto } + { case 8 thus ?case using Cons.hyps(8) a by (cases b) auto } + { case 9 thus ?case using Cons.hyps(9) a by (cases b) auto } + { case 10 thus ?case using Cons.hyps(10) a by (cases b) auto } +qed simp_all + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain: + assumes "s \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))" + shows "\l B s'. (l,s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,s') \ prefix (B@[(l,s')]) A" + using assms +proof (induction A rule: List.rev_induct) + case (snoc a A) + obtain i b where a: "a = (i,b)" by (metis surj_pair) + show ?case using snoc + proof (cases "s \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))") + case False thus ?thesis + using a snoc.prems unlabel_append[of "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t [a]"] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append[of A "[a]"] + by (cases b) (force simp add: unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def)+ + qed auto +qed simp + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain_subst: + assumes "s \ set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)))" + shows "\l B s'. (l,s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s') \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ prefix ((B \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)@[(l,s') \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \]) (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +proof - + obtain B l s' where B: "(l,s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,s')" "prefix (B@[(l,s')]) (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain[OF assms] by moura + + obtain C where C: "C \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B@[(l,s')]" + using subst_lsst_prefix[OF B(2)] by moura + + obtain D u where D: "C = D@[(l,u)]" "D \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = B" "[(l,u)] \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = [(l, s')]" + using subst_lsst_prefix[OF B(2)] subst_lsst_append_inv[OF C(1)] + by (auto simp add: subst_apply_labeled_stateful_strand_def) + + show ?thesis + using B D subst_lsst_cons subst_lsst_singleton + by (metis (no_types, lifting) nth_append_length) +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons.IH by (cases b) auto +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst_cons: + "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((l,b)#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +by (metis subst_lsst_unlabel trms\<^sub>s\<^sub>s\<^sub>t_subst_cons unlabel_Cons(1)) + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst: + assumes "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" + shows "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" +by (metis trms\<^sub>s\<^sub>s\<^sub>t_subst[OF assms] subst_lsst_unlabel) + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst': + fixes t::"('a,'b) term" and \::"('a,'b) subst" + assumes "t \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + shows "\s \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S. \X. set X \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ t = s \ rm_vars (set X) \" +using assms +proof (induction S) + case (Cons a S) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + hence "t \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \ t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + using Cons.prems trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst_cons by fast + thus ?case + proof + assume *: "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + show ?thesis using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst''[OF *] a by auto + next + assume *: "t \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + show ?thesis using Cons.IH[OF *] a by auto + qed +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst'': + fixes t::"('a,'b) term" and \ \::"('a,'b) subst" + assumes "t \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>e\<^sub>t \" + shows "\s \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S. \X. set X \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ t = s \ rm_vars (set X) \ \\<^sub>s \" +proof - + obtain s where s: "s \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" "t = s \ \" using assms by moura + show ?thesis using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst'[OF s(1)] s(2) by auto +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual_subst_cons: + "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) = (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)) \ (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)))" +proof - + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?thesis using a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_cons[of a A \] by (cases b) auto +qed + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_funs_term: + "\(funs_term ` (trms\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S)))) = \(funs_term ` (trms\<^sub>s\<^sub>s\<^sub>t (unlabel S)))" +using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq by fast + +lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_db\<^sub>l\<^sub>s\<^sub>s\<^sub>t: + "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons by (cases b) auto +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_unlabel_append: + "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) I D = db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t B I (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I D)" +by (metis db\<^sub>s\<^sub>s\<^sub>t_append unlabel_append) + +lemma db\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t: + "db'\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \))) \ D = db'\<^sub>s\<^sub>s\<^sub>t (unlabel (T \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) \ D" +proof (induction T arbitrary: D) + case (Cons x T) + obtain l s where "x = (l,s)" by moura + thus ?case + using Cons + by (cases s) (simp_all add: unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def) +qed (simp add: unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def) + +lemma labeled_list_insert_eq_cases: + "d \ set (unlabel D) \ List.insert d (unlabel D) = unlabel (List.insert (i,d) D)" + "(i,d) \ set D \ List.insert d (unlabel D) = unlabel (List.insert (i,d) D)" +unfolding unlabel_def +by (metis (no_types, hide_lams) List.insert_def image_eqI list.simps(9) set_map snd_conv, + metis in_set_insert set_zip_rightD zip_map_fst_snd) + +lemma labeled_list_insert_eq_ex_cases: + "List.insert d (unlabel D) = unlabel (List.insert (i,d) D) \ + (\j. (j,d) \ set D \ List.insert d (unlabel D) = unlabel (List.insert (j,d) D))" +using labeled_list_insert_eq_cases unfolding unlabel_def +by (metis in_set_impl_in_set_zip2 length_map zip_map_fst_snd) + +lemma proj_subst: "proj l (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = proj l A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \" +proof (induction A) + case (Cons a A) + obtain l b where "a = (l,b)" by (metis surj_pair) + thus ?case using Cons unfolding proj_def subst_apply_labeled_stateful_strand_def by force +qed simp + +lemma proj_set_subset[simp]: + "set (proj n A) \ set A" +unfolding proj_def by auto + +lemma proj_proj_set_subset[simp]: + "set (proj n (proj m A)) \ set (proj n A)" + "set (proj n (proj m A)) \ set (proj m A)" + "set (proj_unl n (proj m A)) \ set (proj_unl n A)" + "set (proj_unl n (proj m A)) \ set (proj_unl m A)" +unfolding unlabel_def proj_def by auto + +lemma proj_in_set_iff: + "(ln i, d) \ set (proj i D) \ (ln i, d) \ set D" + "(\, d) \ set (proj i D) \ (\, d) \ set D" +unfolding proj_def by auto + +lemma proj_list_insert: + "proj i (List.insert (ln i,d) D) = List.insert (ln i,d) (proj i D)" + "proj i (List.insert (\,d) D) = List.insert (\,d) (proj i D)" + "i \ j \ proj i (List.insert (ln j,d) D) = proj i D" +unfolding List.insert_def proj_def by auto + +lemma proj_filter: "proj i [d\D. d \ set Di] = [d\proj i D. d \ set Di]" +by (simp_all add: proj_def conj_commute) + +lemma proj_list_Cons: + "proj i ((ln i,d)#D) = (ln i,d)#proj i D" + "proj i ((\,d)#D) = (\,d)#proj i D" + "i \ j \ proj i ((ln j,d)#D) = proj i D" +unfolding List.insert_def proj_def by auto + +lemma proj_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t: + "proj l (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l A)" +proof (induction A) + case (Cons a A) + obtain k b where "a = (k,b)" by (metis surj_pair) + thus ?case using Cons unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def proj_def by (cases b) auto +qed simp + +lemma proj_instance_ex: + assumes B: "\b \ set B. \a \ set A. \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ P \" + and b: "b \ set (proj l B)" + shows "\a \ set (proj l A). \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ P \" +proof - + obtain a \ where a: "a \ set A" "b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "P \" using B b proj_set_subset by fast + obtain k b' where b': "b = (k, b')" "k = (ln l) \ k = \" using b proj_in_setD by metis + obtain a' where a': "a = (k, a')" using b'(1) a(2) by (cases a) simp_all + show ?thesis using a a' b'(2) unfolding proj_def by auto +qed + +lemma proj_dbproj: + "dbproj (ln i) (proj i D) = dbproj (ln i) D" + "dbproj \ (proj i D) = dbproj \ D" + "i \ j \ dbproj (ln j) (proj i D) = []" +unfolding proj_def by (induct D) auto + +lemma dbproj_Cons: + "dbproj i ((i,d)#D) = (i,d)#dbproj i D" + "i \ j \ dbproj j ((i,d)#D) = dbproj j D" +by auto + +lemma dbproj_subset[simp]: + "set (unlabel (dbproj i D)) \ set (unlabel D)" +unfolding unlabel_def by auto + +lemma dbproj_subseq: + assumes "Di \ set (subseqs (dbproj k D))" + shows "dbproj k Di = Di" (is ?A) + and "i \ k \ dbproj i Di = []" (is "i \ k \ ?B") +proof - + have *: "set Di \ set (dbproj k D)" using subseqs_powset[of "dbproj k D"] assms by auto + thus ?A by (metis filter_True filter_set member_filter subsetCE) + + have "\j d. (j,d) \ set Di \ j = k" using * by auto + moreover have "\j d. (j,d) \ set (dbproj i Di) \ j = i" by auto + moreover have "\j d. (j,d) \ set (dbproj i Di) \ (j,d) \ set Di" by auto + ultimately show "i \ k \ ?B" by (metis set_empty subrelI subset_empty) +qed + +lemma dbproj_subseq_subset: + assumes "Di \ set (subseqs (dbproj i D))" + shows "set Di \ set D" +by (metis Pow_iff assms filter_set image_eqI member_filter subseqs_powset subsetCE subsetI) + +lemma dbproj_subseq_in_subseqs: + assumes "Di \ set (subseqs (dbproj i D))" + shows "Di \ set (subseqs D)" +using assms in_set_subseqs subseq_filter_left subseq_order.dual_order.trans by blast + +lemma proj_subseq: + assumes "Di \ set (subseqs (dbproj (ln j) D))" "j \ i" + shows "[d\proj i D. d \ set Di] = proj i D" +proof - + have "set Di \ set (dbproj (ln j) D)" using subseqs_powset[of "dbproj (ln j) D"] assms by auto + hence "\k d. (k,d) \ set Di \ k = ln j" by auto + moreover have "\k d. (k,d) \ set (proj i D) \ k \ ln j" + using assms(2) unfolding proj_def by auto + ultimately have "\d. d \ set (proj i D) \ d \ set Di" by auto + thus ?thesis by simp +qed + +lemma unlabel_subseqsD: + assumes "A \ set (subseqs (unlabel B))" + shows "\C \ set (subseqs B). unlabel C = A" +using assms map_subseqs unfolding unlabel_def by (metis imageE set_map) + +lemma unlabel_filter_eq: + assumes "\(j, p) \ set A \ B. \(k, q) \ set A \ B. p = q \ j = k" (is "?P (set A)") + shows "[d\unlabel A. d \ snd ` B] = unlabel [d\A. d \ B]" +using assms unfolding unlabel_def +proof (induction A) + case (Cons a A) + have "set A \ set (a#A)" "{a} \ set (a#A)" by auto + hence *: "?P (set A)" "?P {a}" using Cons.prems by fast+ + hence IH: "[d\map snd A . d \ snd ` B] = map snd [d\A . d \ B]" using Cons.IH by auto + + { assume "snd a \ snd ` B" + then obtain b where b: "b \ B" "snd a = snd b" by moura + hence "fst a = fst b" using *(2) by auto + hence "a \ B" using b by (metis surjective_pairing) + } hence **: "a \ B \ snd a \ snd ` B" by metis + + show ?case by (cases "a \ B") (simp add: ** IH)+ +qed simp + +lemma subseqs_mem_dbproj: + assumes "Di \ set (subseqs D)" "list_all (\d. fst d = i) Di" + shows "Di \ set (subseqs (dbproj i D))" +using assms +proof (induction D arbitrary: Di) + case (Cons di D) + obtain d j where di: "di = (j,d)" by (metis surj_pair) + show ?case + proof (cases "Di \ set (subseqs D)") + case True + hence "Di \ set (subseqs (dbproj i D))" using Cons.IH Cons.prems by auto + thus ?thesis using subseqs_Cons by auto + next + case False + then obtain Di' where Di': "Di = di#Di'" using Cons.prems(1) + by (metis (mono_tags, lifting) Un_iff imageE set_append set_map subseqs.simps(2)) + hence "Di' \ set (subseqs D)" using Cons.prems(1) False + by (metis (no_types, lifting) UnE imageE list.inject set_append set_map subseqs.simps(2)) + hence "Di' \ set (subseqs (dbproj i D))" using Cons.IH Cons.prems Di' by auto + moreover have "i = j" using Di' di Cons.prems(2) by auto + hence "dbproj i (di#D) = di#dbproj i D" by (simp add: di) + ultimately show ?thesis using Di' + by (metis (no_types, lifting) UnCI image_eqI set_append set_map subseqs.simps(2)) + qed +qed simp + +lemma unlabel_subst: "unlabel S \\<^sub>s\<^sub>s\<^sub>t \ = unlabel (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" +unfolding unlabel_def subst_apply_stateful_strand_def subst_apply_labeled_stateful_strand_def +by auto + +lemma subterms_subst_lsst: + assumes "\x \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S). (\f. \ x = Fun f []) \ (\y. \ x = Var y)" + and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) = subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \\<^sub>s\<^sub>e\<^sub>t \" +using subterms_subst''[OF assms(1)] trms\<^sub>s\<^sub>s\<^sub>t_subst[OF assms(2)] unlabel_subst[of S \] +by simp + +lemma subterms_subst_lsst_ik: + assumes "\x \ fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t S). (\f. \ x = Fun f []) \ (\y. \ x = Var y)" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) = subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \\<^sub>s\<^sub>e\<^sub>t \" +using subterms_subst''[OF assms(1)] ik\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel S" \] unlabel_subst[of S \] +by simp + +lemma labeled_stateful_strand_subst_comp: + assumes "range_vars \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \\<^sub>s \ = (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \" +using assms +proof (induction S) + case (Cons s S) + obtain l x where s: "s = (l,x)" by (metis surj_pair) + hence IH: "S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \\<^sub>s \ = (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \" using Cons by auto + + have "x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \\<^sub>s \ = (x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" + using s Cons.prems stateful_strand_step_subst_comp[of \ x \] by auto + thus ?case using s IH by (simp add: subst_apply_labeled_stateful_strand_def) +qed simp + +lemma sst_vars_proj_subset[simp]: + "fv\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + "bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + "vars\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ vars\<^sub>s\<^sub>s\<^sub>t (unlabel A)" +using vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"] + vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "proj_unl n A"] +unfolding unlabel_def proj_def by auto + +lemma trms\<^sub>s\<^sub>s\<^sub>t_proj_subset[simp]: + "trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A)" (is ?A) + "trms\<^sub>s\<^sub>s\<^sub>t (proj_unl m (proj n A)) \ trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n A)" (is ?B) + "trms\<^sub>s\<^sub>s\<^sub>t (proj_unl m (proj n A)) \ trms\<^sub>s\<^sub>s\<^sub>t (proj_unl m A)" (is ?C) +proof - + show ?A unfolding unlabel_def proj_def by auto + show ?B using trms\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_proj_set_subset(4)] by metis + show ?C using trms\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_proj_set_subset(3)] by metis +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset: + "trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel (A@B))" (is ?A) + "trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n (A@B))" (is ?B) +using trms\<^sub>s\<^sub>s\<^sub>t_mono[of "proj_unl n A" "proj_unl n (A@B)"] +unfolding unlabel_def proj_def by auto + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_suffix_subset: + "trms\<^sub>s\<^sub>s\<^sub>t (unlabel B) \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel (A@B))" + "trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n B) \ trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n (A@B))" +using trms\<^sub>s\<^sub>s\<^sub>t_mono[of "proj_unl n B" "proj_unl n (A@B)"] +unfolding unlabel_def proj_def by auto + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>pD: + assumes p: "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" + shows "fst p = fst a" (is ?P) + and "is_Update (snd a) \ is_InSet (snd a) \ is_NegChecks (snd a)" (is ?Q) +proof - + obtain l k p' a' where a: "p = (l,p')" "a = (k,a')" by (metis surj_pair) + show ?P using p a by (cases a') auto + show ?Q using p a by (cases a') auto +qed + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_nil[simp]: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] = {}" +by (simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_cons[simp]: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (x#S) = setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S" +by (simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_proj_subset: + "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl m (proj n A)) \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n A)" + "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl m (proj n A)) \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl m A)" +unfolding unlabel_def proj_def +proof (induction A) + case (Cons a A) + obtain l b where lb: "a = (l,b)" by moura + { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } + { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } + { case 3 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } +qed simp_all + +lemma setops\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset: + "setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@B))" + "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n (A@B))" +unfolding unlabel_def proj_def +proof (induction A) + case (Cons a A) + obtain l b where lb: "a = (l,b)" by moura + { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } + { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } +qed (simp_all add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_unlabel_suffix_subset: + "setops\<^sub>s\<^sub>s\<^sub>t (unlabel B) \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@B))" + "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n B) \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n (A@B))" +unfolding unlabel_def proj_def +proof (induction A) + case (Cons a A) + obtain l b where lb: "a = (l,b)" by moura + { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } + { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) } +qed simp_all + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj_subset: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj m (proj n A)) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A)" +unfolding proj_def setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_prefix_subset: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B)" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n (A@B))" +unfolding proj_def setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_suffix_subset: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B)" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n B) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n (A@B))" +unfolding proj_def setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_mono: + "set M \ set N \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t M \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t N" +by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + +lemma trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label: + "\list_ex (is_LabelN l) A \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l A) \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l' A)" +by (rule trms\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_subset_if_no_label(2)[of l A l']]) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label: + "\list_ex (is_LabelN l) A \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l A) \ setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l' A)" +by (rule setops\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_subset_if_no_label(2)[of l A l']]) + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj_subset_if_no_label: + "\list_ex (is_LabelN l) A \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l A) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l' A)" +by (rule setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_subset_if_no_label(1)[of l A l']]) + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases[simp]: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,send\t\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,receive\t\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,\ac: s \ t\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,insert\t,s\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {(l,t \ \,s \ \)}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,delete\t,s\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {(l,t \ \,s \ \)}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,\ac: t \ s\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = {(l,t \ \,s \ \)}" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,\X\\\: F \\: F'\) \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + ((\(t,s). (l,t \ rm_vars (set X) \,s \ rm_vars (set X) \)) ` set F')" (is "?A = ?B") +proof - + have "?A = (\(t,s). (l,t,s)) ` set (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" by auto + thus "?A = ?B" unfolding subst_apply_pairs_def by auto +qed simp_all + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: + assumes "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a)) \ subst_domain \ = {}" + shows "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = (\p. (fst a,snd p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" +proof - + obtain l a' where a: "a = (l,a')" by (metis surj_pair) + show ?thesis + proof (cases a') + case (NegChecks X F G) + hence *: "rm_vars (set X) \ = \" using a assms rm_vars_apply'[of \ "set X"] by auto + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = (\p. (fst a, p)) ` set (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using * NegChecks a by auto + moreover have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = (\p. (fst a, p)) ` set G" using NegChecks a by simp + hence "(\p. (fst a,snd p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = (\p. (fst a, p \\<^sub>p \)) ` set G" + by (metis (mono_tags, lifting) image_cong image_image snd_conv) + hence "(\p. (fst a,snd p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = (\p. (fst a, p)) ` (set G \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \)" + unfolding case_prod_unfold by auto + ultimately show ?thesis by (simp add: subst_apply_pairs_def) + qed (use a in simp_all) +qed + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst': + assumes "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a)) \ subst_domain \ = {}" + shows "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = (\(i,p). (i,p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" +using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF assms] setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>pD(1) unfolding case_prod_unfold +by (metis (mono_tags, lifting) image_cong) + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst: + assumes "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" + shows "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (\p. (fst p,snd p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S" +using assms +proof (induction S) + case (Cons a S) + have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" and *: "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a)) \ subst_domain \ = {}" + using Cons.prems by auto + hence IH: "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (\p. (fst p,snd p \\<^sub>p \)) ` setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S" + using Cons.IH by auto + show ?case + using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst'[OF *] IH + unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def case_prod_unfold subst_lsst_cons + by auto +qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_in_subst: + assumes p: "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + shows "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. fst p = fst q \ snd p = snd q \\<^sub>p rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a))) \" + (is "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. ?P q") +proof - + obtain l b where a: "a = (l,b)" by (metis surj_pair) + + show ?thesis + proof (cases b) + case (NegChecks X F F') + hence "p \ (\(t, s). (l, t \ rm_vars (set X) \, s \ rm_vars (set X) \)) ` set F'" + using p a setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(7)[of l X F F' \] by blast + then obtain s t where st: + "(t,s) \ set F'" "p = (l, t \ rm_vars (set X) \, s \ rm_vars (set X) \)" + by auto + hence "(l,t,s) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" "fst p = fst (l,t,s)" + "snd p = snd (l,t,s) \\<^sub>p rm_vars (set X) \" + using a NegChecks by fastforce+ + moreover have "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a) = X" using NegChecks a by auto + ultimately show ?thesis by blast + qed (use p a in auto) +qed + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_subst: + assumes "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + shows "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. fst p = fst q \ (\X \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. snd p = snd q \\<^sub>p rm_vars X \)" + (is "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. ?P A q") + using assms +proof (induction A) + case (Cons a A) + note 0 = unlabel_Cons(2)[of a A] bvars\<^sub>s\<^sub>s\<^sub>t_Cons[of "snd a" "unlabel A"] + show ?case + proof (cases "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)") + case False + hence "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + using Cons.prems setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_cons[of "a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \"] subst_lsst_cons[of a A \] by auto + moreover have "(set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a))) \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A)" using 0 by simp + ultimately have "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. ?P (a#A) q" using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_in_subst[of p a \] by blast + thus ?thesis by auto + qed (use Cons.IH 0 in auto) +qed simp + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + obtain l b where "a = (l,b)" by (metis surj_pair) + thus ?case using Cons unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by (cases b) auto +qed simp + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Labeled_Strands.thy b/Stateful_Protocol_Composition_and_Typing/Labeled_Strands.thy new file mode 100644 index 0000000..d9089f9 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Labeled_Strands.thy @@ -0,0 +1,372 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 +(C) Copyright Sebastian A. Mödersheim, DTU, 2018-2020 +(C) Copyright Achim D. Brucker, University of Sheffield, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Labeled_Strands.thy + Author: Andreas Viktor Hess, DTU + Author: Sebastian A. Mödersheim, DTU + Author: Achim D. Brucker, The University of Sheffield +*) + +section \Labeled Strands\ +theory Labeled_Strands +imports Strands_and_Constraints +begin + +subsection \Definitions: Labeled Strands and Constraints\ +datatype 'l strand_label = + LabelN (the_LabelN: "'l") ("ln _") +| LabelS ("\") + +text \Labeled strands are strands whose steps are equipped with labels\ +type_synonym ('a,'b,'c) labeled_strand_step = "'c strand_label \ ('a,'b) strand_step" +type_synonym ('a,'b,'c) labeled_strand = "('a,'b,'c) labeled_strand_step list" + +abbreviation is_LabelN where "is_LabelN n x \ fst x = ln n" +abbreviation is_LabelS where "is_LabelS x \ fst x = \" + +definition unlabel where "unlabel S \ map snd S" +definition proj where "proj n S \ filter (\s. is_LabelN n s \ is_LabelS s) S" +abbreviation proj_unl where "proj_unl n S \ unlabel (proj n S)" + +abbreviation wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t where "wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>t (unlabel S)" + +abbreviation subst_apply_labeled_strand_step (infix "\\<^sub>l\<^sub>s\<^sub>t\<^sub>p" 51) where + "x \\<^sub>l\<^sub>s\<^sub>t\<^sub>p \ \ (case x of (l, s) \ (l, s \\<^sub>s\<^sub>t\<^sub>p \))" + +abbreviation subst_apply_labeled_strand (infix "\\<^sub>l\<^sub>s\<^sub>t" 51) where + "S \\<^sub>l\<^sub>s\<^sub>t \ \ map (\x. x \\<^sub>l\<^sub>s\<^sub>t\<^sub>p \) S" + +abbreviation trms\<^sub>l\<^sub>s\<^sub>t where "trms\<^sub>l\<^sub>s\<^sub>t S \ trms\<^sub>s\<^sub>t (unlabel S)" +abbreviation trms_proj\<^sub>l\<^sub>s\<^sub>t where "trms_proj\<^sub>l\<^sub>s\<^sub>t n S \ trms\<^sub>s\<^sub>t (proj_unl n S)" + +abbreviation vars\<^sub>l\<^sub>s\<^sub>t where "vars\<^sub>l\<^sub>s\<^sub>t S \ vars\<^sub>s\<^sub>t (unlabel S)" +abbreviation vars_proj\<^sub>l\<^sub>s\<^sub>t where "vars_proj\<^sub>l\<^sub>s\<^sub>t n S \ vars\<^sub>s\<^sub>t (proj_unl n S)" + +abbreviation bvars\<^sub>l\<^sub>s\<^sub>t where "bvars\<^sub>l\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t (unlabel S)" +abbreviation fv\<^sub>l\<^sub>s\<^sub>t where "fv\<^sub>l\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>t (unlabel S)" + +abbreviation wf\<^sub>l\<^sub>s\<^sub>t where "wf\<^sub>l\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t V (unlabel S)" + + +subsection \Lemmata: Projections\ +lemma is_LabelS_proj_iff_not_is_LabelN: + "list_all is_LabelS (proj l A) \ \list_ex (is_LabelN l) A" +by (induct A) (auto simp add: proj_def) + +lemma proj_subset_if_no_label: + assumes "\list_ex (is_LabelN l) A" + shows "set (proj l A) \ set (proj l' A)" + and "set (proj_unl l A) \ set (proj_unl l' A)" +using assms by (induct A) (auto simp add: unlabel_def proj_def) + +lemma proj_in_setD: + assumes a: "a \ set (proj l A)" + obtains k b where "a = (k, b)" "k = (ln l) \ k = \" +using that a unfolding proj_def by (cases a) auto + +lemma proj_set_mono: + assumes "set A \ set B" + shows "set (proj n A) \ set (proj n B)" + and "set (proj_unl n A) \ set (proj_unl n B)" +using assms unfolding proj_def unlabel_def by auto + +lemma unlabel_nil[simp]: "unlabel [] = []" +by (simp add: unlabel_def) + +lemma unlabel_mono: "set A \ set B \ set (unlabel A) \ set (unlabel B)" +by (auto simp add: unlabel_def) + +lemma unlabel_in: "(l,x) \ set A \ x \ set (unlabel A)" +unfolding unlabel_def by force + +lemma unlabel_mem_has_label: "x \ set (unlabel A) \ \l. (l,x) \ set A" +unfolding unlabel_def by auto + +lemma proj_nil[simp]: "proj n [] = []" "proj_unl n [] = []" +unfolding unlabel_def proj_def by auto + +lemma singleton_lst_proj[simp]: + "proj_unl l [(ln l, a)] = [a]" + "l \ l' \ proj_unl l' [(ln l, a)] = []" + "proj_unl l [(\, a)] = [a]" + "unlabel [(l'', a)] = [a]" +unfolding proj_def unlabel_def by simp_all + +lemma unlabel_nil_only_if_nil[simp]: "unlabel A = [] \ A = []" +unfolding unlabel_def by auto + +lemma unlabel_Cons[simp]: + "unlabel ((l,a)#A) = a#unlabel A" + "unlabel (b#A) = snd b#unlabel A" +unfolding unlabel_def by simp_all + +lemma unlabel_append[simp]: "unlabel (A@B) = unlabel A@unlabel B" +unfolding unlabel_def by auto + +lemma proj_Cons[simp]: + "proj n ((ln n,a)#A) = (ln n,a)#proj n A" + "proj n ((\,a)#A) = (\,a)#proj n A" + "m \ n \ proj n ((ln m,a)#A) = proj n A" + "l = (ln n) \ proj n ((l,a)#A) = (l,a)#proj n A" + "l = \ \ proj n ((l,a)#A) = (l,a)#proj n A" + "fst b \ \ \ fst b \ (ln n) \ proj n (b#A) = proj n A" +unfolding proj_def by auto + +lemma proj_append[simp]: + "proj l (A'@B') = proj l A'@proj l B'" + "proj_unl l (A@B) = proj_unl l A@proj_unl l B" +unfolding proj_def unlabel_def by auto + +lemma proj_unl_cons[simp]: + "proj_unl l ((ln l, a)#A) = a#proj_unl l A" + "l \ l' \ proj_unl l' ((ln l, a)#A) = proj_unl l' A" + "proj_unl l ((\, a)#A) = a#proj_unl l A" +unfolding proj_def unlabel_def by simp_all + +lemma trms_unlabel_proj[simp]: + "trms\<^sub>s\<^sub>t\<^sub>p (snd (ln l, x)) \ trms_proj\<^sub>l\<^sub>s\<^sub>t l [(ln l, x)]" +by auto + +lemma trms_unlabel_star[simp]: + "trms\<^sub>s\<^sub>t\<^sub>p (snd (\, x)) \ trms_proj\<^sub>l\<^sub>s\<^sub>t l [(\, x)]" +by auto + +lemma trms\<^sub>l\<^sub>s\<^sub>t_union[simp]: "trms\<^sub>l\<^sub>s\<^sub>t A = (\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" +proof (induction A) + case (Cons a A) + obtain l s where ls: "a = (l,s)" by moura + have "trms\<^sub>l\<^sub>s\<^sub>t [a] = (\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a])" + proof - + have *: "trms\<^sub>l\<^sub>s\<^sub>t [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp + show ?thesis + proof (cases l) + case (LabelN n) + hence "trms_proj\<^sub>l\<^sub>s\<^sub>t n [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp + moreover have "\m. n \ m \ trms_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto + ultimately show ?thesis using * ls by fastforce + next + case LabelS + hence "\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by auto + thus ?thesis using * ls by fastforce + qed + qed + moreover have "\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] \ trms_proj\<^sub>l\<^sub>s\<^sub>t l A" + unfolding unlabel_def proj_def by auto + hence "(\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \ (\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" by auto + ultimately show ?case using Cons.IH ls by auto +qed simp + +lemma trms\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms\<^sub>l\<^sub>s\<^sub>t (A@B) = trms\<^sub>l\<^sub>s\<^sub>t A \ trms\<^sub>l\<^sub>s\<^sub>t B" +by (metis trms\<^sub>s\<^sub>t_append unlabel_append) + +lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B) = trms_proj\<^sub>l\<^sub>s\<^sub>t l A \ trms_proj\<^sub>l\<^sub>s\<^sub>t l B" +by (metis (no_types, lifting) filter_append proj_def trms\<^sub>l\<^sub>s\<^sub>t_append) + +lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_subset[simp]: + "trms_proj\<^sub>l\<^sub>s\<^sub>t l A \ trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)" + "trms_proj\<^sub>l\<^sub>s\<^sub>t l B \ trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)" +using trms_proj\<^sub>l\<^sub>s\<^sub>t_append[of l] by blast+ + +lemma trms\<^sub>l\<^sub>s\<^sub>t_subset[simp]: + "trms\<^sub>l\<^sub>s\<^sub>t A \ trms\<^sub>l\<^sub>s\<^sub>t (A@B)" + "trms\<^sub>l\<^sub>s\<^sub>t B \ trms\<^sub>l\<^sub>s\<^sub>t (A@B)" +proof (induction A) + case (Cons a A) + obtain l s where *: "a = (l,s)" by moura + { case 1 thus ?case using Cons * by auto } + { case 2 thus ?case using Cons * by auto } +qed simp_all + +lemma vars\<^sub>l\<^sub>s\<^sub>t_union: "vars\<^sub>l\<^sub>s\<^sub>t A = (\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)" +proof (induction A) + case (Cons a A) + obtain l s where ls: "a = (l,s)" by moura + have "vars\<^sub>l\<^sub>s\<^sub>t [a] = (\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a])" + proof - + have *: "vars\<^sub>l\<^sub>s\<^sub>t [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto + show ?thesis + proof (cases l) + case (LabelN n) + hence "vars_proj\<^sub>l\<^sub>s\<^sub>t n [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by simp + moreover have "\m. n \ m \ vars_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto + ultimately show ?thesis using * ls by fast + next + case LabelS + hence "\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto + thus ?thesis using * ls by fast + qed + qed + moreover have "\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] \ vars_proj\<^sub>l\<^sub>s\<^sub>t l A" + unfolding unlabel_def proj_def by auto + hence "(\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \ (\l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)" + using strand_vars_split(1) by auto + ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto +qed simp + +lemma unlabel_Cons_inv: + "unlabel A = b#B \ \A'. (\n. A = (ln n, b)#A') \ A = (\, b)#A'" +proof - + assume *: "unlabel A = b#B" + then obtain l A' where "A = (l,b)#A'" unfolding unlabel_def by moura + thus "\A'. (\l. A = (ln l, b)#A') \ A = (\, b)#A'" by (metis strand_label.exhaust) +qed + +lemma unlabel_snoc_inv: + "unlabel A = B@[b] \ \A'. (\n. A = A'@[(ln n, b)]) \ A = A'@[(\, b)]" +proof - + assume *: "unlabel A = B@[b]" + then obtain A' l where "A = A'@[(l,b)]" + unfolding unlabel_def by (induct A rule: List.rev_induct) auto + thus "\A'. (\n. A = A'@[(ln n, b)]) \ A = A'@[(\, b)]" by (cases l) auto +qed + +lemma proj_idem[simp]: "proj l (proj l A) = proj l A" +unfolding proj_def by auto + +lemma proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set: + "ik\<^sub>s\<^sub>t (proj_unl n A) = {t. (ln n, Receive t) \ set A \ (\, Receive t) \ set A} " +using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def proj_def by force + +lemma unlabel_ik\<^sub>s\<^sub>t_is_rcv_set: + "ik\<^sub>s\<^sub>t (unlabel A) = {t | l t. (l, Receive t) \ set A}" +using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def by force + +lemma proj_ik_union_is_unlabel_ik: + "ik\<^sub>s\<^sub>t (unlabel A) = (\l. ik\<^sub>s\<^sub>t (proj_unl l A))" +proof + show "(\l. ik\<^sub>s\<^sub>t (proj_unl l A)) \ ik\<^sub>s\<^sub>t (unlabel A)" + using unlabel_ik\<^sub>s\<^sub>t_is_rcv_set[of A] proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by auto + + show "ik\<^sub>s\<^sub>t (unlabel A) \ (\l. ik\<^sub>s\<^sub>t (proj_unl l A))" + proof + fix t assume "t \ ik\<^sub>s\<^sub>t (unlabel A)" + then obtain l where "(l, Receive t) \ set A" + using ik\<^sub>s\<^sub>t_is_rcv_set unlabel_mem_has_label[of _ A] + by moura + thus "t \ (\l. ik\<^sub>s\<^sub>t (proj_unl l A))" using proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by (cases l) auto + qed +qed + +lemma proj_ik_append[simp]: + "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) = ik\<^sub>s\<^sub>t (proj_unl l A) \ ik\<^sub>s\<^sub>t (proj_unl l B)" +using proj_append(2)[of l A B] ik_append by auto + +lemma proj_ik_append_subst_all: + "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) \\<^sub>s\<^sub>e\<^sub>t I = (ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t I) \ (ik\<^sub>s\<^sub>t (proj_unl l B) \\<^sub>s\<^sub>e\<^sub>t I)" +using proj_ik_append[of l] by auto + +lemma ik_proj_subset[simp]: "ik\<^sub>s\<^sub>t (proj_unl n A) \ trms_proj\<^sub>l\<^sub>s\<^sub>t n A" +by auto + +lemma prefix_proj: + "prefix A B \ prefix (unlabel A) (unlabel B)" + "prefix A B \ prefix (proj n A) (proj n B)" + "prefix A B \ prefix (proj_unl n A) (proj_unl n B)" +unfolding prefix_def unlabel_def proj_def by auto + + +subsection \Lemmata: Well-formedness\ +lemma wfvarsoccs\<^sub>s\<^sub>t_proj_union: + "wfvarsoccs\<^sub>s\<^sub>t (unlabel A) = (\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))" +proof (induction A) + case (Cons a A) + obtain l s where ls: "a = (l,s)" by moura + have "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = (\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]))" + proof - + have *: "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto + show ?thesis + proof (cases l) + case (LabelN n) + hence "wfvarsoccs\<^sub>s\<^sub>t (proj_unl n [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by simp + moreover have "\m. n \ m \ wfvarsoccs\<^sub>s\<^sub>t (proj_unl m [a]) = {}" using ls LabelN by auto + ultimately show ?thesis using * ls by fast + next + case LabelS + hence "\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto + thus ?thesis using * ls by fast + qed + qed + moreover have + "wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A)) = + wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) \ wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" + for l + unfolding unlabel_def proj_def by auto + hence "(\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A))) = + (\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a])) \ (\l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))" + using strand_vars_split(1) by auto + ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto +qed simp + +lemma wf_if_wf_proj: + assumes "\l. wf\<^sub>s\<^sub>t V (proj_unl l A)" + shows "wf\<^sub>s\<^sub>t V (unlabel A)" +using assms +proof (induction A arbitrary: V rule: List.rev_induct) + case (snoc a A) + hence IH: "wf\<^sub>s\<^sub>t V (unlabel A)" using proj_append(2)[of _ A] by auto + obtain b l where b: "a = (ln l, b) \ a = (\, b)" by (cases a, metis strand_label.exhaust) + hence *: "wf\<^sub>s\<^sub>t V (proj_unl l A@[b])" + by (metis snoc.prems proj_append(2) singleton_lst_proj(1) proj_unl_cons(1,3)) + thus ?case using IH b snoc.prems proj_append(2)[of l A "[a]"] unlabel_append[of A "[a]"] + proof (cases b) + case (Receive t) + have "fv t \ wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \ V" + proof + fix x assume "x \ fv t" + hence "x \ V \ wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Receive by auto + thus "x \ wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \ V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto + qed + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t (unlabel A) \ V" + using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] by blast + hence "wf\<^sub>s\<^sub>t V (unlabel A@[Receive t])" by (rule wf_rcv_append'''[OF IH]) + thus ?thesis using b Receive unlabel_append[of A "[a]"] by auto + next + case (Equality ac s t) + have "fv t \ wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \ V" when "ac = Assign" + proof + fix x assume "x \ fv t" + hence "x \ V \ wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Equality that by auto + thus "x \ wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \ V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto + qed + hence "fv t \ wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t A \ V" when "ac = Assign" + using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] that by blast + hence "wf\<^sub>s\<^sub>t V (unlabel A@[Equality ac s t])" + by (cases ac) (metis wf_eq_append'''[OF IH], metis wf_eq_check_append''[OF IH]) + thus ?thesis using b Equality unlabel_append[of A "[a]"] by auto + qed auto +qed simp + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Lazy_Intruder.thy b/Stateful_Protocol_Composition_and_Typing/Lazy_Intruder.thy new file mode 100644 index 0000000..f2c245a --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Lazy_Intruder.thy @@ -0,0 +1,884 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Lazy_Intruder.thy + Author: Andreas Viktor Hess, DTU +*) + +section \The Lazy Intruder\ +theory Lazy_Intruder +imports Strands_and_Constraints Intruder_Deduction +begin + +context intruder_model +begin + +subsection \Definition of the Lazy Intruder\ +text \The lazy intruder constraint reduction system, defined as a relation on constraint states\ +inductive_set LI_rel:: + "((('fun,'var) strand \ (('fun,'var) subst)) \ + ('fun,'var) strand \ (('fun,'var) subst)) set" + and LI_rel' (infix "\" 50) + and LI_rel_trancl (infix "\\<^sup>+" 50) + and LI_rel_rtrancl (infix "\\<^sup>*" 50) +where + "A \ B \ (A,B) \ LI_rel" +| "A \\<^sup>+ B \ (A,B) \ LI_rel\<^sup>+" +| "A \\<^sup>* B \ (A,B) \ LI_rel\<^sup>*" + +| Compose: "\simple S; length T = arity f; public f\ + \ (S@Send (Fun f T)#S',\) \ (S@(map Send T)@S',\)" +| Unify: "\simple S; Fun f T' \ ik\<^sub>s\<^sub>t S; Some \ = mgu (Fun f T) (Fun f T')\ + \ (S@Send (Fun f T)#S',\) \ ((S@S') \\<^sub>s\<^sub>t \,\ \\<^sub>s \)" +| Equality: "\simple S; Some \ = mgu t t'\ + \ (S@Equality _ t t'#S',\) \ ((S@S') \\<^sub>s\<^sub>t \,\ \\<^sub>s \)" + + +subsection \Lemma: The Lazy Intruder is Well-founded\ +context +begin +private lemma LI_compose_measure_lt: "((S@(map Send T)@S',\\<^sub>1), (S@Send (Fun f T)#S',\\<^sub>2)) \ measure\<^sub>s\<^sub>t" +using strand_fv_card_map_fun_eq[of S f T S'] strand_size_map_fun_lt(2)[of T f] +by (simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) + +private lemma LI_unify_measure_lt: + assumes "Some \ = mgu (Fun f T) t" "fv t \ fv\<^sub>s\<^sub>t S" + shows "(((S@S') \\<^sub>s\<^sub>t \,\\<^sub>1), (S@Send (Fun f T)#S',\\<^sub>2)) \ measure\<^sub>s\<^sub>t" +proof (cases "\ = Var") + assume "\ = Var" + hence "(S@S') \\<^sub>s\<^sub>t \ = S@S'" by blast + thus ?thesis + using strand_fv_card_rm_fun_le[of S S' f T] + by (auto simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) +next + assume "\ \ Var" + then obtain v where "v \ fv (Fun f T) \ fv t" "subst_elim \ v" + using mgu_eliminates[OF assms(1)[symmetric]] by metis + hence v_in: "v \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using assms(2) by (auto simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) + + have "range_vars \ \ fv (Fun f T) \ fv\<^sub>s\<^sub>t S" + using assms(2) mgu_vars_bounded[OF assms(1)[symmetric]] by auto + hence img_bound: "range_vars \ \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" by auto + + have finite_fv: "finite (fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S'))" by auto + + have "v \ fv\<^sub>s\<^sub>t ((S@Send (Fun f T)#S') \\<^sub>s\<^sub>t \)" + using strand_fv_subst_subset_if_subst_elim[OF \subst_elim \ v\] v_in by metis + hence v_not_in: "v \ fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" by auto + + have "fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp + hence "fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" using v_in v_not_in by blast + hence "card (fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)) < card (fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S'))" + using psubset_card_mono[OF finite_fv] by simp + thus ?thesis by (auto simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) +qed + +private lemma LI_equality_measure_lt: + assumes "Some \ = mgu t t'" + shows "(((S@S') \\<^sub>s\<^sub>t \,\\<^sub>1), (S@Equality a t t'#S',\\<^sub>2)) \ measure\<^sub>s\<^sub>t" +proof (cases "\ = Var") + assume "\ = Var" + hence "(S@S') \\<^sub>s\<^sub>t \ = S@S'" by blast + thus ?thesis + using strand_fv_card_rm_eq_le[of S S' a t t'] + by (auto simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) +next + assume "\ \ Var" + then obtain v where "v \ fv t \ fv t'" "subst_elim \ v" + using mgu_eliminates[OF assms(1)[symmetric]] by metis + hence v_in: "v \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" using assms by auto + + have "range_vars \ \ fv t \ fv t' \ fv\<^sub>s\<^sub>t S" + using assms mgu_vars_bounded[OF assms(1)[symmetric]] by auto + hence img_bound: "range_vars \ \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" by auto + + have finite_fv: "finite (fv\<^sub>s\<^sub>t (S@Equality a t t'#S'))" by auto + + have "v \ fv\<^sub>s\<^sub>t ((S@Equality a t t'#S') \\<^sub>s\<^sub>t \)" + using strand_fv_subst_subset_if_subst_elim[OF \subst_elim \ v\] v_in by metis + hence v_not_in: "v \ fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" by auto + + have "fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp + hence "fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" using v_in v_not_in by blast + hence "card (fv\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)) < card (fv\<^sub>s\<^sub>t (S@Equality a t t'#S'))" + using psubset_card_mono[OF finite_fv] by simp + thus ?thesis by (auto simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) +qed + +private lemma LI_in_measure: "(S\<^sub>1,\\<^sub>1) \ (S\<^sub>2,\\<^sub>2) \ ((S\<^sub>2,\\<^sub>2),(S\<^sub>1,\\<^sub>1)) \ measure\<^sub>s\<^sub>t" +proof (induction rule: LI_rel.induct) + case (Compose S T f S' \) thus ?case using LI_compose_measure_lt[of S T S'] by metis +next + case (Unify S f U \ T S' \) + hence "fv (Fun f U) \ fv\<^sub>s\<^sub>t S" + using fv_snd_rcv_strand_subset(2)[of S] by force + thus ?case using LI_unify_measure_lt[OF Unify.hyps(3), of S S'] by metis +qed (metis LI_equality_measure_lt) + +private lemma LI_in_measure_trans: "(S\<^sub>1,\\<^sub>1) \\<^sup>+ (S\<^sub>2,\\<^sub>2) \ ((S\<^sub>2,\\<^sub>2),(S\<^sub>1,\\<^sub>1)) \ measure\<^sub>s\<^sub>t" +by (induction rule: trancl.induct, metis surjective_pairing LI_in_measure) + (metis (no_types, lifting) surjective_pairing LI_in_measure measure\<^sub>s\<^sub>t_trans trans_def) + +private lemma LI_converse_wellfounded_trans: "wf ((LI_rel\<^sup>+)\)" +proof - + have "(LI_rel\<^sup>+)\ \ measure\<^sub>s\<^sub>t" using LI_in_measure_trans by auto + thus ?thesis using measure\<^sub>s\<^sub>t_wellfounded wf_subset by metis +qed + +private lemma LI_acyclic_trans: "acyclic (LI_rel\<^sup>+)" +using wf_acyclic[OF LI_converse_wellfounded_trans] acyclic_converse by metis + +private lemma LI_acyclic: "acyclic LI_rel" +using LI_acyclic_trans acyclic_subset by (simp add: acyclic_def) + +lemma LI_no_infinite_chain: "\(\f. \i. f i \\<^sup>+ f (Suc i))" +proof - + have "\(\f. \i. (f (Suc i), f i) \ (LI_rel\<^sup>+)\)" + using wf_iff_no_infinite_down_chain LI_converse_wellfounded_trans by metis + thus ?thesis by simp +qed + +private lemma LI_unify_finite: + assumes "finite M" + shows "finite {((S@Send (Fun f T)#S',\), ((S@S') \\<^sub>s\<^sub>t \,\ \\<^sub>s \)) | \ T'. + simple S \ Fun f T' \ M \ Some \ = mgu (Fun f T) (Fun f T')}" +using assms +proof (induction M rule: finite_induct) + case (insert m M) thus ?case + proof (cases m) + case (Fun g U) + let ?a = "\\. ((S@Send (Fun f T)#S',\), ((S@S') \\<^sub>s\<^sub>t \,\ \\<^sub>s \))" + let ?A = "\B. {?a \ | \ T'. simple S \ Fun f T' \ B \ Some \ = mgu (Fun f T) (Fun f T')}" + + have "?A (insert m M) = (?A M) \ (?A {m})" by auto + moreover have "finite (?A {m})" + proof (cases "\\. Some \ = mgu (Fun f T) (Fun g U)") + case True + then obtain \ where \: "Some \ = mgu (Fun f T) (Fun g U)" by blast + + have A_m_eq: "\\'. ?a \' \ ?A {m} \ ?a \ = ?a \'" + proof - + fix \' assume "?a \' \ ?A {m}" + hence "\\. Some \ = mgu (Fun f T) (Fun g U) \ ?a \ = ?a \'" + using \m = Fun g U\ by auto + thus "?a \ = ?a \'" by (metis \ option.inject) + qed + + have "?A {m} = {} \ ?A {m} = {?a \}" + proof (cases "simple S \ ?A {m} \ {}") + case True + hence "simple S" "?A {m} \ {}" by meson+ + hence "?A {m} = {?a \ | \. Some \ = mgu (Fun f T) (Fun g U)}" using \m = Fun g U\ by auto + hence "?a \ \ ?A {m}" using \ by auto + show ?thesis + proof (rule ccontr) + assume "\(?A {m} = {} \ ?A {m} = {?a \})" + then obtain B where B: "?A {m} = insert (?a \) B" "?a \ \ B" "B \ {}" + using \?A {m} \ {}\ \?a \ \ ?A {m}\ by (metis (no_types, lifting) Set.set_insert) + then obtain b where b: "?a \ \ b" "b \ B" by (metis (no_types, lifting) ex_in_conv) + then obtain \' where \': "b = ?a \'" using B(1) by blast + moreover have "?a \' \ ?A {m}" using B(1) b(2) \' by auto + hence "?a \ = ?a \'" by (blast dest!: A_m_eq) + ultimately show False using b(1) by simp + qed + qed auto + thus ?thesis by (metis (no_types, lifting) finite.emptyI finite_insert) + next + case False + hence "?A {m} = {}" using \m = Fun g U\ by blast + thus ?thesis by (metis finite.emptyI) + qed + ultimately show ?thesis using insert.IH by auto + qed simp +qed fastforce +end + + +subsection \Lemma: The Lazy Intruder Preserves Well-formedness\ +context +begin +private lemma LI_preserves_subst_wf_single: + assumes "(S\<^sub>1,\\<^sub>1) \ (S\<^sub>2,\\<^sub>2)" "fv\<^sub>s\<^sub>t S\<^sub>1 \ bvars\<^sub>s\<^sub>t S\<^sub>1 = {}" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>1" + and "subst_domain \\<^sub>1 \ vars\<^sub>s\<^sub>t S\<^sub>1 = {}" "range_vars \\<^sub>1 \ bvars\<^sub>s\<^sub>t S\<^sub>1 = {}" + shows "fv\<^sub>s\<^sub>t S\<^sub>2 \ bvars\<^sub>s\<^sub>t S\<^sub>2 = {}" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>2" + and "subst_domain \\<^sub>2 \ vars\<^sub>s\<^sub>t S\<^sub>2 = {}" "range_vars \\<^sub>2 \ bvars\<^sub>s\<^sub>t S\<^sub>2 = {}" +using assms +proof (induction rule: LI_rel.induct) + case (Compose S X f S' \) + { case 1 thus ?case using vars_st_snd_map by auto } + { case 2 thus ?case using vars_st_snd_map by auto } + { case 3 thus ?case using vars_st_snd_map by force } + { case 4 thus ?case using vars_st_snd_map by auto } +next + case (Unify S f U \ T S' \) + hence "fv (Fun f U) \ fv\<^sub>s\<^sub>t S" using fv_subset_if_in_strand_ik' by blast + hence *: "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] + unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps) + + have "fv\<^sub>s\<^sub>t (S@S') \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" "vars\<^sub>s\<^sub>t (S@S') \ vars\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + by auto + hence **: "fv\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + "vars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) \ vars\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using subst_sends_strand_fv_to_img[of "S@S'" \] + strand_subst_vars_union_bound[of "S@S'" \] * + by blast+ + + have "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" by (fact mgu_gives_wellformed_subst[OF Unify.hyps(3)[symmetric]]) + + { case 1 + have "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using bvars_subst_ident[of "S@S'" \] by auto + thus ?case using 1 ** by blast + } + { case 2 + hence "subst_domain \ \ subst_domain \ = {}" "subst_domain \ \ range_vars \ = {}" + using * by blast+ + thus ?case by (metis wf_subst_compose[OF \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\]) + } + { case 3 + hence "subst_domain \ \ vars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using ** by blast + moreover have "v \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" when "v \ subst_domain \" for v + using * that by blast + hence "subst_domain \ \ fv\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + using mgu_eliminates_dom[OF Unify.hyps(3)[symmetric], + THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Send (Fun f T)#S'"] + unfolding subst_elim_def by auto + moreover have "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using bvars_subst_ident[of "S@S'" \] by auto + hence "subst_domain \ \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using 3(1) * by blast + ultimately show ?case + using ** * subst_domain_compose[of \ \] vars\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>t[of "S@S' \\<^sub>s\<^sub>t \"] + by blast + } + { case 4 + have ***: "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using bvars_subst_ident[of "S@S'" \] by auto + hence "range_vars \ \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using 4(1) * by blast + thus ?case using subst_img_comp_subset[of \ \] 4(4) *** by blast + } +next + case (Equality S \ t t' a S' \) + hence *: "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] + unfolding range_vars_alt_def by fastforce + + have "fv\<^sub>s\<^sub>t (S@S') \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" "vars\<^sub>s\<^sub>t (S@S') \ vars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + by auto + hence **: "fv\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" + "vars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) \ vars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using subst_sends_strand_fv_to_img[of "S@S'" \] + strand_subst_vars_union_bound[of "S@S'" \] * + by blast+ + + have "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" by (fact mgu_gives_wellformed_subst[OF Equality.hyps(2)[symmetric]]) + + { case 1 + have "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using bvars_subst_ident[of "S@S'" \] by auto + thus ?case using 1 ** by blast + } + { case 2 + hence "subst_domain \ \ subst_domain \ = {}" "subst_domain \ \ range_vars \ = {}" + using * by blast+ + thus ?case by (metis wf_subst_compose[OF \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\]) + } + { case 3 + hence "subst_domain \ \ vars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using ** by blast + moreover have "v \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" when "v \ subst_domain \" for v + using * that by blast + hence "subst_domain \ \ fv\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + using mgu_eliminates_dom[OF Equality.hyps(2)[symmetric], + THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Equality a t t'#S'"] + unfolding subst_elim_def by auto + moreover have "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using bvars_subst_ident[of "S@S'" \] by auto + hence "subst_domain \ \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using 3(1) * by blast + ultimately show ?case + using ** * subst_domain_compose[of \ \] vars\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>t[of "S@S' \\<^sub>s\<^sub>t \"] + by blast + } + { case 4 + have ***: "bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using bvars_subst_ident[of "S@S'" \] by auto + hence "range_vars \ \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" using 4(1) * by blast + thus ?case using subst_img_comp_subset[of \ \] 4(4) *** by blast + } +qed + +private lemma LI_preserves_subst_wf: + assumes "(S\<^sub>1,\\<^sub>1) \\<^sup>* (S\<^sub>2,\\<^sub>2)" "fv\<^sub>s\<^sub>t S\<^sub>1 \ bvars\<^sub>s\<^sub>t S\<^sub>1 = {}" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>1" + and "subst_domain \\<^sub>1 \ vars\<^sub>s\<^sub>t S\<^sub>1 = {}" "range_vars \\<^sub>1 \ bvars\<^sub>s\<^sub>t S\<^sub>1 = {}" + shows "fv\<^sub>s\<^sub>t S\<^sub>2 \ bvars\<^sub>s\<^sub>t S\<^sub>2 = {}" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>2" + and "subst_domain \\<^sub>2 \ vars\<^sub>s\<^sub>t S\<^sub>2 = {}" "range_vars \\<^sub>2 \ bvars\<^sub>s\<^sub>t S\<^sub>2 = {}" +using assms +proof (induction S\<^sub>2 \\<^sub>2 rule: rtrancl_induct2) + case (step S\<^sub>i \\<^sub>i S\<^sub>j \\<^sub>j) + { case 1 thus ?case using LI_preserves_subst_wf_single[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] step.IH by metis } + { case 2 thus ?case using LI_preserves_subst_wf_single[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] step.IH by metis } + { case 3 thus ?case using LI_preserves_subst_wf_single[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] step.IH by metis } + { case 4 thus ?case using LI_preserves_subst_wf_single[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] step.IH by metis } +qed metis + +lemma LI_preserves_wellformedness: + assumes "(S\<^sub>1,\\<^sub>1) \\<^sup>* (S\<^sub>2,\\<^sub>2)" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" + shows "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>2 \\<^sub>2" +proof - + have *: "wf\<^sub>s\<^sub>t {} S\<^sub>j" + when "(S\<^sub>i, \\<^sub>i) \ (S\<^sub>j, \\<^sub>j)" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>i \\<^sub>i" for S\<^sub>i \\<^sub>i S\<^sub>j \\<^sub>j + using that + proof (induction rule: LI_rel.induct) + case (Unify S f U \ T S' \) + have "fv (Fun f T) \ fv (Fun f U) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" using Unify.hyps(2) by force + hence "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by (metis subset_trans) + hence "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@Send (Fun f T)#S') = {}" + using Unify.prems unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by blast + thus ?case + using wf_unify[OF _ Unify.hyps(2) MGU_is_Unifier[OF mgu_gives_MGU], of "{}", + OF _ Unify.hyps(3)[symmetric], of S'] Unify.prems(1) + by (auto simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + next + case (Equality S \ t t' a S' \) + have "fv t \ fv t' \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" using Equality.hyps(2) by force + hence "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by (metis subset_trans) + hence "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@Equality a t t'#S') = {}" + using Equality.prems unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by blast + thus ?case + using wf_equality[OF _ Equality.hyps(2)[symmetric], of "{}" S a S'] Equality.prems(1) + by (auto simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + qed (metis wf_send_compose wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + + show ?thesis using assms + proof (induction rule: rtrancl_induct2) + case (step S\<^sub>i \\<^sub>i S\<^sub>j \\<^sub>j) thus ?case + using LI_preserves_subst_wf_single[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] *[OF \(S\<^sub>i,\\<^sub>i) \ (S\<^sub>j,\\<^sub>j)\] + by (metis wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + qed simp +qed + +lemma LI_preserves_trm_wf: + assumes "(S,\) \\<^sup>* (S',\')" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S')" +proof - + { fix S \ S' \' + assume "(S,\) \ (S',\')" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S')" + proof (induction rule: LI_rel.induct) + case (Compose S T f S' \) + hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" + and *: "t \ set S \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p t)" "t \ set S' \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p t)" for t + by auto + hence "wf\<^sub>t\<^sub>r\<^sub>m t" when "t \ set T" for t using that unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p t)" when "t \ set (map Send T)" for t + using that unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + thus ?case using * by force + next + case (Unify S f U \ T S' \) + have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun f U)" + using Unify.prems(1) Unify.hyps(2) wf_trm_subterm[of _ "Fun f U"] + by (simp, force) + hence range_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Unify.hyps(3)[symmetric]] by simp + + { fix s assume "s \ set (S@S' \\<^sub>s\<^sub>t \)" + hence "\s' \ set (S@S'). s = s' \\<^sub>s\<^sub>t\<^sub>p \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')" + using Unify.prems(1) by (auto simp add: subst_apply_strand_def) + moreover { + fix s' assume s': "s = s' \\<^sub>s\<^sub>t\<^sub>p \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')" "s' \ set (S@S')" + from s'(2) have "trms\<^sub>s\<^sub>t\<^sub>p (s' \\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>t\<^sub>p s' \\<^sub>s\<^sub>e\<^sub>t (rm_vars (set (bvars\<^sub>s\<^sub>t\<^sub>p s')) \)" + proof (induction s') + case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def) + qed auto + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s)" + using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] \wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')\ s'(1) + by simp + } + ultimately have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s)" by auto + } + thus ?case by auto + next + case (Equality S \ t t' a S' \) + hence "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" by simp_all + hence range_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Equality.hyps(2)[symmetric]] by simp + + { fix s assume "s \ set (S@S' \\<^sub>s\<^sub>t \)" + hence "\s' \ set (S@S'). s = s' \\<^sub>s\<^sub>t\<^sub>p \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')" + using Equality.prems(1) by (auto simp add: subst_apply_strand_def) + moreover { + fix s' assume s': "s = s' \\<^sub>s\<^sub>t\<^sub>p \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')" "s' \ set (S@S')" + from s'(2) have "trms\<^sub>s\<^sub>t\<^sub>p (s' \\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>t\<^sub>p s' \\<^sub>s\<^sub>e\<^sub>t (rm_vars (set (bvars\<^sub>s\<^sub>t\<^sub>p s')) \)" + proof (induction s') + case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def) + qed auto + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s)" + using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] \wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s')\ s'(1) + by simp + } + ultimately have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p s)" by auto + } + thus ?case by auto + qed + } + with assms show ?thesis by (induction rule: rtrancl_induct2) metis+ +qed +end + +subsection \Theorem: Soundness of the Lazy Intruder\ +context +begin +private lemma LI_soundness_single: + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" "(S\<^sub>1,\\<^sub>1) \ (S\<^sub>2,\\<^sub>2)" "\ \\<^sub>c \S\<^sub>2,\\<^sub>2\" + shows "\ \\<^sub>c \S\<^sub>1,\\<^sub>1\" +using assms(2,1,3) +proof (induction rule: LI_rel.induct) + case (Compose S T f S' \) + hence *: "\{}; S\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; map Send T\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" + unfolding constr_sem_c_def by force+ + + have "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c Fun f T \ \" + using *(2) Compose.hyps(2) ComposeC[OF _ Compose.hyps(3), of "map (\x. x \ \) T"] + unfolding subst_compose_def by force + thus "\ \\<^sub>c \S@Send (Fun f T)#S',\\" + using *(1,3) \\ \\<^sub>c \S@map Send T@S',\\\ + by (auto simp add: constr_sem_c_def) +next + case (Unify S f U \ T S' \) + have "(\ \\<^sub>s \) supports \" "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" + using Unify.prems(2) unfolding constr_sem_c_def by metis+ + then obtain \ where \: "\ \\<^sub>s \ \\<^sub>s \ = \" unfolding subst_compose_def by auto + + have \fun_id: "Fun f U \ \ = Fun f U" "Fun f T \ \ = Fun f T" + using Unify.prems(1) trm_subst_ident[of "Fun f U" \] + fv_subset_if_in_strand_ik[of "Fun f U" S] Unify.hyps(2) + fv_snd_rcv_strand_subset(2)[of S] + strand_vars_split(1)[of S "Send (Fun f T)#S'"] + unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def apply blast + using Unify.prems(1) trm_subst_ident[of "Fun f T" \] + unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by fastforce + hence \\_disj: + "subst_domain \ \ subst_domain \ = {}" + "subst_domain \ \ range_vars \ = {}" + "subst_domain \ \ range_vars \ = {}" + using trm_subst_disj mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] apply (blast,blast) + using Unify.prems(1) unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by blast + hence \\_support: "\ supports \" "\ supports \" + by (simp_all add: subst_support_comp_split[OF \(\ \\<^sub>s \) supports \\]) + + have "fv (Fun f T) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" "fv (Fun f U) \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using Unify.hyps(2) by force+ + hence \_vars_bound: "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Send (Fun f T)#S')" + using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by blast + + have "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; [Send (Fun f T)]\\<^sub>c \" + proof - + from Unify.hyps(2) have "Fun f U \ \ \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" by blast + hence "Fun f U \ \ \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" by blast + moreover have "Unifier \ (Fun f T) (Fun f U)" + by (fact MGU_is_Unifier[OF mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]]) + ultimately have "Fun f T \ \ \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" + using \ by (metis \fun_id subst_subst_compose) + thus ?thesis by simp + qed + + have "\{}; S\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" + proof - + have "(S@S' \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = S@S' \\<^sub>s\<^sub>t \" "(S@S') \\<^sub>s\<^sub>t \ = S@S'" + proof - + have "subst_domain \ \ vars\<^sub>s\<^sub>t (S@S') = {}" + using Unify.prems(1) by (auto simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + hence "subst_domain \ \ vars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + using \\_disj(2) strand_subst_vars_union_bound[of "S@S'" \] by blast + thus "(S@S' \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = S@S' \\<^sub>s\<^sub>t \" "(S@S') \\<^sub>s\<^sub>t \ = S@S'" + using strand_subst_comp \subst_domain \ \ vars\<^sub>s\<^sub>t (S@S') = {}\ by (blast,blast) + qed + moreover have "subst_idem \" by (fact mgu_gives_subst_idem[OF Unify.hyps(3)[symmetric]]) + moreover have + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S') = {}" + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S') = {}" + using wf_constr_bvars_disj[OF Unify.prems(1)] + wf_constr_bvars_disj'[OF Unify.prems(1) \_vars_bound] + by auto + ultimately have "\{}; S@S'\\<^sub>c \" + using \\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \\ \ + strand_sem_subst(1)[of \ "S@S' \\<^sub>s\<^sub>t \" "{}" "\ \\<^sub>s \"] + strand_sem_subst(2)[of \ "S@S'" "{}" "\ \\<^sub>s \"] + strand_sem_subst_subst_idem[of \ "S@S'" "{}" \] + unfolding constr_sem_c_def + by (metis subst_compose_assoc) + thus "\{}; S\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" by auto + qed + + show "\ \\<^sub>c \S@Send (Fun f T)#S',\\" + using \\_support(1) \\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; [Send (Fun f T)]\\<^sub>c \\ \\{}; S\\<^sub>c \\ \\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \\ + by (auto simp add: constr_sem_c_def) +next + case (Equality S \ t t' a S' \) + have "(\ \\<^sub>s \) supports \" "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" + using Equality.prems(2) unfolding constr_sem_c_def by metis+ + then obtain \ where \: "\ \\<^sub>s \ \\<^sub>s \ = \" unfolding subst_compose_def by auto + + have "fv t \ vars\<^sub>s\<^sub>t (S@Equality a t t'#S')" "fv t' \ vars\<^sub>s\<^sub>t (S@Equality a t t'#S')" + by auto + moreover have "subst_domain \ \ vars\<^sub>s\<^sub>t (S@Equality a t t'#S') = {}" + using Equality.prems(1) unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by auto + ultimately have \fun_id: "t \ \ = t" "t' \ \ = t'" + using trm_subst_ident[of t \] trm_subst_ident[of t' \] + by auto + hence \\_disj: + "subst_domain \ \ subst_domain \ = {}" + "subst_domain \ \ range_vars \ = {}" + "subst_domain \ \ range_vars \ = {}" + using trm_subst_disj mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] apply (blast,blast) + using Equality.prems(1) unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by blast + hence \\_support: "\ supports \" "\ supports \" + by (simp_all add: subst_support_comp_split[OF \(\ \\<^sub>s \) supports \\]) + + have "fv t \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" "fv t' \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" by auto + hence \_vars_bound: "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t (S@Equality a t t'#S')" + using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by blast + + have "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; [Equality a t t']\\<^sub>c \" + proof - + have "t \ \ = t' \ \" + using MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]] + by metis + hence "t \ (\ \\<^sub>s \) = t' \ (\ \\<^sub>s \)" by (metis \fun_id subst_subst_compose) + hence "t \ \ = t' \ \" by (metis \ subst_subst_compose) + thus ?thesis by simp + qed + + have "\{}; S\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" + proof - + have "(S@S' \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = S@S' \\<^sub>s\<^sub>t \" "(S@S') \\<^sub>s\<^sub>t \ = S@S'" + proof - + have "subst_domain \ \ vars\<^sub>s\<^sub>t (S@S') = {}" + using Equality.prems(1) + by (fastforce simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def simp del: subst_range.simps) + hence "subst_domain \ \ fv\<^sub>s\<^sub>t (S@S') = {}" by blast + hence "subst_domain \ \ fv\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + using \\_disj(2) subst_sends_strand_fv_to_img[of "S@S'" \] by blast + thus "(S@S' \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = S@S' \\<^sub>s\<^sub>t \" "(S@S') \\<^sub>s\<^sub>t \ = S@S'" + using strand_subst_comp \subst_domain \ \ vars\<^sub>s\<^sub>t (S@S') = {}\ by (blast,blast) + qed + moreover have + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S') = {}" + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \) = {}" + "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S@S') = {}" + using wf_constr_bvars_disj[OF Equality.prems(1)] + wf_constr_bvars_disj'[OF Equality.prems(1) \_vars_bound] + by auto + ultimately have "\{}; S@S'\\<^sub>c \" + using \\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \\ \ + strand_sem_subst(1)[of \ "S@S' \\<^sub>s\<^sub>t \" "{}" "\ \\<^sub>s \"] + strand_sem_subst(2)[of \ "S@S'" "{}" "\ \\<^sub>s \"] + strand_sem_subst_subst_idem[of \ "S@S'" "{}" \] + mgu_gives_subst_idem[OF Equality.hyps(2)[symmetric]] + unfolding constr_sem_c_def + by (metis subst_compose_assoc) + thus "\{}; S\\<^sub>c \" "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" by auto + qed + + show "\ \\<^sub>c \S@Equality a t t'#S',\\" + using \\_support(1) \\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; [Equality a t t']\\<^sub>c \\ \\{}; S\\<^sub>c \\ \\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \\ + by (auto simp add: constr_sem_c_def) +qed + +theorem LI_soundness: + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" "(S\<^sub>1,\\<^sub>1) \\<^sup>* (S\<^sub>2,\\<^sub>2)" "\ \\<^sub>c \S\<^sub>2, \\<^sub>2\" + shows "\ \\<^sub>c \S\<^sub>1, \\<^sub>1\" +using assms(2,1,3) +proof (induction S\<^sub>2 \\<^sub>2 rule: rtrancl_induct2) + case (step S\<^sub>i \\<^sub>i S\<^sub>j \\<^sub>j) thus ?case + using LI_preserves_wellformedness[OF \(S\<^sub>1, \\<^sub>1) \\<^sup>* (S\<^sub>i, \\<^sub>i)\ \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1\] + LI_soundness_single[OF _ \(S\<^sub>i, \\<^sub>i) \ (S\<^sub>j, \\<^sub>j)\ \\ \\<^sub>c \S\<^sub>j, \\<^sub>j\\] + step.IH[OF \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1\] + by metis +qed metis +end + +subsection \Theorem: Completeness of the Lazy Intruder\ +context +begin +private lemma LI_completeness_single: + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" "\ \\<^sub>c \S\<^sub>1, \\<^sub>1\" "\simple S\<^sub>1" + shows "\S\<^sub>2 \\<^sub>2. (S\<^sub>1,\\<^sub>1) \ (S\<^sub>2,\\<^sub>2) \ (\ \\<^sub>c \S\<^sub>2, \\<^sub>2\)" +using not_simple_elim[OF \\simple S\<^sub>1\] +proof - + { \ \In this case \S\<^sub>1\ isn't simple because it contains an equality constraint, + so we can simply proceed with the reduction by computing the MGU for the equation\ + assume "\S' S'' a t t'. S\<^sub>1 = S'@Equality a t t'#S'' \ simple S'" + then obtain S a t t' S' where S\<^sub>1: "S\<^sub>1 = S@Equality a t t'#S'" "simple S" by moura + hence *: "wf\<^sub>s\<^sub>t {} S" "\ \\<^sub>c \S, \\<^sub>1\" "\\<^sub>1 supports \" "t \ \ = t' \ \" + using \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1\ wf_eq_fv[of "{}" S t t' S'] + fv_snd_rcv_strand_subset(5)[of S] + by (auto simp add: constr_sem_c_def wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + + from * have "Unifier \ t t'" by simp + then obtain \ where \: + "Some \ = mgu t t'" "subst_idem \" "subst_domain \ \ range_vars \ \ fv t \ fv t'" + using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+ + + have "\ \\<^sub>\ \" + using mgu_gives_MGU[OF \(1)[symmetric]] + by (metis \Unifier \ t t'\) + hence "\ supports \" using subst_support_if_mgt_subst_idem[OF _ \(2)] by metis + hence "(\\<^sub>1 \\<^sub>s \) supports \" using subst_support_comp \\\<^sub>1 supports \\ by metis + + have "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" + proof - + have "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t S\<^sub>1" using \(3) S\<^sub>1(1) by auto + hence "\{}; S\<^sub>1 \\<^sub>s\<^sub>t \\\<^sub>c \" + using \subst_idem \\ \\ \\<^sub>\ \\ \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ strand_sem_subst + wf_constr_bvars_disj'(1)[OF assms(1)] + unfolding subst_idem_def constr_sem_c_def + by (metis (no_types) subst_compose_assoc) + thus "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" using S\<^sub>1(1) by force + qed + moreover have "(S@Equality a t t'#S', \\<^sub>1) \ (S@S' \\<^sub>s\<^sub>t \, \\<^sub>1 \\<^sub>s \)" + using LI_rel.Equality[OF \simple S\ \(1)] S\<^sub>1 by metis + ultimately have ?thesis + using S\<^sub>1(1) \(\\<^sub>1 \\<^sub>s \) supports \\ + by (auto simp add: constr_sem_c_def) + } moreover { + \ \In this case \S\<^sub>1\ isn't simple because it contains a deduction constraint for a composed + term, so we must look at how this composed term is derived under the interpretation \\\\ + assume "\S' S'' f T. S\<^sub>1 = S'@Send (Fun f T)#S'' \ simple S'" + with assms obtain S f T S' where S\<^sub>1: "S\<^sub>1 = S@Send (Fun f T)#S'" "simple S" by moura + hence "wf\<^sub>s\<^sub>t {} S" "\ \\<^sub>c \S, \\<^sub>1\" "\\<^sub>1 supports \" + using \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1\ + by (auto simp add: constr_sem_c_def wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + + \ \Lemma for a common subcase\ + have fun_sat: "\ \\<^sub>c \S@(map Send T)@S', \\<^sub>1\" when T: "\t. t \ set T \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" + proof - + have "\t. t \ set T \ \ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; [Send t]\\<^sub>c \" using T by simp + hence "\ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \; map Send T\\<^sub>c \" using \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ strand_sem_Send_map by metis + moreover have "\ik\<^sub>s\<^sub>t (S@(map Send T)) \\<^sub>s\<^sub>e\<^sub>t \; S'\\<^sub>c \" + using \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ S\<^sub>1 + by (auto simp add: constr_sem_c_def) + ultimately show ?thesis + using \\ \\<^sub>c \S, \\<^sub>1\\ \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ + by (force simp add: constr_sem_c_def) + qed + + from S\<^sub>1 \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ have "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c Fun f T \ \" by (auto simp add: constr_sem_c_def) + hence ?thesis + proof cases + \ \Case 1: \\(f(T))\ has been derived using the \AxiomC\ rule.\ + case AxiomC + hence ex_t: "\t. t \ ik\<^sub>s\<^sub>t S \ Fun f T \ \ = t \ \" by auto + show ?thesis + proof (cases "\T'. Fun f T' \ ik\<^sub>s\<^sub>t S \ Fun f T \ \ \ Fun f T' \ \") + \ \Case 1.1: \f(T)\ is equal to a variable in the intruder knowledge under \\\. + Hence there must exists a deduction constraint in the simple prefix of the constraint + in which this variable occurs/"is sent" for the first time. Since this variable itself + cannot have been derived from the \AxiomC\ rule (because it must be equal under the + interpretation to \f(T)\, which is by assumption not in the intruder knowledge under + \\\) it must be the case that we can derive it using the \ComposeC\ rule. Hence we can + apply the \Compose\ rule of the lazy intruder to \f(T)\.\ + case True + have "\v. Var v \ ik\<^sub>s\<^sub>t S \ Fun f T \ \ = \ v" + proof - + obtain t where "t \ ik\<^sub>s\<^sub>t S" "Fun f T \ \ = t \ \" using ex_t by moura + thus ?thesis + using \\T'. Fun f T' \ ik\<^sub>s\<^sub>t S \ Fun f T \ \ \ Fun f T' \ \\ + by (cases t) auto + qed + hence "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. Fun f T \ \ = \ v" + using vars_subset_if_in_strand_ik2[of _ S] by fastforce + then obtain v S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f + where S: "S = S\<^sub>p\<^sub>r\<^sub>e@Send (Var v)#S\<^sub>s\<^sub>u\<^sub>f" "Fun f T \ \ = \ v" + "\(\w \ wfrestrictedvars\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e. Fun f T \ \ = \ w)" + using \wf\<^sub>s\<^sub>t {} S\ wf_simple_strand_first_Send_var_split[OF _ \simple S\, of "Fun f T" \] + by auto + hence "\w. Var w \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \ \ v \ Var w \ \" by auto + moreover have "\T'. Fun f T' \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \ Fun f T \ \ \ Fun f T' \ \" + using \\T'. Fun f T' \ ik\<^sub>s\<^sub>t S \ Fun f T \ \ \ Fun f T' \ \\ S(1) + by (meson contra_subsetD ik_append_subset(1)) + hence "\g T'. Fun g T' \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \ \ v \ Fun g T' \ \" using S(2) by simp + ultimately have "\t \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e. \ v \ t \ \" by (metis term.exhaust) + hence "\ v \ (ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e) \\<^sub>s\<^sub>e\<^sub>t \" by auto + + have "ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c \ v" + using S\<^sub>1(1) S(1) \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ + by (auto simp add: constr_sem_c_def) + hence "ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c Fun f T \ \" using \Fun f T \ \ = \ v\ by metis + hence "length T = arity f" "public f" "\t. t \ set T \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" + using \Fun f T \ \ = \ v\ \\ v \ ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \\ + intruder_synth.simps[of "ik\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \" "\ v"] + by auto + hence *: "\t. t \ set T \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" + using S(1) by (auto intro: ideduct_synth_mono) + hence "\ \\<^sub>c \S@(map Send T)@S', \\<^sub>1\" by (metis fun_sat) + moreover have "(S@Send (Fun f T)#S', \\<^sub>1) \ (S@map Send T@S', \\<^sub>1)" + by (metis LI_rel.Compose[OF \simple S\ \length T = arity f\ \public f\]) + ultimately show ?thesis using S\<^sub>1 by auto + next + \ \Case 1.2: \\(f(T))\ can be derived from an interpreted composed term in the intruder + knowledge. Use the \Unify\ rule on this composed term to further reduce the constraint.\ + case False + then obtain T' where t: "Fun f T' \ ik\<^sub>s\<^sub>t S" "Fun f T \ \ = Fun f T' \ \" + by auto + hence "fv (Fun f T') \ fv\<^sub>s\<^sub>t S\<^sub>1" + using S\<^sub>1(1) fv_subset_if_in_strand_ik'[OF t(1)] + fv_snd_rcv_strand_subset(2)[of S] + by auto + from t have "Unifier \ (Fun f T) (Fun f T')" by simp + then obtain \ where \: + "Some \ = mgu (Fun f T) (Fun f T')" "subst_idem \" + "subst_domain \ \ range_vars \ \ fv (Fun f T) \ fv (Fun f T')" + using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+ + + have "\ \\<^sub>\ \" + using mgu_gives_MGU[OF \(1)[symmetric]] + by (metis \Unifier \ (Fun f T) (Fun f T')\) + hence "\ supports \" using subst_support_if_mgt_subst_idem[OF _ \(2)] by metis + hence "(\\<^sub>1 \\<^sub>s \) supports \" using subst_support_comp \\\<^sub>1 supports \\ by metis + + have "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" + proof - + have "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t S\<^sub>1" + using \(3) S\<^sub>1(1) \fv (Fun f T') \ fv\<^sub>s\<^sub>t S\<^sub>1\ + unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps) + hence "\{}; S\<^sub>1 \\<^sub>s\<^sub>t \\\<^sub>c \" + using \subst_idem \\ \\ \\<^sub>\ \\ \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\ strand_sem_subst + wf_constr_bvars_disj'(1)[OF assms(1)] + unfolding subst_idem_def constr_sem_c_def + by (metis (no_types) subst_compose_assoc) + thus "\{}; S@S' \\<^sub>s\<^sub>t \\\<^sub>c \" using S\<^sub>1(1) by force + qed + moreover have "(S@Send (Fun f T)#S', \\<^sub>1) \ (S@S' \\<^sub>s\<^sub>t \, \\<^sub>1 \\<^sub>s \)" + using LI_rel.Unify[OF \simple S\ t(1) \(1)] S\<^sub>1 by metis + ultimately show ?thesis + using S\<^sub>1(1) \(\\<^sub>1 \\<^sub>s \) supports \\ + by (auto simp add: constr_sem_c_def) + qed + next + \ \Case 2: \\(f(T))\ has been derived using the \ComposeC\ rule. + Simply use the \Compose\ rule of the lazy intruder to proceed with the reduction.\ + case (ComposeC T' g) + hence "f = g" "length T = arity f" "public f" + and "\x. x \ set T \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c x \ \" + by auto + hence "\ \\<^sub>c \S@(map Send T)@S', \\<^sub>1\" using fun_sat by metis + moreover have "(S\<^sub>1, \\<^sub>1) \ (S@(map Send T)@S', \\<^sub>1)" + using S\<^sub>1 LI_rel.Compose[OF \simple S\ \length T = arity f\ \public f\] + by metis + ultimately show ?thesis by metis + qed + } moreover have "\A B X F. S\<^sub>1 = A@Inequality X F#B \ ineq_model \ X F" + using assms(2) by (auto simp add: constr_sem_c_def) + ultimately show ?thesis using not_simple_elim[OF \\simple S\<^sub>1\] by metis +qed + +theorem LI_completeness: + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" "\ \\<^sub>c \S\<^sub>1, \\<^sub>1\" + shows "\S\<^sub>2 \\<^sub>2. (S\<^sub>1,\\<^sub>1) \\<^sup>* (S\<^sub>2,\\<^sub>2) \ simple S\<^sub>2 \ (\ \\<^sub>c \S\<^sub>2, \\<^sub>2\)" +proof (cases "simple S\<^sub>1") + case False + let ?Stuck = "\S\<^sub>2 \\<^sub>2. \(\S\<^sub>3 \\<^sub>3. (S\<^sub>2,\\<^sub>2) \ (S\<^sub>3,\\<^sub>3) \ (\ \\<^sub>c \S\<^sub>3, \\<^sub>3\))" + let ?Sats = "{((S,\),(S',\')). (S,\) \ (S',\') \ (\ \\<^sub>c \S, \\) \ (\ \\<^sub>c \S', \'\)}" + + have simple_if_stuck: + "\S\<^sub>2 \\<^sub>2. \(S\<^sub>1,\\<^sub>1) \\<^sup>+ (S\<^sub>2,\\<^sub>2); \ \\<^sub>c \S\<^sub>2, \\<^sub>2\; ?Stuck S\<^sub>2 \\<^sub>2\ \ simple S\<^sub>2" + using LI_completeness_single + LI_preserves_wellformedness + \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1\ + trancl_into_rtrancl + by metis + + have base: "\b. ((S\<^sub>1,\\<^sub>1),b) \ ?Sats" + using LI_completeness_single[OF assms False] assms(2) + by auto + + have *: "\S \ S' \'. ((S,\),(S',\')) \ ?Sats\<^sup>+ \ (S,\) \\<^sup>+ (S',\') \ (\ \\<^sub>c \S', \'\)" + proof - + fix S \ S' \' + assume "((S,\),(S',\')) \ ?Sats\<^sup>+" + thus "(S,\) \\<^sup>+ (S',\') \ (\ \\<^sub>c \S', \'\)" + by (induct rule: trancl_induct2) auto + qed + + have "\S\<^sub>2 \\<^sub>2. ((S\<^sub>1,\\<^sub>1),(S\<^sub>2,\\<^sub>2)) \ ?Sats\<^sup>+ \ ?Stuck S\<^sub>2 \\<^sub>2" + proof (rule ccontr) + assume "\(\S\<^sub>2 \\<^sub>2. ((S\<^sub>1,\\<^sub>1),(S\<^sub>2,\\<^sub>2)) \ ?Sats\<^sup>+ \ ?Stuck S\<^sub>2 \\<^sub>2)" + hence sat_not_stuck: "\S\<^sub>2 \\<^sub>2. ((S\<^sub>1,\\<^sub>1),(S\<^sub>2,\\<^sub>2)) \ ?Sats\<^sup>+ \ \?Stuck S\<^sub>2 \\<^sub>2" by blast + + have "\S \. ((S\<^sub>1,\\<^sub>1),(S,\)) \ ?Sats\<^sup>+ \ (\b. ((S,\),b) \ ?Sats)" + proof (intro allI impI) + fix S \ assume a: "((S\<^sub>1,\\<^sub>1),(S,\)) \ ?Sats\<^sup>+" + have "\b. ((S\<^sub>1,\\<^sub>1),b) \ ?Sats\<^sup>+ \ \c. b \ c \ ((S\<^sub>1,\\<^sub>1),c) \ ?Sats\<^sup>+" + proof - + fix b assume in_sat: "((S\<^sub>1,\\<^sub>1),b) \ ?Sats\<^sup>+" + hence "\c. (b,c) \ ?Sats" using * sat_not_stuck by (cases b) blast + thus "\c. b \ c \ ((S\<^sub>1,\\<^sub>1),c) \ ?Sats\<^sup>+" + using trancl_into_trancl[OF in_sat] by blast + qed + hence "\S' \'. (S,\) \ (S',\') \ ((S\<^sub>1,\\<^sub>1),(S',\')) \ ?Sats\<^sup>+" using a by auto + then obtain S' \' where S'\': "(S,\) \ (S',\')" "((S\<^sub>1,\\<^sub>1),(S',\')) \ ?Sats\<^sup>+" by auto + hence "\ \\<^sub>c \S', \'\" using * by blast + moreover have "(S\<^sub>1, \\<^sub>1) \\<^sup>+ (S,\)" using a trancl_mono by blast + ultimately have "((S,\),(S',\')) \ ?Sats" using S'\'(1) * a by blast + thus "\b. ((S,\),b) \ ?Sats" using S'\'(2) by blast + qed + hence "\f. \i::nat. (f i, f (Suc i)) \ ?Sats" + using infinite_chain_intro'[OF base] by blast + moreover have "?Sats \ LI_rel\<^sup>+" by auto + hence "\(\f. \i::nat. (f i, f (Suc i)) \ ?Sats)" + using LI_no_infinite_chain infinite_chain_mono by blast + ultimately show False by auto + qed + hence "\S\<^sub>2 \\<^sub>2. (S\<^sub>1, \\<^sub>1) \\<^sup>+ (S\<^sub>2, \\<^sub>2) \ simple S\<^sub>2 \ (\ \\<^sub>c \S\<^sub>2, \\<^sub>2\)" + using simple_if_stuck * by blast + thus ?thesis by (meson trancl_into_rtrancl) +qed (blast intro: \\ \\<^sub>c \S\<^sub>1, \\<^sub>1\\) +end + + +subsection \Corollary: Soundness and Completeness as a Single Theorem\ +corollary LI_soundness_and_completeness: + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S\<^sub>1 \\<^sub>1" + shows "\ \\<^sub>c \S\<^sub>1, \\<^sub>1\ \ (\S\<^sub>2 \\<^sub>2. (S\<^sub>1,\\<^sub>1) \\<^sup>* (S\<^sub>2,\\<^sub>2) \ simple S\<^sub>2 \ (\ \\<^sub>c \S\<^sub>2, \\<^sub>2\))" +by (metis LI_soundness[OF assms] LI_completeness[OF assms]) + +end + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Messages.thy b/Stateful_Protocol_Composition_and_Typing/Messages.thy new file mode 100644 index 0000000..6df19d3 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Messages.thy @@ -0,0 +1,538 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Messages.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Protocol Messages as (First-Order) Terms\ + +theory Messages + imports Miscellaneous "First_Order_Terms.Term" +begin + +subsection \Term-related definitions: subterms and free variables\ +abbreviation "the_Fun \ un_Fun1" +lemmas the_Fun_def = un_Fun1_def + +fun subterms::"('a,'b) term \ ('a,'b) terms" where + "subterms (Var x) = {Var x}" +| "subterms (Fun f T) = {Fun f T} \ (\t \ set T. subterms t)" + +abbreviation subtermeq (infix "\" 50) where "t' \ t \ (t' \ subterms t)" +abbreviation subterm (infix "\" 50) where "t' \ t \ (t' \ t \ t' \ t)" + +abbreviation "subterms\<^sub>s\<^sub>e\<^sub>t M \ \(subterms ` M)" +abbreviation subtermeqset (infix "\\<^sub>s\<^sub>e\<^sub>t" 50) where "t \\<^sub>s\<^sub>e\<^sub>t M \ (t \ subterms\<^sub>s\<^sub>e\<^sub>t M)" + +abbreviation fv where "fv \ vars_term" +lemmas fv_simps = term.simps(17,18) + +fun fv\<^sub>s\<^sub>e\<^sub>t where "fv\<^sub>s\<^sub>e\<^sub>t M = \(fv ` M)" + +abbreviation fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r where "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r p \ case p of (t,t') \ fv t \ fv t'" + +fun fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s where "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = \(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` set F)" + +abbreviation ground where "ground M \ fv\<^sub>s\<^sub>e\<^sub>t M = {}" + + +subsection \Variants that return lists insteads of sets\ +fun fv_list where + "fv_list (Var x) = [x]" +| "fv_list (Fun f T) = concat (map fv_list T)" + +definition fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s where + "fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ concat (map (\(t,t'). fv_list t@fv_list t') F)" + +fun subterms_list::"('a,'b) term \ ('a,'b) term list" where + "subterms_list (Var x) = [Var x]" +| "subterms_list (Fun f T) = remdups (Fun f T#concat (map subterms_list T))" + +lemma fv_list_is_fv: "fv t = set (fv_list t)" +by (induct t) auto + +lemma fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = set (fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)" +by (induct F) (auto simp add: fv_list_is_fv fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_def) + +lemma subterms_list_is_subterms: "subterms t = set (subterms_list t)" +by (induct t) auto + + +subsection \The subterm relation defined as a function\ +fun subterm_of where + "subterm_of t (Var y) = (t = Var y)" +| "subterm_of t (Fun f T) = (t = Fun f T \ list_ex (subterm_of t) T)" + +lemma subterm_of_iff_subtermeq[code_unfold]: "t \ t' = subterm_of t t'" +proof (induction t') + case (Fun f T) thus ?case + proof (cases "t = Fun f T") + case False thus ?thesis + using Fun.IH subterm_of.simps(2)[of t f T] + unfolding list_ex_iff by fastforce + qed simp +qed simp + +lemma subterm_of_ex_set_iff_subtermeqset[code_unfold]: "t \\<^sub>s\<^sub>e\<^sub>t M = (\t' \ M. subterm_of t t')" +using subterm_of_iff_subtermeq by blast + + +subsection \The subterm relation is a partial order on terms\ +interpretation "term": order "(\)" "(\)" +proof + show "s \ s" for s :: "('a,'b) term" + by (induct s rule: subterms.induct) auto + + show trans: "s \ t \ t \ u \ s \ u" for s t u :: "('a,'b) term" + by (induct u rule: subterms.induct) auto + + show "s \ t \ t \ s \ s = t" for s t :: "('a,'b) term" + proof (induction s arbitrary: t rule: subterms.induct[case_names Var Fun]) + case (Fun f T) + { assume 0: "t \ Fun f T" + then obtain u::"('a,'b) term" where u: "u \ set T" "t \ u" using Fun.prems(2) by auto + hence 1: "Fun f T \ u" using trans[OF Fun.prems(1)] by simp + + have 2: "u \ Fun f T" + by (cases u) (use u(1) in force, use u(1) subterms.simps(2)[of f T] in fastforce) + hence 3: "u = Fun f T" using Fun.IH[OF u(1) _ 1] by simp + + have "u \ t" using trans[OF 2 Fun.prems(1)] by simp + hence 4: "u = t" using Fun.IH[OF u(1) _ u(2)] by simp + + have "t = Fun f T" using 3 4 by simp + hence False using 0 by simp + } + thus ?case by auto + qed simp + thus "(s \ t) = (s \ t \ \(t \ s))" for s t :: "('a,'b) term" + by blast +qed + + +subsection \Lemmata concerning subterms and free variables\ +lemma fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append: "fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) = fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F@fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" +by (simp add: fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_def) + +lemma distinct_fv_list_idx_fv_disjoint: + assumes t: "distinct (fv_list t)" "Fun f T \ t" + and ij: "i < length T" "j < length T" "i < j" + shows "fv (T ! i) \ fv (T ! j) = {}" +using t +proof (induction t rule: fv_list.induct) + case (2 g S) + have "distinct (fv_list s)" when s: "s \ set S" for s + by (metis (no_types, lifting) s "2.prems"(1) concat_append distinct_append + map_append split_list fv_list.simps(2) concat.simps(2) list.simps(9)) + hence IH: "fv (T ! i) \ fv (T ! j) = {}" + when s: "s \ set S" "Fun f T \ s" for s + using "2.IH" s by blast + + show ?case + proof (cases "Fun f T = Fun g S") + case True + define U where "U \ map fv_list T" + + have a: "distinct (concat U)" + using "2.prems"(1) True unfolding U_def by auto + + have b: "i < length U" "j < length U" + using ij(1,2) unfolding U_def by simp_all + + show ?thesis + using b distinct_concat_idx_disjoint[OF a b ij(3)] + fv_list_is_fv[of "T ! i"] fv_list_is_fv[of "T ! j"] + unfolding U_def by force + qed (use IH "2.prems"(2) in auto) +qed force + +lemmas subtermeqI'[intro] = term.eq_refl + +lemma subtermeqI''[intro]: "t \ set T \ t \ Fun f T" +by force + +lemma finite_fv_set[intro]: "finite M \ finite (fv\<^sub>s\<^sub>e\<^sub>t M)" +by auto + +lemma finite_fun_symbols[simp]: "finite (funs_term t)" +by (induct t) simp_all + +lemma fv_set_mono: "M \ N \ fv\<^sub>s\<^sub>e\<^sub>t M \ fv\<^sub>s\<^sub>e\<^sub>t N" +by auto + +lemma subterms\<^sub>s\<^sub>e\<^sub>t_mono: "M \ N \ subterms\<^sub>s\<^sub>e\<^sub>t M \ subterms\<^sub>s\<^sub>e\<^sub>t N" +by auto + +lemma ground_empty[simp]: "ground {}" +by simp + +lemma ground_subset: "M \ N \ ground N \ ground M" +by auto + +lemma fv_map_fv_set: "\(set (map fv L)) = fv\<^sub>s\<^sub>e\<^sub>t (set L)" +by (induct L) auto + +lemma fv\<^sub>s\<^sub>e\<^sub>t_union: "fv\<^sub>s\<^sub>e\<^sub>t (M \ N) = fv\<^sub>s\<^sub>e\<^sub>t M \ fv\<^sub>s\<^sub>e\<^sub>t N" +by auto + +lemma finite_subset_Union: + fixes A::"'a set" and f::"'a \ 'b set" + assumes "finite (\a \ A. f a)" + shows "\B. finite B \ B \ A \ (\b \ B. f b) = (\a \ A. f a)" +by (metis assms eq_iff finite_subset_image finite_UnionD) + +lemma inv_set_fv: "finite M \ \(set (map fv (inv set M))) = fv\<^sub>s\<^sub>e\<^sub>t M" +using fv_map_fv_set[of "inv set M"] inv_set_fset by auto + +lemma ground_subterm: "fv t = {} \ t' \ t \ fv t' = {}" by (induct t) auto + +lemma empty_fv_not_var: "fv t = {} \ t \ Var x" by auto + +lemma empty_fv_exists_fun: "fv t = {} \ \f X. t = Fun f X" by (cases t) auto + +lemma vars_iff_subtermeq: "x \ fv t \ Var x \ t" by (induct t) auto + +lemma vars_iff_subtermeq_set: "x \ fv\<^sub>s\<^sub>e\<^sub>t M \ Var x \ subterms\<^sub>s\<^sub>e\<^sub>t M" +using vars_iff_subtermeq[of x] by auto + +lemma vars_if_subtermeq_set: "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t M \ x \ fv\<^sub>s\<^sub>e\<^sub>t M" +by (metis vars_iff_subtermeq_set) + +lemma subtermeq_set_if_vars: "x \ fv\<^sub>s\<^sub>e\<^sub>t M \ Var x \ subterms\<^sub>s\<^sub>e\<^sub>t M" +by (metis vars_iff_subtermeq_set) + +lemma vars_iff_subterm_or_eq: "x \ fv t \ Var x \ t \ Var x = t" +by (induct t) (auto simp add: vars_iff_subtermeq) + +lemma var_is_subterm: "x \ fv t \ Var x \ subterms t" +by (simp add: vars_iff_subtermeq) + +lemma subterm_is_var: "Var x \ subterms t \ x \ fv t" +by (simp add: vars_iff_subtermeq) + +lemma no_var_subterm: "\t \ Var v" by auto + +lemma fun_if_subterm: "t \ u \ \f X. u = Fun f X" by (induct u) simp_all + +lemma subtermeq_vars_subset: "M \ N \ fv M \ fv N" by (induct N) auto + +lemma fv_subterms[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (subterms t) = fv t" +by (induct t) auto + +lemma fv_subterms_set[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t M) = fv\<^sub>s\<^sub>e\<^sub>t M" +using subtermeq_vars_subset by auto + +lemma fv_subset: "t \ M \ fv t \ fv\<^sub>s\<^sub>e\<^sub>t M" +by auto + +lemma fv_subset_subterms: "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \ fv t \ fv\<^sub>s\<^sub>e\<^sub>t M" +using fv_subset fv_subterms_set by metis + +lemma subterms_finite[simp]: "finite (subterms t)" by (induction rule: subterms.induct) auto + +lemma subterms_union_finite: "finite M \ finite (\t \ M. subterms t)" +by (induction rule: subterms.induct) auto + +lemma subterms_subset: "t' \ t \ subterms t' \ subterms t" +by (induction rule: subterms.induct) auto + +lemma subterms_subset_set: "M \ subterms t \ subterms\<^sub>s\<^sub>e\<^sub>t M \ subterms t" +by (metis SUP_least contra_subsetD subterms_subset) + +lemma subset_subterms_Union[simp]: "M \ subterms\<^sub>s\<^sub>e\<^sub>t M" by auto + +lemma in_subterms_Union: "t \ M \ t \ subterms\<^sub>s\<^sub>e\<^sub>t M" using subset_subterms_Union by blast + +lemma in_subterms_subset_Union: "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \ subterms t \ subterms\<^sub>s\<^sub>e\<^sub>t M" +using subterms_subset by auto + +lemma subterm_param_split: + assumes "t \ Fun f X" + shows "\pre x suf. t \ x \ X = pre@x#suf" +proof - + obtain x where "t \ x" "x \ set X" using assms by auto + then obtain pre suf where "X = pre@x#suf" "x \ set pre \ x \ set suf" + by (meson split_list_first split_list_last) + thus ?thesis using \t \ x\ by auto +qed + +lemma ground_iff_no_vars: "ground (M::('a,'b) terms) \ (\v. Var v \ (\m \ M. subterms m))" +proof + assume "ground M" + hence "\v. \m \ M. v \ fv m" by auto + hence "\v. \m \ M. Var v \ subterms m" by (simp add: vars_iff_subtermeq) + thus "(\v. Var v \ (\m \ M. subterms m))" by simp +next + assume no_vars: "\v. Var v \ (\m \ M. subterms m)" + moreover + { assume "\ground M" + then obtain v and m::"('a,'b) term" where "m \ M" "fv m \ {}" "v \ fv m" by auto + hence "Var v \ (subterms m)" by (simp add: vars_iff_subtermeq) + hence "\v. Var v \ (\t \ M. subterms t)" using \m \ M\ by auto + hence False using no_vars by simp + } + ultimately show "ground M" by blast +qed + +lemma index_Fun_subterms_subset[simp]: "i < length T \ subterms (T ! i) \ subterms (Fun f T)" +by auto + +lemma index_Fun_fv_subset[simp]: "i < length T \ fv (T ! i) \ fv (Fun f T)" +using subtermeq_vars_subset by fastforce + +lemma subterms_union_ground: + assumes "ground M" + shows "ground (subterms\<^sub>s\<^sub>e\<^sub>t M)" +proof - + { fix t assume "t \ M" + hence "fv t = {}" + using ground_iff_no_vars[of M] assms + by auto + hence "\t' \ subterms t. fv t' = {}" using subtermeq_vars_subset[of _ t] by simp + hence "ground (subterms t)" by auto + } + thus ?thesis by auto +qed + +lemma Var_subtermeq: "t \ Var v \ t = Var v" by simp + +lemma subtermeq_imp_funs_term_subset: "s \ t \ funs_term s \ funs_term t" +by (induct t arbitrary: s) auto + +lemma subterms_const: "subterms (Fun f []) = {Fun f []}" by simp + +lemma subterm_subtermeq_neq: "\t \ u; u \ v\ \ t \ v" +by (metis term.eq_iff) + +lemma subtermeq_subterm_neq: "\t \ u; u \ v\ \ t \ v" +by (metis term.eq_iff) + +lemma subterm_size_lt: "x \ y \ size x < size y" +using not_less_eq size_list_estimation by (induct y, simp, fastforce) + +lemma in_subterms_eq: "\x \ subterms y; y \ subterms x\ \ subterms x = subterms y" +using term.antisym by auto + +lemma Fun_gt_params: "Fun f X \ (\x \ set X. subterms x)" +proof - + have "size_list size X < size (Fun f X)" by simp + hence "Fun f X \ set X" by (meson less_not_refl size_list_estimation) + hence "\x \ set X. Fun f X \ subterms x \ x \ subterms (Fun f X)" + by (metis term.antisym[of "Fun f X" _]) + moreover have "\x \ set X. x \ subterms (Fun f X)" by fastforce + ultimately show ?thesis by auto +qed + +lemma params_subterms[simp]: "set X \ subterms (Fun f X)" by auto + +lemma params_subterms_Union[simp]: "subterms\<^sub>s\<^sub>e\<^sub>t (set X) \ subterms (Fun f X)" by auto + +lemma Fun_subterm_inside_params: "t \ Fun f X \ t \ (\x \ (set X). subterms x)" +using Fun_gt_params by fastforce + +lemma Fun_param_is_subterm: "x \ set X \ x \ Fun f X" +using Fun_subterm_inside_params by fastforce + +lemma Fun_param_in_subterms: "x \ set X \ x \ subterms (Fun f X)" +using Fun_subterm_inside_params by fastforce + +lemma Fun_not_in_param: "x \ set X \ \Fun f X \ x" +using term.antisym by fast + +lemma Fun_ex_if_subterm: "t \ s \ \f T. Fun f T \ s \ t \ set T" +proof (induction s) + case (Fun f T) + then obtain s' where s': "s' \ set T" "t \ s'" by auto + show ?case + proof (cases "t = s'") + case True thus ?thesis using s' by blast + next + case False + thus ?thesis + using Fun.IH[OF s'(1)] s'(2) term.order_trans[OF _ Fun_param_in_subterms[OF s'(1), of f]] + by metis + qed +qed simp + +lemma const_subterm_obtain: + assumes "fv t = {}" + obtains c where "Fun c [] \ t" +using assms +proof (induction t) + case (Fun f T) thus ?case by (cases "T = []") force+ +qed simp + +lemma const_subterm_obtain': "fv t = {} \ \c. Fun c [] \ t" +by (metis const_subterm_obtain) + +lemma subterms_singleton: + assumes "(\v. t = Var v) \ (\f. t = Fun f [])" + shows "subterms t = {t}" +using assms by (cases t) auto + +lemma subtermeq_Var_const: + assumes "s \ t" + shows "t = Var v \ s = Var v" "t = Fun f [] \ s = Fun f []" +using assms by fastforce+ + +lemma subterms_singleton': + assumes "subterms t = {t}" + shows "(\v. t = Var v) \ (\f. t = Fun f [])" +proof (cases t) + case (Fun f T) + { fix s S assume "T = s#S" + hence "s \ subterms t" using Fun by auto + hence "s = t" using assms by auto + hence False + using Fun_param_is_subterm[of s "s#S" f] \T = s#S\ Fun + by auto + } + hence "T = []" by (cases T) auto + thus ?thesis using Fun by simp +qed (simp add: assms) + +lemma funs_term_subterms_eq[simp]: + "(\s \ subterms t. funs_term s) = funs_term t" + "(\s \ subterms\<^sub>s\<^sub>e\<^sub>t M. funs_term s) = \(funs_term ` M)" +proof - + show "\t. \(funs_term ` subterms t) = funs_term t" + using term.order_refl subtermeq_imp_funs_term_subset by blast + thus "\(funs_term ` (subterms\<^sub>s\<^sub>e\<^sub>t M)) = \(funs_term ` M)" by force +qed + +lemmas subtermI'[intro] = Fun_param_is_subterm + +lemma funs_term_Fun_subterm: "f \ funs_term t \ \T. Fun f T \ subterms t" +proof (induction t) + case (Fun g T) + hence "f = g \ (\s \ set T. f \ funs_term s)" by simp + thus ?case + proof + assume "\s \ set T. f \ funs_term s" + then obtain s where "s \ set T" "\T. Fun f T \ subterms s" using Fun.IH by auto + thus ?thesis by auto + qed (auto simp add: Fun) +qed simp + +lemma funs_term_Fun_subterm': "Fun f T \ subterms t \ f \ funs_term t" +by (induct t) auto + +lemma zip_arg_subterm: + assumes "(s,t) \ set (zip X Y)" + shows "s \ Fun f X" "t \ Fun g Y" +proof - + from assms have *: "s \ set X" "t \ set Y" by (meson in_set_zipE)+ + show "s \ Fun f X" by (metis Fun_param_is_subterm[OF *(1)]) + show "t \ Fun g Y" by (metis Fun_param_is_subterm[OF *(2)]) +qed + +lemma fv_disj_Fun_subterm_param_cases: + assumes "fv t \ X = {}" "Fun f T \ subterms t" + shows "T = [] \ (\s\set T. s \ Var ` X)" +proof (cases T) + case (Cons s S) + hence "s \ subterms t" + using assms(2) term.order_trans[of _ "Fun f T" t] + by auto + hence "fv s \ X = {}" using assms(1) fv_subterms by force + thus ?thesis using Cons by auto +qed simp + +lemma fv_eq_FunI: + assumes "length T = length S" "\i. i < length T \ fv (T ! i) = fv (S ! i)" + shows "fv (Fun f T) = fv (Fun g S)" +using assms +proof (induction T arbitrary: S) + case (Cons t T S') + then obtain s S where S': "S' = s#S" by (cases S') simp_all + thus ?case using Cons by fastforce +qed simp + +lemma fv_eq_FunI': + assumes "length T = length S" "\i. i < length T \ x \ fv (T ! i) \ x \ fv (S ! i)" + shows "x \ fv (Fun f T) \ x \ fv (Fun g S)" +using assms +proof (induction T arbitrary: S) + case (Cons t T S') + then obtain s S where S': "S' = s#S" by (cases S') simp_all + thus ?case using Cons by fastforce +qed simp + +lemma finite_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[simp]: "finite (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s x)" by auto + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_Nil[simp]: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s [] = {}" by simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_singleton[simp]: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s [(t,s)] = fv t \ fv s" by simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_Cons: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) = fv s \ fv t \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" by simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" by simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_mono: "set M \ set N \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s M \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s N" by auto + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_inI[intro]: + "f \ set F \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r f \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + "f \ set F \ x \ fv (fst f) \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + "f \ set F \ x \ fv (snd f) \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + "(t,s) \ set F \ x \ fv t \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + "(t,s) \ set F \ x \ fv s \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" +using UN_I by fastforce+ + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_cons_subset: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#F)" +by auto + + +subsection \Other lemmata\ +lemma nonvar_term_has_composed_shallow_term: + fixes t::"('f,'v) term" + assumes "\(\x. t = Var x)" + shows "\f T. Fun f T \ t \ (\s \ set T. (\c. s = Fun c []) \ (\x. s = Var x))" +proof - + let ?Q = "\S. \s \ set S. (\c. s = Fun c []) \ (\x. s = Var x)" + let ?P = "\t. \g S. Fun g S \ t \ ?Q S" + { fix t::"('f,'v) term" + have "(\x. t = Var x) \ ?P t" + proof (induction t) + case (Fun h R) show ?case + proof (cases "R = [] \ (\r \ set R. \x. r = Var x)") + case False + then obtain r g S where "r \ set R" "?P r" "Fun g S \ r" "?Q S" using Fun.IH by fast + thus ?thesis by auto + qed force + qed simp + } thus ?thesis using assms by blast +qed + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Miscellaneous.thy b/Stateful_Protocol_Composition_and_Typing/Miscellaneous.thy new file mode 100644 index 0000000..7912f10 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Miscellaneous.thy @@ -0,0 +1,492 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Miscellaneous.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Miscellaneous Lemmata\ +theory Miscellaneous +imports Main "HOL-Library.Sublist" "HOL-Library.While_Combinator" +begin + +subsection \List: zip, filter, map\ +lemma zip_arg_subterm_split: + assumes "(x,y) \ set (zip xs ys)" + obtains xs' xs'' ys' ys'' where "xs = xs'@x#xs''" "ys = ys'@y#ys''" "length xs' = length ys'" +proof - + from assms have "\zs zs' vs vs'. xs = zs@x#zs' \ ys = vs@y#vs' \ length zs = length vs" + proof (induction ys arbitrary: xs) + case (Cons y' ys' xs) + then obtain x' xs' where x': "xs = x'#xs'" + by (metis empty_iff list.exhaust list.set(1) set_zip_leftD) + show ?case + by (cases "(x, y) \ set (zip xs' ys')", + metis \xs = x'#xs'\ Cons.IH[of xs'] Cons_eq_appendI list.size(4), + use Cons.prems x' in fastforce) + qed simp + thus ?thesis using that by blast +qed + +lemma zip_arg_index: + assumes "(x,y) \ set (zip xs ys)" + obtains i where "xs ! i = x" "ys ! i = y" "i < length xs" "i < length ys" +proof - + obtain xs1 xs2 ys1 ys2 where "xs = xs1@x#xs2" "ys = ys1@y#ys2" "length xs1 = length ys1" + using zip_arg_subterm_split[OF assms] by moura + thus ?thesis using nth_append_length[of xs1 x xs2] nth_append_length[of ys1 y ys2] that by simp +qed + +lemma filter_nth: "i < length (filter P xs) \ P (filter P xs ! i)" +using nth_mem by force + +lemma list_all_filter_eq: "list_all P xs \ filter P xs = xs" +by (metis list_all_iff filter_True) + +lemma list_all_filter_nil: + assumes "list_all P xs" + and "\x. P x \ \Q x" + shows "filter Q xs = []" +using assms by (induct xs) simp_all + +lemma list_all_concat: "list_all (list_all f) P \ list_all f (concat P)" +by (induct P) auto + +lemma map_upt_index_eq: + assumes "j < length xs" + shows "(map (\i. xs ! is i) [0..(i,p) \ insert x (set xs). \(i',p') \ insert x (set xs). p = p' \ i = i'" + shows "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" +using assms +proof (induction xs rule: List.rev_induct) + case (snoc y xs) + hence IH: "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" by fastforce + + obtain iy py where y: "y = (iy,py)" by (metis surj_pair) + obtain ix px where x: "x = (ix,px)" by (metis surj_pair) + + have "(ix,px) \ insert x (set (y#xs))" "(iy,py) \ insert x (set (y#xs))" using y x by auto + hence *: "iy = ix" when "py = px" using that snoc.prems by auto + + show ?case + proof (cases "px = py") + case True + hence "y = x" using * y x by auto + thus ?thesis using IH by simp + next + case False + hence "y \ x" using y x by simp + have "List.insert x (xs@[y]) = (List.insert x xs)@[y]" + proof - + have 1: "insert y (set xs) = set (xs@[y])" by simp + have 2: "x \ insert y (set xs) \ x \ set xs" using \y \ x\ by blast + show ?thesis using 1 2 by (metis (no_types) List.insert_def append_Cons insertCI) + qed + thus ?thesis using IH y x False by (auto simp add: List.insert_def) + qed +qed simp + +lemma map_append_inv: "map f xs = ys@zs \ \vs ws. xs = vs@ws \ map f vs = ys \ map f ws = zs" +proof (induction xs arbitrary: ys zs) + case (Cons x xs') + note prems = Cons.prems + note IH = Cons.IH + + show ?case + proof (cases ys) + case (Cons y ys') + then obtain vs' ws where *: "xs' = vs'@ws" "map f vs' = ys'" "map f ws = zs" + using prems IH[of ys' zs] by auto + hence "x#xs' = (x#vs')@ws" "map f (x#vs') = y#ys'" using Cons prems by force+ + thus ?thesis by (metis Cons *(3)) + qed (use prems in simp) +qed simp + + +subsection \List: subsequences\ +lemma subseqs_set_subset: + assumes "ys \ set (subseqs xs)" + shows "set ys \ set xs" +using assms subseqs_powset[of xs] by auto + +lemma subset_sublist_exists: + "ys \ set xs \ \zs. set zs = ys \ zs \ set (subseqs xs)" +proof (induction xs arbitrary: ys) + case Cons thus ?case by (metis (no_types, lifting) Pow_iff imageE subseqs_powset) +qed simp + +lemma map_subseqs: "map (map f) (subseqs xs) = subseqs (map f xs)" +proof (induct xs) + case (Cons x xs) + have "map (Cons (f x)) (map (map f) (subseqs xs)) = map (map f) (map (Cons x) (subseqs xs))" + by (induct "subseqs xs") auto + thus ?case by (simp add: Let_def Cons) +qed simp + +lemma subseqs_Cons: + assumes "ys \ set (subseqs xs)" + shows "ys \ set (subseqs (x#xs))" +by (metis assms Un_iff set_append subseqs.simps(2)) + +lemma subseqs_subset: + assumes "ys \ set (subseqs xs)" + shows "set ys \ set xs" +using assms by (metis Pow_iff image_eqI subseqs_powset) + + +subsection \List: prefixes, suffixes\ +lemma suffix_Cons': "suffix [x] (y#ys) \ suffix [x] ys \ (y = x \ ys = [])" +using suffix_Cons[of "[x]"] by auto + +lemma prefix_Cons': "prefix (x#xs) (x#ys) \ prefix xs ys" +by simp + +lemma prefix_map: "prefix xs (map f ys) \ \zs. prefix zs ys \ map f zs = xs" +using map_append_inv unfolding prefix_def by fast + +lemma length_prefix_ex: + assumes "n \ length xs" + shows "\ys zs. xs = ys@zs \ length ys = n" + using assms +proof (induction n) + case (Suc n) + then obtain ys zs where IH: "xs = ys@zs" "length ys = n" by moura + hence "length zs > 0" using Suc.prems(1) by auto + then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc) + hence "length (ys@[v]) = Suc n" using IH(2) by simp + thus ?case using IH(1) v by (metis append.assoc append_Cons append_Nil) +qed simp + +lemma length_prefix_ex': + assumes "n < length xs" + shows "\ys zs. xs = ys@xs ! n#zs \ length ys = n" +proof - + obtain ys zs where xs: "xs = ys@zs" "length ys = n" using assms length_prefix_ex[of n xs] by moura + hence "length zs > 0" using assms by auto + then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc) + hence "(ys@zs) ! n = v" using xs by auto + thus ?thesis using v xs by auto +qed + +lemma length_prefix_ex2: + assumes "i < length xs" "j < length xs" "i < j" + shows "\ys zs vs. xs = ys@xs ! i#zs@xs ! j#vs \ length ys = i \ length zs = j - i - 1" +by (smt assms length_prefix_ex' nth_append append.assoc append.simps(2) add_diff_cancel_left' + diff_Suc_1 length_Cons length_append) + + +subsection \List: products\ +lemma product_lists_Cons: + "x#xs \ set (product_lists (y#ys)) \ (xs \ set (product_lists ys) \ x \ set y)" +by auto + +lemma product_lists_in_set_nth: + assumes "xs \ set (product_lists ys)" + shows "\i set (ys ! i)" +proof - + have 0: "length ys = length xs" using assms(1) by (simp add: in_set_product_lists_length) + thus ?thesis using assms + proof (induction ys arbitrary: xs) + case (Cons y ys) + obtain x xs' where xs: "xs = x#xs'" using Cons.prems(1) by (metis length_Suc_conv) + hence "xs' \ set (product_lists ys) \ \i set (ys ! i)" + "length ys = length xs'" "x#xs' \ set (product_lists (y#ys))" + using Cons by simp_all + thus ?case using xs product_lists_Cons[of x xs' y ys] by (simp add: nth_Cons') + qed simp +qed + +lemma product_lists_in_set_nth': + assumes "\i set (xs ! i)" + and "length xs = length ys" + shows "ys \ set (product_lists xs)" +using assms +proof (induction xs arbitrary: ys) + case (Cons x xs) + obtain y ys' where ys: "ys = y#ys'" using Cons.prems(2) by (metis length_Suc_conv) + hence "ys' \ set (product_lists xs)" "y \ set x" "length xs = length ys'" + using Cons by fastforce+ + thus ?case using ys product_lists_Cons[of y ys' x xs] by (simp add: nth_Cons') +qed simp + + +subsection \Other Lemmata\ +lemma inv_set_fset: "finite M \ set (inv set M) = M" +unfolding inv_def by (metis (mono_tags) finite_list someI_ex) + +lemma lfp_eqI': + assumes "mono f" + and "f C = C" + and "\X \ Pow C. f X = X \ X = C" + shows "lfp f = C" +by (metis PowI assms lfp_lowerbound lfp_unfold subset_refl) + +lemma lfp_while': + fixes f::"'a set \ 'a set" and M::"'a set" + defines "N \ while (\A. f A \ A) f {}" + assumes f_mono: "mono f" + and N_finite: "finite N" + and N_supset: "f N \ N" + shows "lfp f = N" +proof - + have *: "f X \ N" when "X \ N" for X using N_supset monoD[OF f_mono that] by blast + show ?thesis + using lfp_while[OF f_mono * N_finite] + by (simp add: N_def) +qed + +lemma lfp_while'': + fixes f::"'a set \ 'a set" and M::"'a set" + defines "N \ while (\A. f A \ A) f {}" + assumes f_mono: "mono f" + and lfp_finite: "finite (lfp f)" + shows "lfp f = N" +proof - + have *: "f X \ lfp f" when "X \ lfp f" for X + using lfp_fixpoint[OF f_mono] monoD[OF f_mono that] + by blast + show ?thesis + using lfp_while[OF f_mono * lfp_finite] + by (simp add: N_def) +qed + +lemma preordered_finite_set_has_maxima: + assumes "finite A" "A \ {}" + shows "\a::'a::{preorder} \ A. \b \ A. \(a < b)" +using assms +proof (induction A rule: finite_induct) + case (insert a A) thus ?case + by (cases "A = {}", simp, metis insert_iff order_trans less_le_not_le) +qed simp + +lemma partition_index_bij: + fixes n::nat + obtains I k where + "bij_betw I {0.. n" + "\i. i < k \ P (I i)" + "\i. k \ i \ i < n \ \(P (I i))" +proof - + define A where "A = filter P [0..i. \P i) [0..n. (A@B) ! n)" + + note defs = A_def B_def k_def I_def + + have k1: "k \ n" by (metis defs(1,3) diff_le_self dual_order.trans length_filter_le length_upt) + + have "i < k \ P (A ! i)" for i by (metis defs(1,3) filter_nth) + hence k2: "i < k \ P ((A@B) ! i)" for i by (simp add: defs nth_append) + + have "i < length B \ \(P (B ! i))" for i by (metis defs(2) filter_nth) + hence "i < length B \ \(P ((A@B) ! (k + i)))" for i using k_def by simp + hence "k \ i \ i < k + length B \ \(P ((A@B) ! i))" for i + by (metis add.commute add_less_imp_less_right le_add_diff_inverse2) + hence k3: "k \ i \ i < n \ \(P ((A@B) ! i))" for i by (simp add: defs sum_length_filter_compl) + + have *: "length (A@B) = n" "set (A@B) = {0.. {0.. y \ {0.. (I x = I y) = (x = y)" + by (metis *(1,3) defs(4) nth_eq_iff_index_eq atLeastLessThan_iff) + next + fix x show "x \ {0.. I x \ {0.. {0.. \x \ {0..x. x \ set xs \ finite {y. P x y}" + shows "finite {ys. length xs = length ys \ (\y \ set ys. \x \ set xs. P x y)}" +proof - + define Q where "Q \ \ys. \y \ set ys. \x \ set xs. P x y" + define M where "M \ {y. \x \ set xs. P x y}" + + have 0: "finite M" using assms unfolding M_def by fastforce + + have "Q ys \ set ys \ M" + "(Q ys \ length ys = length xs) \ (length xs = length ys \ Q ys)" + for ys + unfolding Q_def M_def by auto + thus ?thesis + using finite_lists_length_eq[OF 0, of "length xs"] + unfolding Q_def by presburger +qed + +lemma trancl_eqI: + assumes "\(a,b) \ A. \(c,d) \ A. b = c \ (a,d) \ A" + shows "A = A\<^sup>+" +proof + show "A\<^sup>+ \ A" + proof + fix x assume x: "x \ A\<^sup>+" + then obtain a b where ab: "x = (a,b)" by (metis surj_pair) + hence "(a,b) \ A\<^sup>+" using x by metis + hence "(a,b) \ A" using assms by (induct rule: trancl_induct) auto + thus "x \ A" using ab by metis + qed +qed auto + +lemma trancl_eqI': + assumes "\(a,b) \ A. \(c,d) \ A. b = c \ a \ d \ (a,d) \ A" + and "\(a,b) \ A. a \ b" + shows "A = {(a,b) \ A\<^sup>+. a \ b}" +proof + show "{(a,b) \ A\<^sup>+. a \ b} \ A" + proof + fix x assume x: "x \ {(a,b) \ A\<^sup>+. a \ b}" + then obtain a b where ab: "x = (a,b)" by (metis surj_pair) + hence "(a,b) \ A\<^sup>+" "a \ b" using x by blast+ + hence "(a,b) \ A" + proof (induction rule: trancl_induct) + case base thus ?case by blast + next + case step thus ?case using assms(1) by force + qed + thus "x \ A" using ab by metis + qed +qed (use assms(2) in auto) + +lemma distinct_concat_idx_disjoint: + assumes xs: "distinct (concat xs)" + and ij: "i < length xs" "j < length xs" "i < j" + shows "set (xs ! i) \ set (xs ! j) = {}" +proof - + obtain ys zs vs where ys: "xs = ys@xs ! i#zs@xs ! j#vs" "length ys = i" "length zs = j - i - 1" + using length_prefix_ex2[OF ij] by moura + thus ?thesis + using xs concat_append[of "ys@xs ! i#zs" "xs ! j#vs"] + distinct_append[of "concat (ys@xs ! i#zs)" "concat (xs ! j#vs)"] + by auto +qed + +lemma remdups_ex2: + "length (remdups xs) > 1 \ \a \ set xs. \b \ set xs. a \ b" +by (metis distinct_Ex1 distinct_remdups less_trans nth_mem set_remdups zero_less_one zero_neq_one) + +lemma trancl_minus_refl_idem: + defines "cl \ \ts. {(a,b) \ ts\<^sup>+. a \ b}" + shows "cl (cl ts) = cl ts" +proof - + have 0: "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \ ts\<^sup>+" "(cl ts)\<^sup>+ \ (ts\<^sup>+)\<^sup>+" + proof - + show "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \ ts\<^sup>+" unfolding cl_def by auto + thus "(cl ts)\<^sup>+ \ (ts\<^sup>+)\<^sup>+" using trancl_mono[of _ "cl ts" "ts\<^sup>+"] by blast + qed + + have 1: "t \ cl (cl ts)" when t: "t \ cl ts" for t + using t 0 unfolding cl_def by fast + + have 2: "t \ cl ts" when t: "t \ cl (cl ts)" for t + proof - + obtain a b where ab: "t = (a,b)" by (metis surj_pair) + have "t \ (cl ts)\<^sup>+" and a_neq_b: "a \ b" using t unfolding cl_def ab by force+ + hence "t \ ts\<^sup>+" using 0 by blast + thus ?thesis using a_neq_b unfolding cl_def ab by blast + qed + + show ?thesis using 1 2 by blast +qed + + +subsection \Infinite Paths in Relations as Mappings from Naturals to States\ +context +begin + +private fun rel_chain_fun::"nat \ 'a \ 'a \ ('a \ 'a) set \ 'a" where + "rel_chain_fun 0 x _ _ = x" +| "rel_chain_fun (Suc i) x y r = (if i = 0 then y else SOME z. (rel_chain_fun i x y r, z) \ r)" + +lemma infinite_chain_intro: + fixes r::"('a \ 'a) set" + assumes "\(a,b) \ r. \c. (b,c) \ r" "r \ {}" + shows "\f. \i::nat. (f i, f (Suc i)) \ r" +proof - + from assms(2) obtain a b where "(a,b) \ r" by auto + + let ?P = "\i. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \ r" + let ?Q = "\i. \z. (rel_chain_fun i a b r, z) \ r" + + have base: "?P 0" using \(a,b) \ r\ by auto + + have step: "?P (Suc i)" when i: "?P i" for i + proof - + have "?Q (Suc i)" using assms(1) i by auto + thus ?thesis using someI_ex[OF \?Q (Suc i)\] by auto + qed + + have "\i::nat. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \ r" + using base step nat_induct[of ?P] by simp + thus ?thesis by fastforce +qed + +end + +lemma infinite_chain_intro': + fixes r::"('a \ 'a) set" + assumes base: "\b. (x,b) \ r" and step: "\b. (x,b) \ r\<^sup>+ \ (\c. (b,c) \ r)" + shows "\f. \i::nat. (f i, f (Suc i)) \ r" +proof - + let ?s = "{(a,b) \ r. a = x \ (x,a) \ r\<^sup>+}" + + have "?s \ {}" using base by auto + + have "\c. (b,c) \ ?s" when ab: "(a,b) \ ?s" for a b + proof (cases "a = x") + case False + hence "(x,a) \ r\<^sup>+" using ab by auto + hence "(x,b) \ r\<^sup>+" using \(a,b) \ ?s\ by auto + thus ?thesis using step by auto + qed (use ab step in auto) + hence "\f. \i. (f i, f (Suc i)) \ ?s" using infinite_chain_intro[of ?s] \?s \ {}\ by blast + thus ?thesis by auto +qed + +lemma infinite_chain_mono: + assumes "S \ T" "\f. \i::nat. (f i, f (Suc i)) \ S" + shows "\f. \i::nat. (f i, f (Suc i)) \ T" +using assms by auto + +end diff --git a/Stateful_Protocol_Composition_and_Typing/More_Unification.thy b/Stateful_Protocol_Composition_and_Typing/More_Unification.thy new file mode 100644 index 0000000..d4b098f --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/More_Unification.thy @@ -0,0 +1,3228 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* +Based on src/HOL/ex/Unification.thy packaged with Isabelle/HOL 2015 having the following license: + +ISABELLE COPYRIGHT NOTICE, LICENCE AND DISCLAIMER. + +Copyright (c) 1986-2015, + University of Cambridge, + Technische Universitaet Muenchen, + and contributors. + + All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +* Neither the name of the University of Cambridge or the Technische +Universitaet Muenchen nor the names of their contributors may be used +to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + + +(* Title: More_Unification.thy + Author: Andreas Viktor Hess, DTU + + Originally based on src/HOL/ex/Unification.thy (Isabelle/HOL 2015) by: + Author: Martin Coen, Cambridge University Computer Laboratory + Author: Konrad Slind, TUM & Cambridge University Computer Laboratory + Author: Alexander Krauss, TUM +*) + +section \Definitions and Properties Related to Substitutions and Unification\ + +theory More_Unification + imports Messages "First_Order_Terms.Unification" +begin + +subsection \Substitutions\ + +abbreviation subst_apply_list (infix "\\<^sub>l\<^sub>i\<^sub>s\<^sub>t" 51) where + "T \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \ \ map (\t. t \ \) T" + +abbreviation subst_apply_pair (infixl "\\<^sub>p" 60) where + "d \\<^sub>p \ \ (case d of (t,t') \ (t \ \, t' \ \))" + +abbreviation subst_apply_pair_set (infixl "\\<^sub>p\<^sub>s\<^sub>e\<^sub>t" 60) where + "M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ (\d. d \\<^sub>p \) ` M" + +definition subst_apply_pairs (infix "\\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s" 51) where + "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ \ map (\f. f \\<^sub>p \) F" + +abbreviation subst_more_general_than (infixl "\\<^sub>\" 50) where + "\ \\<^sub>\ \ \ \\. \ = \ \\<^sub>s \" + +abbreviation subst_support (infix "supports" 50) where + "\ supports \ \ (\x. \ x \ \ = \ x)" + +abbreviation rm_var where + "rm_var v s \ s(v := Var v)" + +abbreviation rm_vars where + "rm_vars vs \ \ (\v. if v \ vs then Var v else \ v)" + +definition subst_elim where + "subst_elim \ v \ \t. v \ fv (t \ \)" + +definition subst_idem where + "subst_idem s \ s \\<^sub>s s = s" + +lemma subst_support_def: "\ supports \ \ \ = \ \\<^sub>s \" +unfolding subst_compose_def by metis + +lemma subst_supportD: "\ supports \ \ \ \\<^sub>\ \" +using subst_support_def by auto + +lemma rm_vars_empty[simp]: "rm_vars {} s = s" "rm_vars (set []) s = s" +by simp_all + +lemma rm_vars_singleton: "rm_vars {v} s = rm_var v s" +by auto + +lemma subst_apply_terms_empty: "M \\<^sub>s\<^sub>e\<^sub>t Var = M" +by simp + +lemma subst_agreement: "(t \ r = t \ s) \ (\v \ fv t. Var v \ r = Var v \ s)" +by (induct t) auto + +lemma repl_invariance[dest?]: "v \ fv t \ t \ s(v := u) = t \ s" +by (simp add: subst_agreement) + +lemma subst_idx_map: + assumes "\i \ set I. i < length T" + shows "(map ((!) T) I) \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \ = map ((!) (map (\t. t \ \) T)) I" +using assms by auto + +lemma subst_idx_map': + assumes "\i \ fv\<^sub>s\<^sub>e\<^sub>t (set K). i < length T" + shows "(K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T) \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \ = K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t ((!) (map (\t. t \ \) T))" (is "?A = ?B") +proof - + have "T ! i \ \ = (map (\t. t \ \) T) ! i" + when "i < length T" for i + using that by auto + hence "T ! i \ \ = (map (\t. t \ \) T) ! i" + when "i \ fv\<^sub>s\<^sub>e\<^sub>t (set K)" for i + using that assms by auto + hence "k \ (!) T \ \ = k \ (!) (map (\t. t \ \) T)" + when "fv k \ fv\<^sub>s\<^sub>e\<^sub>t (set K)" for k + using that by (induction k) force+ + thus ?thesis by auto +qed + +lemma subst_remove_var: "v \ fv s \ v \ fv (t \ Var(v := s))" +by (induct t) simp_all + +lemma subst_set_map: "x \ set X \ x \ s \ set (map (\x. x \ s) X)" +by simp + +lemma subst_set_idx_map: + assumes "\i \ I. i < length T" + shows "(!) T ` I \\<^sub>s\<^sub>e\<^sub>t \ = (!) (map (\t. t \ \) T) ` I" (is "?A = ?B") +proof + have *: "T ! i \ \ = (map (\t. t \ \) T) ! i" + when "i < length T" for i + using that by auto + + show "?A \ ?B" using * assms by blast + show "?B \ ?A" using * assms by auto +qed + +lemma subst_set_idx_map': + assumes "\i \ fv\<^sub>s\<^sub>e\<^sub>t K. i < length T" + shows "K \\<^sub>s\<^sub>e\<^sub>t (!) T \\<^sub>s\<^sub>e\<^sub>t \ = K \\<^sub>s\<^sub>e\<^sub>t (!) (map (\t. t \ \) T)" (is "?A = ?B") +proof + have "T ! i \ \ = (map (\t. t \ \) T) ! i" + when "i < length T" for i + using that by auto + hence "T ! i \ \ = (map (\t. t \ \) T) ! i" + when "i \ fv\<^sub>s\<^sub>e\<^sub>t K" for i + using that assms by auto + hence *: "k \ (!) T \ \ = k \ (!) (map (\t. t \ \) T)" + when "fv k \ fv\<^sub>s\<^sub>e\<^sub>t K" for k + using that by (induction k) force+ + + show "?A \ ?B" using * by auto + show "?B \ ?A" using * by force +qed + +lemma subst_term_list_obtain: + assumes "\i < length T. \s. P (T ! i) s \ S ! i = s \ \" + and "length T = length S" + shows "\U. length T = length U \ (\i < length T. P (T ! i) (U ! i)) \ S = map (\u. u \ \) U" +using assms +proof (induction T arbitrary: S) + case (Cons t T S') + then obtain s S where S': "S' = s#S" by (cases S') auto + + have "\i < length T. \s. P (T ! i) s \ S ! i = s \ \" "length T = length S" + using Cons.prems S' by force+ + then obtain U where U: + "length T = length U" "\i < length T. P (T ! i) (U ! i)" "S = map (\u. u \ \) U" + using Cons.IH by moura + + obtain u where u: "P t u" "s = u \ \" + using Cons.prems(1) S' by auto + + have 1: "length (t#T) = length (u#U)" + using Cons.prems(2) U(1) by fastforce + + have 2: "\i < length (t#T). P ((t#T) ! i) ((u#U) ! i)" + using u(1) U(2) by (simp add: nth_Cons') + + have 3: "S' = map (\u. u \ \) (u#U)" + using U u S' by simp + + show ?case using 1 2 3 by blast +qed simp + +lemma subst_mono: "t \ u \ t \ s \ u \ s" +by (induct u) auto + +lemma subst_mono_fv: "x \ fv t \ s x \ t \ s" +by (induct t) auto + +lemma subst_mono_neq: + assumes "t \ u" + shows "t \ s \ u \ s" +proof (cases u) + case (Var v) + hence False using \t \ u\ by simp + thus ?thesis .. +next + case (Fun f X) + then obtain x where "x \ set X" "t \ x" using \t \ u\ by auto + hence "t \ s \ x \ s" using subst_mono by metis + + obtain Y where "Fun f X \ s = Fun f Y" by auto + hence "x \ s \ set Y" using \x \ set X\ by auto + hence "x \ s \ Fun f X \ s" using \Fun f X \ s = Fun f Y\ Fun_param_is_subterm by simp + hence "t \ s \ Fun f X \ s" using \t \ s \ x \ s\ by (metis term.dual_order.trans term.eq_iff) + thus ?thesis using \u = Fun f X\ \t \ u\ by metis +qed + +lemma subst_no_occs[dest]: "\Var v \ t \ t \ Var(v := s) = t" +by (induct t) (simp_all add: map_idI) + +lemma var_comp[simp]: "\ \\<^sub>s Var = \" "Var \\<^sub>s \ = \" +unfolding subst_compose_def by simp_all + +lemma subst_comp_all: "M \\<^sub>s\<^sub>e\<^sub>t (\ \\<^sub>s \) = (M \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>s\<^sub>e\<^sub>t \" +using subst_subst_compose[of _ \ \] by auto + +lemma subst_all_mono: "M \ M' \ M \\<^sub>s\<^sub>e\<^sub>t s \ M' \\<^sub>s\<^sub>e\<^sub>t s" +by auto + +lemma subst_comp_set_image: "(\ \\<^sub>s \) ` X = \ ` X \\<^sub>s\<^sub>e\<^sub>t \" +using subst_compose by fastforce + +lemma subst_ground_ident[dest?]: "fv t = {} \ t \ s = t" +by (induct t, simp, metis subst_agreement empty_iff subst_apply_term_empty) + +lemma subst_ground_ident_compose: + "fv (\ x) = {} \ (\ \\<^sub>s \) x = \ x" + "fv (t \ \) = {} \ t \ (\ \\<^sub>s \) = t \ \" +using subst_subst_compose[of t \ \] +by (simp_all add: subst_compose_def subst_ground_ident) + +lemma subst_all_ground_ident[dest?]: "ground M \ M \\<^sub>s\<^sub>e\<^sub>t s = M" +proof - + assume "ground M" + hence "\t. t \ M \ fv t = {}" by auto + hence "\t. t \ M \ t \ s = t" by (metis subst_ground_ident) + moreover have "\t. t \ M \ t \ s \ M \\<^sub>s\<^sub>e\<^sub>t s" by (metis imageI) + ultimately show "M \\<^sub>s\<^sub>e\<^sub>t s = M" by (simp add: image_cong) +qed + +lemma subst_eqI[intro]: "(\t. t \ \ = t \ \) \ \ = \" +proof - + assume "\t. t \ \ = t \ \" + hence "\v. Var v \ \ = Var v \ \" by auto + thus "\ = \" by auto +qed + +lemma subst_cong: "\\ = \'; \ = \'\ \ (\ \\<^sub>s \) = (\' \\<^sub>s \')" +by auto + +lemma subst_mgt_bot[simp]: "Var \\<^sub>\ \" +by simp + +lemma subst_mgt_refl[simp]: "\ \\<^sub>\ \" +by (metis var_comp(1)) + +lemma subst_mgt_trans: "\\ \\<^sub>\ \; \ \\<^sub>\ \\ \ \ \\<^sub>\ \" +by (metis subst_compose_assoc) + +lemma subst_mgt_comp: "\ \\<^sub>\ \ \\<^sub>s \" +by auto + +lemma subst_mgt_comp': "\ \\<^sub>s \ \\<^sub>\ \ \ \ \\<^sub>\ \" +by (metis subst_compose_assoc) + +lemma var_self: "(\w. if w = v then Var v else Var w) = Var" +using subst_agreement by auto + +lemma var_same[simp]: "Var(v := t) = Var \ t = Var v" +by (intro iffI, metis fun_upd_same, simp add: var_self) + +lemma subst_eq_if_eq_vars: "(\v. (Var v) \ \ = (Var v) \ \) \ \ = \" +by (auto simp add: subst_agreement) + +lemma subst_all_empty[simp]: "{} \\<^sub>s\<^sub>e\<^sub>t \ = {}" +by simp + +lemma subst_all_insert:"(insert t M) \\<^sub>s\<^sub>e\<^sub>t \ = insert (t \ \) (M \\<^sub>s\<^sub>e\<^sub>t \)" +by auto + +lemma subst_apply_fv_subset: "fv t \ V \ fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" +by (induct t) auto + +lemma subst_apply_fv_empty: + assumes "fv t = {}" + shows "fv (t \ \) = {}" +using assms subst_apply_fv_subset[of t "{}" \] +by auto + +lemma subst_compose_fv: + assumes "fv (\ x) = {}" + shows "fv ((\ \\<^sub>s \) x) = {}" +using assms subst_apply_fv_empty +unfolding subst_compose_def by fast + +lemma subst_compose_fv': + fixes \ \::"('a,'b) subst" + assumes "y \ fv ((\ \\<^sub>s \) x)" + shows "\z. z \ fv (\ x)" +using assms subst_compose_fv +by fast + +lemma subst_apply_fv_unfold: "fv (t \ \) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv t)" +by (induct t) auto + +lemma subst_apply_fv_unfold': "fv (t \ \) = (\v \ fv t. fv (\ v))" +using subst_apply_fv_unfold by simp + +lemma subst_apply_fv_union: "fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t))" +proof - + have "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t)) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv t)" by auto + thus ?thesis using subst_apply_fv_unfold by metis +qed + +lemma subst_elimI[intro]: "(\t. v \ fv (t \ \)) \ subst_elim \ v" +by (auto simp add: subst_elim_def) + +lemma subst_elimI'[intro]: "(\w. v \ fv (Var w \ \)) \ subst_elim \ v" +by (simp add: subst_elim_def subst_apply_fv_unfold') + +lemma subst_elimD[dest]: "subst_elim \ v \ v \ fv (t \ \)" +by (auto simp add: subst_elim_def) + +lemma subst_elimD'[dest]: "subst_elim \ v \ \ v \ Var v" +by (metis subst_elim_def subst_apply_term.simps(1) term.set_intros(3)) + +lemma subst_elimD''[dest]: "subst_elim \ v \ v \ fv (\ w)" +by (metis subst_elim_def subst_apply_term.simps(1)) + +lemma subst_elim_rm_vars_dest[dest]: + "subst_elim (\::('a,'b) subst) v \ v \ vs \ subst_elim (rm_vars vs \) v" +proof - + assume assms: "subst_elim \ v" "v \ vs" + obtain f::"('a, 'b) subst \ 'b \ 'b" where + "\\ v. (\w. v \ fv (Var w \ \)) = (v \ fv (Var (f \ v) \ \))" + by moura + hence *: "\a \. a \ fv (Var (f \ a) \ \) \ subst_elim \ a" by blast + have "Var (f (rm_vars vs \) v) \ \ \ Var (f (rm_vars vs \) v) \ rm_vars vs \ + \ v \ fv (Var (f (rm_vars vs \) v) \ rm_vars vs \)" + using assms(1) by fastforce + moreover + { assume "Var (f (rm_vars vs \) v) \ \ \ Var (f (rm_vars vs \) v) \ rm_vars vs \" + hence "rm_vars vs \ (f (rm_vars vs \) v) \ \ (f (rm_vars vs \) v)" by auto + hence "f (rm_vars vs \) v \ vs" by meson + hence ?thesis using * assms(2) by force + } + ultimately show ?thesis using * by blast +qed + +lemma occs_subst_elim: "\Var v \ t \ subst_elim (Var(v := t)) v \ (Var(v := t)) = Var" +proof (cases "Var v = t") + assume "Var v \ t" "\Var v \ t" + hence "v \ fv t" by (simp add: vars_iff_subterm_or_eq) + thus ?thesis by (auto simp add: subst_remove_var) +qed auto + +lemma occs_subst_elim': "\Var v \ t \ subst_elim (Var(v := t)) v" +proof - + assume "\Var v \ t" + hence "v \ fv t" by (auto simp add: vars_iff_subterm_or_eq) + thus "subst_elim (Var(v := t)) v" by (simp add: subst_elim_def subst_remove_var) +qed + +lemma subst_elim_comp: "subst_elim \ v \ subst_elim (\ \\<^sub>s \) v" +by (auto simp add: subst_elim_def) + +lemma var_subst_idem: "subst_idem Var" +by (simp add: subst_idem_def) + +lemma var_upd_subst_idem: + assumes "\Var v \ t" shows "subst_idem (Var(v := t))" +unfolding subst_idem_def +proof + let ?\ = "Var(v := t)" + from assms have t_\_id: "t \ ?\ = t" by blast + fix s show "s \ (?\ \\<^sub>s ?\) = s \ ?\" + unfolding subst_compose_def + by (induction s, metis t_\_id fun_upd_def subst_apply_term.simps(1), simp) +qed + + +subsection \Lemmata: Domain and Range of Substitutions\ +lemma range_vars_alt_def: "range_vars s \ fv\<^sub>s\<^sub>e\<^sub>t (subst_range s)" +unfolding range_vars_def by simp + +lemma subst_dom_var_finite[simp]: "finite (subst_domain Var)" by simp + +lemma subst_range_Var[simp]: "subst_range Var = {}" by simp + +lemma range_vars_Var[simp]: "range_vars Var = {}" by fastforce + +lemma finite_subst_img_if_finite_dom: "finite (subst_domain \) \ finite (range_vars \)" +unfolding range_vars_alt_def by auto + +lemma finite_subst_img_if_finite_dom': "finite (subst_domain \) \ finite (subst_range \)" +by auto + +lemma subst_img_alt_def: "subst_range s = {t. \v. s v = t \ t \ Var v}" +by (auto simp add: subst_domain_def) + +lemma subst_fv_img_alt_def: "range_vars s = (\t \ {t. \v. s v = t \ t \ Var v}. fv t)" +unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + +lemma subst_domI[intro]: "\ v \ Var v \ v \ subst_domain \" +by (simp add: subst_domain_def) + +lemma subst_imgI[intro]: "\ v \ Var v \ \ v \ subst_range \" +by (simp add: subst_domain_def) + +lemma subst_fv_imgI[intro]: "\ v \ Var v \ fv (\ v) \ range_vars \" +unfolding range_vars_alt_def by auto + +lemma subst_domain_subst_Fun_single[simp]: + "subst_domain (Var(x := Fun f T)) = {x}" (is "?A = ?B") +unfolding subst_domain_def by simp + +lemma subst_range_subst_Fun_single[simp]: + "subst_range (Var(x := Fun f T)) = {Fun f T}" (is "?A = ?B") +by simp + +lemma range_vars_subst_Fun_single[simp]: + "range_vars (Var(x := Fun f T)) = fv (Fun f T)" +unfolding range_vars_alt_def by force + +lemma var_renaming_is_Fun_iff: + assumes "subst_range \ \ range Var" + shows "is_Fun t = is_Fun (t \ \)" +proof (cases t) + case (Var x) + hence "\y. \ x = Var y" using assms by auto + thus ?thesis using Var by auto +qed simp + +lemma subst_fv_dom_img_subset: "fv t \ subst_domain \ \ fv (t \ \) \ range_vars \" +unfolding range_vars_alt_def by (induct t) auto + +lemma subst_fv_dom_img_subset_set: "fv\<^sub>s\<^sub>e\<^sub>t M \ subst_domain \ \ fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) \ range_vars \" +proof - + assume assms: "fv\<^sub>s\<^sub>e\<^sub>t M \ subst_domain \" + obtain f::"'a set \ (('b, 'a) term \ 'a set) \ ('b, 'a) terms \ ('b, 'a) term" where + "\x y z. (\v. v \ z \ \ y v \ x) \ (f x y z \ z \ \ y (f x y z) \ x)" + by moura + hence *: + "\T g A. (\ \ (g ` T) \ A \ (\t. t \ T \ g t \ A)) \ + (\ (g ` T) \ A \ f A g T \ T \ \ g (f A g T) \ A)" + by (metis (no_types) SUP_le_iff) + hence **: "\t. t \ M \ fv t \ subst_domain \" by (metis (no_types) assms fv\<^sub>s\<^sub>e\<^sub>t.simps) + have "\t::('b, 'a) term. \f T. t \ f ` T \ (\t'::('b, 'a) term. t = f t' \ t' \ T)" by blast + hence "f (range_vars \) fv (M \\<^sub>s\<^sub>e\<^sub>t \) \ M \\<^sub>s\<^sub>e\<^sub>t \ \ + fv (f (range_vars \) fv (M \\<^sub>s\<^sub>e\<^sub>t \)) \ range_vars \" + by (metis (full_types) ** subst_fv_dom_img_subset) + thus ?thesis by (metis (no_types) * fv\<^sub>s\<^sub>e\<^sub>t.simps) +qed + +lemma subst_fv_dom_ground_if_ground_img: + assumes "fv t \ subst_domain s" "ground (subst_range s)" + shows "fv (t \ s) = {}" +using subst_fv_dom_img_subset[OF assms(1)] assms(2) by force + +lemma subst_fv_dom_ground_if_ground_img': + assumes "fv t \ subst_domain s" "\x. x \ subst_domain s \ fv (s x) = {}" + shows "fv (t \ s) = {}" +using subst_fv_dom_ground_if_ground_img[OF assms(1)] assms(2) by auto + +lemma subst_fv_unfold: "fv (t \ s) = (fv t - subst_domain s) \ fv\<^sub>s\<^sub>e\<^sub>t (s ` (fv t \ subst_domain s))" +proof (induction t) + case (Var v) thus ?case + proof (cases "v \ subst_domain s") + case True thus ?thesis by auto + next + case False + hence "fv (Var v \ s) = {v}" "fv (Var v) \ subst_domain s = {}" by auto + thus ?thesis by auto + qed +next + case Fun thus ?case by auto +qed + +lemma subst_fv_unfold_ground_img: "range_vars s = {} \ fv (t \ s) = fv t - subst_domain s" +using subst_fv_unfold[of t s] unfolding range_vars_alt_def by auto + +lemma subst_img_update: + "\\ v = Var v; t \ Var v\ \ range_vars (\(v := t)) = range_vars \ \ fv t" +proof - + assume "\ v = Var v" "t \ Var v" + hence "(\s \ {s. \w. (\(v := t)) w = s \ s \ Var w}. fv s) = fv t \ range_vars \" + unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + thus "range_vars (\(v := t)) = range_vars \ \ fv t" + by (metis Un_commute subst_fv_img_alt_def) +qed + +lemma subst_dom_update1: "v \ subst_domain \ \ subst_domain (\(v := Var v)) = subst_domain \" +by (auto simp add: subst_domain_def) + +lemma subst_dom_update2: "t \ Var v \ subst_domain (\(v := t)) = insert v (subst_domain \)" +by (auto simp add: subst_domain_def) + +lemma subst_dom_update3: "t = Var v \ subst_domain (\(v := t)) = subst_domain \ - {v}" +by (auto simp add: subst_domain_def) + +lemma var_not_in_subst_dom[elim]: "v \ subst_domain s \ s v = Var v" +by (simp add: subst_domain_def) + +lemma subst_dom_vars_in_subst[elim]: "v \ subst_domain s \ s v \ Var v" +by (simp add: subst_domain_def) + +lemma subst_not_dom_fixed: "\v \ fv t; v \ subst_domain s\ \ v \ fv (t \ s)" by (induct t) auto + +lemma subst_not_img_fixed: "\v \ fv (t \ s); v \ range_vars s\ \ v \ fv t" +unfolding range_vars_alt_def by (induct t) force+ + +lemma ground_range_vars[intro]: "ground (subst_range s) \ range_vars s = {}" +unfolding range_vars_alt_def by metis + +lemma ground_subst_no_var[intro]: "ground (subst_range s) \ x \ range_vars s" +using ground_range_vars[of s] by blast + +lemma ground_img_obtain_fun: + assumes "ground (subst_range s)" "x \ subst_domain s" + obtains f T where "s x = Fun f T" "Fun f T \ subst_range s" "fv (Fun f T) = {}" +proof - + from assms(2) obtain t where t: "s x = t" "t \ subst_range s" by moura + hence "fv t = {}" using assms(1) by auto + thus ?thesis using t that by (cases t) simp_all +qed + +lemma ground_term_subst_domain_fv_subset: + "fv (t \ \) = {} \ fv t \ subst_domain \" +by (induct t) auto + +lemma ground_subst_range_empty_fv: + "ground (subst_range \) \ x \ subst_domain \ \ fv (\ x) = {}" +by simp + +lemma subst_Var_notin_img: "x \ range_vars s \ t \ s = Var x \ t = Var x" +using subst_not_img_fixed[of x t s] by (induct t) auto + +lemma fv_in_subst_img: "\s v = t; t \ Var v\ \ fv t \ range_vars s" +unfolding range_vars_alt_def by auto + +lemma empty_dom_iff_empty_subst: "subst_domain \ = {} \ \ = Var" by auto + +lemma subst_dom_cong: "(\v t. \ v = t \ \ v = t) \ subst_domain \ \ subst_domain \" +by (auto simp add: subst_domain_def) + +lemma subst_img_cong: "(\v t. \ v = t \ \ v = t) \ range_vars \ \ range_vars \" +unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + +lemma subst_dom_elim: "subst_domain s \ range_vars s = {} \ fv (t \ s) \ subst_domain s = {}" +proof (induction t) + case (Var v) thus ?case + using fv_in_subst_img[of s] + by (cases "s v = Var v") (auto simp add: subst_domain_def) +next + case Fun thus ?case by auto +qed + +lemma subst_dom_insert_finite: "finite (subst_domain s) = finite (subst_domain (s(v := t)))" +proof + assume "finite (subst_domain s)" + have "subst_domain (s(v := t)) \ insert v (subst_domain s)" by (auto simp add: subst_domain_def) + thus "finite (subst_domain (s(v := t)))" + by (meson \finite (subst_domain s)\ finite_insert rev_finite_subset) +next + assume *: "finite (subst_domain (s(v := t)))" + hence "finite (insert v (subst_domain s))" + proof (cases "t = Var v") + case True + hence "finite (subst_domain s - {v})" by (metis * subst_dom_update3) + thus ?thesis by simp + qed (metis * subst_dom_update2[of t v s]) + thus "finite (subst_domain s)" by simp +qed + +lemma trm_subst_disj: "t \ \ = t \ fv t \ subst_domain \ = {}" +proof (induction t) + case (Fun f X) + hence "map (\x. x \ \) X = X" by simp + hence "\x. x \ set X \ x \ \ = x" using map_eq_conv by fastforce + thus ?case using Fun.IH by auto +qed (simp add: subst_domain_def) + +lemma trm_subst_ident[intro]: "fv t \ subst_domain \ = {} \ t \ \ = t" +proof - + assume "fv t \ subst_domain \ = {}" + hence "\v \ fv t. \w \ subst_domain \. v \ w" by auto + thus ?thesis + by (metis subst_agreement subst_apply_term.simps(1) subst_apply_term_empty subst_domI) +qed + +lemma trm_subst_ident'[intro]: "v \ subst_domain \ \ (Var v) \ \ = Var v" +using trm_subst_ident by (simp add: subst_domain_def) + +lemma trm_subst_ident''[intro]: "(\x. x \ fv t \ \ x = Var x) \ t \ \ = t" +proof - + assume "\x. x \ fv t \ \ x = Var x" + hence "fv t \ subst_domain \ = {}" by (auto simp add: subst_domain_def) + thus ?thesis using trm_subst_ident by auto +qed + +lemma set_subst_ident: "fv\<^sub>s\<^sub>e\<^sub>t M \ subst_domain \ = {} \ M \\<^sub>s\<^sub>e\<^sub>t \ = M" +proof - + assume "fv\<^sub>s\<^sub>e\<^sub>t M \ subst_domain \ = {}" + hence "\t \ M. t \ \ = t" by auto + thus ?thesis by force +qed + +lemma trm_subst_ident_subterms[intro]: + "fv t \ subst_domain \ = {} \ subterms t \\<^sub>s\<^sub>e\<^sub>t \ = subterms t" +using set_subst_ident[of "subterms t" \] fv_subterms[of t] by simp + +lemma trm_subst_ident_subterms'[intro]: + "v \ fv t \ subterms t \\<^sub>s\<^sub>e\<^sub>t Var(v := s) = subterms t" +using trm_subst_ident_subterms[of t "Var(v := s)"] +by (meson subst_no_occs trm_subst_disj vars_iff_subtermeq) + +lemma const_mem_subst_cases: + assumes "Fun c [] \ M \\<^sub>s\<^sub>e\<^sub>t \" + shows "Fun c [] \ M \ Fun c [] \ \ ` fv\<^sub>s\<^sub>e\<^sub>t M" +proof - + obtain m where m: "m \ M" "m \ \ = Fun c []" using assms by auto + thus ?thesis by (cases m) force+ +qed + +lemma const_mem_subst_cases': + assumes "Fun c [] \ M \\<^sub>s\<^sub>e\<^sub>t \" + shows "Fun c [] \ M \ Fun c [] \ subst_range \" +using const_mem_subst_cases[OF assms] by force + +lemma fv_subterms_substI[intro]: "y \ fv t \ \ y \ subterms t \\<^sub>s\<^sub>e\<^sub>t \" +using image_iff vars_iff_subtermeq by fastforce + +lemma fv_subterms_subst_eq[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (subterms (t \ \)) = fv\<^sub>s\<^sub>e\<^sub>t (subterms t \\<^sub>s\<^sub>e\<^sub>t \)" +using fv_subterms by (induct t) force+ + +lemma fv_subterms_set_subst: "fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \) = fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \))" +using fv_subterms_subst_eq[of _ \] by auto + +lemma fv_subterms_set_subst': "fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \) = fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" +using fv_subterms_set[of "M \\<^sub>s\<^sub>e\<^sub>t \"] fv_subterms_set_subst[of \ M] by simp + +lemma fv_subst_subset: "x \ fv t \ fv (\ x) \ fv (t \ \)" +by (metis fv_subset image_eqI subst_apply_fv_unfold) + +lemma fv_subst_subset': "fv s \ fv t \ fv (s \ \) \ fv (t \ \)" +using fv_subst_subset by (induct s) force+ + +lemma fv_subst_obtain_var: + fixes \::"('a,'b) subst" + assumes "x \ fv (t \ \)" + shows "\y \ fv t. x \ fv (\ y)" +using assms by (induct t) force+ + +lemma set_subst_all_ident: "fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) \ subst_domain \ = {} \ M \\<^sub>s\<^sub>e\<^sub>t (\ \\<^sub>s \) = M \\<^sub>s\<^sub>e\<^sub>t \" +by (metis set_subst_ident subst_comp_all) + +lemma subterms_subst: + "subterms (t \ d) = (subterms t \\<^sub>s\<^sub>e\<^sub>t d) \ subterms\<^sub>s\<^sub>e\<^sub>t (d ` (fv t \ subst_domain d))" +by (induct t) (auto simp add: subst_domain_def) + +lemma subterms_subst': + fixes \::"('a,'b) subst" + assumes "\x \ fv t. (\f. \ x = Fun f []) \ (\y. \ x = Var y)" + shows "subterms (t \ \) = subterms t \\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction t) + case (Var x) thus ?case + proof (cases "x \ subst_domain \") + case True + hence "(\f. \ x = Fun f []) \ (\y. \ x = Var y)" using Var by simp + hence "subterms (\ x) = {\ x}" by auto + thus ?thesis by simp + qed auto +qed auto + +lemma subterms_subst'': + fixes \::"('a,'b) subst" + assumes "\x \ fv\<^sub>s\<^sub>e\<^sub>t M. (\f. \ x = Fun f []) \ (\y. \ x = Var y)" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) = subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \" +using subterms_subst'[of _ \] assms by auto + +lemma subterms_subst_subterm: + fixes \::"('a,'b) subst" + assumes "\x \ fv a. (\f. \ x = Fun f []) \ (\y. \ x = Var y)" + and "b \ subterms (a \ \)" + shows "\c \ subterms a. c \ \ = b" +using subterms_subst'[OF assms(1)] assms(2) by auto + +lemma subterms_subst_subset: "subterms t \\<^sub>s\<^sub>e\<^sub>t \ \ subterms (t \ \)" +by (induct t) auto + +lemma subterms_subst_subset': "subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \ \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" +using subterms_subst_subset by fast + +lemma subterms\<^sub>s\<^sub>e\<^sub>t_subst: + fixes \::"('a,'b) subst" + assumes "t \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + shows "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \ \ (\x \ fv\<^sub>s\<^sub>e\<^sub>t M. t \ subterms (\ x))" +using assms subterms_subst[of _ \] by auto + +lemma rm_vars_dom: "subst_domain (rm_vars V s) = subst_domain s - V" +by (auto simp add: subst_domain_def) + +lemma rm_vars_dom_subset: "subst_domain (rm_vars V s) \ subst_domain s" +by (auto simp add: subst_domain_def) + +lemma rm_vars_dom_eq': + "subst_domain (rm_vars (UNIV - V) s) = subst_domain s \ V" +using rm_vars_dom[of "UNIV - V" s] by blast + +lemma rm_vars_img: "subst_range (rm_vars V s) = s ` subst_domain (rm_vars V s)" +by (auto simp add: subst_domain_def) + +lemma rm_vars_img_subset: "subst_range (rm_vars V s) \ subst_range s" +by (auto simp add: subst_domain_def) + +lemma rm_vars_img_fv_subset: "range_vars (rm_vars V s) \ range_vars s" +unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + +lemma rm_vars_fv_obtain: + assumes "x \ fv (t \ rm_vars X \) - X" + shows "\y \ fv t - X. x \ fv (rm_vars X \ y)" +using assms by (induct t) (fastforce, force) + +lemma rm_vars_apply: "v \ subst_domain (rm_vars V s) \ (rm_vars V s) v = s v" +by (auto simp add: subst_domain_def) + +lemma rm_vars_apply': "subst_domain \ \ vs = {} \ rm_vars vs \ = \" +by force + +lemma rm_vars_ident: "fv t \ vs = {} \ t \ (rm_vars vs \) = t \ \" +by (induct t) auto + +lemma rm_vars_fv_subset: "fv (t \ rm_vars X \) \ fv t \ fv (t \ \)" +by (induct t) auto + +lemma rm_vars_fv_disj: + assumes "fv t \ X = {}" "fv (t \ \) \ X = {}" + shows "fv (t \ rm_vars X \) \ X = {}" +using rm_vars_ident[OF assms(1)] assms(2) by auto + +lemma rm_vars_ground_supports: + assumes "ground (subst_range \)" + shows "rm_vars X \ supports \" +proof + fix x + have *: "ground (subst_range (rm_vars X \))" + using rm_vars_img_subset[of X \] assms + by (auto simp add: subst_domain_def) + show "rm_vars X \ x \ \ = \ x " + proof (cases "x \ subst_domain (rm_vars X \)") + case True + hence "fv (rm_vars X \ x) = {}" using * by auto + thus ?thesis using True by auto + qed (simp add: subst_domain_def) +qed + +lemma rm_vars_split: + assumes "ground (subst_range \)" + shows "\ = rm_vars X \ \\<^sub>s rm_vars (subst_domain \ - X) \" +proof - + let ?s1 = "rm_vars X \" + let ?s2 = "rm_vars (subst_domain \ - X) \" + + have doms: "subst_domain ?s1 \ subst_domain \" "subst_domain ?s2 \ subst_domain \" + by (auto simp add: subst_domain_def) + + { fix x assume "x \ subst_domain \" + hence "\ x = Var x" "?s1 x = Var x" "?s2 x = Var x" using doms by auto + hence "\ x = (?s1 \\<^sub>s ?s2) x" by (simp add: subst_compose_def) + } moreover { + fix x assume "x \ subst_domain \" "x \ X" + hence "?s1 x = Var x" "?s2 x = \ x" using doms by auto + hence "\ x = (?s1 \\<^sub>s ?s2) x" by (simp add: subst_compose_def) + } moreover { + fix x assume "x \ subst_domain \" "x \ X" + hence "?s1 x = \ x" "fv (\ x) = {}" using assms doms by auto + hence "\ x = (?s1 \\<^sub>s ?s2) x" by (simp add: subst_compose subst_ground_ident) + } ultimately show ?thesis by blast +qed + +lemma rm_vars_fv_img_disj: + assumes "fv t \ X = {}" "X \ range_vars \ = {}" + shows "fv (t \ rm_vars X \) \ X = {}" +using assms +proof (induction t) + case (Var x) + hence *: "(rm_vars X \) x = \ x" by auto + show ?case + proof (cases "x \ subst_domain \") + case True + hence "\ x \ subst_range \" by auto + hence "fv (\ x) \ X = {}" using Var.prems(2) unfolding range_vars_alt_def by fastforce + thus ?thesis using * by auto + next + case False thus ?thesis using Var.prems(1) by auto + qed +next + case Fun thus ?case by auto +qed + +lemma subst_apply_dom_ident: "t \ \ = t \ subst_domain \ \ subst_domain \ \ t \ \ = t" +proof (induction t) + case (Fun f T) thus ?case by (induct T) auto +qed (auto simp add: subst_domain_def) + +lemma rm_vars_subst_apply_ident: + assumes "t \ \ = t" + shows "t \ (rm_vars vs \) = t" +using rm_vars_dom[of vs \] subst_apply_dom_ident[OF assms, of "rm_vars vs \"] by auto + +lemma rm_vars_subst_eq: + "t \ \ = t \ rm_vars (subst_domain \ - subst_domain \ \ fv t) \" +by (auto intro: term_subst_eq) + +lemma rm_vars_subst_eq': + "t \ \ = t \ rm_vars (UNIV - fv t) \" +by (auto intro: term_subst_eq) + +lemma rm_vars_comp: + assumes "range_vars \ \ vs = {}" + shows "t \ rm_vars vs (\ \\<^sub>s \) = t \ (rm_vars vs \ \\<^sub>s rm_vars vs \)" +using assms +proof (induction t) + case (Var x) thus ?case + proof (cases "x \ vs") + case True thus ?thesis using Var by auto + next + case False + have "subst_domain (rm_vars vs \) \ vs = {}" by (auto simp add: subst_domain_def) + moreover have "fv (\ x) \ vs = {}" + using Var False unfolding range_vars_alt_def by force + ultimately have "\ x \ (rm_vars vs \) = \ x \ \" + using rm_vars_ident by (simp add: subst_domain_def) + moreover have "(rm_vars vs (\ \\<^sub>s \)) x = (\ \\<^sub>s \) x" by (metis False) + ultimately show ?thesis using subst_compose by auto + qed +next + case Fun thus ?case by auto +qed + +lemma rm_vars_fv\<^sub>s\<^sub>e\<^sub>t_subst: + assumes "x \ fv\<^sub>s\<^sub>e\<^sub>t (rm_vars X \ ` Y)" + shows "x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` Y) \ x \ X" +using assms by auto + +lemma disj_dom_img_var_notin: + assumes "subst_domain \ \ range_vars \ = {}" "\ v = t" "t \ Var v" + shows "v \ fv t" "\v \ fv (t \ \). v \ subst_domain \" +proof - + have "v \ subst_domain \" "fv t \ range_vars \" + using fv_in_subst_img[of \ v t, OF assms(2)] assms(2,3) + by (auto simp add: subst_domain_def) + thus "v \ fv t" using assms(1) by auto + + have *: "fv t \ subst_domain \ = {}" + using assms(1) \fv t \ range_vars \\ + by auto + hence "t \ \ = t" by blast + thus "\v \ fv (t \ \). v \ subst_domain \" using * by auto +qed + +lemma subst_sends_dom_to_img: "v \ subst_domain \ \ fv (Var v \ \) \ range_vars \" +unfolding range_vars_alt_def by auto + +lemma subst_sends_fv_to_img: "fv (t \ s) \ fv t \ range_vars s" +proof (induction t) + case (Var v) thus ?case + proof (cases "Var v \ s = Var v") + case True thus ?thesis by simp + next + case False + hence "v \ subst_domain s" by (meson trm_subst_ident') + hence "fv (Var v \ s) \ range_vars s" + using subst_sends_dom_to_img by simp + thus ?thesis by auto + qed +next + case Fun thus ?case by auto +qed + +lemma ident_comp_subst_trm_if_disj: + assumes "subst_domain \ \ range_vars \ = {}" "v \ subst_domain \" + shows "(\ \\<^sub>s \) v = \ v" +proof - + from assms have " subst_domain \ \ fv (\ v) = {}" + using fv_in_subst_img unfolding range_vars_alt_def by auto + thus "(\ \\<^sub>s \) v = \ v" unfolding subst_compose_def by blast +qed + +lemma ident_comp_subst_trm_if_disj': "fv (\ v) \ subst_domain \ = {} \ (\ \\<^sub>s \) v = \ v" +unfolding subst_compose_def by blast + +lemma subst_idemI[intro]: "subst_domain \ \ range_vars \ = {} \ subst_idem \" +using ident_comp_subst_trm_if_disj[of \ \] + var_not_in_subst_dom[of _ \] + subst_eq_if_eq_vars[of \] +by (metis subst_idem_def subst_compose_def var_comp(2)) + +lemma subst_idemI'[intro]: "ground (subst_range \) \ subst_idem \" +proof (intro subst_idemI) + assume "ground (subst_range \)" + hence "range_vars \ = {}" by (metis ground_range_vars) + thus "subst_domain \ \ range_vars \ = {}" by blast +qed + +lemma subst_idemE: "subst_idem \ \ subst_domain \ \ range_vars \ = {}" +proof - + assume "subst_idem \" + hence "\v. fv (\ v) \ subst_domain \ = {}" + unfolding subst_idem_def subst_compose_def by (metis trm_subst_disj) + thus ?thesis + unfolding range_vars_alt_def by auto +qed + +lemma subst_idem_rm_vars: "subst_idem \ \ subst_idem (rm_vars X \)" +proof - + assume "subst_idem \" + hence "subst_domain \ \ range_vars \ = {}" by (metis subst_idemE) + moreover have + "subst_domain (rm_vars X \) \ subst_domain \" + "range_vars (rm_vars X \) \ range_vars \" + unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + ultimately show ?thesis by blast +qed + +lemma subst_fv_bounded_if_img_bounded: "range_vars \ \ fv t \ V \ fv (t \ \) \ fv t \ V" +proof (induction t) + case (Var v) thus ?case unfolding range_vars_alt_def by (cases "\ v = Var v") auto +qed (metis (no_types, lifting) Un_assoc Un_commute subst_sends_fv_to_img sup.absorb_iff2) + +lemma subst_fv_bound_singleton: "fv (t \ Var(v := t')) \ fv t \ fv t'" +using subst_fv_bounded_if_img_bounded[of "Var(v := t')" t "fv t'"] +unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + +lemma subst_fv_bounded_if_img_bounded': + assumes "range_vars \ \ fv\<^sub>s\<^sub>e\<^sub>t M" + shows "fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t M" +proof + fix v assume *: "v \ fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + + obtain t where t: "t \ M" "t \ \ \ M \\<^sub>s\<^sub>e\<^sub>t \" "v \ fv (t \ \)" + proof - + assume **: "\t. \t \ M; t \ \ \ M \\<^sub>s\<^sub>e\<^sub>t \; v \ fv (t \ \)\ \ thesis" + have "v \ \ (fv ` ((\t. t \ \) ` M))" using * by (metis fv\<^sub>s\<^sub>e\<^sub>t.simps) + hence "\t. t \ M \ v \ fv (t \ \)" by blast + thus ?thesis using ** imageI by blast + qed + + from \t \ M\ obtain M' where "t \ M'" "M = insert t M'" by (meson Set.set_insert) + hence "fv\<^sub>s\<^sub>e\<^sub>t M = fv t \ fv\<^sub>s\<^sub>e\<^sub>t M'" by simp + hence "fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t M" using subst_fv_bounded_if_img_bounded assms by simp + thus "v \ fv\<^sub>s\<^sub>e\<^sub>t M" using assms \v \ fv (t \ \)\ by auto +qed + +lemma ground_img_if_ground_subst: "(\v t. s v = t \ fv t = {}) \ range_vars s = {}" +unfolding range_vars_alt_def by auto + +lemma ground_subst_fv_subset: "ground (subst_range \) \ fv (t \ \) \ fv t" +using subst_fv_bounded_if_img_bounded[of \] +unfolding range_vars_alt_def by force + +lemma ground_subst_fv_subset': "ground (subst_range \) \ fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t M" +using subst_fv_bounded_if_img_bounded'[of \ M] +unfolding range_vars_alt_def by auto + +lemma subst_to_var_is_var[elim]: "t \ s = Var v \ \w. t = Var w" +using subst_apply_term.elims by blast + +lemma subst_dom_comp_inI: + assumes "y \ subst_domain \" + and "y \ subst_domain \" + shows "y \ subst_domain (\ \\<^sub>s \)" +using assms subst_domain_subst_compose[of \ \] by blast + +lemma subst_comp_notin_dom_eq: + "x \ subst_domain \1 \ (\1 \\<^sub>s \2) x = \2 x" +unfolding subst_compose_def by fastforce + +lemma subst_dom_comp_eq: + assumes "subst_domain \ \ range_vars \ = {}" + shows "subst_domain (\ \\<^sub>s \) = subst_domain \ \ subst_domain \" +proof (rule ccontr) + assume "subst_domain (\ \\<^sub>s \) \ subst_domain \ \ subst_domain \" + hence "subst_domain (\ \\<^sub>s \) \ subst_domain \ \ subst_domain \" + using subst_domain_compose[of \ \] by (simp add: subst_domain_def) + then obtain v where "v \ subst_domain (\ \\<^sub>s \)" "v \ subst_domain \ \ subst_domain \" by auto + hence v_in_some_subst: "\ v \ Var v \ \ v \ Var v" and "\ v \ \ = Var v" + unfolding subst_compose_def by (auto simp add: subst_domain_def) + then obtain w where "\ v = Var w" using subst_to_var_is_var by fastforce + show False + proof (cases "v = w") + case True + hence "\ v = Var v" using \\ v = Var w\ by simp + hence "\ v \ Var v" using v_in_some_subst by simp + thus False using \\ v = Var v\ \\ v \ \ = Var v\ by simp + next + case False + hence "v \ subst_domain \" using v_in_some_subst \\ v \ \ = Var v\ by auto + hence "v \ range_vars \" using assms by auto + moreover have "\ w = Var v" using \\ v \ \ = Var v\ \\ v = Var w\ by simp + hence "v \ range_vars \" using \v \ w\ subst_fv_imgI[of \ w] by simp + ultimately show False .. + qed +qed + +lemma subst_img_comp_subset[simp]: + "range_vars (\1 \\<^sub>s \2) \ range_vars \1 \ range_vars \2" +proof + let ?img = "range_vars" + fix x assume "x \ ?img (\1 \\<^sub>s \2)" + then obtain v t where vt: "x \ fv t" "t = (\1 \\<^sub>s \2) v" "t \ Var v" + unfolding range_vars_alt_def subst_compose_def by (auto simp add: subst_domain_def) + + { assume "x \ ?img \1" hence "x \ ?img \2" + by (metis (no_types, hide_lams) fv_in_subst_img Un_iff subst_compose_def + vt subsetCE subst_apply_term.simps(1) subst_sends_fv_to_img) + } + thus "x \ ?img \1 \ ?img \2" by auto +qed + +lemma subst_img_comp_subset': + assumes "t \ subst_range (\1 \\<^sub>s \2)" + shows "t \ subst_range \2 \ (\t' \ subst_range \1. t = t' \ \2)" +proof - + obtain x where x: "x \ subst_domain (\1 \\<^sub>s \2)" "(\1 \\<^sub>s \2) x = t" "t \ Var x" + using assms by (auto simp add: subst_domain_def) + { assume "x \ subst_domain \1" + hence "(\1 \\<^sub>s \2) x = \2 x" unfolding subst_compose_def by auto + hence ?thesis using x by auto + } moreover { + assume "x \ subst_domain \1" hence ?thesis using subst_compose x(2) by fastforce + } ultimately show ?thesis by metis +qed + +lemma subst_img_comp_subset'': + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (\1 \\<^sub>s \2)) \ + subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2) \ ((subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \1)) \\<^sub>s\<^sub>e\<^sub>t \2)" +proof + fix t assume "t \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (\1 \\<^sub>s \2))" + then obtain x where x: "x \ subst_domain (\1 \\<^sub>s \2)" "t \ subterms ((\1 \\<^sub>s \2) x)" + by auto + show "t \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2) \ (subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \1) \\<^sub>s\<^sub>e\<^sub>t \2)" + proof (cases "x \ subst_domain \1") + case True thus ?thesis + using subst_compose[of \1 \2] x(2) subterms_subst + by fastforce + next + case False + hence "(\1 \\<^sub>s \2) x = \2 x" unfolding subst_compose_def by auto + thus ?thesis using x by (auto simp add: subst_domain_def) + qed +qed + +lemma subst_img_comp_subset''': + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (\1 \\<^sub>s \2)) - range Var \ + subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2) - range Var \ ((subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \1) - range Var) \\<^sub>s\<^sub>e\<^sub>t \2)" +proof + fix t assume t: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (\1 \\<^sub>s \2)) - range Var" + then obtain f T where fT: "t = Fun f T" by (cases t) simp_all + then obtain x where x: "x \ subst_domain (\1 \\<^sub>s \2)" "Fun f T \ subterms ((\1 \\<^sub>s \2) x)" + using t by auto + have "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2) \ (subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \1) - range Var \\<^sub>s\<^sub>e\<^sub>t \2)" + proof (cases "x \ subst_domain \1") + case True + hence "Fun f T \ (subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2)) \ (subterms (\1 x) \\<^sub>s\<^sub>e\<^sub>t \2)" + using x(2) subterms_subst[of "\1 x" \2] + unfolding subst_compose[of \1 \2 x] by auto + moreover have ?thesis when *: "Fun f T \ subterms (\1 x) \\<^sub>s\<^sub>e\<^sub>t \2" + proof - + obtain s where s: "s \ subterms (\1 x)" "Fun f T = s \ \2" using * by moura + show ?thesis + proof (cases s) + case (Var y) + hence "Fun f T \ subst_range \2" using s by force + thus ?thesis by blast + next + case (Fun g S) + hence "Fun f T \ (subterms (\1 x) - range Var) \\<^sub>s\<^sub>e\<^sub>t \2" using s by blast + thus ?thesis using True by auto + qed + qed + ultimately show ?thesis by blast + next + case False + hence "(\1 \\<^sub>s \2) x = \2 x" unfolding subst_compose_def by auto + thus ?thesis using x by (auto simp add: subst_domain_def) + qed + thus "t \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \2) - range Var \ + (subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \1) - range Var \\<^sub>s\<^sub>e\<^sub>t \2)" + using fT by auto +qed + +lemma subst_img_comp_subset_const: + assumes "Fun c [] \ subst_range (\1 \\<^sub>s \2)" + shows "Fun c [] \ subst_range \2 \ Fun c [] \ subst_range \1 \ + (\x. Var x \ subst_range \1 \ \2 x = Fun c [])" +proof (cases "Fun c [] \ subst_range \2") + case False + then obtain t where t: "t \ subst_range \1" "Fun c [] = t \ \2" + using subst_img_comp_subset'[OF assms] by auto + thus ?thesis by (cases t) auto +qed (simp add: subst_img_comp_subset'[OF assms]) + +lemma subst_img_comp_subset_const': + fixes \ \::"('f,'v) subst" + assumes "(\ \\<^sub>s \) x = Fun c []" + shows "\ x = Fun c [] \ (\z. \ x = Var z \ \ z = Fun c [])" +proof (cases "\ x = Fun c []") + case False + then obtain t where "\ x = t" "t \ \ = Fun c []" using assms unfolding subst_compose_def by auto + thus ?thesis by (cases t) auto +qed simp + +lemma subst_img_comp_subset_ground: + assumes "ground (subst_range \1)" + shows "subst_range (\1 \\<^sub>s \2) \ subst_range \1 \ subst_range \2" +proof + fix t assume t: "t \ subst_range (\1 \\<^sub>s \2)" + then obtain x where x: "x \ subst_domain (\1 \\<^sub>s \2)" "t = (\1 \\<^sub>s \2) x" by auto + + show "t \ subst_range \1 \ subst_range \2" + proof (cases "x \ subst_domain \1") + case True + hence "fv (\1 x) = {}" using assms ground_subst_range_empty_fv by fast + hence "t = \1 x" using x(2) unfolding subst_compose_def by blast + thus ?thesis using True by simp + next + case False + hence "t = \2 x" "x \ subst_domain \2" + using x subst_domain_compose[of \1 \2] + by (metis subst_comp_notin_dom_eq, blast) + thus ?thesis using x by simp + qed +qed + +lemma subst_fv_dom_img_single: + assumes "v \ fv t" "\ v = t" "\w. v \ w \ \ w = Var w" + shows "subst_domain \ = {v}" "range_vars \ = fv t" +proof - + show "subst_domain \ = {v}" using assms by (fastforce simp add: subst_domain_def) + have "fv t \ range_vars \" by (metis fv_in_subst_img assms(1,2) vars_iff_subterm_or_eq) + moreover have "\v. \ v \ Var v \ \ v = t" using assms by fastforce + ultimately show "range_vars \ = fv t" + unfolding range_vars_alt_def + by (auto simp add: subst_domain_def) +qed + +lemma subst_comp_upd1: + "\(v := t) \\<^sub>s \ = (\ \\<^sub>s \)(v := t \ \)" +unfolding subst_compose_def by auto + +lemma subst_comp_upd2: + assumes "v \ subst_domain s" "v \ range_vars s" + shows "s(v := t) = s \\<^sub>s (Var(v := t))" +unfolding subst_compose_def +proof - + { fix w + have "(s(v := t)) w = s w \ Var(v := t)" + proof (cases "w = v") + case True + hence "s w = Var w" using \v \ subst_domain s\ by (simp add: subst_domain_def) + thus ?thesis using \w = v\ by simp + next + case False + hence "(s(v := t)) w = s w" by simp + moreover have "s w \ Var(v := t) = s w" using \w \ v\ \v \ range_vars s\ + by (metis fv_in_subst_img fun_upd_apply insert_absorb insert_subset + repl_invariance subst_apply_term.simps(1) subst_apply_term_empty) + ultimately show ?thesis .. + qed + } + thus "s(v := t) = (\w. s w \ Var(v := t))" by auto +qed + +lemma ground_subst_dom_iff_img: + "ground (subst_range \) \ x \ subst_domain \ \ \ x \ subst_range \" +by (auto simp add: subst_domain_def) + +lemma finite_dom_subst_exists: + "finite S \ \\::('f,'v) subst. subst_domain \ = S" +proof (induction S rule: finite.induct) + case (insertI A a) + then obtain \::"('f,'v) subst" where "subst_domain \ = A" by blast + fix f::'f + have "subst_domain (\(a := Fun f [])) = insert a A" + using \subst_domain \ = A\ + by (auto simp add: subst_domain_def) + thus ?case by metis +qed (auto simp add: subst_domain_def) + +lemma subst_inj_is_bij_betw_dom_img_if_ground_img: + assumes "ground (subst_range \)" + shows "inj \ \ bij_betw \ (subst_domain \) (subst_range \)" (is "?A \ ?B") +proof + show "?A \ ?B" by (metis bij_betw_def injD inj_onI subst_range.simps) +next + assume ?B + hence "inj_on \ (subst_domain \)" unfolding bij_betw_def by auto + moreover have "\x. x \ UNIV - subst_domain \ \ \ x = Var x" by auto + hence "inj_on \ (UNIV - subst_domain \)" + using inj_onI[of "UNIV - subst_domain \"] + by (metis term.inject(1)) + moreover have "\x y. x \ subst_domain \ \ y \ subst_domain \ \ \ x \ \ y" + using assms by (auto simp add: subst_domain_def) + ultimately show ?A by (metis injI inj_onD subst_domI term.inject(1)) +qed + +lemma bij_finite_ground_subst_exists: + assumes "finite (S::'v set)" "infinite (U::('f,'v) term set)" "ground U" + shows "\\::('f,'v) subst. subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subst_range \ \ U" +proof - + obtain T' where "T' \ U" "card T' = card S" "finite T'" + by (meson assms(2) finite_Diff2 infinite_arbitrarily_large) + then obtain f::"'v \ ('f,'v) term" where f_bij: "bij_betw f S T'" + using finite_same_card_bij[OF assms(1)] by metis + hence *: "\v. v \ S \ f v \ Var v" + using \ground U\ \T' \ U\ bij_betwE + by fastforce + + let ?\ = "\v. if v \ S then f v else Var v" + have "subst_domain ?\ = S" + proof + show "subst_domain ?\ \ S" by (auto simp add: subst_domain_def) + + { fix v assume "v \ S" "v \ subst_domain ?\" + hence "f v = Var v" by (simp add: subst_domain_def) + hence False using *[OF \v \ S\] by metis + } + thus "S \ subst_domain ?\" by blast + qed + hence "\v w. \v \ subst_domain ?\; w \ subst_domain ?\\ \ ?\ w \ ?\ v" + using \ground U\ bij_betwE[OF f_bij] set_rev_mp[OF _ \T' \ U\] + by (metis (no_types, lifting) UN_iff empty_iff vars_iff_subterm_or_eq fv\<^sub>s\<^sub>e\<^sub>t.simps) + hence "inj_on ?\ (subst_domain ?\)" + using f_bij \subst_domain ?\ = S\ + unfolding bij_betw_def inj_on_def + by metis + hence "bij_betw ?\ (subst_domain ?\) (subst_range ?\)" + using inj_on_imp_bij_betw[of ?\] by simp + moreover have "subst_range ?\ = T'" + using \bij_betw f S T'\ \subst_domain ?\ = S\ + unfolding bij_betw_def by auto + hence "subst_range ?\ \ U" using \T' \ U\ by auto + ultimately show ?thesis using \subst_domain ?\ = S\ by (metis (lifting)) +qed + +lemma bij_finite_const_subst_exists: + assumes "finite (S::'v set)" "finite (T::'f set)" "infinite (U::'f set)" + shows "\\::('f,'v) subst. subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subst_range \ \ (\c. Fun c []) ` (U - T)" +proof - + obtain T' where "T' \ U - T" "card T' = card S" "finite T'" + by (meson assms(2,3) finite_Diff2 infinite_arbitrarily_large) + then obtain f::"'v \ 'f" where f_bij: "bij_betw f S T'" + using finite_same_card_bij[OF assms(1)] by metis + + let ?\ = "\v. if v \ S then Fun (f v) [] else Var v" + have "subst_domain ?\ = S" by (simp add: subst_domain_def) + moreover have "\v w. \v \ subst_domain ?\; w \ subst_domain ?\\ \ ?\ w \ ?\ v" by auto + hence "inj_on ?\ (subst_domain ?\)" + using f_bij unfolding bij_betw_def inj_on_def + by (metis \subst_domain ?\ = S\ term.inject(2)) + hence "bij_betw ?\ (subst_domain ?\) (subst_range ?\)" + using inj_on_imp_bij_betw[of ?\] by simp + moreover have "subst_range ?\ = ((\c. Fun c []) ` T')" + using \bij_betw f S T'\ unfolding bij_betw_def inj_on_def by (auto simp add: subst_domain_def) + hence "subst_range ?\ \ ((\c. Fun c []) ` (U - T))" using \T' \ U - T\ by auto + ultimately show ?thesis by (metis (lifting)) +qed + +lemma bij_finite_const_subst_exists': + assumes "finite (S::'v set)" "finite (T::('f,'v) terms)" "infinite (U::'f set)" + shows "\\::('f,'v) subst. subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subst_range \ \ ((\c. Fun c []) ` U) - T" +proof - + have "finite (\(funs_term ` T))" using assms(2) by auto + then obtain \ where \: + "subst_domain \ = S" "bij_betw \ (subst_domain \) (subst_range \)" + "subst_range \ \ (\c. Fun c []) ` (U - (\(funs_term ` T)))" + using bij_finite_const_subst_exists[OF assms(1) _ assms(3)] by blast + moreover have "(\c. Fun c []) ` (U - (\(funs_term ` T))) \ ((\c. Fun c []) ` U) - T" by auto + ultimately show ?thesis by blast +qed + +lemma bij_betw_iteI: + assumes "bij_betw f A B" "bij_betw g C D" "A \ C = {}" "B \ D = {}" + shows "bij_betw (\x. if x \ A then f x else g x) (A \ C) (B \ D)" +proof - + have "bij_betw (\x. if x \ A then f x else g x) A B" + by (metis bij_betw_cong[of A f "\x. if x \ A then f x else g x" B] assms(1)) + moreover have "bij_betw (\x. if x \ A then f x else g x) C D" + using bij_betw_cong[of C g "\x. if x \ A then f x else g x" D] assms(2,3) by force + ultimately show ?thesis using bij_betw_combine[OF _ _ assms(4)] by metis +qed + +lemma subst_comp_split: + assumes "subst_domain \ \ range_vars \ = {}" + shows "\ = (rm_vars (subst_domain \ - V) \) \\<^sub>s (rm_vars V \)" (is ?P) + and "\ = (rm_vars V \) \\<^sub>s (rm_vars (subst_domain \ - V) \)" (is ?Q) +proof - + let ?rm1 = "rm_vars (subst_domain \ - V) \" and ?rm2 = "rm_vars V \" + have "subst_domain ?rm2 \ range_vars ?rm1 = {}" + "subst_domain ?rm1 \ range_vars ?rm2 = {}" + using assms unfolding range_vars_alt_def by (force simp add: subst_domain_def)+ + hence *: "\v. v \ subst_domain ?rm1 \ (?rm1 \\<^sub>s ?rm2) v = \ v" + "\v. v \ subst_domain ?rm2 \ (?rm2 \\<^sub>s ?rm1) v = \ v" + using ident_comp_subst_trm_if_disj[of ?rm2 ?rm1] + ident_comp_subst_trm_if_disj[of ?rm1 ?rm2] + by (auto simp add: subst_domain_def) + hence "\v. v \ subst_domain ?rm1 \ (?rm1 \\<^sub>s ?rm2) v = \ v" + "\v. v \ subst_domain ?rm2 \ (?rm2 \\<^sub>s ?rm1) v = \ v" + unfolding subst_compose_def by (auto simp add: subst_domain_def) + hence "\v. (?rm1 \\<^sub>s ?rm2) v = \ v" "\v. (?rm2 \\<^sub>s ?rm1) v = \ v" using * by blast+ + thus ?P ?Q by auto +qed + +lemma subst_comp_eq_if_disjoint_vars: + assumes "(subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + shows "\ \\<^sub>s \ = \ \\<^sub>s \" +proof - + { fix x assume "x \ subst_domain \" + hence "(\ \\<^sub>s \) x = \ x" "(\ \\<^sub>s \) x = \ x" + using assms unfolding range_vars_alt_def by (force simp add: subst_compose)+ + hence "(\ \\<^sub>s \) x = (\ \\<^sub>s \) x" by metis + } moreover + { fix x assume "x \ subst_domain \" + hence "(\ \\<^sub>s \) x = \ x" "(\ \\<^sub>s \) x = \ x" + using assms + unfolding range_vars_alt_def by (auto simp add: subst_compose subst_domain_def) + hence "(\ \\<^sub>s \) x = (\ \\<^sub>s \) x" by metis + } moreover + { fix x assume "x \ subst_domain \" "x \ subst_domain \" + hence "(\ \\<^sub>s \) x = (\ \\<^sub>s \) x" by (simp add: subst_compose subst_domain_def) + } ultimately show ?thesis by auto +qed + +lemma subst_eq_if_disjoint_vars_ground: + fixes \ \::"('f,'v) subst" + assumes "subst_domain \ \ subst_domain \ = {}" "ground (subst_range \)" "ground (subst_range \)" + shows "t \ \ \ \ = t \ \ \ \" +by (metis assms subst_comp_eq_if_disjoint_vars range_vars_alt_def + subst_subst_compose sup_bot.right_neutral) + +lemma subst_img_bound: "subst_domain \ \ range_vars \ \ fv t \ range_vars \ \ fv (t \ \)" +proof - + assume "subst_domain \ \ range_vars \ \ fv t" + hence "subst_domain \ \ fv t" by blast + thus ?thesis + by (metis (no_types) range_vars_alt_def le_iff_sup subst_apply_fv_unfold + subst_apply_fv_union subst_range.simps) +qed + +lemma subst_all_fv_subset: "fv t \ fv\<^sub>s\<^sub>e\<^sub>t M \ fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" +proof - + assume *: "fv t \ fv\<^sub>s\<^sub>e\<^sub>t M" + { fix v assume "v \ fv t" + hence "v \ fv\<^sub>s\<^sub>e\<^sub>t M" using * by auto + then obtain t' where "t' \ M" "v \ fv t'" by auto + hence "fv (\ v) \ fv (t' \ \)" + by (metis subst_apply_term.simps(1) subst_apply_fv_subset subst_apply_fv_unfold + subtermeq_vars_subset vars_iff_subtermeq) + hence "fv (\ v) \ fv\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" using \t' \ M\ by auto + } + thus ?thesis using subst_apply_fv_unfold[of t \] by auto +qed + +lemma subst_support_if_mgt_subst_idem: + assumes "\ \\<^sub>\ \" "subst_idem \" + shows "\ supports \" +proof - + from \\ \\<^sub>\ \\ obtain \ where \: "\ = \ \\<^sub>s \" by blast + hence "\v. \ v \ \ = Var v \ (\ \\<^sub>s \ \\<^sub>s \)" by simp + hence "\v. \ v \ \ = Var v \ (\ \\<^sub>s \)" using \subst_idem \ \ unfolding subst_idem_def by simp + hence "\v. \ v \ \ = Var v \ \" using \ by simp + thus "\ supports \" by simp +qed + +lemma subst_support_iff_mgt_if_subst_idem: + assumes "subst_idem \" + shows "\ \\<^sub>\ \ \ \ supports \" +proof + show "\ \\<^sub>\ \ \ \ supports \" by (fact subst_support_if_mgt_subst_idem[OF _ \subst_idem \\]) + show "\ supports \ \ \ \\<^sub>\ \" by (fact subst_supportD) +qed + +lemma subst_support_comp: + fixes \ \ \::"('a,'b) subst" + assumes "\ supports \" "\ supports \" + shows "(\ \\<^sub>s \) supports \" +by (metis (no_types) assms subst_agreement subst_apply_term.simps(1) subst_subst_compose) + +lemma subst_support_comp': + fixes \ \ \::"('a,'b) subst" + assumes "\ supports \" + shows "\ supports (\ \\<^sub>s \)" "\ supports \ \ \ supports (\ \\<^sub>s \)" +using assms unfolding subst_support_def by (metis subst_compose_assoc, metis) + +lemma subst_support_comp_split: + fixes \ \ \::"('a,'b) subst" + assumes "(\ \\<^sub>s \) supports \" + shows "subst_domain \ \ range_vars \ = {} \ \ supports \" + and "subst_domain \ \ subst_domain \ = {} \ \ supports \" +proof - + assume "subst_domain \ \ range_vars \ = {}" + hence "subst_idem \" by (metis subst_idemI) + have "\ \\<^sub>\ \" using assms subst_compose_assoc[of \ \ \] unfolding subst_compose_def by metis + show "\ supports \" using subst_support_if_mgt_subst_idem[OF \\ \\<^sub>\ \\ \subst_idem \\] by auto +next + assume "subst_domain \ \ subst_domain \ = {}" + moreover have "\v \ subst_domain (\ \\<^sub>s \). (\ \\<^sub>s \) v \ \ = \ v" using assms by metis + ultimately have "\v \ subst_domain \. \ v \ \ = \ v" + using var_not_in_subst_dom unfolding subst_compose_def + by (metis IntI empty_iff subst_apply_term.simps(1)) + thus "\ supports \" by force +qed + +lemma subst_idem_support: "subst_idem \ \ \ supports \ \\<^sub>s \" +unfolding subst_idem_def by (metis subst_support_def subst_compose_assoc) + +lemma subst_idem_iff_self_support: "subst_idem \ \ \ supports \" +using subst_support_def[of \ \] unfolding subst_idem_def by auto + +lemma subterm_subst_neq: "t \ t' \ t \ s \ t' \ s" +by (metis subst_mono_neq) + +lemma fv_Fun_subst_neq: "x \ fv (Fun f T) \ \ x \ Fun f T \ \" +using subterm_subst_neq[of "Var x" "Fun f T"] vars_iff_subterm_or_eq[of x "Fun f T"] by auto + +lemma subterm_subst_unfold: + assumes "t \ s \ \" + shows "(\s'. s' \ s \ t = s' \ \) \ (\x \ fv s. t \ \ x)" +using assms +proof (induction s) + case (Fun f T) thus ?case + proof (cases "t = Fun f T \ \") + case True thus ?thesis using Fun by auto + next + case False + then obtain s' where s': "s' \ set T" "t \ s' \ \" using Fun by auto + hence "(\s''. s'' \ s' \ t = s'' \ \) \ (\x \ fv s'. t \ \ x)" by (metis Fun.IH) + thus ?thesis using s'(1) by auto + qed +qed simp + +lemma subterm_subst_img_subterm: + assumes "t \ s \ \" "\s'. s' \ s \ t \ s' \ \" + shows "\w \ fv s. t \ \ w" +using subterm_subst_unfold[OF assms(1)] assms(2) by force + +lemma subterm_subst_not_img_subterm: + assumes "t \ s \ \" "\(\w \ fv s. t \ \ w)" + shows "\f T. Fun f T \ s \ t = Fun f T \ \" +proof (rule ccontr) + assume "\(\f T. Fun f T \ s \ t = Fun f T \ \)" + hence "\f T. Fun f T \ s \ t \ Fun f T \ \" by simp + moreover have "\x. Var x \ s \ t \ Var x \ \" + using assms(2) vars_iff_subtermeq by force + ultimately have "\s'. s' \ s \ t \ s' \ \" by (metis "term.exhaust") + thus False using assms subterm_subst_img_subterm by blast +qed + +lemma subst_apply_img_var: + assumes "v \ fv (t \ \)" "v \ fv t" + obtains w where "w \ fv t" "v \ fv (\ w)" +using assms by (induct t) auto + +lemma subst_apply_img_var': + assumes "x \ fv (t \ \)" "x \ fv t" + shows "\y \ fv t. x \ fv (\ y)" +by (metis assms subst_apply_img_var) + +lemma nth_map_subst: + fixes \::"('f,'v) subst" and T::"('f,'v) term list" and i::nat + shows "i < length T \ (map (\t. t \ \) T) ! i = (T ! i) \ \" +by (fact nth_map) + +lemma subst_subterm: + assumes "Fun f T \ t \ \" + shows "(\S. Fun f S \ t \ Fun f S \ \ = Fun f T) \ + (\s \ subst_range \. Fun f T \ s)" +using assms subterm_subst_not_img_subterm by (cases "\s \ subst_range \. Fun f T \ s") fastforce+ + +lemma subst_subterm': + assumes "Fun f T \ t \ \" + shows "\S. length S = length T \ (Fun f S \ t \ (\s \ subst_range \. Fun f S \ s))" +using subst_subterm[OF assms] by auto + +lemma subst_subterm'': + assumes "s \ subterms (t \ \)" + shows "(\u \ subterms t. s = u \ \) \ s \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" +proof (cases s) + case (Var x) + thus ?thesis + using assms subterm_subst_not_img_subterm vars_iff_subtermeq + by (cases "s = t \ \") fastforce+ +next + case (Fun f T) + thus ?thesis + using subst_subterm[of f T t \] assms + by fastforce +qed + + +subsection \More Small Lemmata\ +lemma funs_term_subst: "funs_term (t \ \) = funs_term t \ (\x \ fv t. funs_term (\ x))" +by (induct t) auto + +lemma fv\<^sub>s\<^sub>e\<^sub>t_subst_img_eq: + assumes "X \ (subst_domain \ \ range_vars \) = {}" + shows "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (Y - X)) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` Y) - X" +using assms unfolding range_vars_alt_def by force + +lemma subst_Fun_index_eq: + assumes "i < length T" "Fun f T \ \ = Fun g T' \ \" + shows "T ! i \ \ = T' ! i \ \" +proof - + have "map (\x. x \ \) T = map (\x. x \ \) T'" using assms by simp + thus ?thesis by (metis assms(1) length_map nth_map) +qed + +lemma fv_exists_if_unifiable_and_neq: + fixes t t'::"('a,'b) term" and \ \::"('a,'b) subst" + assumes "t \ t'" "t \ \ = t' \ \" + shows "fv t \ fv t' \ {}" +proof + assume "fv t \ fv t' = {}" + hence "fv t = {}" "fv t' = {}" by auto + hence "t \ \ = t" "t' \ \ = t'" by auto + hence "t = t'" using assms(2) by metis + thus False using assms(1) by auto +qed + +lemma const_subterm_subst: "Fun c [] \ t \ Fun c [] \ t \ \" +by (induct t) auto + +lemma const_subterm_subst_var_obtain: + assumes "Fun c [] \ t \ \" "\Fun c [] \ t" + obtains x where "x \ fv t" "Fun c [] \ \ x" +using assms by (induct t) auto + +lemma const_subterm_subst_cases: + assumes "Fun c [] \ t \ \" + shows "Fun c [] \ t \ (\x \ fv t. x \ subst_domain \ \ Fun c [] \ \ x)" +proof (cases "Fun c [] \ t") + case False + then obtain x where "x \ fv t" "Fun c [] \ \ x" + using const_subterm_subst_var_obtain[OF assms] by moura + thus ?thesis by (cases "x \ subst_domain \") auto +qed simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_fv_subset: + assumes "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + shows "fv (\ x) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using assms +proof (induction F) + case (Cons f F) + then obtain t t' where f: "f = (t,t')" by (metis surj_pair) + show ?case + proof (cases "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F") + case True thus ?thesis + using Cons.IH + unfolding subst_apply_pairs_def + by auto + next + case False + hence "x \ fv t \ fv t'" using Cons.prems f by simp + hence "fv (\ x) \ fv (t \ \) \ fv (t' \ \)" using fv_subst_subset[of x] by force + thus ?thesis using f unfolding subst_apply_pairs_def by auto + qed +qed simp + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_step_subst: "fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +proof (induction F) + case (Cons f F) + obtain t t' where "f = (t,t')" by moura + thus ?case + using Cons + by (simp add: subst_apply_pairs_def subst_apply_fv_unfold) +qed (simp_all add: subst_apply_pairs_def) + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var: + fixes \::"('a,'b) subst" + assumes "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + shows "\y \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. x \ fv (\ y)" + using assms +proof (induction F) + case (Cons f F) + then obtain t s where f: "f = (t,s)" by (metis surj_pair) + + from Cons.IH show ?case + proof (cases "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)") + case False + hence "x \ fv (t \ \) \ x \ fv (s \ \)" + using f Cons.prems + by (simp add: subst_apply_pairs_def) + hence "(\y \ fv t. x \ fv (\ y)) \ (\y \ fv s. x \ fv (\ y))" by (metis fv_subst_obtain_var) + thus ?thesis using f by (auto simp add: subst_apply_pairs_def) + qed (auto simp add: Cons.IH) +qed (simp add: subst_apply_pairs_def) + +lemma pair_subst_ident[intro]: "(fv t \ fv t') \ subst_domain \ = {} \ (t,t') \\<^sub>p \ = (t,t')" +by auto + +lemma pairs_substI[intro]: + assumes "subst_domain \ \ (\(s,t) \ M. fv s \ fv t) = {}" + shows "M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ = M" +proof - + { fix m assume M: "m \ M" + then obtain s t where m: "m = (s,t)" by (metis surj_pair) + hence "(fv s \ fv t) \ subst_domain \ = {}" using assms M by auto + hence "m \\<^sub>p \ = m" using m by auto + } thus ?thesis by (simp add: image_cong) +qed + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F))" +proof (induction F) + case (Cons g G) + obtain t t' where "g = (t,t')" by (metis surj_pair) + thus ?case + using Cons.IH + by (simp add: subst_apply_pairs_def subst_apply_fv_unfold) +qed (simp add: subst_apply_pairs_def) + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_subset: + assumes "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ subst_domain \" + shows "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ subst_domain \ \ subst_domain \" + using assms +proof (induction F) + case (Cons g G) + hence IH: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \ subst_domain \ \ subst_domain \" + by (simp add: subst_apply_pairs_def) + obtain t t' where g: "g = (t,t')" by (metis surj_pair) + hence "fv (t \ \) \ subst_domain \" "fv (t' \ \) \ subst_domain \" + using Cons.prems by (simp_all add: subst_apply_pairs_def) + hence "fv t \ subst_domain \ \ subst_domain \" "fv t' \ subst_domain \ \ subst_domain \" + using subst_apply_fv_unfold[of _ \] by force+ + thus ?case using IH g by (simp add: subst_apply_pairs_def) +qed (simp add: subst_apply_pairs_def) + +lemma pairs_subst_comp: "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ \\<^sub>s \ = ((F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +by (induct F) (auto simp add: subst_apply_pairs_def) + +lemma pairs_substI'[intro]: + "subst_domain \ \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = {} \ F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ = F" +by (induct F) (force simp add: subst_apply_pairs_def)+ + +lemma subst_pair_compose[simp]: "d \\<^sub>p (\ \\<^sub>s \) = d \\<^sub>p \ \\<^sub>p \" +proof - + obtain t s where "d = (t,s)" by moura + thus ?thesis by auto +qed + +lemma subst_pairs_compose[simp]: "D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t (\ \\<^sub>s \) = D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +by auto + +lemma subst_apply_pair_pair: "(t, s) \\<^sub>p \ = (t \ \, s \ \)" +by (rule prod.case) + +lemma subst_apply_pairs_nil[simp]: "[] \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ = []" +unfolding subst_apply_pairs_def by simp + +lemma subst_apply_pairs_singleton[simp]: "[(t,s)] \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ = [(t \ \,s \ \)]" +unfolding subst_apply_pairs_def by simp + +lemma subst_apply_pairs_Var[iff]: "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s Var = F" by (simp add: subst_apply_pairs_def) + +lemma subst_apply_pairs_pset_subst: "set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = set F \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +unfolding subst_apply_pairs_def by force + + +subsection \Finite Substitutions\ +inductive_set fsubst::"('a,'b) subst set" where + fvar: "Var \ fsubst" +| FUpdate: "\\ \ fsubst; v \ subst_domain \; t \ Var v\ \ \(v := t) \ fsubst" + +lemma finite_dom_iff_fsubst: + "finite (subst_domain \) \ \ \ fsubst" +proof + assume "finite (subst_domain \)" thus "\ \ fsubst" + proof (induction "subst_domain \" arbitrary: \ rule: finite.induct) + case emptyI + hence "\ = Var" using empty_dom_iff_empty_subst by metis + thus ?case using fvar by simp + next + case (insertI \'\<^sub>d\<^sub>o\<^sub>m v) thus ?case + proof (cases "v \ \'\<^sub>d\<^sub>o\<^sub>m") + case True + hence "\'\<^sub>d\<^sub>o\<^sub>m = subst_domain \" using \insert v \'\<^sub>d\<^sub>o\<^sub>m = subst_domain \\ by auto + thus ?thesis using insertI.hyps(2) by metis + next + case False + let ?\' = "\w. if w \ \'\<^sub>d\<^sub>o\<^sub>m then \ w else Var w" + have "subst_domain ?\' = \'\<^sub>d\<^sub>o\<^sub>m" + using \v \ \'\<^sub>d\<^sub>o\<^sub>m\ \insert v \'\<^sub>d\<^sub>o\<^sub>m = subst_domain \\ + by (auto simp add: subst_domain_def) + hence "?\' \ fsubst" using insertI.hyps(2) by simp + moreover have "?\'(v := \ v) = (\w. if w \ insert v \'\<^sub>d\<^sub>o\<^sub>m then \ w else Var w)" by auto + hence "?\'(v := \ v) = \" + using \insert v \'\<^sub>d\<^sub>o\<^sub>m = subst_domain \\ + by (auto simp add: subst_domain_def) + ultimately show ?thesis + using FUpdate[of ?\' v "\ v"] False insertI.hyps(3) + by (auto simp add: subst_domain_def) + qed + qed +next + assume "\ \ fsubst" thus "finite (subst_domain \)" + by (induct \, simp, metis subst_dom_insert_finite) +qed + +lemma fsubst_induct[case_names fvar FUpdate, induct set: finite]: + assumes "finite (subst_domain \)" "P Var" + and "\\ v t. \finite (subst_domain \); v \ subst_domain \; t \ Var v; P \\ \ P (\(v := t))" + shows "P \" +using assms finite_dom_iff_fsubst fsubst.induct by metis + +lemma fun_upd_fsubst: "s(v := t) \ fsubst \ s \ fsubst" +using subst_dom_insert_finite[of s] finite_dom_iff_fsubst by blast + +lemma finite_img_if_fsubst: "s \ fsubst \ finite (subst_range s)" +using finite_dom_iff_fsubst finite_subst_img_if_finite_dom' by blast + + +subsection \Unifiers and Most General Unifiers (MGUs)\ + +abbreviation Unifier::"('f,'v) subst \ ('f,'v) term \ ('f,'v) term \ bool" where + "Unifier \ t u \ (t \ \ = u \ \)" + +abbreviation MGU::"('f,'v) subst \ ('f,'v) term \ ('f,'v) term \ bool" where + "MGU \ t u \ Unifier \ t u \ (\\. Unifier \ t u \ \ \\<^sub>\ \)" + +lemma MGUI[intro]: + shows "\t \ \ = u \ \; \\::('f,'v) subst. t \ \ = u \ \ \ \ \\<^sub>\ \\ \ MGU \ t u" +by auto + +lemma UnifierD[dest]: + fixes \::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list" + assumes "Unifier \ (Fun f X) (Fun g Y)" + shows "f = g" "length X = length Y" +proof - + from assms show "f = g" by auto + + from assms have "Fun f X \ \ = Fun g Y \ \" by auto + hence "length (map (\x. x \ \) X) = length (map (\x. x \ \) Y)" by auto + thus "length X = length Y" by auto +qed + +lemma MGUD[dest]: + fixes \::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list" + assumes "MGU \ (Fun f X) (Fun g Y)" + shows "f = g" "length X = length Y" +using assms by (auto intro!: UnifierD[of f X \ g Y]) + +lemma MGU_sym[sym]: "MGU \ s t \ MGU \ t s" by auto +lemma Unifier_sym[sym]: "Unifier \ s t \ Unifier \ t s" by auto + +lemma MGU_nil: "MGU Var s t \ s = t" by fastforce + +lemma Unifier_comp: "Unifier (\ \\<^sub>s \) t u \ Unifier \ (t \ \) (u \ \)" +by simp + +lemma Unifier_comp': "Unifier \ (t \ \) (u \ \) \ Unifier (\ \\<^sub>s \) t u" +by simp + +lemma Unifier_excludes_subterm: + assumes \: "Unifier \ t u" + shows "\t \ u" +proof + assume "t \ u" + hence "t \ \ \ u \ \" using subst_mono_neq by metis + hence "t \ \ \ u \ \" by simp + moreover from \ have "t \ \ = u \ \" by auto + ultimately show False .. +qed + +lemma MGU_is_Unifier: "MGU \ t u \ Unifier \ t u" by (rule conjunct1) + +lemma MGU_Var1: + assumes "\Var v \ t" + shows "MGU (Var(v := t)) (Var v) t" +proof (intro MGUI exI) + show "Var v \ (Var(v := t)) = t \ (Var(v := t))" using assms subst_no_occs by fastforce +next + fix \::"('a,'b) subst" assume th: "Var v \ \ = t \ \" + show "\ = (Var(v := t)) \\<^sub>s \" + proof + fix s show "s \ \ = s \ ((Var(v := t)) \\<^sub>s \)" using th by (induct s) auto + qed +qed + +lemma MGU_Var2: "v \ fv t \ MGU (Var(v := t)) (Var v) t" +by (metis (no_types) MGU_Var1 vars_iff_subterm_or_eq) + +lemma MGU_Var3: "MGU Var (Var v) (Var w) \ v = w" by fastforce + +lemma MGU_Const1: "MGU Var (Fun c []) (Fun d []) \ c = d" by fastforce + +lemma MGU_Const2: "MGU \ (Fun c []) (Fun d []) \ c = d" by auto + +lemma MGU_Fun: + assumes "MGU \ (Fun f X) (Fun g Y)" + shows "f = g" "length X = length Y" +proof - + let ?F = "\\ X. map (\x. x \ \) X" + from assms have + "\f = g; ?F \ X = ?F \ Y; \\'. f = g \ ?F \' X = ?F \' Y \ \ \\<^sub>\ \'\ \ length X = length Y" + using map_eq_imp_length_eq by auto + thus "f = g" "length X = length Y" using assms by auto +qed + +lemma Unifier_Fun: + assumes "Unifier \ (Fun f (x#X)) (Fun g (y#Y))" + shows "Unifier \ x y" "Unifier \ (Fun f X) (Fun g Y)" +using assms by simp_all + +lemma Unifier_subst_idem_subst: + "subst_idem r \ Unifier s (t \ r) (u \ r) \ Unifier (r \\<^sub>s s) (t \ r) (u \ r)" +by (metis (no_types, lifting) subst_idem_def subst_subst_compose) + +lemma subst_idem_comp: + "subst_idem r \ Unifier s (t \ r) (u \ r) \ + (\q. Unifier q (t \ r) (u \ r) \ s \\<^sub>s q = q) \ + subst_idem (r \\<^sub>s s)" +by (frule Unifier_subst_idem_subst, blast, metis subst_idem_def subst_compose_assoc) + +lemma Unifier_mgt: "\Unifier \ t u; \ \\<^sub>\ \\ \ Unifier \ t u" by auto + +lemma Unifier_support: "\Unifier \ t u; \ supports \\ \ Unifier \ t u" +using subst_supportD Unifier_mgt by metis + +lemma MGU_mgt: "\MGU \ t u; MGU \ t u\ \ \ \\<^sub>\ \" by auto + +lemma Unifier_trm_fv_bound: + "\Unifier s t u; v \ fv t\ \ v \ subst_domain s \ range_vars s \ fv u" +proof (induction t arbitrary: s u) + case (Fun f X) + hence "v \ fv (u \ s) \ v \ subst_domain s" by (metis subst_not_dom_fixed) + thus ?case by (metis (no_types) Un_iff contra_subsetD subst_sends_fv_to_img) +qed (metis (no_types) UnI1 UnI2 subsetCE no_var_subterm subst_sends_dom_to_img + subst_to_var_is_var trm_subst_ident' vars_iff_subterm_or_eq) + +lemma Unifier_rm_var: "\Unifier \ s t; v \ fv s \ fv t\ \ Unifier (rm_var v \) s t" +by (auto simp add: repl_invariance) + +lemma Unifier_ground_rm_vars: + assumes "ground (subst_range s)" "Unifier (rm_vars X s) t t'" + shows "Unifier s t t'" +by (rule Unifier_support[OF assms(2) rm_vars_ground_supports[OF assms(1)]]) + +lemma Unifier_dom_restrict: + assumes "Unifier s t t'" "fv t \ fv t' \ S" + shows "Unifier (rm_vars (UNIV - S) s) t t'" +proof - + let ?s = "rm_vars (UNIV - S) s" + show ?thesis using term_subst_eq_conv[of t s ?s] term_subst_eq_conv[of t' s ?s] assms by auto +qed + + +subsection \Well-formedness of Substitutions and Unifiers\ +inductive_set wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set::"('a,'b) subst set" where + Empty[simp]: "Var \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" +| Insert[simp]: + "\\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set; v \ subst_domain \; + v \ range_vars \; fv t \ (insert v (subst_domain \)) = {}\ + \ \(v := t) \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" + +definition wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t::"('a,'b) subst \ bool" where + "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ subst_domain \ \ range_vars \ = {} \ finite (subst_domain \)" + +definition wf\<^sub>M\<^sub>G\<^sub>U::"('a,'b) subst \ ('a,'b) term \ ('a,'b) term \ bool" where + "wf\<^sub>M\<^sub>G\<^sub>U \ s t \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ MGU \ s t \ subst_domain \ \ range_vars \ \ fv s \ fv t" + +lemma wf_subst_subst_idem: "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ subst_idem \" using subst_idemI[of \] unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by fast + +lemma wf_subst_properties: "\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set = wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +proof + show "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def + proof - + assume "subst_domain \ \ range_vars \ = {} \ finite (subst_domain \)" + hence "finite (subst_domain \)" "subst_domain \ \ range_vars \ = {}" + by auto + thus "\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" + proof (induction \ rule: fsubst_induct) + case fvar thus ?case by simp + next + case (FUpdate \ v t) + have "subst_domain \ \ subst_domain (\(v := t))" "range_vars \ \ range_vars (\(v := t))" + using FUpdate.hyps(2,3) subst_img_update + unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def)+ + hence "subst_domain \ \ range_vars \ = {}" using FUpdate.prems(1) by blast + hence "\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" using FUpdate.IH by metis + + have *: "range_vars (\(v := t)) = range_vars \ \ fv t" + using FUpdate.hyps(2) subst_img_update[OF _ FUpdate.hyps(3)] + by fastforce + hence "fv t \ insert v (subst_domain \) = {}" + using FUpdate.prems subst_dom_update2[OF FUpdate.hyps(3)] by blast + moreover have "subst_domain (\(v := t)) = insert v (subst_domain \)" + by (meson FUpdate.hyps(3) subst_dom_update2) + hence "v \ range_vars \" using FUpdate.prems * by blast + ultimately show ?case using Insert[OF \\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set\ \v \ subst_domain \\] by metis + qed + qed + + show "\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def + proof (induction \ rule: wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set.induct) + case Empty thus ?case by simp + next + case (Insert \ v t) + hence 1: "subst_domain \ \ range_vars \ = {}" by simp + hence 2: "subst_domain (\(v := t)) \ range_vars \ = {}" + using Insert.hyps(3) by (auto simp add: subst_domain_def) + have 3: "fv t \ subst_domain (\(v := t)) = {}" + using Insert.hyps(4) by (auto simp add: subst_domain_def) + have 4: "\ v = Var v" using \v \ subst_domain \\ by (simp add: subst_domain_def) + + from Insert.IH have "finite (subst_domain \)" by simp + hence 5: "finite (subst_domain (\(v := t)))" using subst_dom_insert_finite[of \] by simp + + have "subst_domain (\(v := t)) \ range_vars (\(v := t)) = {}" + proof (cases "t = Var v") + case True + hence "range_vars (\(v := t)) = range_vars \" + using 4 fun_upd_triv term.inject(1) + unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + thus "subst_domain (\(v := t)) \ range_vars (\(v := t)) = {}" + using 1 2 3 by auto + next + case False + hence "range_vars (\(v := t)) = fv t \ (range_vars \)" + using 4 subst_img_update[of \ v] by auto + thus "subst_domain (\(v := t)) \ range_vars (\(v := t)) = {}" using 1 2 3 by blast + qed + thus ?case using 5 by blast + qed +qed + +lemma wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_induct[consumes 1, case_names Empty Insert]: + assumes "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "P Var" + and "\\ v t. \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \; P \; v \ subst_domain \; v \ range_vars \; + fv t \ insert v (subst_domain \) = {}\ + \ P (\(v := t))" + shows "P \" +proof - + from assms(1,3) wf_subst_properties have + "\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set" + "\\ v t. \\ \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set; P \; v \ subst_domain \; v \ range_vars \; + fv t \ insert v (subst_domain \) = {}\ + \ P (\(v := t))" + by blast+ + thus "P \" using wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set.induct assms(2) by blast +qed + +lemma wf_subst_fsubst: "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \ \ fsubst" +unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def using finite_dom_iff_fsubst by blast + +lemma wf_subst_nil: "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp + +lemma wf_MGU_nil: "MGU Var s t \ wf\<^sub>M\<^sub>G\<^sub>U Var s t" +using wf_subst_nil subst_domain_Var range_vars_Var +unfolding wf\<^sub>M\<^sub>G\<^sub>U_def by fast + +lemma wf_MGU_dom_bound: "wf\<^sub>M\<^sub>G\<^sub>U \ s t \ subst_domain \ \ fv s \ fv t" unfolding wf\<^sub>M\<^sub>G\<^sub>U_def by blast + +lemma wf_subst_single: + assumes "v \ fv t" "\ v = t" "\w. v \ w \ \ w = Var w" + shows "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +proof - + have *: "subst_domain \ = {v}" by (metis subst_fv_dom_img_single(1)[OF assms]) + + have "subst_domain \ \ range_vars \ = {}" + using * assms subst_fv_dom_img_single(2) + by (metis inf_bot_left insert_disjoint(1)) + moreover have "finite (subst_domain \)" using * by simp + ultimately show ?thesis by (metis wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) +qed + +lemma wf_subst_reduction: + "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t s \ wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (rm_var v s)" +proof - + assume "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t s" + moreover have "subst_domain (rm_var v s) \ subst_domain s" by (auto simp add: subst_domain_def) + moreover have "range_vars (rm_var v s) \ range_vars s" + unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + ultimately have "subst_domain (rm_var v s) \ range_vars (rm_var v s) = {}" + by (meson compl_le_compl_iff disjoint_eq_subset_Compl subset_trans wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + moreover have "finite (subst_domain (rm_var v s))" + using \subst_domain (rm_var v s) \ subst_domain s\ \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t s\ rev_finite_subset + unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by blast + ultimately show "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (rm_var v s)" by (metis wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) +qed + +lemma wf_subst_compose: + assumes "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \1" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \2" + and "subst_domain \1 \ subst_domain \2 = {}" + and "subst_domain \1 \ range_vars \2 = {}" + shows "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\1 \\<^sub>s \2)" +using assms +proof (induction \1 rule: wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_induct) + case Empty thus ?case unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp +next + case (Insert \1 v t) + have "t \ Var v" using Insert.hyps(4) by auto + hence dom1v_unfold: "subst_domain (\1(v := t)) = insert v (subst_domain \1)" + using subst_dom_update2 by metis + hence doms_disj: "subst_domain \1 \ subst_domain \2 = {}" + using Insert.prems(2) disjoint_insert(1) by blast + moreover have dom_img_disj: "subst_domain \1 \ range_vars \2 = {}" + using Insert.hyps(2) Insert.prems(3) + by (fastforce simp add: subst_domain_def) + ultimately have "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\1 \\<^sub>s \2)" using Insert.IH[OF \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \2\] by metis + + have dom_comp_is_union: "subst_domain (\1 \\<^sub>s \2) = subst_domain \1 \ subst_domain \2" + using subst_dom_comp_eq[OF dom_img_disj] . + + have "v \ subst_domain \2" + using Insert.prems(2) \t \ Var v\ + by (fastforce simp add: subst_domain_def) + hence "\2 v = Var v" "\1 v = Var v" using Insert.hyps(2) by (simp_all add: subst_domain_def) + hence "(\1 \\<^sub>s \2) v = Var v" "(\1(v := t) \\<^sub>s \2) v = t \ \2" "((\1 \\<^sub>s \2)(v := t)) v = t" + unfolding subst_compose_def by simp_all + + have fv_t2_bound: "fv (t \ \2) \ fv t \ range_vars \2" by (meson subst_sends_fv_to_img) + + have 1: "v \ subst_domain (\1 \\<^sub>s \2)" + using \(\1 \\<^sub>s \2) v = Var v\ + by (auto simp add: subst_domain_def) + + have "insert v (subst_domain \1) \ range_vars \2 = {}" + using Insert.prems(3) dom1v_unfold by blast + hence "v \ range_vars \1 \ range_vars \2" using Insert.hyps(3) by blast + hence 2: "v \ range_vars (\1 \\<^sub>s \2)" by (meson set_rev_mp subst_img_comp_subset) + + have "subst_domain \2 \ range_vars \2 = {}" + using \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \2\ unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp + hence "fv (t \ \2) \ subst_domain \2 = {}" + using subst_dom_elim unfolding range_vars_alt_def by simp + moreover have "v \ range_vars \2" using Insert.prems(3) dom1v_unfold by blast + hence "v \ fv t \ range_vars \2" using Insert.hyps(4) by blast + hence "v \ fv (t \ \2)" using \fv (t \ \2) \ fv t \ range_vars \2\ by blast + moreover have "fv (t \ \2) \ subst_domain \1 = {}" + using dom_img_disj fv_t2_bound \fv t \ insert v (subst_domain \1) = {}\ by blast + ultimately have 3: "fv (t \ \2) \ insert v (subst_domain (\1 \\<^sub>s \2)) = {}" + using dom_comp_is_union by blast + + have "\1(v := t) \\<^sub>s \2 = (\1 \\<^sub>s \2)(v := t \ \2)" using subst_comp_upd1[of \1 v t \2] . + moreover have "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t ((\1 \\<^sub>s \2)(v := t \ \2))" + using "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set.Insert"[OF _ 1 2 3] \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\1 \\<^sub>s \2)\ wf_subst_properties by metis + ultimately show ?case by presburger +qed + +lemma wf_subst_append: + fixes \1 \2::"('f,'v) subst" + assumes "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \1" "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \2" + and "subst_domain \1 \ subst_domain \2 = {}" + and "subst_domain \1 \ range_vars \2 = {}" + and "range_vars \1 \ subst_domain \2 = {}" + shows "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\v. if \1 v = Var v then \2 v else \1 v)" +using assms +proof (induction \1 rule: wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_induct) + case Empty thus ?case unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp +next + case (Insert \1 v t) + let ?if = "\w. if \1 w = Var w then \2 w else \1 w" + let ?if_upd = "\w. if (\1(v := t)) w = Var w then \2 w else (\1(v := t)) w" + + from Insert.hyps(4) have "?if_upd = ?if(v := t)" by fastforce + + have dom_insert: "subst_domain (\1(v := t)) = insert v (subst_domain \1)" + using Insert.hyps(4) by (auto simp add: subst_domain_def) + + have "\1 v = Var v" "t \ Var v" using Insert.hyps(2,4) by auto + hence img_insert: "range_vars (\1(v := t)) = range_vars \1 \ fv t" + using subst_img_update by metis + + from Insert.prems(2) dom_insert have "subst_domain \1 \ subst_domain \2 = {}" + by (auto simp add: subst_domain_def) + moreover have "subst_domain \1 \ range_vars \2 = {}" + using Insert.prems(3) dom_insert + by (simp add: subst_domain_def) + moreover have "range_vars \1 \ subst_domain \2 = {}" + using Insert.prems(4) img_insert + by blast + ultimately have "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t ?if" using Insert.IH[OF Insert.prems(1)] by metis + + have dom_union: "subst_domain ?if = subst_domain \1 \ subst_domain \2" + by (auto simp add: subst_domain_def) + hence "v \ subst_domain ?if" + using Insert.hyps(2) Insert.prems(2) dom_insert + by (auto simp add: subst_domain_def) + moreover have "v \ range_vars ?if" + using Insert.prems(3) Insert.hyps(3) dom_insert + unfolding range_vars_alt_def by (auto simp add: subst_domain_def) + moreover have "fv t \ insert v (subst_domain ?if) = {}" + using Insert.hyps(4) Insert.prems(4) img_insert + unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def) + ultimately show ?case + using wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_set.Insert \wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t ?if\ \?if_upd = ?if(v := t)\ wf_subst_properties + by (metis (no_types, lifting)) +qed + +lemma wf_subst_elim_append: + assumes "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "subst_elim \ v" "v \ fv t" + shows "subst_elim (\(w := t)) v" +using assms +proof (induction \ rule: wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_induct) + case (Insert \ v' t') + hence "\q. v \ fv (Var q \ \(v' := t'))" using subst_elimD by blast + hence "\q. v \ fv (Var q \ \(v' := t', w := t))" using \v \ fv t\ by simp + thus ?case by (metis subst_elimI' subst_apply_term.simps(1)) +qed (simp add: subst_elim_def) + +lemma wf_subst_elim_dom: + assumes "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\v \ subst_domain \. subst_elim \ v" +using assms +proof (induction \ rule: wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_induct) + case (Insert \ w t) + have dom_insert: "subst_domain (\(w := t)) \ insert w (subst_domain \)" + by (auto simp add: subst_domain_def) + hence "\v \ subst_domain \. subst_elim (\(w := t)) v" using Insert.IH Insert.hyps(2,4) + by (metis Insert.hyps(1) IntI disjoint_insert(2) empty_iff wf_subst_elim_append) + moreover have "w \ fv t" using Insert.hyps(4) by simp + hence "\q. w \ fv (Var q \ \(w := t))" + by (metis fv_simps(1) fv_in_subst_img Insert.hyps(3) contra_subsetD + fun_upd_def singletonD subst_apply_term.simps(1)) + hence "subst_elim (\(w := t)) w" by (metis subst_elimI') + ultimately show ?case using dom_insert by blast +qed simp + +lemma wf_subst_support_iff_mgt: "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \ supports \ \ \ \\<^sub>\ \" +using subst_support_def subst_support_if_mgt_subst_idem wf_subst_subst_idem by blast + + +subsection \Interpretations\ +abbreviation interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t::"('a,'b) subst \ bool" where + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ subst_domain \ = UNIV \ ground (subst_range \)" + +lemma interpretation_substI: + "(\v. fv (\ v) = {}) \ interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +proof - + assume "\v. fv (\ v) = {}" + moreover { fix v assume "fv (\ v) = {}" hence "v \ subst_domain \" by auto } + ultimately show ?thesis by auto +qed + +lemma interpretation_grounds[simp]: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ fv (t \ \) = {}" +using subst_fv_dom_ground_if_ground_img[of t \] by blast + +lemma interpretation_grounds_all: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ (\v. fv (\ v) = {})" +by (metis range_vars_alt_def UNIV_I fv_in_subst_img subset_empty subst_dom_vars_in_subst) + +lemma interpretation_grounds_all': + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ ground (M \\<^sub>s\<^sub>e\<^sub>t \)" +using subst_fv_dom_ground_if_ground_img[of _ \] +by simp + +lemma interpretation_comp: + assumes "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" +proof - + have \_fv: "fv (\ v) = {}" for v using interpretation_grounds_all[OF assms] by simp + hence \_fv': "fv (t \ \) = {}" for t + by (metis all_not_in_conv subst_elimD subst_elimI' subst_apply_term.simps(1)) + + from assms have "(\ \\<^sub>s \) v \ Var v" for v + unfolding subst_compose_def by (metis fv_simps(1) \_fv' insert_not_empty) + hence "subst_domain (\ \\<^sub>s \) = UNIV" by (simp add: subst_domain_def) + moreover have "fv ((\ \\<^sub>s \) v) = {}" for v unfolding subst_compose_def using \_fv' by simp + hence "ground (subst_range (\ \\<^sub>s \))" by simp + ultimately show "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" .. + + from assms have "(\ \\<^sub>s \) v \ Var v" for v + unfolding subst_compose_def by (metis fv_simps(1) \_fv insert_not_empty subst_to_var_is_var) + hence "subst_domain (\ \\<^sub>s \) = UNIV" by (simp add: subst_domain_def) + moreover have "fv ((\ \\<^sub>s \) v) = {}" for v + unfolding subst_compose_def by (simp add: \_fv trm_subst_ident) + hence "ground (subst_range (\ \\<^sub>s \))" by simp + ultimately show "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" .. +qed + +lemma interpretation_subst_exists: + "\\::('f,'v) subst. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +proof - + obtain c::"'f" where "c \ UNIV" by simp + then obtain \::"('f,'v) subst" where "\v. \ v = Fun c []" by simp + hence "subst_domain \ = UNIV" "ground (subst_range \)" + by (simp_all add: subst_domain_def) + thus ?thesis by auto +qed + +lemma interpretation_subst_exists': + "\\::('f,'v) subst. subst_domain \ = X \ ground (subst_range \)" +proof - + obtain \::"('f,'v) subst" where \: "subst_domain \ = UNIV" "ground (subst_range \)" + using interpretation_subst_exists by moura + let ?\ = "rm_vars (UNIV - X) \" + have 1: "subst_domain ?\ = X" using \ by (auto simp add: subst_domain_def) + hence 2: "ground (subst_range ?\)" using \ by force + show ?thesis using 1 2 by blast +qed + +lemma interpretation_subst_idem: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ subst_idem \" +unfolding subst_idem_def +using interpretation_grounds_all[of \] trm_subst_ident subst_eq_if_eq_vars +by fastforce + +lemma subst_idem_comp_upd_eq: + assumes "v \ subst_domain \" "subst_idem \" + shows "\ \\<^sub>s \ = \(v := \ v) \\<^sub>s \" +proof - + from assms(1) have "(\ \\<^sub>s \) v = \ v" unfolding subst_compose_def by auto + moreover have "\w. w \ v \ (\ \\<^sub>s \) w = (\(v := \ v) \\<^sub>s \) w" unfolding subst_compose_def by auto + moreover have "(\(v := \ v) \\<^sub>s \) v = \ v" using assms(2) unfolding subst_idem_def subst_compose_def + by (metis fun_upd_same) + ultimately show ?thesis by (metis fun_upd_same fun_upd_triv subst_comp_upd1) +qed + +lemma interpretation_dom_img_disjoint: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ subst_domain \ \ range_vars \ = {}" +unfolding range_vars_alt_def by auto + + +subsection \Basic Properties of MGUs\ +lemma MGU_is_mgu_singleton: "MGU \ t u = is_mgu \ {(t,u)}" +unfolding is_mgu_def unifiers_def by auto + +lemma Unifier_in_unifiers_singleton: "Unifier \ s t \ \ \ unifiers {(s,t)}" +unfolding unifiers_def by auto + +lemma subst_list_singleton_fv_subset: + "(\x \ set (subst_list (subst v t) E). fv (fst x) \ fv (snd x)) + \ fv t \ (\x \ set E. fv (fst x) \ fv (snd x))" +proof (induction E) + case (Cons x E) + let ?fvs = "\L. \x \ set L. fv (fst x) \ fv (snd x)" + let ?fvx = "fv (fst x) \ fv (snd x)" + let ?fvxsubst = "fv (fst x \ Var(v := t)) \ fv (snd x \ Var(v := t))" + have "?fvs (subst_list (subst v t) (x#E)) = ?fvxsubst \ ?fvs (subst_list (subst v t) E)" + unfolding subst_list_def subst_def by auto + hence "?fvs (subst_list (subst v t) (x#E)) \ ?fvxsubst \ fv t \ ?fvs E" + using Cons.IH by blast + moreover have "?fvs (x#E) = ?fvx \ ?fvs E" by auto + moreover have "?fvxsubst \ ?fvx \ fv t" using subst_fv_bound_singleton[of _ v t] by blast + ultimately show ?case unfolding range_vars_alt_def by auto +qed (simp add: subst_list_def) + +lemma subst_of_dom_subset: "subst_domain (subst_of L) \ set (map fst L)" +proof (induction L rule: List.rev_induct) + case (snoc x L) + then obtain v t where x: "x = (v,t)" by (metis surj_pair) + hence "subst_of (L@[x]) = Var(v := t) \\<^sub>s subst_of L" + unfolding subst_of_def subst_def by (induct L) auto + hence "subst_domain (subst_of (L@[x])) \ insert v (subst_domain (subst_of L))" + using x subst_domain_compose[of "Var(v := t)" "subst_of L"] + by (auto simp add: subst_domain_def) + thus ?case using snoc.IH x by auto +qed simp + +lemma wf_MGU_is_imgu_singleton: "wf\<^sub>M\<^sub>G\<^sub>U \ s t \ is_imgu \ {(s,t)}" +proof - + assume 1: "wf\<^sub>M\<^sub>G\<^sub>U \ s t" + + have 2: "subst_idem \" by (metis wf_subst_subst_idem 1 wf\<^sub>M\<^sub>G\<^sub>U_def) + + have 3: "\\' \ unifiers {(s,t)}. \ \\<^sub>\ \'" "\ \ unifiers {(s,t)}" + by (metis 1 Unifier_in_unifiers_singleton wf\<^sub>M\<^sub>G\<^sub>U_def)+ + + have "\\ \ unifiers {(s,t)}. \ = \ \\<^sub>s \" by (metis 2 3 subst_idem_def subst_compose_assoc) + thus "is_imgu \ {(s,t)}" by (metis is_imgu_def \\ \ unifiers {(s,t)}\) +qed + +lemma mgu_subst_range_vars: + assumes "mgu s t = Some \" shows "range_vars \ \ vars_term s \ vars_term t" +proof - + obtain xs where *: "Unification.unify [(s, t)] [] = Some xs" and [simp]: "subst_of xs = \" + using assms by (simp split: option.splits) + from unify_Some_UNIF [OF *] obtain ss + where "compose ss = \" and "UNIF ss {#(s, t)#} {#}" by auto + with UNIF_range_vars_subset [of ss "{#(s, t)#}" "{#}"] + show ?thesis by (metis vars_mset_singleton fst_conv snd_conv) +qed + +lemma mgu_subst_domain_range_vars_disjoint: + assumes "mgu s t = Some \" shows "subst_domain \ \ range_vars \ = {}" +proof - + have "is_imgu \ {(s, t)}" using assms mgu_sound by simp + hence "\ = \ \\<^sub>s \" unfolding is_imgu_def by blast + thus ?thesis by (metis subst_idemp_iff) +qed + +lemma mgu_same_empty: "mgu (t::('a,'b) term) t = Some Var" +proof - + { fix E::"('a,'b) equation list" and U::"('b \ ('a,'b) term) list" + assume "\(s,t) \ set E. s = t" + hence "Unification.unify E U = Some U" + proof (induction E U rule: Unification.unify.induct) + case (2 f S g T E U) + hence *: "f = g" "S = T" by auto + moreover have "\(s,t) \ set (zip T T). s = t" by (induct T) auto + hence "\(s,t) \ set (zip T T@E). s = t" using "2.prems"(1) by auto + moreover have "zip_option S T = Some (zip S T)" using \S = T\ by auto + hence **: "decompose (Fun f S) (Fun g T) = Some (zip S T)" + using \f = g\ unfolding decompose_def by auto + ultimately have "Unification.unify (zip S T@E) U = Some U" using "2.IH" * by auto + thus ?case using ** by auto + qed auto + } + hence "Unification.unify [(t,t)] [] = Some []" by auto + thus ?thesis by auto +qed + +lemma mgu_var: assumes "x \ fv t" shows "mgu (Var x) t = Some (Var(x := t))" +proof - + have "unify [(Var x,t)] [] = Some [(x,t)]" using assms by (auto simp add: subst_list_def) + moreover have "subst_of [(x,t)] = Var(x := t)" unfolding subst_of_def subst_def by simp + ultimately show ?thesis by simp +qed + +lemma mgu_gives_wellformed_subst: + assumes "mgu s t = Some \" shows "wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +using mgu_finite_subst_domain[OF assms] mgu_subst_domain_range_vars_disjoint[OF assms] +unfolding wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def +by auto + +lemma mgu_gives_wellformed_MGU: + assumes "mgu s t = Some \" shows "wf\<^sub>M\<^sub>G\<^sub>U \ s t" +using mgu_subst_domain[OF assms] mgu_sound[OF assms] mgu_subst_range_vars [OF assms] + MGU_is_mgu_singleton[of s \ t] is_imgu_imp_is_mgu[of \ "{(s,t)}"] + mgu_gives_wellformed_subst[OF assms] +unfolding wf\<^sub>M\<^sub>G\<^sub>U_def by blast + +lemma mgu_vars_bounded[dest?]: + "mgu M N = Some \ \ subst_domain \ \ range_vars \ \ fv M \ fv N" +using mgu_gives_wellformed_MGU unfolding wf\<^sub>M\<^sub>G\<^sub>U_def by blast + +lemma mgu_gives_subst_idem: "mgu s t = Some \ \ subst_idem \" +using mgu_sound[of s t \] unfolding is_imgu_def subst_idem_def by auto + +lemma mgu_always_unifies: "Unifier \ M N \ \\. mgu M N = Some \" +using mgu_complete Unifier_in_unifiers_singleton by blast + +lemma mgu_gives_MGU: "mgu s t = Some \ \ MGU \ s t" +using mgu_sound[of s t \, THEN is_imgu_imp_is_mgu] MGU_is_mgu_singleton by metis + +lemma mgu_eliminates[dest?]: + assumes "mgu M N = Some \" + shows "(\v \ fv M \ fv N. subst_elim \ v) \ \ = Var" + (is "?P M N \") +proof (cases "\ = Var") + case False + then obtain v where v: "v \ subst_domain \" by auto + hence "v \ fv M \ fv N" using mgu_vars_bounded[OF assms] by blast + thus ?thesis using wf_subst_elim_dom[OF mgu_gives_wellformed_subst[OF assms]] v by blast +qed simp + +lemma mgu_eliminates_dom: + assumes "mgu x y = Some \" "v \ subst_domain \" + shows "subst_elim \ v" +using mgu_gives_wellformed_subst[OF assms(1)] +unfolding wf\<^sub>M\<^sub>G\<^sub>U_def wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_elim_def +by (metis disjoint_iff_not_equal subst_dom_elim assms(2)) + +lemma unify_list_distinct: + assumes "Unification.unify E B = Some U" "distinct (map fst B)" + and "(\x \ set E. fv (fst x) \ fv (snd x)) \ set (map fst B) = {}" + shows "distinct (map fst U)" +using assms +proof (induction E B arbitrary: U rule: Unification.unify.induct) + case 1 thus ?case by simp +next + case (2 f X g Y E B U) + let ?fvs = "\L. \x \ set L. fv (fst x) \ fv (snd x)" + from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'" + and [simp]: "f = g" "length X = length Y" "E' = zip X Y" + and **: "Unification.unify (E'@E) B = Some U" + by (auto split: option.splits) + hence "\t t'. (t,t') \ set E' \ fv t \ fv (Fun f X) \ fv t' \ fv (Fun g Y)" + by (metis zip_arg_subterm subtermeq_vars_subset) + hence "?fvs E' \ fv (Fun f X) \ fv (Fun g Y)" by fastforce + moreover have "fv (Fun f X) \ set (map fst B) = {}" "fv (Fun g Y) \ set (map fst B) = {}" + using "2.prems"(3) by auto + ultimately have "?fvs E' \ set (map fst B) = {}" by blast + moreover have "?fvs E \ set (map fst B) = {}" using "2.prems"(3) by auto + ultimately have "?fvs (E'@E) \ set (map fst B) = {}" by auto + thus ?case using "2.IH"[OF * ** "2.prems"(2)] by metis +next + case (3 v t E B) + let ?fvs = "\L. \x \ set L. fv (fst x) \ fv (snd x)" + let ?E' = "subst_list (subst v t) E" + from "3.prems"(3) have "v \ set (map fst B)" "fv t \ set (map fst B) = {}" by force+ + hence *: "distinct (map fst ((v, t)#B))" using "3.prems"(2) by auto + + show ?case + proof (cases "t = Var v") + case True thus ?thesis using "3.prems" "3.IH"(1) by auto + next + case False + hence "v \ fv t" using "3.prems"(1) by auto + hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U" + using \t \ Var v\ "3.prems"(1) by auto + moreover have "?fvs ?E' \ set (map fst ((v, t)#B)) = {}" + proof - + have "v \ ?fvs ?E'" + unfolding subst_list_def subst_def + by (simp add: \v \ fv t\ subst_remove_var) + moreover have "?fvs ?E' \ fv t \ ?fvs E" by (metis subst_list_singleton_fv_subset) + hence "?fvs ?E' \ set (map fst B) = {}" using "3.prems"(3) by auto + ultimately show ?thesis by auto + qed + ultimately show ?thesis using "3.IH"(2)[OF \t \ Var v\ \v \ fv t\ _ *] by metis + qed +next + case (4 f X v E B U) + let ?fvs = "\L. \x \ set L. fv (fst x) \ fv (snd x)" + let ?E' = "subst_list (subst v (Fun f X)) E" + have *: "?fvs E \ set (map fst B) = {}" using "4.prems"(3) by auto + from "4.prems"(1) have "v \ fv (Fun f X)" by force + from "4.prems"(3) have **: "v \ set (map fst B)" "fv (Fun f X) \ set (map fst B) = {}" by force+ + hence ***: "distinct (map fst ((v, Fun f X)#B))" using "4.prems"(2) by auto + from "4.prems"(3) have ****: "?fvs ?E' \ set (map fst ((v, Fun f X)#B)) = {}" + proof - + have "v \ ?fvs ?E'" + unfolding subst_list_def subst_def + using \v \ fv (Fun f X)\ subst_remove_var[of v "Fun f X"] by simp + moreover have "?fvs ?E' \ fv (Fun f X) \ ?fvs E" by (metis subst_list_singleton_fv_subset) + hence "?fvs ?E' \ set (map fst B) = {}" using * ** by blast + ultimately show ?thesis by auto + qed + have "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, Fun f X) # B) = Some U" + using \v \ fv (Fun f X)\ "4.prems"(1) by auto + thus ?case using "4.IH"[OF \v \ fv (Fun f X)\ _ *** ****] by metis +qed + +lemma mgu_None_is_subst_neq: + fixes s t::"('a,'b) term" and \::"('a,'b) subst" + assumes "mgu s t = None" + shows "s \ \ \ t \ \" +using assms mgu_always_unifies by force + +lemma mgu_None_if_neq_ground: + assumes "t \ t'" "fv t = {}" "fv t' = {}" + shows "mgu t t' = None" +proof (rule ccontr) + assume "mgu t t' \ None" + then obtain \ where \: "mgu t t' = Some \" by auto + hence "t \ \ = t" "t' \ \ = t'" using assms subst_ground_ident by auto + thus False using assms(1) MGU_is_Unifier[OF mgu_gives_MGU[OF \]] by auto +qed + +lemma mgu_None_commutes: + "mgu s t = None \ mgu t s = None" +using mgu_complete[of s t] + Unifier_in_unifiers_singleton[of s _ t] + Unifier_sym[of t _ s] + Unifier_in_unifiers_singleton[of t _ s] + mgu_sound[of t s] +unfolding is_imgu_def +by fastforce + +lemma mgu_img_subterm_subst: + fixes \::"('f,'v) subst" and s t u::"('f,'v) term" + assumes "mgu s t = Some \" "u \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) - range Var" + shows "u \ ((subterms s \ subterms t) - range Var) \\<^sub>s\<^sub>e\<^sub>t \" +proof - + define subterms_tuples::"('f,'v) equation list \ ('f,'v) terms" where subtt_def: + "subterms_tuples \ \E. subterms\<^sub>s\<^sub>e\<^sub>t (fst ` set E) \ subterms\<^sub>s\<^sub>e\<^sub>t (snd ` set E)" + define subterms_img::"('f,'v) subst \ ('f,'v) terms" where subti_def: + "subterms_img \ \d. subterms\<^sub>s\<^sub>e\<^sub>t (subst_range d)" + + define d where "d \ \v t. subst v t::('f,'v) subst" + define V where "V \ range Var::('f,'v) terms" + define R where "R \ \d::('f,'v) subst. ((subterms s \ subterms t) - V) \\<^sub>s\<^sub>e\<^sub>t d" + define M where "M \ \E d. subterms_tuples E \ subterms_img d" + define Q where "Q \ (\E d. M E d - V \ R d - V)" + define Q' where "Q' \ (\E d d'. (M E d - V) \\<^sub>s\<^sub>e\<^sub>t d' \ (R d - V) \\<^sub>s\<^sub>e\<^sub>t (d'::('f,'v) subst))" + + have Q_subst: "Q (subst_list (subst v t') E) (subst_of ((v, t')#B))" + when v_fv: "v \ fv t'" and Q_assm: "Q ((Var v, t')#E) (subst_of B)" + for v t' E B + proof - + define E' where "E' \ subst_list (subst v t') E" + define B' where "B' \ subst_of ((v, t')#B)" + + have E': "E' = subst_list (d v t') E" + and B': "B' = subst_of B \\<^sub>s d v t'" + using subst_of_simps(3)[of "(v, t')"] + unfolding subst_def E'_def B'_def d_def by simp_all + + have vt_img_subt: "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (d v t')) = subterms t'" + and vt_dom: "subst_domain (d v t') = {v}" + using v_fv by (auto simp add: subst_domain_def d_def subst_def) + + have *: "subterms u1 \ subterms\<^sub>s\<^sub>e\<^sub>t (fst ` set E)" "subterms u2 \ subterms\<^sub>s\<^sub>e\<^sub>t (snd ` set E)" + when "(u1,u2) \ set E" for u1 u2 + using that by auto + + have **: "subterms\<^sub>s\<^sub>e\<^sub>t (d v t' ` (fv u \ subst_domain (d v t'))) \ subterms t'" + for u::"('f,'v) term" + using vt_dom unfolding d_def by force + + have 1: "subterms_tuples E' - V \ (subterms t' - V) \ (subterms_tuples E - V \\<^sub>s\<^sub>e\<^sub>t d v t')" + (is "?A \ ?B") + proof + fix u assume "u \ ?A" + then obtain u1 u2 where u12: + "(u1,u2) \ set E" + "u \ (subterms (u1 \ (d v t')) - V) \ (subterms (u2 \ (d v t')) - V)" + unfolding subtt_def subst_list_def E'_def d_def by moura + hence "u \ (subterms t' - V) \ (((subterms_tuples E) \\<^sub>s\<^sub>e\<^sub>t d v t') - V)" + using subterms_subst[of u1 "d v t'"] subterms_subst[of u2 "d v t'"] + *[OF u12(1)] **[of u1] **[of u2] + unfolding subtt_def subst_list_def by auto + moreover have + "(subterms_tuples E \\<^sub>s\<^sub>e\<^sub>t d v t') - V \ + (subterms_tuples E - V \\<^sub>s\<^sub>e\<^sub>t d v t') \ {t'}" + unfolding subst_def subtt_def V_def d_def by force + ultimately show "u \ ?B" using u12 v_fv by auto + qed + + have 2: "subterms_img B' - V \ + (subterms t' - V) \ (subterms_img (subst_of B) - V \\<^sub>s\<^sub>e\<^sub>t d v t')" + using B' vt_img_subt subst_img_comp_subset'''[of "subst_of B" "d v t'"] + unfolding subti_def subst_def V_def by argo + + have 3: "subterms_tuples ((Var v, t')#E) - V = (subterms t' - V) \ (subterms_tuples E - V)" + by (auto simp add: subst_def subtt_def V_def) + + have "fv\<^sub>s\<^sub>e\<^sub>t (subterms t' - V) \ subst_domain (d v t') = {}" + using v_fv vt_dom fv_subterms[of t'] by fastforce + hence 4: "subterms t' - V \\<^sub>s\<^sub>e\<^sub>t d v t' = subterms t' - V" + using set_subst_ident[of "subterms t' - range Var" "d v t'"] by (simp add: V_def) + + have "M E' B' - V \ M ((Var v, t')#E) (subst_of B) - V \\<^sub>s\<^sub>e\<^sub>t d v t'" + using 1 2 3 4 unfolding M_def by blast + moreover have "Q' ((Var v, t')#E) (subst_of B) (d v t')" + using Q_assm unfolding Q_def Q'_def by auto + moreover have "R (subst_of B) \\<^sub>s\<^sub>e\<^sub>t d v t' = R (subst_of ((v,t')#B))" + unfolding R_def d_def by auto + ultimately have + "M (subst_list (d v t') E) (subst_of ((v, t')#B)) - V \ R (subst_of ((v, t')#B)) - V" + unfolding Q'_def E'_def B'_def d_def by blast + thus ?thesis unfolding Q_def M_def R_def d_def by blast + qed + + have "u \ subterms s \ subterms t - V \\<^sub>s\<^sub>e\<^sub>t subst_of U" + when assms': + "unify E B = Some U" + "u \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range (subst_of U)) - V" + "Q E (subst_of B)" + for E B U and T::"('f,'v) term list" + using assms' + proof (induction E B arbitrary: U rule: Unification.unify.induct) + case (1 B) thus ?case by (auto simp add: Q_def M_def R_def subti_def) + next + case (2 g X h Y E B U) + from "2.prems"(1) obtain E' where E': + "decompose (Fun g X) (Fun h Y) = Some E'" + "g = h" "length X = length Y" "E' = zip X Y" + "Unification.unify (E'@E) B = Some U" + by (auto split: option.splits) + moreover have "subterms_tuples (E'@E) \ subterms_tuples ((Fun g X, Fun h Y)#E)" + proof + fix u assume "u \ subterms_tuples (E'@E)" + then obtain u1 u2 where u12: "(u1,u2) \ set (E'@E)" "u \ subterms u1 \ subterms u2" + unfolding subtt_def by fastforce + thus "u \ subterms_tuples ((Fun g X, Fun h Y)#E)" + proof (cases "(u1,u2) \ set E'") + case True + hence "subterms u1 \ subterms (Fun g X)" "subterms u2 \ subterms (Fun h Y)" + using E'(4) subterms_subset params_subterms subsetCE + by (metis set_zip_leftD, metis set_zip_rightD) + thus ?thesis using u12 unfolding subtt_def by auto + next + case False thus ?thesis using u12 unfolding subtt_def by fastforce + qed + qed + hence "Q (E'@E) (subst_of B)" using "2.prems"(3) unfolding Q_def M_def by blast + ultimately show ?case using "2.IH"[of E' U] "2.prems" by meson + next + case (3 v t' E B) + show ?case + proof (cases "t' = Var v") + case True thus ?thesis + using "3.prems" "3.IH"(1) unfolding Q_def M_def V_def subtt_def by auto + next + case False + hence 1: "v \ fv t'" using "3.prems"(1) by auto + hence "unify (subst_list (subst v t') E) ((v, t')#B) = Some U" + using False "3.prems"(1) by auto + thus ?thesis + using Q_subst[OF 1 "3.prems"(3)] + "3.IH"(2)[OF False 1 _ "3.prems"(2)] + by metis + qed + next + case (4 g X v E B U) + have 1: "v \ fv (Fun g X)" using "4.prems"(1) not_None_eq by fastforce + hence 2: "unify (subst_list (subst v (Fun g X)) E) ((v, Fun g X)#B) = Some U" + using "4.prems"(1) by auto + + have 3: "Q ((Var v, Fun g X)#E) (subst_of B)" + using "4.prems"(3) unfolding Q_def M_def subtt_def by auto + + show ?case + using Q_subst[OF 1 3] "4.IH"[OF 1 2 "4.prems"(2)] + by metis + qed + moreover obtain D where "unify [(s, t)] [] = Some D" "\ = subst_of D" + using assms(1) by (auto split: option.splits) + moreover have "Q [(s,t)] (subst_of [])" + unfolding Q_def M_def R_def subtt_def subti_def + by force + ultimately show ?thesis using assms(2) unfolding V_def by auto +qed + +lemma mgu_img_consts: + fixes \::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v + assumes "mgu s t = Some \" "Fun c [] \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" + shows "Fun c [] \ subterms s \ subterms t" +proof - + obtain u where "u \ (subterms s \ subterms t) - range Var" "u \ \ = Fun c []" + using mgu_img_subterm_subst[OF assms(1), of "Fun c []"] assms(2) by force + thus ?thesis by (cases u) auto +qed + +lemma mgu_img_consts': + fixes \::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v + assumes "mgu s t = Some \" "\ z = Fun c []" + shows "Fun c [] \ s \ Fun c [] \ t" +using mgu_img_consts[OF assms(1)] assms(2) +by (metis Un_iff in_subterms_Union subst_imgI term.distinct(1)) + +lemma mgu_img_composed_var_term: + fixes \::"('f,'v) subst" and s t::"('f,'v) term" and f::'f and Z::"'v list" + assumes "mgu s t = Some \" "Fun f (map Var Z) \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" + shows "\Z'. map \ Z' = map Var Z \ Fun f (map Var Z') \ subterms s \ subterms t" +proof - + obtain u where u: "u \ (subterms s \ subterms t) - range Var" "u \ \ = Fun f (map Var Z)" + using mgu_img_subterm_subst[OF assms(1), of "Fun f (map Var Z)"] assms(2) by fastforce + then obtain T where T: "u = Fun f T" "map (\t. t \ \) T = map Var Z" by (cases u) auto + have "\t \ set T. \x. t = Var x" using T(2) by (induct T arbitrary: Z) auto + then obtain Z' where Z': "map Var Z' = T" by (metis ex_map_conv) + hence "map \ Z' = map Var Z" using T(2) by (induct Z' arbitrary: T Z) auto + thus ?thesis using u(1) T(1) Z' by auto +qed + + +subsection \Lemmata: The "Inequality Lemmata"\ +text \Subterm injectivity (a stronger injectivity property)\ +definition subterm_inj_on where + "subterm_inj_on f A \ \x\A. \y\A. (\v. v \ f x \ v \ f y) \ x = y" + +lemma subterm_inj_on_imp_inj_on: "subterm_inj_on f A \ inj_on f A" +unfolding subterm_inj_on_def inj_on_def by fastforce + +lemma subst_inj_on_is_bij_betw: + "inj_on \ (subst_domain \) = bij_betw \ (subst_domain \) (subst_range \)" +unfolding inj_on_def bij_betw_def by auto + +lemma subterm_inj_on_alt_def: + "subterm_inj_on f A \ + (inj_on f A \ (\s \ f`A. \u \ f`A. (\v. v \ s \ v \ u) \ s = u))" + (is "?A \ ?B") +unfolding subterm_inj_on_def inj_on_def by fastforce + +lemma subterm_inj_on_alt_def': + "subterm_inj_on \ (subst_domain \) \ + (inj_on \ (subst_domain \) \ + (\s \ subst_range \. \u \ subst_range \. (\v. v \ s \ v \ u) \ s = u))" + (is "?A \ ?B") +by (metis subterm_inj_on_alt_def subst_range.simps) + +lemma subterm_inj_on_subset: + assumes "subterm_inj_on f A" + and "B \ A" + shows "subterm_inj_on f B" +proof - + have "inj_on f A" "\s\f ` A. \u\f ` A. (\v. v \ s \ v \ u) \ s = u" + using subterm_inj_on_alt_def[of f A] assms(1) by auto + moreover have "f ` B \ f ` A" using assms(2) by auto + ultimately have "inj_on f B" "\s\f ` B. \u\f ` B. (\v. v \ s \ v \ u) \ s = u" + using inj_on_subset[of f A] assms(2) by blast+ + thus ?thesis by (metis subterm_inj_on_alt_def) +qed + +lemma inj_subst_unif_consts: + fixes \ \ \::"('f,'v) subst" and s t::"('f,'v) term" + assumes \: "subterm_inj_on \ (subst_domain \)" "\x \ (fv s \ fv t) - X. \c. \ x = Fun c []" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ (subterms s \ subterms t) = {}" "ground (subst_range \)" + "subst_domain \ \ X = {}" + and \: "ground (subst_range \)" "subst_domain \ = subst_domain \" + and unif: "Unifier \ (s \ \) (t \ \)" + shows "\\. Unifier \ (s \ \) (t \ \)" +proof - + let ?xs = "subst_domain \" + let ?ys = "(fv s \ fv t) - ?xs" + + have "\\::('f,'v) subst. s \ \ = t \ \" by (metis subst_subst_compose unif) + then obtain \::"('f,'v) subst" where \: "mgu s t = Some \" + using mgu_always_unifies by moura + have 1: "\\::('f,'v) subst. s \ \ \ \ = t \ \ \ \" by (metis unif) + have 2: "\\::('f,'v) subst. s \ \ \ \ = t \ \ \ \ \ \ \\<^sub>\ \ \\<^sub>s \" using mgu_gives_MGU[OF \] by simp + have 3: "\(z::'v) (c::'f). \ z = Fun c [] \ Fun c [] \ s \ Fun c [] \ t" + by (rule mgu_img_consts'[OF \]) + have 4: "subst_domain \ \ range_vars \ = {}" + by (metis mgu_gives_wellformed_subst[OF \] wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + have 5: "subst_domain \ \ range_vars \ \ fv s \ fv t" + by (metis mgu_gives_wellformed_MGU[OF \] wf\<^sub>M\<^sub>G\<^sub>U_def) + + { fix x and \::"('f,'v) subst" assume "x \ subst_domain \" + hence "(\ \\<^sub>s \) x = \ x" + using \(4) ident_comp_subst_trm_if_disj[of \ \] + unfolding range_vars_alt_def by fast + } + then obtain \::"('f,'v) subst" where \: "\x \ subst_domain \. \ x = (\ \\<^sub>s \) x" using 1 2 by moura + + have *: "\x. x \ subst_domain \ \ subst_domain \ \ \y \ ?ys. \ x = Var y" + proof - + fix x assume "x \ subst_domain \ \ ?xs" + hence x: "x \ subst_domain \" "x \ subst_domain \" by auto + then obtain c where c: "\ x = Fun c []" using \(2,5) 5 by moura + hence *: "(\ \\<^sub>s \) x = Fun c []" using \ x by fastforce + hence **: "x \ subst_domain (\ \\<^sub>s \)" "Fun c [] \ subst_range (\ \\<^sub>s \)" + by (auto simp add: subst_domain_def) + have "\ x = Fun c [] \ (\z. \ x = Var z \ \ z = Fun c [])" + by (rule subst_img_comp_subset_const'[OF *]) + moreover have "\ x \ Fun c []" + proof (rule ccontr) + assume "\\ x \ Fun c []" + hence "Fun c [] \ s \ Fun c [] \ t" using 3 by metis + moreover have "\u \ subst_range \. u \ subterms s \ subterms t" + using \(3) by force + hence "Fun c [] \ subterms s \ subterms t" + by (metis c \ground (subst_range \)\x(2) ground_subst_dom_iff_img) + ultimately show False by auto + qed + moreover have "\x' \ subst_domain \. \ x \ Var x'" + proof (rule ccontr) + assume "\(\x' \ subst_domain \. \ x \ Var x')" + then obtain x' where x': "x' \ subst_domain \" "\ x = Var x'" by moura + hence "\ x' = Fun c []" "(\ \\<^sub>s \) x = Fun c []" using * unfolding subst_compose_def by auto + moreover have "x \ x'" + using x(1) x'(2) 4 + by (auto simp add: subst_domain_def) + moreover have "x' \ subst_domain \" + using x'(2) mgu_eliminates_dom[OF \] + by (metis (no_types) subst_elim_def subst_apply_term.simps(1) vars_iff_subterm_or_eq) + moreover have "(\ \\<^sub>s \) x = \ x" "(\ \\<^sub>s \) x' = \ x'" using \ x(2) x'(1) by auto + ultimately show False + using subterm_inj_on_imp_inj_on[OF \(1)] * + by (simp add: inj_on_def subst_compose_def x'(2) subst_domain_def) + qed + ultimately show "\y \ ?ys. \ x = Var y" + by (metis 5 x(2) subtermeqI' vars_iff_subtermeq DiffI Un_iff subst_fv_imgI sup.orderE) + qed + + have **: "inj_on \ (subst_domain \ \ ?xs)" + proof (intro inj_onI) + fix x y assume *: + "x \ subst_domain \ \ subst_domain \" "y \ subst_domain \ \ subst_domain \" "\ x = \ y" + hence "(\ \\<^sub>s \) x = (\ \\<^sub>s \) y" unfolding subst_compose_def by auto + hence "\ x = \ y" using \ * by auto + thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF \(1)]] *(1,2) by simp + qed + + define \ where "\ = (\y'. if Var y' \ \ ` (subst_domain \ \ ?xs) + then Var ((inv_into (subst_domain \ \ ?xs) \) (Var y')) + else Var y'::('f,'v) term)" + have a1: "Unifier (\ \\<^sub>s \) s t" using mgu_gives_MGU[OF \] by auto + + define \' where "\' = \ \\<^sub>s \" + have d1: "subst_domain \' \ ?ys" + proof + fix z assume z: "z \ subst_domain \'" + have "z \ ?xs \ z \ subst_domain \'" + proof (cases "z \ subst_domain \") + case True + moreover assume "z \ ?xs" + ultimately have z_in: "z \ subst_domain \ \ ?xs" by simp + then obtain y where y: "\ z = Var y" "y \ ?ys" using * by moura + hence "\ y = Var ((inv_into (subst_domain \ \ ?xs) \) (Var y))" + using \_def z_in by simp + hence "\ y = Var z" by (metis y(1) z_in ** inv_into_f_eq) + hence "\' z = Var z" using \'_def y(1) subst_compose_def[of \ \] by simp + thus ?thesis by (simp add: subst_domain_def) + next + case False + hence "\ z = Var z" by (simp add: subst_domain_def) + moreover assume "z \ ?xs" + hence "\ z = Var z" using \_def * by force + ultimately show ?thesis + using \'_def subst_compose_def[of \ \] + by (simp add: subst_domain_def) + qed + moreover have "subst_domain \ \ range_vars \" + unfolding \'_def \_def range_vars_alt_def + by (auto simp add: subst_domain_def) + hence "subst_domain \' \ subst_domain \ \ range_vars \" + using subst_domain_compose[of \ \] unfolding \'_def by blast + ultimately show "z \ ?ys" using 5 z by auto + qed + have d2: "Unifier (\' \\<^sub>s \) s t" using a1 \'_def by auto + have d3: "\ \\<^sub>s \' \\<^sub>s \ = \' \\<^sub>s \" + proof - + { fix z::'v assume z: "z \ ?xs" + then obtain u where u: "\ z = u" "fv u = {}" using \ by auto + hence "(\ \\<^sub>s \' \\<^sub>s \) z = u" by (simp add: subst_compose subst_ground_ident) + moreover have "z \ subst_domain \'" using d1 z by auto + hence "\' z = Var z" by (simp add: subst_domain_def) + hence "(\' \\<^sub>s \) z = u" using u(1) by (simp add: subst_compose) + ultimately have "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by metis + } moreover { + fix z::'v assume "z \ ?ys" + hence "z \ subst_domain \" using \(2) by auto + hence "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by (simp add: subst_compose subst_domain_def) + } moreover { + fix z::'v assume "z \ ?xs" "z \ ?ys" + hence "\ z = Var z" "\' z = Var z" using \(2) d1 by blast+ + hence "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by (simp add: subst_compose) + } ultimately show ?thesis by auto + qed + + from d2 d3 have "Unifier (\' \\<^sub>s \) (s \ \) (t \ \)" by (metis subst_subst_compose) + thus ?thesis by metis +qed + +lemma inj_subst_unif_comp_terms: + fixes \ \ \::"('f,'v) subst" and s t::"('f,'v) term" + assumes \: "subterm_inj_on \ (subst_domain \)" "ground (subst_range \)" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ (subterms s \ subterms t) = {}" + "(fv s \ fv t) - subst_domain \ \ X" + and tfr: "\f U. Fun f U \ subterms s \ subterms t \ U = [] \ (\u \ set U. u \ Var ` X)" + and \: "ground (subst_range \)" "subst_domain \ = subst_domain \" + and unif: "Unifier \ (s \ \) (t \ \)" + shows "\\. Unifier \ (s \ \) (t \ \)" +proof - + let ?xs = "subst_domain \" + let ?ys = "(fv s \ fv t) - ?xs" + + have "ground (subst_range \)" using \(2) by auto + + have "\\::('f,'v) subst. s \ \ = t \ \" by (metis subst_subst_compose unif) + then obtain \::"('f,'v) subst" where \: "mgu s t = Some \" + using mgu_always_unifies by moura + have 1: "\\::('f,'v) subst. s \ \ \ \ = t \ \ \ \" by (metis unif) + have 2: "\\::('f,'v) subst. s \ \ \ \ = t \ \ \ \ \ \ \\<^sub>\ \ \\<^sub>s \" using mgu_gives_MGU[OF \] by simp + have 3: "\(z::'v) (c::'f). Fun c [] \ \ z \ Fun c [] \ s \ Fun c [] \ t" + using mgu_img_consts[OF \] by force + have 4: "subst_domain \ \ range_vars \ = {}" + using mgu_gives_wellformed_subst[OF \] + by (metis wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + have 5: "subst_domain \ \ range_vars \ \ fv s \ fv t" + using mgu_gives_wellformed_MGU[OF \] + by (metis wf\<^sub>M\<^sub>G\<^sub>U_def) + + { fix x and \::"('f,'v) subst" assume "x \ subst_domain \" + hence "(\ \\<^sub>s \) x = \ x" + using \ground (subst_range \)\ ident_comp_subst_trm_if_disj[of \ \ x] + unfolding range_vars_alt_def by blast + } + then obtain \::"('f,'v) subst" where \: "\x \ subst_domain \. \ x = (\ \\<^sub>s \) x" using 1 2 by moura + + have ***: "\x. x \ subst_domain \ \ subst_domain \ \ fv (\ x) \ ?ys" + proof - + fix x assume "x \ subst_domain \ \ ?xs" + hence x: "x \ subst_domain \" "x \ subst_domain \" by auto + moreover have "\(\x' \ ?xs. x' \ fv (\ x))" + proof (rule ccontr) + assume "\\(\x' \ ?xs. x' \ fv (\ x))" + then obtain x' where x': "x' \ fv (\ x)" "x' \ ?xs" by metis + have "x \ x'" "x' \ subst_domain \" "\ x' = Var x'" + using 4 x(1) x'(1) unfolding range_vars_alt_def by auto + hence "(\ \\<^sub>s \) x' \ (\ \\<^sub>s \) x" "\ x' = (\ \\<^sub>s \) x'" + using \ x(2) x'(2) + by (metis subst_compose subst_mono vars_iff_subtermeq x'(1), + metis subst_apply_term.simps(1) subst_compose_def) + hence "\ x' \ \ x" using \ x(2) x'(2) by auto + thus False + using \(1) x'(2) x(2) \x \ x'\ + unfolding subterm_inj_on_def + by (meson subtermeqI') + qed + ultimately show "fv (\ x) \ ?ys" + using 5 subst_dom_vars_in_subst[of x \] subst_fv_imgI[of \ x] + by blast + qed + + have **: "inj_on \ (subst_domain \ \ ?xs)" + proof (intro inj_onI) + fix x y assume *: + "x \ subst_domain \ \ subst_domain \" "y \ subst_domain \ \ subst_domain \" "\ x = \ y" + hence "(\ \\<^sub>s \) x = (\ \\<^sub>s \) y" unfolding subst_compose_def by auto + hence "\ x = \ y" using \ * by auto + thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF \(1)]] *(1,2) by simp + qed + + have *: "\x. x \ subst_domain \ \ subst_domain \ \ \y \ ?ys. \ x = Var y" + proof (rule ccontr) + fix xi assume xi_assms: "xi \ subst_domain \ \ subst_domain \" "\(\y \ ?ys. \ xi = Var y)" + hence xi_\: "xi \ subst_domain \" and \_xi_comp: "\(\y. \ xi = Var y)" + using ***[of xi] 5 by auto + then obtain f T where f: "\ xi = Fun f T" by (cases "\ xi") moura + + have "\g Y'. Y' \ [] \ Fun g (map Var Y') \ \ xi \ set Y' \ ?ys" + proof - + have "\c. Fun c [] \ \ xi \ Fun c [] \ \ xi" + using \ xi_\ by (metis const_subterm_subst subst_compose) + hence 1: "\c. \(Fun c [] \ \ xi)" + using 3[of _ xi] xi_\ \(3) + by auto + + have "\(\x. \ xi = Var x)" using f by auto + hence "\g S. Fun g S \ \ xi \ (\s \ set S. (\c. s = Fun c []) \ (\x. s = Var x))" + using nonvar_term_has_composed_shallow_term[of "\ xi"] by auto + then obtain g S where gS: "Fun g S \ \ xi" "\s \ set S. (\c. s = Fun c []) \ (\x. s = Var x)" + by moura + + have "\s \ set S. \x. s = Var x" + using 1 term.order_trans gS + by (metis (no_types, lifting) UN_I term.order_refl subsetCE subterms.simps(2) sup_ge2) + then obtain S' where 2: "map Var S' = S" by (metis ex_map_conv) + + have "S \ []" using 1 term.order_trans[OF _ gS(1)] by fastforce + hence 3: "S' \ []" "Fun g (map Var S') \ \ xi" using gS(1) 2 by auto + + have "set S' \ fv (Fun g (map Var S'))" by simp + hence 4: "set S' \ fv (\ xi)" using 3(2) fv_subterms by force + + show ?thesis using ***[OF xi_assms(1)] 2 3 4 by auto + qed + then obtain g Y' where g: "Y' \ []" "Fun g (map Var Y') \ \ xi" "set Y' \ ?ys" by moura + then obtain X where X: "map \ X = map Var Y'" "Fun g (map Var X) \ subterms s \ subterms t" + using mgu_img_composed_var_term[OF \, of g Y'] by force + hence "\(u::('f,'v) term) \ set (map Var X). u \ Var ` ?ys" + using \(4) tfr g(1) by fastforce + then obtain j where j: "j < length X" "X ! j \ ?ys" + by (metis image_iff[of _ Var "fv s \ fv t - subst_domain \"] nth_map[of _ X Var] + in_set_conv_nth[of _ "map Var X"] length_map[of Var X]) + + define yj' where yj': "yj' \ Y' ! j" + define xj where xj: "xj \ X ! j" + + have "xj \ fv s \ fv t" + using j X(1) g(3) 5 xj yj' + by (metis length_map nth_map term.simps(1) in_set_conv_nth le_supE subsetCE subst_domI) + hence xj_\: "xj \ subst_domain \" using j unfolding xj by simp + + have len: "length X = length Y'" by (rule map_eq_imp_length_eq[OF X(1)]) + + have "Var yj' \ \ xi" + using term.order_trans[OF _ g(2)] j(1) len unfolding yj' by auto + hence "\ yj' \ \ xi" + using \ xi_\ by (metis subst_apply_term.simps(1) subst_compose_def subst_mono) + moreover have \_xj_var: "Var yj' = \ xj" + using X(1) len j(1) nth_map + unfolding xj yj' by metis + hence "\ yj' = \ xj" using \ xj_\ by (metis subst_apply_term.simps(1) subst_compose_def) + moreover have "xi \ xj" using \_xi_comp \_xj_var by auto + ultimately show False using \(1) xi_\ xj_\ unfolding subterm_inj_on_def by blast + qed + + define \ where "\ = (\y'. if Var y' \ \ ` (subst_domain \ \ ?xs) + then Var ((inv_into (subst_domain \ \ ?xs) \) (Var y')) + else Var y'::('f,'v) term)" + have a1: "Unifier (\ \\<^sub>s \) s t" using mgu_gives_MGU[OF \] by auto + + define \' where "\' = \ \\<^sub>s \" + have d1: "subst_domain \' \ ?ys" + proof + fix z assume z: "z \ subst_domain \'" + have "z \ ?xs \ z \ subst_domain \'" + proof (cases "z \ subst_domain \") + case True + moreover assume "z \ ?xs" + ultimately have z_in: "z \ subst_domain \ \ ?xs" by simp + then obtain y where y: "\ z = Var y" "y \ ?ys" using * by moura + hence "\ y = Var ((inv_into (subst_domain \ \ ?xs) \) (Var y))" + using \_def z_in by simp + hence "\ y = Var z" by (metis y(1) z_in ** inv_into_f_eq) + hence "\' z = Var z" using \'_def y(1) subst_compose_def[of \ \] by simp + thus ?thesis by (simp add: subst_domain_def) + next + case False + hence "\ z = Var z" by (simp add: subst_domain_def) + moreover assume "z \ ?xs" + hence "\ z = Var z" using \_def * by force + ultimately show ?thesis using \'_def subst_compose_def[of \ \] by (simp add: subst_domain_def) + qed + moreover have "subst_domain \ \ range_vars \" + unfolding \'_def \_def range_vars_alt_def subst_domain_def + by auto + hence "subst_domain \' \ subst_domain \ \ range_vars \" + using subst_domain_compose[of \ \] + unfolding \'_def by blast + ultimately show "z \ ?ys" using 5 z by blast + qed + have d2: "Unifier (\' \\<^sub>s \) s t" using a1 \'_def by auto + have d3: "\ \\<^sub>s \' \\<^sub>s \ = \' \\<^sub>s \" + proof - + { fix z::'v assume z: "z \ ?xs" + then obtain u where u: "\ z = u" "fv u = {}" using \ by auto + hence "(\ \\<^sub>s \' \\<^sub>s \) z = u" by (simp add: subst_compose subst_ground_ident) + moreover have "z \ subst_domain \'" using d1 z by auto + hence "\' z = Var z" by (simp add: subst_domain_def) + hence "(\' \\<^sub>s \) z = u" using u(1) by (simp add: subst_compose) + ultimately have "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by metis + } moreover { + fix z::'v assume "z \ ?ys" + hence "z \ subst_domain \" using \(2) by auto + hence "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by (simp add: subst_compose subst_domain_def) + } moreover { + fix z::'v assume "z \ ?xs" "z \ ?ys" + hence "\ z = Var z" "\' z = Var z" using \(2) d1 by blast+ + hence "(\ \\<^sub>s \' \\<^sub>s \) z = (\' \\<^sub>s \) z" by (simp add: subst_compose) + } ultimately show ?thesis by auto + qed + + from d2 d3 have "Unifier (\' \\<^sub>s \) (s \ \) (t \ \)" by (metis subst_subst_compose) + thus ?thesis by metis +qed + +context +begin +private lemma sat_ineq_subterm_inj_subst_aux: + fixes \::"('f,'v) subst" + assumes "Unifier \ (s \ \) (t \ \)" "ground (subst_range \)" + "(fv s \ fv t) - X \ subst_domain \" "subst_domain \ \ X = {}" + shows "\\::('f,'v) subst. subst_domain \ = X \ ground (subst_range \) \ s \ \ \ \ = t \ \ \ \" +proof - + have "\\. Unifier \ (s \ \) (t \ \) \ interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + proof - + obtain \'::"('f,'v) subst" where *: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \'" + using interpretation_subst_exists by metis + hence "Unifier (\ \\<^sub>s \') (s \ \) (t \ \)" using assms(1) by simp + thus ?thesis using * interpretation_comp by blast + qed + then obtain \' where \': "Unifier \' (s \ \) (t \ \)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \'" by moura + + define \'' where "\'' = rm_vars (UNIV - X) \'" + + have *: "fv (s \ \) \ X" "fv (t \ \) \ X" + using assms(2,3) subst_fv_unfold_ground_img[of \] + unfolding range_vars_alt_def + by (simp_all add: Diff_subset_conv Un_commute) + hence **: "subst_domain \'' = X" "ground (subst_range \'')" + using rm_vars_img_subset[of "UNIV - X" \'] rm_vars_dom[of "UNIV - X" \'] \'(2) + unfolding \''_def by auto + hence "\t. t \ \ \ \'' = t \ \'' \ \" + using subst_eq_if_disjoint_vars_ground[OF _ _ assms(2)] assms(4) by blast + moreover have "Unifier \'' (s \ \) (t \ \)" + using Unifier_dom_restrict[OF \'(1)] \''_def * by blast + ultimately show ?thesis using ** by auto +qed + +text \ + The "inequality lemma": This lemma gives sufficient syntactic conditions for finding substitutions + \\\ under which terms \s\ and \t\ are not unifiable. + + This is useful later when establishing the typing results since we there want to find well-typed + solutions to inequality constraints / "negative checks" constraints, and this lemma gives + conditions for protocols under which such constraints are well-typed satisfiable if satisfiable. +\ +lemma sat_ineq_subterm_inj_subst: + fixes \ \ \::"('f,'v) subst" + assumes \: "subterm_inj_on \ (subst_domain \)" + "ground (subst_range \)" + "subst_domain \ \ X = {}" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ (subterms s \ subterms t) = {}" + "(fv s \ fv t) - subst_domain \ \ X" + and tfr: "(\x \ (fv s \ fv t) - X. \c. \ x = Fun c []) \ + (\f U. Fun f U \ subterms s \ subterms t \ U = [] \ (\u \ set U. u \ Var ` X))" + and \: "\\::('f,'v) subst. subst_domain \ = X \ ground (subst_range \) \ s \ \ \ \ \ t \ \ \ \" + "(fv s \ fv t) - X \ subst_domain \" "subst_domain \ \ X = {}" "ground (subst_range \)" + "subst_domain \ = subst_domain \" + and \: "subst_domain \ = X" "ground (subst_range \)" + shows "s \ \ \ \ \ t \ \ \ \" +proof - + have "\\. \Unifier \ (s \ \) (t \ \)" + by (metis \(1) sat_ineq_subterm_inj_subst_aux[OF _ \(4,2,3)]) + hence "\Unifier \ (s \ \) (t \ \)" + using inj_subst_unif_consts[OF \(1) _ \(4,2,3) \(4,5)] + inj_subst_unif_comp_terms[OF \(1,2,4,5) _ \(4,5)] + tfr + by metis + moreover have "subst_domain \ \ subst_domain \ = {}" using \(2,3) \(1) by auto + ultimately show ?thesis using \ subst_eq_if_disjoint_vars_ground[OF _ \(2) \(2)] by metis +qed +end + +lemma ineq_subterm_inj_cond_subst: + assumes "X \ range_vars \ = {}" + and "\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t S \ T = [] \ (\u \ set T. u \ Var`X)" + shows "\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (S \\<^sub>s\<^sub>e\<^sub>t \) \ T = [] \ (\u \ set T. u \ Var`X)" +proof (intro allI impI) + let ?M = "\S. subterms\<^sub>s\<^sub>e\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" + let ?N = "\S. subterms\<^sub>s\<^sub>e\<^sub>t (\ ` (fv\<^sub>s\<^sub>e\<^sub>t S \ subst_domain \))" + + fix f T assume "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (S \\<^sub>s\<^sub>e\<^sub>t \)" + hence 1: "Fun f T \ ?M S \ Fun f T \ ?N S" + using subterms_subst[of _ \] by auto + + have 2: "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ \u \ set T. u \ Var`X" + using fv_subset_subterms[of "Fun f T" "subst_range \"] assms(1) + unfolding range_vars_alt_def by force + + have 3: "\x \ subst_domain \. \ x \ Var`X" + proof + fix x assume "x \ subst_domain \" + hence "fv (\ x) \ range_vars \" + using subst_dom_vars_in_subst subst_fv_imgI + unfolding range_vars_alt_def by auto + thus "\ x \ Var`X" using assms(1) by auto + qed + + show "T = [] \ (\s \ set T. s \ Var`X)" using 1 + proof + assume "Fun f T \ ?M S" + then obtain u where u: "u \ subterms\<^sub>s\<^sub>e\<^sub>t S" "u \ \ = Fun f T" by fastforce + show ?thesis + proof (cases u) + case (Var x) + hence "Fun f T \ subst_range \" using u(2) by (simp add: subst_domain_def) + hence "\u \ set T. u \ Var`X" using 2 by force + thus ?thesis by auto + next + case (Fun g S) + hence "S = [] \ (\u \ set S. u \ Var`X)" using assms(2) u(1) by metis + thus ?thesis + proof + assume "S = []" thus ?thesis using u(2) Fun by simp + next + assume "\u \ set S. u \ Var`X" + then obtain u' where u': "u' \ set S" "u' \ Var`X" by moura + hence "u' \ \ \ set T" using u(2) Fun by auto + thus ?thesis using u'(2) 3 by (cases u') force+ + qed + qed + next + assume "Fun f T \ ?N S" + thus ?thesis using 2 by force + qed +qed + + +subsection \Lemmata: Sufficient Conditions for Term Matching\ +text \Injective substitutions from variables to variables are invertible\ +definition subst_var_inv where + "subst_var_inv \ X \ (\x. if Var x \ \ ` X then Var ((inv_into X \) (Var x)) else Var x)" + +lemma inj_var_ran_subst_is_invertible: + assumes \_inj_on_t: "inj_on \ (fv t)" + and \_var_on_t: "\ ` fv t \ range Var" + shows "t = t \ \ \\<^sub>s subst_var_inv \ (fv t)" +proof - + have "\ x \ subst_var_inv \ (fv t) = Var x" when x: "x \ fv t" for x + proof - + obtain y where y: "\ x = Var y" using x \_var_on_t by auto + hence "Var y \ \ ` (fv t)" using x by simp + thus ?thesis using y inv_into_f_eq[OF \_inj_on_t x y] unfolding subst_var_inv_def by simp + qed + thus ?thesis by (simp add: subst_compose_def trm_subst_ident'') +qed + +text \Sufficient conditions for matching unifiable terms\ +lemma inj_var_ran_unifiable_has_subst_match: + assumes "t \ \ = s \ \" "inj_on \ (fv t)" "\ ` fv t \ range Var" + shows "t = s \ \ \\<^sub>s subst_var_inv \ (fv t)" +using assms inj_var_ran_subst_is_invertible by fastforce + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Parallel_Compositionality.thy b/Stateful_Protocol_Composition_and_Typing/Parallel_Compositionality.thy new file mode 100644 index 0000000..f2bee5f --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Parallel_Compositionality.thy @@ -0,0 +1,1178 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 +(C) Copyright Sebastian A. Mödersheim, DTU, 2018-2020 +(C) Copyright Achim D. Brucker, University of Sheffield, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Parallel_Compositionality.thy + Author: Andreas Viktor Hess, DTU + Author: Sebastian A. Mödersheim, DTU + Author: Achim D. Brucker, The University of Sheffield +*) + +section \Parallel Compositionality of Security Protocols\ +theory Parallel_Compositionality +imports Typing_Result Labeled_Strands +begin + + +subsection \Definitions: Labeled Typed Model Locale\ +locale labeled_typed_model = typed_model arity public Ana \ + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,'var) term \ (('fun,'var) term list \ ('fun,'var) term list)" + and \::"('fun,'var) term \ ('fun,'atom::finite) term_type" + + + fixes label_witness1 and label_witness2::"'lbl" + assumes at_least_2_labels: "label_witness1 \ label_witness2" +begin + +text \The Ground Sub-Message Patterns (GSMP)\ +definition GSMP::"('fun,'var) terms \ ('fun,'var) terms" where + "GSMP P \ {t \ SMP P. fv t = {}}" + +definition typing_cond where + "typing_cond \ \ + wf\<^sub>s\<^sub>t {} \ \ + fv\<^sub>s\<^sub>t \ \ bvars\<^sub>s\<^sub>t \ = {} \ + tfr\<^sub>s\<^sub>t \ \ + wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t \) \ + Ana_invar_subst (ik\<^sub>s\<^sub>t \ \ assignment_rhs\<^sub>s\<^sub>t \)" + + +subsection \Definitions: GSMP Disjointedness and Parallel Composability\ +definition GSMP_disjoint where + "GSMP_disjoint P1 P2 Secrets \ GSMP P1 \ GSMP P2 \ Secrets \ {m. {} \\<^sub>c m}" + +definition declassified\<^sub>l\<^sub>s\<^sub>t where + "declassified\<^sub>l\<^sub>s\<^sub>t (\::('fun,'var,'lbl) labeled_strand) \ \ {t. (\, Receive t) \ set \} \\<^sub>s\<^sub>e\<^sub>t \" + +definition par_comp where + "par_comp (\::('fun,'var,'lbl) labeled_strand) (Secrets::('fun,'var) terms) \ + (\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Secrets) \ + (\s \ Secrets. \s' \ subterms s. {} \\<^sub>c s' \ s' \ Secrets) \ + ground Secrets" + +definition strand_leaks\<^sub>l\<^sub>s\<^sub>t where + "strand_leaks\<^sub>l\<^sub>s\<^sub>t \ Sec \ \ (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \ \. \l. (\ \ \proj_unl l \@[Send t]\))" + +subsection \Definitions: Homogeneous and Numbered Intruder Deduction Variants\ + +definition proj_specific where + "proj_specific n t \ Secrets \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n \) - (Secrets \ {m. {} \\<^sub>c m})" + +definition heterogeneous\<^sub>l\<^sub>s\<^sub>t where + "heterogeneous\<^sub>l\<^sub>s\<^sub>t t \ Secrets \ ( + (\l1 l2. \s1 \ subterms t. \s2 \ subterms t. + l1 \ l2 \ proj_specific l1 s1 \ Secrets \ proj_specific l2 s2 \ Secrets))" + +abbreviation homogeneous\<^sub>l\<^sub>s\<^sub>t where + "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Secrets \ \heterogeneous\<^sub>l\<^sub>s\<^sub>t t \ Secrets" + +definition intruder_deduct_hom:: + "('fun,'var) terms \ ('fun,'var,'lbl) labeled_strand \ ('fun,'var) terms \ ('fun,'var) term + \ bool" ("\_;_;_\ \\<^sub>h\<^sub>o\<^sub>m _" 50) +where + "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t \ \M; \t. homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec \ t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)\ \\<^sub>r t" + +lemma intruder_deduct_hom_AxiomH[simp]: + assumes "t \ M" + shows "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" +using intruder_deduct_restricted.AxiomR[of t M] assms +unfolding intruder_deduct_hom_def +by blast + +lemma intruder_deduct_hom_ComposeH[simp]: + assumes "length X = arity f" "public f" "\x. x \ set X \ \M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m x" + and "homogeneous\<^sub>l\<^sub>s\<^sub>t (Fun f X) \ Sec" "Fun f X \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + shows "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m Fun f X" +proof - + let ?Q = "\t. homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec \ t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + show ?thesis + using intruder_deduct_restricted.ComposeR[of X f M ?Q] assms + unfolding intruder_deduct_hom_def + by blast +qed + +lemma intruder_deduct_hom_DecomposeH: + assumes "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" "Ana t = (K, T)" "\k. k \ set K \ \M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m k" "t\<^sub>i \ set T" + shows "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" +proof - + let ?Q = "\t. homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec \ t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + show ?thesis + using intruder_deduct_restricted.DecomposeR[of M ?Q t] assms + unfolding intruder_deduct_hom_def + by blast +qed + +lemma intruder_deduct_hom_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]: + assumes "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" "\t. t \ M \ P M t" + "\X f. \length X = arity f; public f; + \x. x \ set X \ \M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m x; + \x. x \ set X \ P M x; + homogeneous\<^sub>l\<^sub>s\<^sub>t (Fun f X) \ Sec; + Fun f X \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \) + \ \ P M (Fun f X)" + "\t K T t\<^sub>i. \\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t; P M t; Ana t = (K, T); + \k. k \ set K \ \M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m k; + \k. k \ set K \ P M k; t\<^sub>i \ set T\ \ P M t\<^sub>i" + shows "P M t" +proof - + let ?Q = "\t. homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec \ t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + show ?thesis + using intruder_deduct_restricted_induct[of M ?Q t "\M Q t. P M t"] assms + unfolding intruder_deduct_hom_def + by blast +qed + +lemma ideduct_hom_mono: + "\\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t; M \ M'\ \ \M'; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" +using ideduct_restricted_mono[of M _ t M'] +unfolding intruder_deduct_hom_def +by fast + +subsection \Lemmata: GSMP\ +lemma GSMP_disjoint_empty[simp]: + "GSMP_disjoint {} A Sec" "GSMP_disjoint A {} Sec" +unfolding GSMP_disjoint_def GSMP_def by fastforce+ + +lemma GSMP_mono: + assumes "N \ M" + shows "GSMP N \ GSMP M" +using SMP_mono[OF assms] unfolding GSMP_def by fast + +lemma GSMP_SMP_mono: + assumes "SMP N \ SMP M" + shows "GSMP N \ GSMP M" +using assms unfolding GSMP_def by fast + +lemma GSMP_subterm: + assumes "t \ GSMP M" "t' \ t" + shows "t' \ GSMP M" +using SMP.Subterm[of t M t'] ground_subterm[of t t'] assms unfolding GSMP_def by auto + +lemma GSMP_subterms: "subterms\<^sub>s\<^sub>e\<^sub>t (GSMP M) = GSMP M" +using GSMP_subterm[of _ M] by blast + +lemma GSMP_Ana_key: + assumes "t \ GSMP M" "Ana t = (K,T)" "k \ set K" + shows "k \ GSMP M" +using SMP.Ana[of t M K T k] Ana_keys_fv[of t K T] assms unfolding GSMP_def by auto + +lemma GSMP_append[simp]: "GSMP (trms\<^sub>l\<^sub>s\<^sub>t (A@B)) = GSMP (trms\<^sub>l\<^sub>s\<^sub>t A) \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t B)" +using SMP_union[of "trms\<^sub>l\<^sub>s\<^sub>t A" "trms\<^sub>l\<^sub>s\<^sub>t B"] trms\<^sub>l\<^sub>s\<^sub>t_append[of A B] unfolding GSMP_def by auto + +lemma GSMP_union: "GSMP (A \ B) = GSMP A \ GSMP B" +using SMP_union[of A B] unfolding GSMP_def by auto + +lemma GSMP_Union: "GSMP (trms\<^sub>l\<^sub>s\<^sub>t A) = (\l. GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l A))" +proof - + define P where "P \ (\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" + define Q where "Q \ trms\<^sub>l\<^sub>s\<^sub>t A" + have "SMP (\l. P l) = (\l. SMP (P l))" "Q = (\l. P l)" + unfolding P_def Q_def by (metis SMP_Union, metis trms\<^sub>l\<^sub>s\<^sub>t_union) + hence "GSMP Q = (\l. GSMP (P l))" unfolding GSMP_def by auto + thus ?thesis unfolding P_def Q_def by metis +qed + +lemma in_GSMP_in_proj: "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t A) \ \n. t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" +using GSMP_Union[of A] by blast + +lemma in_proj_in_GSMP: "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A) \ t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t A)" +using GSMP_Union[of A] by blast + +lemma GSMP_disjointE: + assumes A: "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t n A) (trms_proj\<^sub>l\<^sub>s\<^sub>t m A) Sec" + shows "GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t m A) \ Sec \ {m. {} \\<^sub>c m}" +using assms unfolding GSMP_disjoint_def by auto + +lemma GSMP_disjoint_term: + assumes "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + shows "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) \ t \ Sec \ {} \\<^sub>c t" +using assms unfolding GSMP_disjoint_def by blast + +lemma GSMP_wt_subst_subset: + assumes "t \ GSMP (M \\<^sub>s\<^sub>e\<^sub>t \)" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "t \ GSMP M" +using SMP_wt_subst_subset[OF _ assms(2,3), of t M] assms(1) unfolding GSMP_def by simp + +lemma GSMP_wt_substI: + assumes "t \ M" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "t \ I \ GSMP M" +proof - + have "t \ SMP M" using assms(1) by auto + hence *: "t \ I \ SMP M" using SMP.Substitution assms(2,3) wf_trm_subst_range_iff[of I] by simp + moreover have "fv (t \ I) = {}" + using assms(1) interpretation_grounds_all'[OF assms(4)] + by auto + ultimately show ?thesis unfolding GSMP_def by simp +qed + +lemma GSMP_disjoint_subset: + assumes "GSMP_disjoint L R S" "L' \ L" "R' \ R" + shows "GSMP_disjoint L' R' S" +using assms(1) SMP_mono[OF assms(2)] SMP_mono[OF assms(3)] +by (auto simp add: GSMP_def GSMP_disjoint_def) + +lemma GSMP_disjoint_fst_specific_not_snd_specific: + assumes "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" "l \ l'" + and "proj_specific l m \ Sec" + shows "\proj_specific l' m \ Sec" +using assms by (fastforce simp add: GSMP_disjoint_def proj_specific_def) + +lemma GSMP_disjoint_snd_specific_not_fst_specific: + assumes "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and "proj_specific l' m \ Sec" + shows "\proj_specific l m \ Sec" +using assms by (auto simp add: GSMP_disjoint_def proj_specific_def) + +lemma GSMP_disjoint_intersection_not_specific: + assumes "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and "t \ Sec \ {} \\<^sub>c t" + shows "\proj_specific l t \ Sec" "\proj_specific l t \ Sec" +using assms by (auto simp add: GSMP_disjoint_def proj_specific_def) + +subsection \Lemmata: Intruder Knowledge and Declassification\ +lemma ik_proj_subst_GSMP_subset: + assumes I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "ik\<^sub>s\<^sub>t (proj_unl n A) \\<^sub>s\<^sub>e\<^sub>t I \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" +proof + fix t assume "t \ ik\<^sub>s\<^sub>t (proj_unl n A) \\<^sub>s\<^sub>e\<^sub>t I" + hence *: "t \ trms_proj\<^sub>l\<^sub>s\<^sub>t n A \\<^sub>s\<^sub>e\<^sub>t I" by auto + then obtain s where "s \ trms_proj\<^sub>l\<^sub>s\<^sub>t n A" "t = s \ I" by auto + hence "t \ SMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" using SMP_I I(1,2) wf_trm_subst_range_iff[of I] by simp + moreover have "fv t = {}" + using * interpretation_grounds_all'[OF I(3)] + by auto + ultimately show "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" unfolding GSMP_def by simp +qed + +lemma declassified_proj_ik_subset: "declassified\<^sub>l\<^sub>s\<^sub>t A I \ ik\<^sub>s\<^sub>t (proj_unl n A) \\<^sub>s\<^sub>e\<^sub>t I" +proof (induction A) + case (Cons a A) thus ?case + using proj_ik_append[of n "[a]" A] by (auto simp add: declassified\<^sub>l\<^sub>s\<^sub>t_def) +qed (simp add: declassified\<^sub>l\<^sub>s\<^sub>t_def) + +lemma declassified_proj_GSMP_subset: + assumes I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "declassified\<^sub>l\<^sub>s\<^sub>t A I \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" +by (rule subset_trans[OF declassified_proj_ik_subset ik_proj_subst_GSMP_subset[OF I]]) + +lemma declassified_subterms_proj_GSMP_subset: + assumes I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (declassified\<^sub>l\<^sub>s\<^sub>t A I) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" +proof + fix t assume t: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (declassified\<^sub>l\<^sub>s\<^sub>t A I)" + then obtain t' where t': "t' \ declassified\<^sub>l\<^sub>s\<^sub>t A I" "t \ t'" by moura + hence "t' \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" using declassified_proj_GSMP_subset[OF assms] by blast + thus "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n A)" + using SMP.Subterm[of t' "trms_proj\<^sub>l\<^sub>s\<^sub>t n A" t] ground_subterm[OF _ t'(2)] t'(2) + unfolding GSMP_def by fast +qed + +lemma declassified_secrets_subset: + assumes A: "\n m. n \ m \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t n A) (trms_proj\<^sub>l\<^sub>s\<^sub>t m A) Sec" + and I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "declassified\<^sub>l\<^sub>s\<^sub>t A I \ Sec \ {m. {} \\<^sub>c m}" +using declassified_proj_GSMP_subset[OF I] A at_least_2_labels +unfolding GSMP_disjoint_def by blast + +lemma declassified_subterms_secrets_subset: + assumes A: "\n m. n \ m \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t n A) (trms_proj\<^sub>l\<^sub>s\<^sub>t m A) Sec" + and I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (declassified\<^sub>l\<^sub>s\<^sub>t A I) \ Sec \ {m. {} \\<^sub>c m}" +using declassified_subterms_proj_GSMP_subset[OF I, of A label_witness1] + declassified_subterms_proj_GSMP_subset[OF I, of A label_witness2] + A at_least_2_labels +unfolding GSMP_disjoint_def by fast + +lemma declassified_proj_eq: "declassified\<^sub>l\<^sub>s\<^sub>t A I = declassified\<^sub>l\<^sub>s\<^sub>t (proj n A) I" +unfolding declassified\<^sub>l\<^sub>s\<^sub>t_def proj_def by auto + +lemma declassified_append: "declassified\<^sub>l\<^sub>s\<^sub>t (A@B) I = declassified\<^sub>l\<^sub>s\<^sub>t A I \ declassified\<^sub>l\<^sub>s\<^sub>t B I" +unfolding declassified\<^sub>l\<^sub>s\<^sub>t_def by auto + +lemma declassified_prefix_subset: "prefix A B \ declassified\<^sub>l\<^sub>s\<^sub>t A I \ declassified\<^sub>l\<^sub>s\<^sub>t B I" +using declassified_append unfolding prefix_def by auto + +subsection \Lemmata: Homogeneous and Heterogeneous Terms\ +lemma proj_specific_secrets_anti_mono: + assumes "proj_specific l t \ Sec" "Sec' \ Sec" + shows "proj_specific l t \ Sec'" +using assms unfolding proj_specific_def by fast + +lemma heterogeneous_secrets_anti_mono: + assumes "heterogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" "Sec' \ Sec" + shows "heterogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec'" +using assms proj_specific_secrets_anti_mono unfolding heterogeneous\<^sub>l\<^sub>s\<^sub>t_def by metis + +lemma homogeneous_secrets_mono: + assumes "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec'" "Sec' \ Sec" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" +using assms heterogeneous_secrets_anti_mono by blast + +lemma heterogeneous_supterm: + assumes "heterogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" "t \ t'" + shows "heterogeneous\<^sub>l\<^sub>s\<^sub>t t' \ Sec" +proof - + obtain l1 l2 s1 s2 where *: + "l1 \ l2" + "s1 \ t" "proj_specific l1 s1 \ Sec" + "s2 \ t" "proj_specific l2 s2 \ Sec" + using assms(1) unfolding heterogeneous\<^sub>l\<^sub>s\<^sub>t_def by moura + thus ?thesis + using term.order_trans[OF *(2) assms(2)] term.order_trans[OF *(4) assms(2)] + by (auto simp add: heterogeneous\<^sub>l\<^sub>s\<^sub>t_def) +qed + +lemma homogeneous_subterm: + assumes "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" "t' \ t" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t' \ Sec" +by (metis assms heterogeneous_supterm) + +lemma proj_specific_subterm: + assumes "t \ t'" "proj_specific l t' \ Sec" + shows "proj_specific l t \ Sec \ t \ Sec \ {} \\<^sub>c t" +using GSMP_subterm[OF _ assms(1)] assms(2) by (auto simp add: proj_specific_def) + +lemma heterogeneous_term_is_Fun: + assumes "heterogeneous\<^sub>l\<^sub>s\<^sub>t t A S" shows "\f T. t = Fun f T" +using assms by (cases t) (auto simp add: GSMP_def heterogeneous\<^sub>l\<^sub>s\<^sub>t_def proj_specific_def) + +lemma proj_specific_is_homogeneous: + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and t: "proj_specific l m \ Sec" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" +proof + assume "heterogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" + then obtain s l' where s: "s \ subterms m" "proj_specific l' s \ Sec" "l \ l'" + unfolding heterogeneous\<^sub>l\<^sub>s\<^sub>t_def by moura + hence "s \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" "s \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \)" + using t by (auto simp add: GSMP_def proj_specific_def) + hence "s \ Sec \ {} \\<^sub>c s" + using \ s(3) by (auto simp add: GSMP_disjoint_def) + thus False using s(2) by (auto simp add: proj_specific_def) +qed + +lemma deduct_synth_homogeneous: + assumes "{} \\<^sub>c t" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" +proof - + have "\s \ subterms t. {} \\<^sub>c s" using deduct_synth_subterm[OF assms] by auto + thus ?thesis unfolding heterogeneous\<^sub>l\<^sub>s\<^sub>t_def proj_specific_def by auto +qed + +lemma GSMP_proj_is_homogeneous: + assumes "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l A) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' A) Sec" + and "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" "t \ Sec" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t A Sec" +proof + assume "heterogeneous\<^sub>l\<^sub>s\<^sub>t t A Sec" + then obtain s l' where s: "s \ subterms t" "proj_specific l' s A Sec" "l \ l'" + unfolding heterogeneous\<^sub>l\<^sub>s\<^sub>t_def by moura + hence "s \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" "s \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' A)" + using assms by (auto simp add: GSMP_def proj_specific_def) + hence "s \ Sec \ {} \\<^sub>c s" using assms(1) s(3) by (auto simp add: GSMP_disjoint_def) + thus False using s(2) by (auto simp add: proj_specific_def) +qed + +lemma homogeneous_is_not_proj_specific: + assumes "homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" + shows "\l::'lbl. \proj_specific l m \ Sec" +proof - + let ?P = "\l s. proj_specific l s \ Sec" + have "\l1 l2. \s1\subterms m. \s2\subterms m. (l1 \ l2 \ (\?P l1 s1 \ \?P l2 s2))" + using assms heterogeneous\<^sub>l\<^sub>s\<^sub>t_def by metis + then obtain l1 l2 where "l1 \ l2" "\?P l1 m \ \?P l2 m" + by (metis term.order_refl at_least_2_labels) + thus ?thesis by metis +qed + +lemma secrets_are_homogeneous: + assumes "\s \ Sec. P s \ (\s' \ subterms s. {} \\<^sub>c s' \ s' \ Sec)" "s \ Sec" "P s" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t s \ Sec" +using assms by (auto simp add: heterogeneous\<^sub>l\<^sub>s\<^sub>t_def proj_specific_def) + +lemma GSMP_is_homogeneous: + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and t: "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" "t \ Sec" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" +proof - + obtain n where n: "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n \)" using in_GSMP_in_proj[OF t(1)] by moura + show ?thesis using GSMP_proj_is_homogeneous[OF \ n t(2)] by metis +qed + +lemma GSMP_intersection_is_homogeneous: + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and t: "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \)" "l \ l'" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" +proof - + define M where "M \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + define M' where "M' \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \)" + + have t_in: "t \ M \ M'" "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + using t(1) in_proj_in_GSMP[of t _ \] + unfolding M_def M'_def by blast+ + + have "M \ M' \ Sec \ {m. {} \\<^sub>c m}" + using \ GSMP_disjointE[of l \ l' Sec] t(2) + unfolding M_def M'_def by presburger + moreover have "subterms\<^sub>s\<^sub>e\<^sub>t (M \ M') = M \ M'" + using GSMP_subterms unfolding M_def M'_def by blast + ultimately have *: "subterms\<^sub>s\<^sub>e\<^sub>t (M \ M') \ Sec \ {m. {} \\<^sub>c m}" + by blast + + show ?thesis + proof (cases "t \ Sec") + case True thus ?thesis + using * secrets_are_homogeneous[of Sec "\t. t \ M \ M'", OF _ _ t_in(1)] + by fast + qed (metis GSMP_is_homogeneous[OF \ t_in(2)]) +qed + +lemma GSMP_is_homogeneous': + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and t: "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + "t \ Sec - \{GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) | l1 l2. l1 \ l2}" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" +using GSMP_is_homogeneous[OF \ t(1)] GSMP_intersection_is_homogeneous[OF \] t(2) +by blast + +lemma declassified_secrets_are_homogeneous: + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and s: "s \ declassified\<^sub>l\<^sub>s\<^sub>t \ \" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t s \ Sec" +proof - + have s_in: "s \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + using declassified_proj_GSMP_subset[OF \, of \ label_witness1] + in_proj_in_GSMP[of s label_witness1 \] s + by blast + + show ?thesis + proof (cases "s \ Sec") + case True thus ?thesis + using declassified_subterms_secrets_subset[OF \ \] + secrets_are_homogeneous[of Sec "\s. s \ declassified\<^sub>l\<^sub>s\<^sub>t \ \", OF _ _ s] + by fast + qed (metis GSMP_is_homogeneous[OF \ s_in]) +qed + +lemma Ana_keys_homogeneous: + assumes \: "\l l'. l \ l' \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \) Sec" + and t: "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + and k: "Ana t = (K,T)" "k \ set K" + "k \ Sec - \{GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) | l1 l2. l1 \ l2}" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t k \ Sec" +proof (cases "k \ \{GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) | l1 l2. l1 \ l2}") + case False + hence "k \ Sec" using k(3) by fast + moreover have "k \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + using t SMP.Ana[OF _ k(1,2)] Ana_keys_fv[OF k(1)] k(2) + unfolding GSMP_def by auto + ultimately show ?thesis using GSMP_is_homogeneous[OF \, of k] by metis +qed (use GSMP_intersection_is_homogeneous[OF \] in blast) + +subsection \Lemmata: Intruder Deduction Equivalences\ +lemma deduct_if_hom_deduct: "\M;A;S\ \\<^sub>h\<^sub>o\<^sub>m m \ M \ m" +using deduct_if_restricted_deduct unfolding intruder_deduct_hom_def by blast + +lemma hom_deduct_if_hom_ik: + assumes "\M;A;Sec\ \\<^sub>h\<^sub>o\<^sub>m m" "\m \ M. homogeneous\<^sub>l\<^sub>s\<^sub>t m A Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t A)" + shows "homogeneous\<^sub>l\<^sub>s\<^sub>t m A Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t A)" +proof - + let ?Q = "\m. homogeneous\<^sub>l\<^sub>s\<^sub>t m A Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t A)" + have "?Q t'" when "?Q t" "t' \ t" for t t' + using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1) + by blast + thus ?thesis + using assms(1) restricted_deduct_if_restricted_ik[OF _ assms(2)] + unfolding intruder_deduct_hom_def + by blast +qed + +lemma deduct_hom_if_synth: + assumes hom: "homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" "m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + and m: "M \\<^sub>c m" + shows "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m m" +proof - + let ?Q = "\m. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + have "?Q t'" when "?Q t" "t' \ t" for t t' + using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1) + by blast + thus ?thesis + using assms deduct_restricted_if_synth[of ?Q] + unfolding intruder_deduct_hom_def + by blast +qed + +lemma hom_deduct_if_deduct: + assumes \: "par_comp \ Sec" + and M: "\m\M. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + and m: "M \ m" "m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" +shows "\M; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m m" +proof - + let ?P = "\x. homogeneous\<^sub>l\<^sub>s\<^sub>t x \ Sec \ x \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + + have GSMP_hom: "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" when "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" for t + using \ GSMP_is_homogeneous[of \ Sec t] + secrets_are_homogeneous[of Sec "\x. True" t \] that + unfolding par_comp_def by blast + + have P_Ana: "?P k" when "?P t" "Ana t = (K, T)" "k \ set K" for t K T k + using GSMP_Ana_key[OF _ that(2,3), of "trms\<^sub>l\<^sub>s\<^sub>t \"] \ that GSMP_hom + by presburger + + have P_subterm: "?P t'" when "?P t" "t' \ t" for t t' + using GSMP_subterm[of _ "trms\<^sub>l\<^sub>s\<^sub>t \"] homogeneous_subterm[of _ \ Sec] that + by blast + + have P_m: "?P m" + using GSMP_hom[OF m(2)] m(2) + by metis + + show ?thesis + using restricted_deduct_if_deduct'[OF M _ _ m(1) P_m] P_Ana P_subterm + unfolding intruder_deduct_hom_def + by fast +qed + + +subsection \Lemmata: Deduction Reduction of Parallel Composable Constraints\ +lemma par_comp_hom_deduct: + assumes \: "par_comp \ Sec" + and M: "\l. \m \ M l. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" + "\l. M l \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + "\l. Discl \ M l" + "Discl \ Sec \ {m. {} \\<^sub>c m}" + and Sec: "\l. \s \ Sec - Discl. \(\M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m s)" + and t: "\\l. M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" + shows "t \ Sec - Discl" (is ?A) + "\l. t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ \M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" (is ?B) +proof - + have M': "\l. \m \ M l. m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + proof (intro allI ballI) + fix l m show "m \ M l \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" using M(2) in_proj_in_GSMP[of m l \] by blast + qed + + show ?A ?B using t + proof (induction t rule: intruder_deduct_hom_induct) + case (AxiomH t) + then obtain lt where t_in_proj_ik: "t \ M lt" by moura + show t_not_Sec: "t \ Sec - Discl" + proof + assume "t \ Sec - Discl" + hence "\l. \(\M l;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m t)" using Sec by auto + thus False using intruder_deduct_hom_AxiomH[OF t_in_proj_ik] by metis + qed + + have 1: "\l. t \ M l \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + using M(2,3) AxiomH by auto + + have 3: "\l1 l2. l1 \ l2 \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) + \ {} \\<^sub>c t \ t \ Discl" + using \ t_not_Sec by (auto simp add: par_comp_def GSMP_disjoint_def) + + have 4: "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" using M(1) M' t_in_proj_ik by auto + + { fix l assume "t \ Discl" + hence "t \ M l" using M(3) by auto + hence "\M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" by auto + } hence 5: "\l. t \ Discl \ \M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" by metis + + show "\l. t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ \M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t" + by (metis (lifting) Int_iff empty_subsetI + 1 3 4 5 t_in_proj_ik + intruder_deduct_hom_AxiomH[of t _ \ Sec] + deduct_hom_if_synth[of t \ Sec "{}"] + ideduct_hom_mono[of "{}" \ Sec t]) + next + case (ComposeH T f) + show "\l. Fun f T \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ \M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m Fun f T" + proof (intro allI impI) + fix l + assume "Fun f T \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + hence "\t. t \ set T \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + using GSMP_subterm[OF _ subtermeqI''] by auto + thus "\M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m Fun f T" + using ComposeH.IH(2) intruder_deduct_hom_ComposeH[OF ComposeH.hyps(1,2) _ ComposeH.hyps(4,5)] + by simp + qed + thus "Fun f T \ Sec - Discl" + using Sec ComposeH.hyps(5) trms\<^sub>l\<^sub>s\<^sub>t_union[of \] GSMP_Union[of \] + by (metis (no_types, lifting) UN_iff) + next + case (DecomposeH t K T t\<^sub>i) + have ti_subt: "t\<^sub>i \ t" using Ana_subterm[OF DecomposeH.hyps(2)] \t\<^sub>i \ set T\ by auto + have t: "homogeneous\<^sub>l\<^sub>s\<^sub>t t \ Sec" "t \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + using DecomposeH.hyps(1) hom_deduct_if_hom_ik M(1) M' + by auto + have ti: "homogeneous\<^sub>l\<^sub>s\<^sub>t t\<^sub>i \ Sec" "t\<^sub>i \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + using intruder_deduct_hom_DecomposeH[OF DecomposeH.hyps] hom_deduct_if_hom_ik M(1) M' by auto + { fix l assume *: "t\<^sub>i \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + hence "\k. k \ set K \ \M l;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m k" + using GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto + hence "\M l;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" "t\<^sub>i \ Sec - Discl" + using Sec DecomposeH.IH(2) *(2) + intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ \t\<^sub>i \ set T\] + by force+ + } moreover { + fix l1 l2 assume *: "t\<^sub>i \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \)" "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \)" "l1 \ l2" + have "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + using *(3) \ by (simp add: par_comp_def) + hence "t\<^sub>i \ Sec \ {m. {} \\<^sub>c m}" + using GSMP_subterm[OF *(2) ti_subt] *(1) by (auto simp add: GSMP_disjoint_def) + moreover have "\k. k \ set K \ \M l2;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m k" + using *(2) GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto + ultimately have "t\<^sub>i \ Sec - Discl" "{} \\<^sub>c t\<^sub>i \ t\<^sub>i \ Discl" + using Sec DecomposeH.IH(2) *(2) + intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ \t\<^sub>i \ set T\] + by (metis (lifting), metis (no_types, lifting) DiffI Un_iff mem_Collect_eq) + hence "\M l1;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" "\M l2;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" "t\<^sub>i \ Sec - Discl" + using M(3,4) deduct_hom_if_synth[THEN ideduct_hom_mono] ti + by (meson intruder_deduct_hom_AxiomH empty_subsetI subsetCE)+ + } moreover have + "\l. t\<^sub>i \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + "\l. t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + using in_GSMP_in_proj[of _ \] ti(2) t(2) by presburger+ + ultimately show + "t\<^sub>i \ Sec - Discl" + "\l. t\<^sub>i \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \) \ \M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" + by (metis (no_types, lifting))+ + qed +qed + +lemma par_comp_deduct_proj: + assumes \: "par_comp \ Sec" + and M: "\l. \m\M l. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" + "\l. M l \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + "\l. Discl \ M l" + and t: "(\l. M l) \ t" "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + and Discl: "Discl \ Sec \ {m. {} \\<^sub>c m}" + shows "M l \ t \ (\s \ Sec - Discl. \l. M l \ s)" +using t +proof (induction t rule: intruder_deduct_induct) + case (Axiom t) + then obtain l' where t_in_ik_proj: "t \ M l'" by moura + show ?case + proof (cases "t \ Sec - Discl \ {} \\<^sub>c t") + case True + note T = True + show ?thesis + proof (cases "t \ Sec - Discl") + case True thus ?thesis using intruder_deduct.Axiom[OF t_in_ik_proj] by metis + next + case False thus ?thesis using T ideduct_mono[of "{}" t] by auto + qed + next + case False + hence "t \ Sec - Discl" "\{} \\<^sub>c t" "t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" using Axiom by auto + hence "(\l'. l \ l' \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \)) \ t \ Discl" + using \ unfolding GSMP_disjoint_def par_comp_def by auto + hence "(\l'. l \ l' \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l' \)) \ t \ M l \ {} \\<^sub>c t" using M by auto + thus ?thesis using Axiom deduct_if_synth[THEN ideduct_mono] t_in_ik_proj + by (metis (no_types, lifting) False M(2) intruder_deduct.Axiom subsetCE) + qed +next + case (Compose T f) + hence "Fun f T \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" using Compose.prems by auto + hence "\t. t \ set T \ t \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" unfolding GSMP_def by auto + hence IH: "\t. t \ set T \ M l \ t \ (\s \ Sec - Discl. \l. M l \ s)" + using Compose.IH by auto + show ?case + proof (cases "\t \ set T. M l \ t") + case True thus ?thesis by (metis intruder_deduct.Compose[OF Compose.hyps(1,2)]) + qed (metis IH) +next + case (Decompose t K T t\<^sub>i) + have hom_ik: "\l. \m\M l. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec \ m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + proof (intro allI ballI conjI) + fix l m assume m: "m \ M l" + thus "homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" using M(1) by simp + show "m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" using in_proj_in_GSMP[of m l \] M(2) m by blast + qed + + have par_comp_unfold: + "\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + using \ by (auto simp add: par_comp_def) + + note ti_GSMP = in_proj_in_GSMP[OF Decompose.prems(1)] + + have "\\l. M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i" + using intruder_deduct.Decompose[OF Decompose.hyps] + hom_deduct_if_deduct[OF \, of "\l. M l"] hom_ik ti_GSMP (* ti_hom *) + by blast + hence "(\M l; \; Sec\ \\<^sub>h\<^sub>o\<^sub>m t\<^sub>i) \ (\s \ Sec-Discl. \l. \M l;\;Sec\ \\<^sub>h\<^sub>o\<^sub>m s)" + using par_comp_hom_deduct(2)[OF \ M Discl(1)] Decompose.prems(1) + by blast + thus ?case using deduct_if_hom_deduct[of _ \ Sec] by auto +qed + + +subsection \Theorem: Parallel Compositionality for Labeled Constraints\ +lemma par_comp_prefix: assumes "par_comp (A@B) M" shows "par_comp A M" +proof - + let ?L = "\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A \ trms_proj\<^sub>l\<^sub>s\<^sub>t l B" + have "\l1 l2. l1 \ l2 \ GSMP_disjoint (?L l1) (?L l2) M" + using assms unfolding par_comp_def + by (metis trms\<^sub>s\<^sub>t_append proj_append(2) unlabel_append) + hence "\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 A) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 A) M" + using SMP_union by (auto simp add: GSMP_def GSMP_disjoint_def) + thus ?thesis using assms unfolding par_comp_def by blast +qed + +theorem par_comp_constr_typed: + assumes \: "par_comp \ Sec" + and \: "\ \ \unlabel \\" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "(\l. (\ \ \proj_unl l \\)) \ (\\'. prefix \' \ \ (strand_leaks\<^sub>l\<^sub>s\<^sub>t \' Sec \))" +proof - + let ?L = "\\'. \t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \' \. \l. \{}; proj_unl l \'@[Send t]\\<^sub>d \" + have "\{}; unlabel \\\<^sub>d \" using \ by (simp add: constr_sem_d_def) + with \ have "(\l. \{}; proj_unl l \\\<^sub>d \) \ (\\'. prefix \' \ \ ?L \')" + proof (induction "unlabel \" arbitrary: \ rule: List.rev_induct) + case Nil + hence "\ = []" using unlabel_nil_only_if_nil by simp + thus ?case by auto + next + case (snoc b B \) + hence disj: "\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + by (auto simp add: par_comp_def) + + obtain a A n where a: "\ = A@[a]" "a = (ln n, b) \ a = (\, b)" + using unlabel_snoc_inv[OF snoc.hyps(2)[symmetric]] by moura + hence A: "\ = A@[(ln n, b)] \ \ = A@[(\, b)]" by metis + + have 1: "B = unlabel A" using a snoc.hyps(2) unlabel_append[of A "[a]"] by auto + have 2: "par_comp A Sec" using par_comp_prefix snoc.prems(1) a by metis + have 3: "\{}; unlabel A\\<^sub>d \" by (metis 1 snoc.prems(2) snoc.hyps(2) strand_sem_split(3)) + have IH: "(\l. \{}; proj_unl l A\\<^sub>d \) \ (\\'. prefix \' A \ ?L \')" + by (rule snoc.hyps(1)[OF 1 2 3]) + + show ?case + proof (cases "\l. \{}; proj_unl l A\\<^sub>d \") + case False + then obtain \' where \': "prefix \' A" "?L \'" by (metis IH) + hence "prefix \' (A@[a])" using a prefix_prefix[of _ A "[a]"] by simp + thus ?thesis using \'(2) a by auto + next + case True + note IH' = True + show ?thesis + proof (cases b) + case (Send t) + hence "ik\<^sub>s\<^sub>t (unlabel A) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" + using a \\{}; unlabel \\\<^sub>d \\ strand_sem_split(2)[of "{}" "unlabel A" "unlabel [a]" \] + unlabel_append[of A "[a]"] + by auto + hence *: "(\l. (ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \)) \ t \ \" + using proj_ik_union_is_unlabel_ik image_UN by metis + + have "ik\<^sub>s\<^sub>t (proj_unl l \) = ik\<^sub>s\<^sub>t (proj_unl l A)" for l + using Send A + by (metis append_Nil2 ik\<^sub>s\<^sub>t.simps(3) proj_unl_cons(3) proj_nil(2) + singleton_lst_proj(1,2) proj_ik_append) + hence **: "ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" for l + using ik_proj_subst_GSMP_subset[OF \(3,4,2), of _ \] + by auto + + note Discl = + declassified_proj_ik_subset[of A \] + declassified_proj_GSMP_subset[OF \(3,4,2), of A] + declassified_secrets_subset[OF disj \(3,4,2)] + declassified_append[of A "[a]" \] + + have Sec: "ground Sec" + using \ by (auto simp add: par_comp_def) + + have "\m\ik\<^sub>s\<^sub>t (proj_unl l \) \\<^sub>s\<^sub>e\<^sub>t \. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec \ m \ Sec-declassified\<^sub>l\<^sub>s\<^sub>t A \" + "\m\ik\<^sub>s\<^sub>t (proj_unl l \) \\<^sub>s\<^sub>e\<^sub>t \. m \ GSMP (trms\<^sub>l\<^sub>s\<^sub>t \)" + "ik\<^sub>s\<^sub>t (proj_unl l \) \\<^sub>s\<^sub>e\<^sub>t \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + for l + using declassified_secrets_are_homogeneous[OF disj \(3,4,2)] + GSMP_proj_is_homogeneous[OF disj] + ik_proj_subst_GSMP_subset[OF \(3,4,2), of _ \] + apply (metis (no_types, lifting) Diff_iff Discl(4) UnCI a(1) subsetCE) + using ik_proj_subst_GSMP_subset[OF \(3,4,2), of _ \] + GSMP_Union[of \] + by auto + moreover have "ik\<^sub>s\<^sub>t (proj_unl l [a]) = {}" for l + using Send proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ "[a]"] a(2) by auto + ultimately have M: + "\l. \m\ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec \ m \ Sec-declassified\<^sub>l\<^sub>s\<^sub>t A \" + "\l. ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" + using a(1) proj_ik_append[of _ A "[a]"] by auto + + have prefix_A: "prefix A \" using A by auto + + have "s \ \ = s" + when "s \ Sec" for s + using that Sec by auto + hence leakage_case: "\{}; proj_unl l A@[Send s]\\<^sub>d \" + when "s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \" "ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ s" for l s + using that strand_sem_append(2) IH' by auto + + have proj_deduct_case_n: + "\m. m \ n \ \{}; proj_unl m (A@[a])\\<^sub>d \" + "ik\<^sub>s\<^sub>t (proj_unl n A) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \ \ \{}; proj_unl n (A@[a])\\<^sub>d \" + when "a = (ln n, Send t)" + using that IH' proj_append(2)[of _ A] + by auto + + have proj_deduct_case_star: + "\{}; proj_unl l (A@[a])\\<^sub>d \" + when "a = (\, Send t)" "ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" for l + using that IH' proj_append(2)[of _ A] + by auto + + show ?thesis + proof (cases "\l. \m \ ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \. m \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \") + case True + then obtain l s where ls: "s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \" "ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ s" + using intruder_deduct.Axiom by metis + thus ?thesis using leakage_case prefix_A by blast + next + case False + hence M': "\l. \m\ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \. homogeneous\<^sub>l\<^sub>s\<^sub>t m \ Sec" using M(1) by blast + + note deduct_proj_lemma = + par_comp_deduct_proj[OF snoc.prems(1) M' M(2) _ *, of "declassified\<^sub>l\<^sub>s\<^sub>t A \" n] + + from a(2) show ?thesis + proof + assume "a = (ln n, b)" + hence "a = (ln n, Send t)" "t \ \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n \)" + using Send a(1) trms_proj\<^sub>l\<^sub>s\<^sub>t_append[of n A "[a]"] + GSMP_wt_substI[OF _ \(3,4,2)] + by (metis, force) + hence + "a = (ln n, Send t)" + "\m. m \ n \ \{}; proj_unl m (A@[a])\\<^sub>d \" + "ik\<^sub>s\<^sub>t (proj_unl n A) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \ \ \{}; proj_unl n (A@[a])\\<^sub>d \" + "t \ \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t n \)" + using proj_deduct_case_n + by auto + hence "(\l. \{}; proj_unl l \\\<^sub>d \) \ + (\s \ Sec-declassified\<^sub>l\<^sub>s\<^sub>t A \. \l. ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ s)" + using deduct_proj_lemma A a Discl + by fast + thus ?thesis using leakage_case prefix_A by metis + next + assume "a = (\, b)" + hence ***: "a = (\, Send t)" "t \ \ \ GSMP (trms_proj\<^sub>l\<^sub>s\<^sub>t l \)" for l + using Send a(1) GSMP_wt_substI[OF _ \(3,4,2)] + by (metis, force) + hence "t \ \ \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \ \ + t \ \ \ declassified\<^sub>l\<^sub>s\<^sub>t A \ \ + t \ \ \ {m. {} \\<^sub>c m}" + using snoc.prems(1) a(1) at_least_2_labels + unfolding par_comp_def GSMP_disjoint_def + by blast + thus ?thesis + proof (elim disjE) + assume "t \ \ \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \" + hence "\s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t A \. \l. ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ s" + using deduct_proj_lemma ***(2) A a Discl + by blast + thus ?thesis using prefix_A leakage_case by blast + next + assume "t \ \ \ declassified\<^sub>l\<^sub>s\<^sub>t A \" + hence "ik\<^sub>s\<^sub>t (proj_unl l A) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" for l + using intruder_deduct.Axiom Discl(1) by blast + thus ?thesis using proj_deduct_case_star[OF ***(1)] a(1) by fast + next + assume "t \ \ \ {m. {} \\<^sub>c m}" + hence "M \ t \ \" for M using ideduct_mono[OF deduct_if_synth] by blast + thus ?thesis using IH' a(1) ***(1) by fastforce + qed + qed + qed + next + case (Receive t) + hence "\{}; proj_unl l \\\<^sub>d \" for l + using IH' a proj_append(2)[of l A "[a]"] + unfolding unlabel_def proj_def by auto + thus ?thesis by metis + next + case (Equality ac t t') + hence *: "\M; [Equality ac t t']\\<^sub>d \" for M + using a \\{}; unlabel \\\<^sub>d \\ unlabel_append[of A "[a]"] + by auto + show ?thesis + using a proj_append(2)[of _ A "[a]"] Equality + strand_sem_append(2)[OF _ *] IH' + unfolding unlabel_def proj_def by auto + next + case (Inequality X F) + hence *: "\M; [Inequality X F]\\<^sub>d \" for M + using a \\{}; unlabel \\\<^sub>d \\ unlabel_append[of A "[a]"] + by auto + show ?thesis + using a proj_append(2)[of _ A "[a]"] Inequality + strand_sem_append(2)[OF _ *] IH' + unfolding unlabel_def proj_def by auto + qed + qed + qed + thus ?thesis using \(1) unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>t_def by (simp add: constr_sem_d_def) +qed + +theorem par_comp_constr: + assumes \: "par_comp \ Sec" "typing_cond (unlabel \)" + and \: "\ \ \unlabel \\" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ (\\<^sub>\ \ \unlabel \\) \ + ((\l. (\\<^sub>\ \ \proj_unl l \\)) \ (\\'. prefix \' \ \ (strand_leaks\<^sub>l\<^sub>s\<^sub>t \' Sec \\<^sub>\)))" +proof - + from \(2) have *: + "wf\<^sub>s\<^sub>t {} (unlabel \)" + "fv\<^sub>s\<^sub>t (unlabel \) \ bvars\<^sub>s\<^sub>t (unlabel \) = {}" + "tfr\<^sub>s\<^sub>t (unlabel \)" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t (unlabel \))" + "Ana_invar_subst (ik\<^sub>s\<^sub>t (unlabel \) \ assignment_rhs\<^sub>s\<^sub>t (unlabel \))" + unfolding typing_cond_def tfr\<^sub>s\<^sub>t_def by metis+ + + obtain \\<^sub>\ where \\<^sub>\: "\\<^sub>\ \ \unlabel \\" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + using wt_attack_if_tfr_attack_d[OF * \(2,1)] by metis + + show ?thesis using par_comp_constr_typed[OF \(1) \\<^sub>\] \\<^sub>\ by auto +qed + + +subsection \Theorem: Parallel Compositionality for Labeled Protocols\ +subsubsection \Definitions: Labeled Protocols\ +text \ + We state our result on the level of protocol traces (i.e., the constraints reachable in a + symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands + to intruder constraints in the following well-formedness definitions. +\ +definition wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s::"('fun,'var,'lbl) labeled_strand set \ bool" where + "wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s \ \ (\\ \ \. wf\<^sub>l\<^sub>s\<^sub>t {} \) \ (\\ \ \. \\' \ \. fv\<^sub>l\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>t \' = {})" + +definition wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s'::"('fun,'var,'lbl) labeled_strand set \ ('fun,'var,'lbl) labeled_strand \ bool" +where + "wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s' \ \ \ (\\' \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t \) (unlabel \')) \ + (\\' \ \. \\'' \ \. fv\<^sub>l\<^sub>s\<^sub>t \' \ bvars\<^sub>l\<^sub>s\<^sub>t \'' = {}) \ + (\\' \ \. fv\<^sub>l\<^sub>s\<^sub>t \' \ bvars\<^sub>l\<^sub>s\<^sub>t \ = {}) \ + (\\' \ \. fv\<^sub>l\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>t \' = {})" + +definition typing_cond_prot where + "typing_cond_prot \

\ + wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s \

\ + tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>l\<^sub>s\<^sub>t ` \

)) \ + wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>l\<^sub>s\<^sub>t ` \

)) \ + (\\ \ \

. list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel \)) \ + Ana_invar_subst (\(ik\<^sub>s\<^sub>t ` unlabel ` \

) \ \(assignment_rhs\<^sub>s\<^sub>t ` unlabel ` \

))" + +definition par_comp_prot where + "par_comp_prot \

Sec \ + (\l1 l2. l1 \ l2 \ + GSMP_disjoint (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec) \ + ground Sec \ (\s \ Sec. \s' \ subterms s. {} \\<^sub>c s' \ s' \ Sec) \ + typing_cond_prot \

" + + +subsubsection \Lemmata: Labeled Protocols\ +lemma wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s_eqs_wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s'[simp]: "wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s S = wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s' S []" +unfolding wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s_def wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s'_def unlabel_def by auto + +lemma par_comp_prot_impl_par_comp: + assumes "par_comp_prot \

Sec" "\ \ \

" + shows "par_comp \ Sec" +proof - + have *: "\l1 l2. l1 \ l2 \ + GSMP_disjoint (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + using assms(1) unfolding par_comp_prot_def by metis + { fix l1 l2::'lbl assume **: "l1 \ l2" + hence ***: "GSMP_disjoint (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (\\ \ \

. trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + using * by auto + have "GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" + using GSMP_disjoint_subset[OF ***] assms(2) by auto + } hence "\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 \) (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 \) Sec" by metis + thus ?thesis using assms unfolding par_comp_prot_def par_comp_def by metis +qed + +lemma typing_cond_prot_impl_typing_cond: + assumes "typing_cond_prot \

" "\ \ \

" + shows "typing_cond (unlabel \)" +proof - + have 1: "wf\<^sub>s\<^sub>t {} (unlabel \)" "fv\<^sub>l\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>t \ = {}" + using assms unfolding typing_cond_prot_def wf\<^sub>l\<^sub>s\<^sub>t\<^sub>s_def by auto + + have "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>l\<^sub>s\<^sub>t ` \

))" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>l\<^sub>s\<^sub>t ` \

))" + "trms\<^sub>l\<^sub>s\<^sub>t \ \ \(trms\<^sub>l\<^sub>s\<^sub>t ` \

)" + "SMP (trms\<^sub>l\<^sub>s\<^sub>t \) - Var`\ \ SMP (\(trms\<^sub>l\<^sub>s\<^sub>t ` \

)) - Var`\" + using assms SMP_mono[of "trms\<^sub>l\<^sub>s\<^sub>t \" "\(trms\<^sub>l\<^sub>s\<^sub>t ` \

)"] + unfolding typing_cond_prot_def + by (metis, metis, auto) + hence 2: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>t \)" and 3: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>t \)" + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (meson subsetD)+ + + have 4: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel \)" using assms unfolding typing_cond_prot_def by auto + + have "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t (unlabel \) \ assignment_rhs\<^sub>s\<^sub>t (unlabel \)) \ + subterms\<^sub>s\<^sub>e\<^sub>t (\(ik\<^sub>s\<^sub>t ` unlabel ` \

) \ \(assignment_rhs\<^sub>s\<^sub>t ` unlabel ` \

))" + using assms(2) by auto + hence 5: "Ana_invar_subst (ik\<^sub>s\<^sub>t (unlabel \) \ assignment_rhs\<^sub>s\<^sub>t (unlabel \))" + using assms SMP_mono unfolding typing_cond_prot_def Ana_invar_subst_def by (meson subsetD) + + show ?thesis using 1 2 3 4 5 unfolding typing_cond_def tfr\<^sub>s\<^sub>t_def by blast +qed + + +subsubsection \Theorem: Parallel Compositionality for Labeled Protocols\ +definition component_prot where + "component_prot n P \ (\l \ P. \s \ set l. is_LabelN n s \ is_LabelS s)" + +definition composed_prot where + "composed_prot \

\<^sub>i \ {\. \n. proj n \ \ \

\<^sub>i n}" + +definition component_secure_prot where + "component_secure_prot n P Sec attack \ (\\ \ P. suffix [(ln n, Send (Fun attack []))] \ \ + (\\\<^sub>\. (interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)) \ + \(\\<^sub>\ \ \proj_unl n \\) \ + (\\'. prefix \' \ \ + (\t \ Sec-declassified\<^sub>l\<^sub>s\<^sub>t \' \\<^sub>\. \(\\<^sub>\ \ \proj_unl n \'@[Send t]\)))))" + +definition component_leaks where + "component_leaks n \ Sec \ (\\' \\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ + prefix \' \ \ (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \' \\<^sub>\. (\\<^sub>\ \ \proj_unl n \'@[Send t]\)))" + +definition unsat where + "unsat \ \ (\\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \(\ \ \unlabel \\))" + +theorem par_comp_constr_prot: + assumes P: "P = composed_prot Pi" "par_comp_prot P Sec" "\n. component_prot n (Pi n)" + and left_secure: "component_secure_prot n (Pi n) Sec attack" + shows "\\ \ P. suffix [(ln n, Send (Fun attack []))] \ \ + unsat \ \ (\m. n \ m \ component_leaks m \ Sec)" +proof - + { fix \ \' assume \: "\ = \'@[(ln n, Send (Fun attack []))]" "\ \ P" + let ?P = "\\' \\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ prefix \' \ \ + (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \' \\<^sub>\. \m. n \ m \ (\\<^sub>\ \ \proj_unl m \'@[Send t]\))" + have tcp: "typing_cond_prot P" using P(2) unfolding par_comp_prot_def by simp + have par_comp: "par_comp \ Sec" "typing_cond (unlabel \)" + using par_comp_prot_impl_par_comp[OF P(2) \(2)] + typing_cond_prot_impl_typing_cond[OF tcp \(2)] + by metis+ + + have "unlabel (proj n \) = proj_unl n \" "proj_unl n \ = proj_unl n (proj n \)" + "\A. A \ Pi n \ proj n A = A" + "proj n \ = (proj n \')@[(ln n, Send (Fun attack []))]" + using P(1,3) \ by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def) + moreover have "proj n \ \ Pi n" + using P(1) \ unfolding composed_prot_def by blast + moreover { + fix A assume "prefix A \" + hence *: "prefix (proj n A) (proj n \)" unfolding proj_def prefix_def by force + hence "proj_unl n A = proj_unl n (proj n A)" + "\I. declassified\<^sub>l\<^sub>s\<^sub>t A I = declassified\<^sub>l\<^sub>s\<^sub>t (proj n A) I" + unfolding proj_def declassified\<^sub>l\<^sub>s\<^sub>t_def by auto + hence "\B. prefix B (proj n \) \ proj_unl n A = proj_unl n B \ + (\I. declassified\<^sub>l\<^sub>s\<^sub>t A I = declassified\<^sub>l\<^sub>s\<^sub>t B I)" + using * by metis + + } + ultimately have *: + "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ + \(\\<^sub>\ \ \proj_unl n \\) \ (\\'. prefix \' \ \ + (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \' \\<^sub>\. \(\\<^sub>\ \ \proj_unl n \'@[Send t]\)))" + using left_secure unfolding component_secure_prot_def composed_prot_def suffix_def by metis + { fix \ assume \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\ \ \unlabel \\" + obtain \\<^sub>\ where \\<^sub>\: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + "\\'. prefix \' \ \ (strand_leaks\<^sub>l\<^sub>s\<^sub>t \' Sec \\<^sub>\)" + using par_comp_constr[OF par_comp \(2,1)] * by moura + hence "\\'. prefix \' \ \ (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \' \\<^sub>\. \m. + n \ m \ (\\<^sub>\ \ \proj_unl m \'@[Send t]\))" + using \\<^sub>\(4) * unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>t_def by metis + hence ?P using \\<^sub>\(1,2,3) by auto + } hence "unsat \ \ (\m. n \ m \ component_leaks m \ Sec)" + by (metis unsat_def component_leaks_def) + } thus ?thesis unfolding suffix_def by metis +qed + +end + + +subsection \Automated GSMP Disjointness\ +locale labeled_typed_model' = typed_model' arity public Ana \ + + labeled_typed_model arity public Ana \ label_witness1 label_witness2 + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,(('fun,'atom::finite) term_type \ nat)) term + \ (('fun,(('fun,'atom) term_type \ nat)) term list + \ ('fun,(('fun,'atom) term_type \ nat)) term list)" + and \::"('fun,(('fun,'atom) term_type \ nat)) term \ ('fun,'atom) term_type" + and label_witness1 label_witness2::'lbl +begin + +lemma GSMP_disjointI: + fixes A' A B B'::"('fun, ('fun, 'atom) term \ nat) term list" + defines "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and "\ \ var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (set A)))" + assumes A'_wf: "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) A'" + and B'_wf: "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) B'" + and A_inst: "has_all_wt_instances_of \ (set A') (set A)" + and B_inst: "has_all_wt_instances_of \ (set B') (set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \))" + and A_SMP_repr: "finite_SMP_representation arity Ana \ A" + and B_SMP_repr: "finite_SMP_representation arity Ana \ (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + and AB_trms_disj: + "\t \ set A. \s \ set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \). \ t = \ s \ mgu t s \ None \ + (intruder_synth' public arity {} t \ intruder_synth' public arity {} s) \ + ((\u \ Sec. is_wt_instance_of_cond \ t u) \ (\u \ Sec. is_wt_instance_of_cond \ s u))" + and Sec_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s Sec" + shows "GSMP_disjoint (set A') (set B') ((f Sec) - {m. {} \\<^sub>c m})" +proof - + have A_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set A)" and B_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \))" + and A'_wf': "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set A')" and B'_wf': "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set B')" + using finite_SMP_representationD[OF A_SMP_repr] + finite_SMP_representationD[OF B_SMP_repr] + A'_wf B'_wf + unfolding wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric] wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric] list_all_iff by blast+ + + have AB_fv_disj: "fv\<^sub>s\<^sub>e\<^sub>t (set A) \ fv\<^sub>s\<^sub>e\<^sub>t (set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)) = {}" + using var_rename_fv_set_disjoint'[of "set A" "set B", unfolded \_def[symmetric]] by simp + + have "GSMP_disjoint (set A) (set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)) ((f Sec) - {m. {} \\<^sub>c m})" + using ground_SMP_disjointI[OF AB_fv_disj A_SMP_repr B_SMP_repr Sec_wf AB_trms_disj] + unfolding GSMP_def GSMP_disjoint_def f_def by blast + moreover have "SMP (set A') \ SMP (set A)" "SMP (set B') \ SMP (set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \))" + using SMP_I'[OF A'_wf' A_wf A_inst] SMP_SMP_subset[of "set A'" "set A"] + SMP_I'[OF B'_wf' B_wf B_inst] SMP_SMP_subset[of "set B'" "set (B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)"] + by blast+ + ultimately show ?thesis unfolding GSMP_def GSMP_disjoint_def by auto +qed + +end + +end diff --git a/Stateful_Protocol_Composition_and_Typing/ROOT b/Stateful_Protocol_Composition_and_Typing/ROOT new file mode 100644 index 0000000..a0c0de0 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/ROOT @@ -0,0 +1,13 @@ +chapter AFP + +session "Stateful_Protocol_Composition_and_Typing-devel" (AFP) = "First_Order_Terms" + + options [timeout = 2400] + directories + "examples" + theories + "Stateful_Compositionality" + "Examples" + document_files + "root.tex" + "root.bib" + diff --git a/Stateful_Protocol_Composition_and_Typing/Stateful_Compositionality.thy b/Stateful_Protocol_Composition_and_Typing/Stateful_Compositionality.thy new file mode 100644 index 0000000..81cb5a5 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Stateful_Compositionality.thy @@ -0,0 +1,3086 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Stateful_Compositionality.thy + Author: Andreas Viktor Hess, DTU +*) + + +section \Stateful Protocol Compositionality\ + +theory Stateful_Compositionality +imports Stateful_Typing Parallel_Compositionality Labeled_Stateful_Strands +begin + +subsection \Small Lemmata\ +lemma (in typed_model) wt_subst_sstp_vars_type_subset: + fixes a::"('fun,'var) stateful_strand_step" + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "\t \ subst_range \. fv t = {} \ (\x. t = Var x)" + shows "\ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ \ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" (is ?A) + and "\ ` Var ` set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)) = \ ` Var ` set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" (is ?B) + and "\ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ \ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" (is ?C) +proof - + show ?A + proof + fix \ assume \: "\ \ \ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + then obtain x where x: "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" "\ (Var x) = \" by moura + + show "\ \ \ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" + proof (cases "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a") + case False + hence "\y \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. \ y = Var x" + proof (cases a) + case (NegChecks X F G) + hence *: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + "x \ set X" + using fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck(1)[of X "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \" "G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \"] + fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck(1)[of X F G] False x(1) + by fastforce+ + + obtain y where y: "y \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" "x \ fv (rm_vars (set X) \ y)" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var[of _ _ "rm_vars (set X) \"] + fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var[of _ _ "rm_vars (set X) \"] + *(1) + by blast + + have "fv (rm_vars (set X) \ z) = {} \ (\u. rm_vars (set X) \ z = Var u)" for z + using assms(2) rm_vars_img_subset[of "set X" \] by blast + hence "rm_vars (set X) \ y = Var x" using y(2) by fastforce + hence "\y \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. rm_vars (set X) \ y = Var x" + using y fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck(1)[of X F G] NegChecks *(2) by fastforce + thus ?thesis by (metis (full_types) *(2) term.inject(1)) + qed (use assms(2) x(1) subst_apply_img_var'[of x _ \] in fastforce)+ + then obtain y where y: "y \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" "\ y = Var x" by moura + hence "\ (Var y) = \" using x(2) assms(1) by (simp add: wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + thus ?thesis using y(1) by auto + qed (use x in auto) + qed + + show ?B by (metis bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst) + + show ?C + proof + fix \ assume \: "\ \ \ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + then obtain x where x: "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" "\ (Var x) = \" by moura + + show "\ \ \ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" + proof (cases "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a") + case False + hence "\y \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. \ y = Var x" + proof (cases a) + case (NegChecks X F G) + hence *: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + "x \ set X" + using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[of X "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \" "G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \"] + vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[of X F G] False x(1) + by (fastforce, blast) + + obtain y where y: "y \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" "x \ fv (rm_vars (set X) \ y)" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var[of _ _ "rm_vars (set X) \"] + fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var[of _ _ "rm_vars (set X) \"] + *(1) + by blast + + have "fv (rm_vars (set X) \ z) = {} \ (\u. rm_vars (set X) \ z = Var u)" for z + using assms(2) rm_vars_img_subset[of "set X" \] by blast + hence "rm_vars (set X) \ y = Var x" using y(2) by fastforce + hence "\y \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a. rm_vars (set X) \ y = Var x" + using y vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[of X F G] NegChecks by blast + thus ?thesis by (metis (full_types) *(2) term.inject(1)) + qed (use assms(2) x(1) subst_apply_img_var'[of x _ \] in fastforce)+ + then obtain y where y: "y \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" "\ y = Var x" by moura + hence "\ (Var y) = \" using x(2) assms(1) by (simp add: wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + thus ?thesis using y(1) by auto + qed (use x in auto) + qed +qed + +lemma (in typed_model) wt_subst_lsst_vars_type_subset: + fixes A::"('fun,'var,'a) labeled_stateful_strand" + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "\t \ subst_range \. fv t = {} \ (\x. t = Var x)" + shows "\ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \ \ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" (is ?A) + and "\ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = \ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" (is ?B) + and "\ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) \ \ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" (is ?C) +proof - + have "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)) \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b) \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand" + using that unlabel_Cons(1)[of l b A] unlabel_subst[of "a#A" \] + subst_lsst_cons[of a A \] subst_sst_cons[of b "unlabel A" \] + subst_apply_labeled_stateful_strand_step.simps(1)[of l b \] + vars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l b A] vars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l "b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \"] + fv\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l b A] fv\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l "b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \"] + bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l b A] bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_Cons[of l "b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \"] + by simp_all + hence *: "\ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = + \ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ \ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "\ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = \ ` Var ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ \ ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + "\ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = + \ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ \ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "\ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = \ ` Var ` fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \ \ ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + "\ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = + \ ` Var ` set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)) \ \ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + "\ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = \ ` Var ` set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b) \ \ ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand" + using that by fast+ + + have "?A \ ?B \ ?C" + proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + + show ?case + using Cons.IH wt_subst_sstp_vars_type_subset[OF assms, of b] *[OF a, of A] + by (metis Un_mono) + qed simp + thus ?A ?B ?C by metis+ +qed + +lemma (in stateful_typed_model) fv_pair_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subset: + assumes "d \ set D" + shows "fv (pair (snd d)) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" +using assms unfolding pair_def by (induct D) (auto simp add: unlabel_def) + +lemma (in stateful_typed_model) labeled_sat_ineq_lift: + assumes "\M; map (\d. \X\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\dbproj i D. d \ set Di]\\<^sub>d \" + (is "?R1 D") + and "\(j,p) \ {(i,t,s)} \ set D \ set Di. \(k,q) \ {(i,t,s)} \ set D \ set Di. + (\\. Unifier \ (pair p) (pair q)) \ j = k" (is "?R2 D") + shows "\M; map (\d. \X\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\D. d \ set Di]\\<^sub>d \" +using assms +proof (induction D) + case (Cons dl D) + obtain d l where dl: "dl = (l,d)" by (metis surj_pair) + + have 1: "?R1 D" + proof (cases "i = l") + case True thus ?thesis using Cons.prems(1) dl by (cases "dl \ set Di") auto + next + case False thus ?thesis using Cons.prems(1) dl by auto + qed + + have "set D \ set (dl#D)" by auto + hence 2: "?R2 D" using Cons.prems(2) by blast + + have "i \ l \ dl \ set Di \ \M; [\X\\\: [(pair (t,s), pair (snd dl))]\\<^sub>s\<^sub>t]\\<^sub>d \" + using Cons.prems(1) dl by (auto simp add: ineq_model_def) + moreover have "\\. Unifier \ (pair (t,s)) (pair d) \ i = l" + using Cons.prems(2) dl by force + ultimately have 3: "dl \ set Di \ \M; [\X\\\: [(pair (t,s), pair (snd dl))]\\<^sub>s\<^sub>t]\\<^sub>d \" + using strand_sem_not_unif_is_sat_ineq[of "pair (t,s)" "pair d"] dl by fastforce + + show ?case using Cons.IH[OF 1 2] 3 dl by auto +qed simp + +lemma (in stateful_typed_model) labeled_sat_ineq_dbproj: + assumes "\M; map (\d. \X\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\D. d \ set Di]\\<^sub>d \" + (is "?P D") + shows "\M; map (\d. \X\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\dbproj i D. d \ set Di]\\<^sub>d \" + (is "?Q D") +using assms +proof (induction D) + case (Cons di D) + obtain d j where di: "di = (j,d)" by (metis surj_pair) + + have "?P D" using Cons.prems by (cases "di \ set Di") auto + hence IH: "?Q D" by (metis Cons.IH) + + show ?case using di IH + proof (cases "i = j \ di \ set Di") + case True + have 1: "\M; [\X\\\: [(pair (t,s), pair (snd di))]\\<^sub>s\<^sub>t]\\<^sub>d \" + using Cons.prems True by auto + have 2: "dbproj i (di#D) = di#dbproj i D" using True dbproj_Cons(1) di by auto + show ?thesis using 1 2 IH by auto + qed auto +qed simp + +lemma (in stateful_typed_model) labeled_sat_ineq_dbproj_sem_equiv: + assumes "\(j,p) \ ((\(t, s). (i, t, s)) ` set F') \ set D. + \(k,q) \ ((\(t, s). (i, t, s)) ` set F') \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" + and "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (map snd D) \ set X = {}" + shows "\M; map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))\\<^sub>d \ \ + \M; map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))\\<^sub>d \" +proof - + let ?A = "set (map snd D) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + let ?B = "set (map snd (dbproj i D)) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + let ?C = "set (map snd D) - set (map snd (dbproj i D))" + let ?F = "(\(t, s). (i, t, s)) ` set F'" + let ?P = "\\. subst_domain \ = set X \ ground (subst_range \)" + + have 1: "\(t, t') \ set (map snd D). (fv t \ fv t') \ set X = {}" + "\(t, t') \ set (map snd (dbproj i D)). (fv t \ fv t') \ set X = {}" + using assms(2) dbproj_subset[of i D] unfolding unlabel_def by force+ + + have 2: "?B \ ?A" by auto + + have 3: "\Unifier \ (pair f) (pair d)" + when f: "f \ set F'" and d: "d \ set (map snd D) - set (map snd (dbproj i D))" + for f d and \::"('fun,'var) subst" + proof - + obtain k where k: "(k,d) \ set D - set (dbproj i D)" + using d by force + + have "(i,f) \ ((\(t, s). (i, t, s)) ` set F') \ set D" + "(k,d) \ ((\(t, s). (i, t, s)) ` set F') \ set D" + using f k by auto + hence "i = k" when "Unifier \ (pair f) (pair d)" for \ + using assms(1) that by blast + moreover have "k \ i" using k d by simp + ultimately show ?thesis by metis + qed + + have "f \\<^sub>p \ \ d \\<^sub>p \" + when "f \ set F'" "d \ ?C" for f d and \::"('fun,'var) subst" + by (metis fun_pair_eq_subst 3[OF that]) + hence "f \\<^sub>p (\ \\<^sub>s \) \ ?C \\<^sub>p\<^sub>s\<^sub>e\<^sub>t (\ \\<^sub>s \)" + when "f \ set F'" for f and \::"('fun,'var) subst" + using that by blast + moreover have "?C \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ = ?C \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + when "?P \" for \ + using assms(2) that pairs_substI[of \ "(set (map snd D) - set (map snd (dbproj i D)))"] + by blast + ultimately have 4: "f \\<^sub>p (\ \\<^sub>s \) \ ?C \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + when "f \ set F'" "?P \" for f and \::"('fun,'var) subst" + by (metis that subst_pairs_compose) + + { fix f and \::"('fun,'var) subst" + assume "f \ set F'" "?P \" + hence "f \\<^sub>p (\ \\<^sub>s \) \ ?C \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" by (metis 4) + hence "f \\<^sub>p (\ \\<^sub>s \) \ ?A - ?B" by force + } hence 5: "\f\set F'. \\. ?P \ \ f \\<^sub>p (\ \\<^sub>s \) \ ?A - ?B" by metis + + show ?thesis + using negchecks_model_db_subset[OF 2] + negchecks_model_db_supset[OF 2 5] + tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_sem_equiv[OF 1(1)] + tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_sem_equiv[OF 1(2)] + tr_NegChecks_constr_iff(1) + strand_sem_eq_defs(2) + by (metis (no_types, lifting)) +qed + +lemma (in stateful_typed_model) labeled_sat_eqs_list_all: + assumes "\(j, p) \ {(i,t,s)} \ set D. \(k,q) \ {(i,t,s)} \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" (is "?P D") + and "\M; map (\d. \ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) D\\<^sub>d \" (is "?Q D") + shows "list_all (\d. fst d = i) D" +using assms +proof (induction D rule: List.rev_induct) + case (snoc di D) + obtain d j where di: "di = (j,d)" by (metis surj_pair) + have "pair (t,s) \ \ = pair d \ \" using di snoc.prems(2) by auto + hence "\\. Unifier \ (pair (t,s)) (pair d)" by auto + hence 1: "i = j" using snoc.prems(1) di by fastforce + + have "set D \ set (D@[di])" by auto + hence 2: "?P D" using snoc.prems(1) by blast + + have 3: "?Q D" using snoc.prems(2) by auto + + show ?case using di 1 snoc.IH[OF 2 3] by simp +qed simp + +lemma (in stateful_typed_model) labeled_sat_eqs_subseqs: + assumes "Di \ set (subseqs D)" + and "\(j, p) \ {(i,t,s)} \ set D. \(k, q) \ {(i,t,s)} \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" (is "?P D") + and "\M; map (\d. \ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) Di\\<^sub>d \" + shows "Di \ set (subseqs (dbproj i D))" +proof - + have "set Di \ set D" by (rule subseqs_subset[OF assms(1)]) + hence "?P Di" using assms(2) by blast + thus ?thesis using labeled_sat_eqs_list_all[OF _ assms(3)] subseqs_mem_dbproj[OF assms(1)] by simp +qed + +lemma (in stateful_typed_model) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + assumes "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel S)" + shows "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S))" +using assms +proof (induction S) + case (Cons a S) + have prems: "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a)" "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel S)" + using Cons.prems unlabel_Cons(2)[of a S] by simp_all + hence IH: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S))" by (metis Cons.IH) + + obtain l b where a: "a = (l,b)" by (metis surj_pair) + with Cons show ?case + proof (cases b) + case (Equality c t t') + hence "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#S) = a#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S" by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_Cons(3) a) + thus ?thesis using a IH prems by fastforce + next + case (NegChecks X F G) + hence "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#S) = a#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S" by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_Cons(7) a) + thus ?thesis using a IH prems by fastforce + qed auto +qed simp + +lemma (in stateful_typed_model) setops\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq: + "setops\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)) = setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" +proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + thus ?case using Cons.IH by (cases b) (simp_all add: setops\<^sub>s\<^sub>s\<^sub>t_def) +qed simp + + +subsection \Locale Setup and Definitions\ +locale labeled_stateful_typed_model = + stateful_typed_model arity public Ana \ Pair ++ labeled_typed_model arity public Ana \ label_witness1 label_witness2 + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,'var) term \ (('fun,'var) term list \ ('fun,'var) term list)" + and \::"('fun,'var) term \ ('fun,'atom::finite) term_type" + and Pair::"'fun" + and label_witness1::"'lbl" + and label_witness2::"'lbl" +begin + +definition lpair where + "lpair lp \ case lp of (i,p) \ (i,pair p)" + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_pair_image[simp]: + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,send\t\)) = {}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,receive\t\)) = {}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,\ac: t \ t'\)) = {}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,insert\t,s\)) = {(i, pair (t,s))}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,delete\t,s\)) = {(i, pair (t,s))}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,\ac: t \ s\)) = {(i, pair (t,s))}" + "lpair ` (setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (i,\X\\\: F \\: F'\)) = ((\(t,s). (i, pair (t,s))) ` set F')" +unfolding lpair_def by force+ + +definition par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t where + "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\::('fun,'var,'lbl) labeled_stateful_strand) (Secrets::('fun,'var) terms) \ + (\l1 l2. l1 \ l2 \ + GSMP_disjoint (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Secrets) \ + ground Secrets \ (\s \ Secrets. \s' \ subterms s. {} \\<^sub>c s' \ s' \ Secrets) \ + (\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. + (\\. Unifier \ (pair p) (pair q)) \ i = j)" + +definition declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t where + "declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ \ {t. \\, receive\t\\ \ set \} \\<^sub>s\<^sub>e\<^sub>t \" + +definition strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t ("_ leaks _ under _") where + "(\::('fun,'var,'lbl) labeled_stateful_strand) leaks Secrets under \ \ + (\t \ Secrets - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \. \n. \ \\<^sub>s (proj_unl n \@[send\t\]))" + +definition typing_cond\<^sub>s\<^sub>s\<^sub>t where + "typing_cond\<^sub>s\<^sub>s\<^sub>t \ \ wf\<^sub>s\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t \) \ tfr\<^sub>s\<^sub>s\<^sub>t \" + +type_synonym ('a,'b,'c) labeleddbstate = "('c strand_label \ (('a,'b) term \ ('a,'b) term)) set" +type_synonym ('a,'b,'c) labeleddbstatelist = "('c strand_label \ (('a,'b) term \ ('a,'b) term)) list" + +text \ + For proving the compositionality theorem for stateful constraints the idea is to first define a + variant of the reduction technique that was used to establish the stateful typing result. This + variant performs database-state projections, and it allows us to reduce the compositionality + problem for stateful constraints to ordinary constraints. +\ +fun tr\<^sub>p\<^sub>c:: + "('fun,'var,'lbl) labeled_stateful_strand \ ('fun,'var,'lbl) labeleddbstatelist + \ ('fun,'var,'lbl) labeled_strand list" +where + "tr\<^sub>p\<^sub>c [] D = [[]]" +| "tr\<^sub>p\<^sub>c ((i,send\t\)#A) D = map ((#) (i,send\t\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>c A D)" +| "tr\<^sub>p\<^sub>c ((i,receive\t\)#A) D = map ((#) (i,receive\t\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>c A D)" +| "tr\<^sub>p\<^sub>c ((i,\ac: t \ t'\)#A) D = map ((#) (i,\ac: t \ t'\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>c A D)" +| "tr\<^sub>p\<^sub>c ((i,insert\t,s\)#A) D = tr\<^sub>p\<^sub>c A (List.insert (i,(t,s)) D)" +| "tr\<^sub>p\<^sub>c ((i,delete\t,s\)#A) D = ( + concat (map (\Di. map (\B. (map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) + [d\dbproj i D. d \ set Di])@B) + (tr\<^sub>p\<^sub>c A [d\D. d \ set Di])) + (subseqs (dbproj i D))))" +| "tr\<^sub>p\<^sub>c ((i,\ac: t \ s\)#A) D = + concat (map (\B. map (\d. (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#B) (dbproj i D)) (tr\<^sub>p\<^sub>c A D))" +| "tr\<^sub>p\<^sub>c ((i,\X\\\: F \\: F' \)#A) D = + map ((@) (map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D))))) (tr\<^sub>p\<^sub>c A D)" + + +subsection \Small Lemmata\ +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_nil: + assumes "ground Sec" "\s \ Sec. \s'\subterms s. {} \\<^sub>c s' \ s' \ Sec" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] Sec" +using assms unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subset: + assumes A: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A Sec" + and BA: "set B \ set A" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t B Sec" +proof - + let ?L = "\n A. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl n A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl n A)" + + have "?L n B \ ?L n A" for n + using trms\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_set_mono(2)[OF BA]] setops\<^sub>s\<^sub>s\<^sub>t_mono[OF proj_set_mono(2)[OF BA]] + by blast + hence "GSMP_disjoint (?L m B) (?L n B) Sec" when nm: "m \ n" for n m::'lbl + using GSMP_disjoint_subset[of "?L m A" "?L n A" Sec "?L m B" "?L n B"] A nm + unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp + thus "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t B Sec" + using A setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_mono[OF BA] + unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by blast +qed + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_split: + assumes "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) Sec" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A Sec" "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t B Sec" +using par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subset[OF assms] by simp_all + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj: + assumes "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A Sec" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) Sec" +using par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subset[OF assms] by simp + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t: + assumes A: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A S" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) S" +proof (unfold par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def case_prod_unfold; intro conjI) + show "ground S" "\s \ S. \s' \ subterms s. {} \\<^sub>c s' \ s' \ S" + using A unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by fast+ + + let ?M = "\l B. (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l B) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l B))" + let ?P = "\B. \l1 l2. l1 \ l2 \ GSMP_disjoint (?M l1 B) (?M l2 B) S" + let ?Q = "\B. \p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. \q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. + (\\. Unifier \ (pair (snd p)) (pair (snd q))) \ fst p = fst q" + + have "?P A" "?Q A" using A unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def case_prod_unfold by blast+ + thus "?P (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" "?Q (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + by (metis setops\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq proj_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t, + metis setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq) +qed + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst: + assumes A: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A S" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "subst_domain \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = {}" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) S" +proof (unfold par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def case_prod_unfold; intro conjI) + show "ground S" "\s \ S. \s' \ subterms s. {} \\<^sub>c s' \ s' \ S" + using A unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by fast+ + + let ?N = "\l B. trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l B) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l B)" + define M where "M \ \l (B::('fun,'var,'lbl) labeled_stateful_strand). ?N l B" + let ?P = "\p q. \\. Unifier \ (pair (snd p)) (pair (snd q))" + let ?Q = "\B. \p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. \q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. ?P p q \ fst p = fst q" + let ?R = "\B. \l1 l2. l1 \ l2 \ GSMP_disjoint (?N l1 B) (?N l2 B) S" + + have d: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l A) \ subst_domain \ = {}" for l + using \(3) unfolding proj_def bvars\<^sub>s\<^sub>s\<^sub>t_def unlabel_def by auto + + have "GSMP_disjoint (M l1 A) (M l2 A) S" when l: "l1 \ l2" for l1 l2 + using l A unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def M_def by presburger + moreover have "M l (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) = (M l A) \\<^sub>s\<^sub>e\<^sub>t \" for l + using fun_pair_subst_set[of \ "setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l A)", symmetric] + trms\<^sub>s\<^sub>s\<^sub>t_subst[OF d[of l]] setops\<^sub>s\<^sub>s\<^sub>t_subst[OF d[of l]] proj_subst[of l A \] + unfolding M_def unlabel_subst by auto + ultimately have "GSMP_disjoint (M l1 (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) (M l2 (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)) S" when l: "l1 \ l2" for l1 l2 + using l GSMP_wt_subst_subset[OF _ \(1,2), of _ "M l1 A"] + GSMP_wt_subst_subset[OF _ \(1,2), of _ "M l2 A"] + unfolding GSMP_disjoint_def by fastforce + thus "?R (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" unfolding M_def by blast + + have "?Q A" using A unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by force + thus "?Q (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" using \(3) + proof (induction A) + case (Cons a A) + obtain l b where a: "a = (l,b)" by (metis surj_pair) + + have 0: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd a)) \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def unlabel_def by simp + + have "?Q A" "subst_domain \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = {}" + using Cons.prems 0 unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + hence IH: "?Q (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" using Cons.IH unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by blast + + have 1: "fst p = fst q" + when p: "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + and q: "q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + and pq: "?P p q" + for p q + using a p q pq by (cases b) auto + + have 2: "fst p = fst q" + when p: "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + and q: "q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + and pq: "?P p q" + for p q + proof - + obtain p' X where p': + "p' \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "fst p = fst p'" + "X \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A)" "snd p = snd p' \\<^sub>p rm_vars X \" + using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_subst[OF p] 0 by blast + + obtain q' Y where q': + "q' \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" "fst q = fst q'" + "Y \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A)" "snd q = snd q' \\<^sub>p rm_vars Y \" + using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_in_subst[OF q] 0 by blast + + have "pair (snd p) = pair (snd p') \ \" + "pair (snd q) = pair (snd q') \ \" + using fun_pair_subst[of "snd p'" "rm_vars X \"] fun_pair_subst[of "snd q'" "rm_vars Y \"] + p'(3,4) q'(3,4) Cons.prems(2) rm_vars_apply'[of \ X] rm_vars_apply'[of \ Y] + by fastforce+ + hence "\\. Unifier \ (pair (snd p')) (pair (snd q'))" + using pq Unifier_comp' by metis + thus ?thesis using Cons.prems p'(1,2) q'(1,2) by simp + qed + + show ?case by (metis 1 2 IH Un_iff setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_cons subst_lsst_cons) + qed simp +qed + +lemma wf_pair_negchecks_map': + assumes "wf\<^sub>s\<^sub>t X (unlabel A)" + shows "wf\<^sub>s\<^sub>t X (unlabel (map (\G. (i,\Y\\\: (F@G)\\<^sub>s\<^sub>t)) M@A))" +using assms by (induct M) auto + +lemma wf_pair_eqs_ineqs_map': + fixes A::"('fun,'var,'lbl) labeled_strand" + assumes "wf\<^sub>s\<^sub>t X (unlabel A)" + "Di \ set (subseqs (dbproj i D))" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" + shows "wf\<^sub>s\<^sub>t X (unlabel ( + (map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d \ set Di])@A))" +proof - + let ?f = "[d\dbproj i D. d \ set Di]" + define c1 where c1: "c1 = map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + define c2 where c2: "c2 = map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) ?f" + define c3 where c3: "c3 = map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) (unlabel Di)" + define c4 where c4: "c4 = map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) (unlabel ?f)" + have ci_eqs: "c3 = unlabel c1" "c4 = unlabel c2" unfolding c1 c2 c3 c4 unlabel_def by auto + have 1: "wf\<^sub>s\<^sub>t X (unlabel (c2@A))" + using wf_fun_pair_ineqs_map[OF assms(1)] ci_eqs(2) unlabel_append[of c2 A] c4 + by metis + have 2: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel Di) \ X" + using assms(3) subseqs_set_subset(1)[OF assms(2)] + unfolding unlabel_def + by fastforce + { fix B::"('fun,'var) strand" assume "wf\<^sub>s\<^sub>t X B" + hence "wf\<^sub>s\<^sub>t X (unlabel c1@B)" using 2 unfolding c1 unlabel_def by (induct Di) auto + } thus ?thesis using 1 unfolding c1 c2 unlabel_def by simp +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_setops\<^sub>s\<^sub>s\<^sub>t_wt_instance_ex: + defines "M \ \A. trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + assumes B: "\b \ set B. \a \ set A. \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\t \ M B. \s \ M A. \\. t = s \ \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +proof + let ?P = "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + + fix t assume "t \ M B" + then obtain b where b: "b \ set B" "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd b) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd b)" + unfolding M_def unfolding unlabel_def trms\<^sub>s\<^sub>s\<^sub>t_def setops\<^sub>s\<^sub>s\<^sub>t_def by auto + then obtain a \ where a: "a \ set A" "b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using B by meson + + note \' = wt_subst_rm_vars[OF \(1)] wf_trms_subst_rm_vars'[OF \(2)] + + have "t \ M (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + using b(2) a + unfolding M_def subst_apply_labeled_stateful_strand_def unlabel_def trms\<^sub>s\<^sub>s\<^sub>t_def setops\<^sub>s\<^sub>s\<^sub>t_def + by auto + moreover have "\s \ M A. \\. t = s \ \ \ ?P \" when "t \ trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst'[OF that] \' unfolding M_def by blast + moreover have "\s \ M A. \\. t = s \ \ \ ?P \" when t: "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A \\<^sub>s\<^sub>s\<^sub>t \)" + proof - + obtain p where p: "p \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel A \\<^sub>s\<^sub>s\<^sub>t \)" "t = pair p" using t by blast + then obtain q X where q: "q \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "p = q \\<^sub>p rm_vars (set X) \" + using setops\<^sub>s\<^sub>s\<^sub>t_subst'[OF p(1)] by blast + hence "t = pair q \ rm_vars (set X) \" + using fun_pair_subst[of q "rm_vars (set X) \"] p(2) by presburger + thus ?thesis using \'[of "set X"] q(1) unfolding M_def by blast + qed + ultimately show "\s \ M A. \\. t = s \ \ \ ?P \" unfolding M_def unlabel_subst by fast +qed + +lemma setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_wt_instance_ex: + assumes B: "\b \ set B. \a \ set A. \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. \q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \\. + fst p = fst q \ snd p = snd q \\<^sub>p \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +proof + let ?P = "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + + fix p assume "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" + then obtain b where b: "b \ set B" "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b" unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by blast + then obtain a \ where a: "a \ set A" "b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using B by meson + hence p: "p \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + using b(2) unfolding setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def by auto + + obtain X q where q: + "q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "fst p = fst q" "snd p = snd q \\<^sub>p rm_vars X \" + using setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_subst[OF p] by blast + + show "\q \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \\. fst p = fst q \ snd p = snd q \\<^sub>p \ \ ?P \" + using q wt_subst_rm_vars[OF \(1)] wf_trms_subst_rm_vars'[OF \(2)] by blast +qed + + +subsection \Lemmata: Properties of the Constraint Translation Function\ +lemma tr_par_labeled_rcv_iff: + "B \ set (tr\<^sub>p\<^sub>c A D) \ (i, receive\t\\<^sub>s\<^sub>t) \ set B \ (i, receive\t\) \ set A" +by (induct A D arbitrary: B rule: tr\<^sub>p\<^sub>c.induct) auto + +lemma tr_par_declassified_eq: + "B \ set (tr\<^sub>p\<^sub>c A D) \ declassified\<^sub>l\<^sub>s\<^sub>t B I = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I" +using tr_par_labeled_rcv_iff unfolding declassified\<^sub>l\<^sub>s\<^sub>t_def declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma tr_par_ik_eq: + assumes "B \ set (tr\<^sub>p\<^sub>c A D)" + shows "ik\<^sub>s\<^sub>t (unlabel B) = ik\<^sub>s\<^sub>s\<^sub>t (unlabel A)" +proof - + have "{t. \i. (i, receive\t\\<^sub>s\<^sub>t) \ set B} = {t. \i. (i, receive\t\) \ set A}" + using tr_par_labeled_rcv_iff[OF assms] by simp + moreover have + "\C. {t. \i. (i, receive\t\\<^sub>s\<^sub>t) \ set C} = {t. receive\t\\<^sub>s\<^sub>t \ set (unlabel C)}" + "\C. {t. \i. (i, receive\t\) \ set C} = {t. receive\t\ \ set (unlabel C)}" + unfolding unlabel_def by force+ + ultimately show ?thesis by (metis ik\<^sub>s\<^sub>s\<^sub>t_def ik\<^sub>s\<^sub>t_is_rcv_set) +qed + +lemma tr_par_deduct_iff: + assumes "B \ set (tr\<^sub>p\<^sub>c A D)" + shows "ik\<^sub>s\<^sub>t (unlabel B) \\<^sub>s\<^sub>e\<^sub>t I \ t \ ik\<^sub>s\<^sub>s\<^sub>t (unlabel A) \\<^sub>s\<^sub>e\<^sub>t I \ t" +using tr_par_ik_eq[OF assms] by metis + +lemma tr_par_vars_subset: + assumes "A' \ set (tr\<^sub>p\<^sub>c A D)" + shows "fv\<^sub>l\<^sub>s\<^sub>t A' \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" (is ?P) + and "bvars\<^sub>l\<^sub>s\<^sub>t A' \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A)" (is ?Q) +proof - + show ?P using assms + proof (induction "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct) + case (ConsIn A' D ac t s AA A A') + then obtain i B where iB: "A = (i,\ac: t \ s\)#B" "AA = unlabel B" + unfolding unlabel_def by moura + then obtain A'' d where *: + "d \ set (dbproj i D)" + "A' = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#A''" + "A'' \ set (tr\<^sub>p\<^sub>c B D)" + using ConsIn.prems(1) by moura + hence "fv\<^sub>l\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel B) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + "fv (pair (snd d)) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + apply (metis ConsIn.hyps(1)[OF iB(2)]) + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_mono[OF dbproj_subset[of i D]] + fv_pair_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subset[OF *(1)] + by blast + thus ?case using * iB unfolding pair_def by auto + next + case (ConsDel A' D t s AA A A') + then obtain i B where iB: "A = (i,delete\t,s\)#B" "AA = unlabel B" + unfolding unlabel_def by moura + + define fltD1 where "fltD1 = (\Di. filter (\d. d \ set Di) D)" + define fltD2 where "fltD2 = (\Di. filter (\d. d \ set Di) (dbproj i D))" + define constr where "constr = + (\Di. (map (\d. (i, \check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i, \[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) (fltD2 Di)))" + + from iB obtain A'' Di where *: + "Di \ set (subseqs (dbproj i D))" "A' = (constr Di)@A''" "A'' \ set (tr\<^sub>p\<^sub>c B (fltD1 Di))" + using ConsDel.prems(1) unfolding constr_def fltD1_def fltD2_def by moura + hence "fv\<^sub>l\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t AA \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (fltD1 Di))" + unfolding constr_def fltD1_def by (metis ConsDel.hyps(1) iB(2)) + hence 1: "fv\<^sub>l\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t AA \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_mono[of "unlabel (fltD1 Di)" "unlabel D"] + unfolding unlabel_def fltD1_def by force + + have 2: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel Di) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (fltD1 Di)) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + using subseqs_set_subset(1)[OF *(1)] + unfolding fltD1_def unlabel_def + by auto + + have 5: "fv\<^sub>l\<^sub>s\<^sub>t A' = fv\<^sub>l\<^sub>s\<^sub>t (constr Di) \ fv\<^sub>l\<^sub>s\<^sub>t A''" using * unfolding unlabel_def by force + + have "fv\<^sub>l\<^sub>s\<^sub>t (constr Di) \ fv t \ fv s \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel Di) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (fltD1 Di))" + unfolding unlabel_def constr_def fltD1_def fltD2_def pair_def by auto + hence 3: "fv\<^sub>l\<^sub>s\<^sub>t (constr Di) \ fv t \ fv s \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" using 2 by blast + + have 4: "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) = fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t AA" using iB by auto + + have "fv\<^sub>s\<^sub>t (unlabel A') \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" using 1 3 4 5 by blast + thus ?case by metis + next + case (ConsNegChecks A' D X F F' AA A A') + then obtain i B where iB: "A = (i,NegChecks X F F')#B" "AA = unlabel B" + unfolding unlabel_def by moura + + define D' where "D' \ \(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (unlabel (dbproj i D))))" + define constr where "constr = map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + + from iB obtain A'' where *: "A'' \ set (tr\<^sub>p\<^sub>c B D)" "A' = constr@A''" + using ConsNegChecks.prems(1) unfolding constr_def by moura + hence "fv\<^sub>l\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t AA \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + by (metis ConsNegChecks.hyps(1) iB(2)) + hence **: "fv\<^sub>l\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t AA \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" by auto + + have 1: "fv\<^sub>l\<^sub>s\<^sub>t constr \ (D' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X" + unfolding D'_def constr_def unlabel_def by auto + + have "set (unlabel (dbproj i D)) \ set (unlabel D)" unfolding unlabel_def by auto + hence 2: "D' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_vars_subset'[of F' "unlabel (dbproj i D)"] fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_mono + unfolding D'_def by blast + + have 3: "fv\<^sub>l\<^sub>s\<^sub>t A' \ ((fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ fv\<^sub>l\<^sub>s\<^sub>t A''" + using 1 2 *(2) unfolding unlabel_def by fastforce + + have 4: "fv\<^sub>s\<^sub>s\<^sub>t AA \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel A)" by (metis ConsNegChecks.hyps(2) fv\<^sub>s\<^sub>s\<^sub>t_cons_subset) + + have 5: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + using ConsNegChecks.hyps(2) unfolding unlabel_def by force + + show ?case using ** 3 4 5 by blast + qed (fastforce simp add: unlabel_def)+ + + show ?Q using assms + apply (induct "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct) + by (fastforce simp add: unlabel_def)+ +qed + +lemma tr_par_vars_disj: + assumes "A' \ set (tr\<^sub>p\<^sub>c A D)" "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + shows "fv\<^sub>l\<^sub>s\<^sub>t A' \ bvars\<^sub>l\<^sub>s\<^sub>t A' = {}" +using assms tr_par_vars_subset by fast + +lemma tr_par_trms_subset: + assumes "A' \ set (tr\<^sub>p\<^sub>c A D)" + shows "trms\<^sub>l\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" +using assms +proof (induction A D arbitrary: A' rule: tr\<^sub>p\<^sub>c.induct) + case 1 thus ?case by simp +next + case (2 i t A D) + then obtain A'' where A'': "A' = (i,send\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" by moura + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" + by (metis "2.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (3 i t A D) + then obtain A'' where A'': "A' = (i,receive\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + by moura + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" + by (metis "3.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (4 i ac t t' A D) + then obtain A'' where A'': "A' = (i,\ac: t \ t'\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + by moura + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" + by (metis "4.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (5 i t s A D) + hence "A' \ set (tr\<^sub>p\<^sub>c A (List.insert (i,t,s) D))" by simp + hence "trms\<^sub>l\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ + pair ` snd ` set (List.insert (i,t,s) D)" + by (metis "5.IH") + thus ?case by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (6 i t s A D) + from 6 obtain Di A'' B C where A'': + "Di \ set (subseqs (dbproj i D))" "A'' \ set (tr\<^sub>p\<^sub>c A [d\D. d \ set Di])" "A' = (B@C)@A''" + "B = map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + "C = map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d \ set Di]" + by moura + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ + pair ` snd ` set [d\D. d \ set Di]" + by (metis "6.IH") + moreover have "set [d\D. d \ set Di] \ set D" using set_filter by auto + ultimately have + "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" + by blast + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,delete\t,s\)#A)) \ + pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,delete\t,s\)#A)) \ + pair ` snd ` set D" + using setops\<^sub>s\<^sub>s\<^sub>t_cons_subset trms\<^sub>s\<^sub>s\<^sub>t_cons + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + moreover have "set Di \ set D" "set [d\dbproj i D . d \ set Di] \ set D" + using subseqs_set_subset[OF A''(1)] by auto + hence "trms\<^sub>s\<^sub>t (unlabel B) \ insert (pair (t, s)) (pair ` snd ` set D)" + "trms\<^sub>s\<^sub>t (unlabel C) \ insert (pair (t, s)) (pair ` snd ` set D)" + using A''(4,5) unfolding unlabel_def by auto + hence "trms\<^sub>s\<^sub>t (unlabel (B@C)) \ insert (pair (t,s)) (pair ` snd ` set D)" + using unlabel_append[of B C] by auto + moreover have "pair (t,s) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (delete\t,s\#unlabel A)" by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + ultimately show ?case + using A''(3) trms\<^sub>s\<^sub>t_append[of "unlabel (B@C)" "unlabel A'"] unlabel_append[of "B@C" A''] + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (7 i ac t s A D) + from 7 obtain d A'' where A'': + "d \ set (dbproj i D)" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + "A' = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#A''" + by moura + hence "trms\<^sub>l\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ + pair ` snd ` set D" + by (metis "7.IH") + moreover have "trms\<^sub>s\<^sub>t (unlabel A') = {pair (t,s), pair (snd d)} \ trms\<^sub>s\<^sub>t (unlabel A'')" + using A''(1,3) by auto + ultimately show ?case using A''(1) by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (8 i X F F' A D) + define constr where "constr = map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + define B where "B \ \(trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D))))" + + from 8 obtain A'' where A'': + "A'' \ set (tr\<^sub>p\<^sub>c A D)" "A' = constr@A''" + unfolding constr_def by moura + + have "trms\<^sub>s\<^sub>t (unlabel A'') \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair`snd`set D" + by (metis A''(1) "8.IH") + moreover have "trms\<^sub>s\<^sub>t (unlabel constr) \ B \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` snd ` set D" + unfolding unlabel_def constr_def B_def by auto + ultimately have "trms\<^sub>s\<^sub>t (unlabel A') \ B \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ + pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D" + using A'' unlabel_append[of constr A''] by auto + moreover have "set (dbproj i D) \ set D" by auto + hence "B \ pair ` set F' \ pair ` snd ` set D" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset'[of F' "map snd (dbproj i D)"] + unfolding B_def by force + moreover have + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ((i, \X\\\: F \\: F'\)#A)) = + pair ` set F' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + by auto + ultimately show ?case by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +qed + +lemma tr_par_wf_trms: + assumes "A' \ set (tr\<^sub>p\<^sub>c A [])" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t (unlabel A))" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>t A')" +using tr_par_trms_subset[OF assms(1)] setops\<^sub>s\<^sub>s\<^sub>t_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s(2)[OF assms(2)] +by auto + +lemma tr_par_wf': + assumes "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + and "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" + and "wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + and "A' \ set (tr\<^sub>p\<^sub>c A D)" + shows "wf\<^sub>l\<^sub>s\<^sub>t X A'" +proof - + define P where + "P = (\(D::('fun,'var,'lbl) labeleddbstatelist) (A::('fun,'var,'lbl) labeled_stateful_strand). + (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}) \ + fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {})" + + have "P D A" using assms(1,4) by (simp add: P_def) + with assms(5,3,2) show ?thesis + proof (induction A arbitrary: X A' D) + case Nil thus ?case by simp + next + case (Cons a A) + obtain i s where i: "a = (i,s)" by (metis surj_pair) + note prems = Cons.prems + note IH = Cons.IH + show ?case + proof (cases s) + case (Receive t) + note si = Receive i + then obtain A'' where A'': "A' = (i,receive\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" "fv t \ X" + using prems unlabel_Cons(1)[of i s A] by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" + "P D A" + using prems si apply (force, force) + using prems(4) si unfolding P_def by fastforce + show ?thesis using IH[OF A''(2) *] A''(1,3) by simp + next + case (Send t) + note si = Send i + then obtain A'' where A'': "A' = (i,send\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + using prems by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t) (unlabel A)" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X \ fv t" + "P D A" + using prems si apply (force, force) + using prems(4) si unfolding P_def by fastforce + show ?thesis using IH[OF A''(2) *] A''(1) by simp + next + case (Equality ac t t') + note si = Equality i + then obtain A'' where A'': + "A' = (i,\ac: t \ t'\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + "ac = Assign \ fv t' \ X" + using prems unlabel_Cons(1)[of i s] by moura + have *: "ac = Assign \ wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t) (unlabel A)" + "ac = Check \ wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" + "ac = Assign \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X \ fv t" + "ac = Check \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" + "P D A" + using prems si apply (force, force, force, force) + using prems(4) si unfolding P_def by fastforce + show ?thesis + using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1,3) + by (cases ac) simp_all + next + case (Insert t t') + note si = Insert i + hence A': "A' \ set (tr\<^sub>p\<^sub>c A (List.insert (i,t,t') D))" "fv t \ X" "fv t' \ X" + using prems by auto + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (List.insert (i,t,t') D)) \ X" + using prems si by (auto simp add: unlabel_def) + have **: "P (List.insert (i,t,t') D) A" + using prems(4) si + unfolding P_def unlabel_def + by fastforce + show ?thesis using IH[OF A'(1) * **] A'(2,3) by simp + next + case (Delete t t') + note si = Delete i + define constr where "constr = (\Di. + (map (\d. (i,\check: (pair (t,t')) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,t'), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d \ set Di]))" + from prems si obtain Di A'' where A'': + "A' = constr Di@A''" "A'' \ set (tr\<^sub>p\<^sub>c A [d\D. d \ set Di])" + "Di \ set (subseqs (dbproj i D))" + unfolding constr_def by auto + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (filter (\d. d \ set Di) D)) \ X" + using prems si apply simp + using prems si by (fastforce simp add: unlabel_def) + + have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel (filter (\d. d \ set Di) D)) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D)" + by (auto simp add: unlabel_def) + hence **: "P [d\D. d \ set Di] A" + using prems si unfolding P_def + by fastforce + + have ***: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" using prems si by auto + show ?thesis + using IH[OF A''(2) * **] A''(1) wf_pair_eqs_ineqs_map'[OF _ A''(3) ***] + unfolding constr_def by simp + next + case (InSet ac t t') + note si = InSet i + then obtain d A'' where A'': + "A' = (i,\ac: (pair (t,t')) \ (pair (snd d))\\<^sub>s\<^sub>t)#A''" + "A'' \ set (tr\<^sub>p\<^sub>c A D)" + "d \ set D" + using prems by moura + have *: + "ac = Assign \ wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t \ fv t') (unlabel A)" + "ac = Check \ wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" + "ac = Assign \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X \ fv t \ fv t'" + "ac = Check \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" + "P D A" + using prems si apply (force, force, force, force) + using prems(4) si unfolding P_def by fastforce + have **: "fv (pair (snd d)) \ X" + using A''(3) prems(3) fv_pair_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subset + by fast + have ***: "fv (pair (t,t')) = fv t \ fv t'" unfolding pair_def by auto + show ?thesis + using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1) ** *** + by (cases ac) (simp_all add: Un_assoc) + next + case (NegChecks Y F F') + note si = NegChecks i + then obtain A'' where A'': + "A' = (map (\G. (i,\Y\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D))))@A''" + "A'' \ set (tr\<^sub>p\<^sub>c A D)" + using prems by moura + + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X (unlabel A)" "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ X" using prems si by auto + + have "bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,\Y\\\: F \\: F'\)#A))" + "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,\Y\\\: F \\: F'\)#A))" + by auto + hence **: "P D A" using prems si unfolding P_def by blast + + show ?thesis using IH[OF A''(2) * **] A''(1) wf_pair_negchecks_map' by simp + qed + qed +qed + +lemma tr_par_wf: + assumes "A' \ set (tr\<^sub>p\<^sub>c A [])" + and "wf\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" + shows "wf\<^sub>l\<^sub>s\<^sub>t {} A'" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>t A')" + and "fv\<^sub>l\<^sub>s\<^sub>t A' \ bvars\<^sub>l\<^sub>s\<^sub>t A' = {}" +using tr_par_wf'[OF _ _ _ _ assms(1)] + tr_par_wf_trms[OF assms(1,3)] + tr_par_vars_disj[OF assms(1)] + assms(2) +by fastforce+ + +lemma tr_par_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + assumes "A' \ set (tr\<^sub>p\<^sub>c A D)" "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel A)" + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" (is "?P0 A D") + and "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel D) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" (is "?P1 A D") + and "\t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D. + \t' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` snd ` set D. + (\\. Unifier \ t t') \ \ t = \ t'" (is "?P3 A D") + shows "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A')" +proof - + have sublmm: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel A)" "?P0 A D" "?P1 A D" "?P3 A D" + when p: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (a#A))" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D" + for a A D + proof - + show "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel A)" using p(1) by (simp add: unlabel_def tfr\<^sub>s\<^sub>s\<^sub>t_def) + show "?P0 A D" using p(2) fv\<^sub>s\<^sub>s\<^sub>t_cons_subset unfolding unlabel_def by fastforce + show "?P1 A D" using p(3) bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset unfolding unlabel_def by fastforce + have "setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ setops\<^sub>s\<^sub>s\<^sub>t (unlabel (a#A))" + using setops\<^sub>s\<^sub>s\<^sub>t_cons_subset unfolding unlabel_def by auto + thus "?P3 A D" using p(4) by blast + qed + + show ?thesis using assms + proof (induction A D arbitrary: A' rule: tr\<^sub>p\<^sub>c.induct) + case 1 thus ?case by simp + next + case (2 i t A D) + note prems = "2.prems" + note IH = "2.IH" + from prems(1) obtain A'' where A'': "A' = (i,send\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] + by meson + thus ?case using A''(1) by simp + next + case (3 i t A D) + note prems = "3.prems" + note IH = "3.IH" + from prems(1) obtain A'' where A'': "A' = (i,receive\t\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] + by meson + thus ?case using A''(1) by simp + next + case (4 i ac t t' A D) + note prems = "4.prems" + note IH = "4.IH" + from prems(1) obtain A'' where A'': "A' = (i,\ac: t \ t'\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] + by meson + thus ?case using A''(1) prems(2) by simp + next + case (5 i t s A D) + note prems = "5.prems" + note IH = "5.IH" + from prems(1) have A': "A' \ set (tr\<^sub>p\<^sub>c A (List.insert (i,t,s) D))" by simp + + have 1: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel A)" using sublmm[OF prems(2,3,4,5)] by simp + + have "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,insert\t,s\)#A)) \ pair`snd`set D = + pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair`snd`set (List.insert (i,t,s) D)" + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + hence 3: "?P3 A (List.insert (i,t,s) D)" using prems(5) by metis + moreover have "?P1 A (List.insert (i,t,s) D)" + using prems(3,4) bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset[of "unlabel A" "insert\t,s\"] + unfolding unlabel_def + by fastforce + ultimately have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A')" + using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis + thus ?case using A'(1) by auto + next + case (6 i t s A D) + note prems = "6.prems" + note IH = "6.IH" + + define constr where constr: "constr \ (\Di. + (map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) (filter (\d. d \ set Di) (dbproj i D))))" + + from prems(1) obtain Di A'' where A'': + "A' = constr Di@A''" "A'' \ set (tr\<^sub>p\<^sub>c A (filter (\d. d \ set Di) D))" + "Di \ set (subseqs (dbproj i D))" + unfolding constr by fastforce + + define Q1 where "Q1 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \x \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X. \a. \ (Var x) = TAtom a)" + define Q2 where "Q2 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X))" + + have "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair`snd`set [d\D. d \ set Di] + \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ((i,delete\t,s\)#A)) \ pair`snd`set D" + using subseqs_set_subset[OF A''(3)] by (force simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + moreover have "\a\M. \b\M. P a b" + when "M \ N" "\a\N. \b\N. P a b" + for M N::"('fun, 'var) terms" and P + using that by blast + ultimately have *: "?P3 A (filter (\d. d \ set Di) D)" + using prems(5) by presburger + + have **: "?P1 A (filter (\d. d \ set Di) D)" + using prems(4) bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset[of "unlabel A" "delete\t,s\"] + unfolding unlabel_def by fastforce + + have 1: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *] + by metis + + have 2: "\ac: u \ u'\\<^sub>s\<^sub>t \ set (unlabel A'') \ + (\d \ set Di. u = pair (t,s) \ u' = pair (snd d))" + when "\ac: u \ u'\\<^sub>s\<^sub>t \ set (unlabel A')" for ac u u' + using that A''(1) unfolding constr unlabel_def by force + have 3: + "\X\\\: u\\<^sub>s\<^sub>t \ set (unlabel A'') \ + (\d \ set (filter (\d. d \ set Di) D). u = [(pair (t,s), pair (snd d))] \ Q2 u X)" + when "\X\\\: u\\<^sub>s\<^sub>t \ set (unlabel A')" for X u + using that A''(1) unfolding Q2_def constr unlabel_def by force + have 4: "\d\set D. (\\. Unifier \ (pair (t,s)) (pair (snd d))) + \ \ (pair (t,s)) = \ (pair (snd d))" + using prems(5) by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + + { fix ac u u' + assume a: "\ac: u \ u'\\<^sub>s\<^sub>t \ set (unlabel A')" "\\. Unifier \ u u'" + hence "\ac: u \ u'\\<^sub>s\<^sub>t \ set (unlabel A'') \ (\d \ set Di. u = pair (t,s) \ u' = pair (snd d))" + using 2 by metis + moreover { + assume "\ac: u \ u'\\<^sub>s\<^sub>t \ set (unlabel A'')" + hence "tfr\<^sub>s\<^sub>t\<^sub>p (\ac: u \ u'\\<^sub>s\<^sub>t)" + using 1 Ball_set_list_all[of "unlabel A''" tfr\<^sub>s\<^sub>t\<^sub>p] + by fast + } moreover { + fix d assume "d \ set Di" "u = pair (t,s)" "u' = pair (snd d)" + hence "\\. Unifier \ u u' \ \ u = \ u'" + using 4 dbproj_subseq_subset A''(3) + by fast + hence "tfr\<^sub>s\<^sub>t\<^sub>p (\ac: u \ u'\\<^sub>s\<^sub>t)" + using Ball_set_list_all[of "unlabel A''" tfr\<^sub>s\<^sub>t\<^sub>p] + by simp + hence "\ u = \ u'" using tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of "unlabel A''"] + using a(2) unfolding unlabel_def by auto + } ultimately have "\ u = \ u'" + using tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of "unlabel A''"] a(2) + unfolding unlabel_def by auto + } moreover { + fix u U + assume "\U\\\: u\\<^sub>s\<^sub>t \ set (unlabel A')" + hence "\U\\\: u\\<^sub>s\<^sub>t \ set (unlabel A'') \ + (\d \ set (filter (\d. d \ set Di) D). u = [(pair (t,s), pair (snd d))] \ Q2 u U)" + using 3 by metis + hence "Q1 u U \ Q2 u U" + using 1 4 subseqs_set_subset[OF A''(3)] tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of "unlabel A''"] + unfolding Q1_def Q2_def + by blast + } ultimately show ?case + using tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of "unlabel A'"] unfolding Q1_def Q2_def unlabel_def by blast + next + case (7 i ac t s A D) + note prems = "7.prems" + note IH = "7.IH" + + from prems(1) obtain d A'' where A'': + "A' = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#A''" + "A'' \ set (tr\<^sub>p\<^sub>c A D)" + "d \ set (dbproj i D)" + by moura + + have 1: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]] + by metis + + have 2: "\ (pair (t,s)) = \ (pair (snd d))" + when "\\. Unifier \ (pair (t,s)) (pair (snd d))" + using that prems(2,5) A''(3) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + + show ?case using A''(1) 1 2 by fastforce + next + case (8 i X F F' A D) + note prems = "8.prems" + note IH = "8.IH" + + define constr where + "constr = map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + + define Q1 where "Q1 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \x \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X. \a. \ (Var x) = TAtom a)" + + define Q2 where "Q2 \ (\(M::('fun,'var) terms) X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t M \ T = [] \ (\s \ set T. s \ Var ` set X))" + + have Q2_subset: "Q2 M' X" when "M' \ M" "Q2 M X" for X M M' + using that unfolding Q2_def by auto + + have Q2_supset: "Q2 (M \ M') X" when "Q2 M X" "Q2 M' X" for X M M' + using that unfolding Q2_def by auto + + from prems obtain A'' where A'': "A' = constr@A''" "A'' \ set (tr\<^sub>p\<^sub>c A D)" + using constr_def by moura + + have 0: "constr = [(i,\X\\\: F\\<^sub>s\<^sub>t)]" when "F' = []" using that unfolding constr_def by simp + + have 1: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A'')" + using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]] + by metis + + have 2: "(F' = [] \ Q1 F X) \ Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X" + using prems(2) unfolding Q1_def Q2_def by simp + + have 3: "F' = [] \ Q1 F X \ list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel constr)" + using 0 2 tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of "unlabel constr"] unfolding Q1_def by auto + + { fix c assume "c \ set (unlabel constr)" + hence "\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D))). c = \X\\\: (F@G)\\<^sub>s\<^sub>t" + unfolding constr_def unlabel_def by force + } moreover { + fix G + assume G: "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + and c: "\X\\\: (F@G)\\<^sub>s\<^sub>t \ set (unlabel constr)" + and e: "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X" + + have d_Q2: "Q2 (pair ` set (map snd D)) X" unfolding Q2_def + proof (intro allI impI) + fix f T assume "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (pair ` set (map snd D))" + then obtain d where d: "d \ set (map snd D)" "Fun f T \ subterms (pair d)" by force + hence "fv (pair d) \ set X = {}" + using prems(4) unfolding pair_def by (force simp add: unlabel_def) + thus "T = [] \ (\s \ set T. s \ Var ` set X)" + by (metis fv_disj_Fun_subterm_param_cases d(2)) + qed + + have "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F' \ pair ` set (map snd D)" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset[OF G] by force + hence "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis + hence "tfr\<^sub>s\<^sub>t\<^sub>p (\X\\\: (F@G)\\<^sub>s\<^sub>t)" by (metis Q2_def tfr\<^sub>s\<^sub>t\<^sub>p.simps(2)) + } ultimately have 4: + "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X \ list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel constr)" + using Ball_set by blast + + have 5: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel constr)" using 2 3 4 by metis + + show ?case using 1 5 A''(1) by (simp add: unlabel_def) + qed +qed + +lemma tr_par_tfr: + assumes "A' \ set (tr\<^sub>p\<^sub>c A [])" and "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + shows "tfr\<^sub>s\<^sub>t (unlabel A')" +proof - + have *: "trms\<^sub>l\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + using tr_par_trms_subset[OF assms(1)] by simp + hence "SMP (trms\<^sub>l\<^sub>s\<^sub>t A') \ SMP (trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A))" + using SMP_mono by simp + moreover have "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A))" + using assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by fast + ultimately have 1: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>t A')" by (metis tfr_subset(2)[OF _ *]) + + have **: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel A)" using assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by fast + have "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ + SMP (trms\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)) - Var`\" + using setops\<^sub>s\<^sub>s\<^sub>t_are_pairs unfolding pair_def by auto + hence "\ t = \ t'" + when "\\. Unifier \ t t'" "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "t' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" + for t t' + using that assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (unlabel []) = {}" "pair ` snd ` set [] = {}" by auto + ultimately have 2: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (unlabel A')" + using tr_par_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p[OF assms(1) ** assms(3)] by simp + + show ?thesis by (metis 1 2 tfr\<^sub>s\<^sub>t_def) +qed + +lemma tr_par_proj: + assumes "B \ set (tr\<^sub>p\<^sub>c A D)" + shows "proj n B \ set (tr\<^sub>p\<^sub>c (proj n A) (proj n D))" +using assms +proof (induction A D arbitrary: B rule: tr\<^sub>p\<^sub>c.induct) + case (5 i t s S D) + note prems = "5.prems" + note IH = "5.IH" + have IH': "proj n B \ set (tr\<^sub>p\<^sub>c (proj n S) (proj n (List.insert (i,t,s) D)))" + using prems IH by auto + show ?case + proof (cases "(i = ln n) \ (i = \)") + case True thus ?thesis + using IH' proj_list_insert(1,2)[of n "(t,s)" D] proj_list_Cons(1,2)[of n _ S] + by auto + next + case False + then obtain m where "i = ln m" "n \ m" by (cases i) simp_all + thus ?thesis + using IH' proj_list_insert(3)[of n _ "(t,s)" D] proj_list_Cons(3)[of n _ "insert\t,s\" S] + by auto + qed +next + case (6 i t s S D) + note prems = "6.prems" + note IH = "6.IH" + define constr where "constr = (\Di D. + (map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d \ set Di]))" + + obtain Di B' where B': + "B = constr Di D@B'" + "Di \ set (subseqs (dbproj i D))" + "B' \ set (tr\<^sub>p\<^sub>c S [d\D. d \ set Di])" + using prems constr_def by fastforce + hence "proj n B' \ set (tr\<^sub>p\<^sub>c (proj n S) (proj n [d\D. d \ set Di]))" using IH by simp + hence IH': "proj n B' \ set (tr\<^sub>p\<^sub>c (proj n S) [d\proj n D. d \ set Di])" by (metis proj_filter) + show ?case + proof (cases "(i = ln n) \ (i = \)") + case True + hence "proj n B = constr Di D@proj n B'" "Di \ set (subseqs (dbproj i (proj n D)))" + using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto + moreover have "constr Di (proj n D) = constr Di D" + using True proj_dbproj(1,2)[of n D] unfolding constr_def by presburger + ultimately have "proj n B \ set (tr\<^sub>p\<^sub>c ((i, delete\t,s\)#proj n S) (proj n D))" + using IH' unfolding constr_def by force + thus ?thesis by (metis proj_list_Cons(1,2) True) + next + case False + then obtain m where m: "i = ln m" "n \ m" by (cases i) simp_all + hence *: "(ln n) \ i" by simp + have "proj n B = proj n B'" using B'(1) False unfolding constr_def proj_def by auto + moreover have "[d\proj n D. d \ set Di] = proj n D" + using proj_subseq[OF _ m(2)[symmetric]] m(1) B'(2) by simp + ultimately show ?thesis using m(1) IH' proj_list_Cons(3)[OF m(2), of _ S] by auto + qed +next + case (7 i ac t s S D) + note prems = "7.prems" + note IH = "7.IH" + define constr where "constr = ( + \d::'lbl strand_label \ ('fun,'var) term \ ('fun,'var) term. + (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t))" + + obtain d B' where B': + "B = constr d#B'" + "d \ set (dbproj i D)" + "B' \ set (tr\<^sub>p\<^sub>c S D)" + using prems constr_def by fastforce + hence IH': "proj n B' \ set (tr\<^sub>p\<^sub>c (proj n S) (proj n D))" using IH by auto + + show ?case + proof (cases "(i = ln n) \ (i = \)") + case True + hence "proj n B = constr d#proj n B'" "d \ set (dbproj i (proj n D))" + using B' proj_list_Cons(1,2)[of n _ B'] + unfolding constr_def + by (force, metis proj_dbproj(1,2)) + hence "proj n B \ set (tr\<^sub>p\<^sub>c ((i, InSet ac t s)#proj n S) (proj n D))" + using IH' unfolding constr_def by auto + thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis + next + case False + then obtain m where m: "i = ln m" "n \ m" by (cases i) simp_all + hence "proj n B = proj n B'" using B'(1) proj_list_Cons(3) unfolding constr_def by auto + thus ?thesis + using IH' m proj_list_Cons(3)[OF m(2), of "InSet ac t s" S] + unfolding constr_def + by auto + qed +next + case (8 i X F F' S D) + note prems = "8.prems" + note IH = "8.IH" + + define constr where + "constr = (\D. map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D))))" + + obtain B' where B': + "B = constr D@B'" + "B' \ set (tr\<^sub>p\<^sub>c S D)" + using prems constr_def by fastforce + hence IH': "proj n B' \ set (tr\<^sub>p\<^sub>c (proj n S) (proj n D))" using IH by auto + + show ?case + proof (cases "(i = ln n) \ (i = \)") + case True + hence "proj n B = constr (proj n D)@proj n B'" + using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto + hence "proj n B \ set (tr\<^sub>p\<^sub>c ((i, NegChecks X F F')#proj n S) (proj n D))" + using IH' unfolding constr_def by auto + thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis + next + case False + then obtain m where m: "i = ln m" "n \ m" by (cases i) simp_all + hence "proj n B = proj n B'" using B'(1) unfolding constr_def proj_def by auto + thus ?thesis + using IH' m proj_list_Cons(3)[OF m(2), of "NegChecks X F F'" S] + unfolding constr_def + by auto + qed +qed (force simp add: proj_def)+ + +lemma tr_par_preserves_typing_cond: + assumes "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A Sec" "typing_cond\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "A' \ set (tr\<^sub>p\<^sub>c A [])" + shows "typing_cond (unlabel A')" +proof - + have "wf'\<^sub>s\<^sub>s\<^sub>t {} (unlabel A)" + "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t (unlabel A))" + using assms(2) unfolding typing_cond\<^sub>s\<^sub>s\<^sub>t_def by simp_all + hence 1: "wf\<^sub>s\<^sub>t {} (unlabel A')" + "fv\<^sub>s\<^sub>t (unlabel A') \ bvars\<^sub>s\<^sub>t (unlabel A') = {}" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t (unlabel A'))" + "Ana_invar_subst (ik\<^sub>s\<^sub>t (unlabel A') \ assignment_rhs\<^sub>s\<^sub>t (unlabel A'))" + using tr_par_wf[OF assms(3)] Ana_invar_subst' by metis+ + + have 2: "tfr\<^sub>s\<^sub>t (unlabel A')" by (metis tr_par_tfr assms(2,3) typing_cond\<^sub>s\<^sub>s\<^sub>t_def) + + show ?thesis by (metis 1 2 typing_cond_def) +qed + +lemma tr_par_preserves_par_comp: + assumes "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A Sec" "A' \ set (tr\<^sub>p\<^sub>c A [])" + shows "par_comp A' Sec" +proof - + let ?M = "\l. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l A)" + let ?N = "\l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A'" + + have 0: "\l1 l2. l1 \ l2 \ GSMP_disjoint (?M l1) (?M l2) Sec" + using assms(1) unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp_all + + { fix l1 l2::'lbl assume *: "l1 \ l2" + hence "GSMP_disjoint (?M l1) (?M l2) Sec" using 0(1) by metis + moreover have "pair ` snd ` set (proj n []) = {}" for n::'lbl unfolding proj_def by simp + hence "?N l1 \ ?M l1" "?N l2 \ ?M l2" + using tr_par_trms_subset[OF tr_par_proj[OF assms(2)]] by (metis Un_empty_right)+ + ultimately have "GSMP_disjoint (?N l1) (?N l2) Sec" + using GSMP_disjoint_subset by presburger + } hence 1: "\l1 l2. l1 \ l2 \ GSMP_disjoint (trms_proj\<^sub>l\<^sub>s\<^sub>t l1 A') (trms_proj\<^sub>l\<^sub>s\<^sub>t l2 A') Sec" + using 0(1) by metis + + have 2: "ground Sec" "\s \ Sec. \s' \ subterms s. {} \\<^sub>c s' \ s' \ Sec" + using assms(1) unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by metis+ + + show ?thesis using 1 2 unfolding par_comp_def by metis +qed + +lemma tr_leaking_prefix_exists: + assumes "A' \ set (tr\<^sub>p\<^sub>c A [])" "prefix B A'" "ik\<^sub>s\<^sub>t (proj_unl n B) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" + shows "\C D. prefix C B \ prefix D A \ C \ set (tr\<^sub>p\<^sub>c D []) \ (ik\<^sub>s\<^sub>t (proj_unl n C) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \)" +proof - + let ?P = "\B C C'. B = C@C' \ (\n t. (n, receive\t\\<^sub>s\<^sub>t) \ set C') \ + (C = [] \ (\n t. suffix [(n,receive\t\\<^sub>s\<^sub>t)] C))" + have "\C C'. ?P B C C'" + proof (induction B) + case (Cons b B) + then obtain C C' n s where *: "?P B C C'" "b = (n,s)" by moura + show ?case + proof (cases "C = []") + case True + note T = True + show ?thesis + proof (cases "\t. s = receive\t\\<^sub>s\<^sub>t") + case True + hence "?P (b#B) [b] C'" using * T by auto + thus ?thesis by metis + next + case False + hence "?P (b#B) [] (b#C')" using * T by auto + thus ?thesis by metis + qed + next + case False + hence "?P (b#B) (b#C) C'" using * unfolding suffix_def by auto + thus ?thesis by metis + qed + qed simp + then obtain C C' where C: + "B = C@C'" "\n t. (n, receive\t\\<^sub>s\<^sub>t) \ set C'" + "C = [] \ (\n t. suffix [(n,receive\t\\<^sub>s\<^sub>t)] C)" + by moura + hence 1: "prefix C B" by simp + hence 2: "prefix C A'" using assms(2) by simp + + have "\m t. (m,receive\t\\<^sub>s\<^sub>t) \ set B \ (m,receive\t\\<^sub>s\<^sub>t) \ set C" using C by auto + hence "\t. receive\t\\<^sub>s\<^sub>t \ set (proj_unl n B) \ receive\t\\<^sub>s\<^sub>t \ set (proj_unl n C)" + unfolding unlabel_def proj_def by force + hence "ik\<^sub>s\<^sub>t (proj_unl n B) \ ik\<^sub>s\<^sub>t (proj_unl n C)" using ik\<^sub>s\<^sub>t_is_rcv_set by auto + hence 3: "ik\<^sub>s\<^sub>t (proj_unl n C) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" by (metis ideduct_mono[OF assms(3)] subst_all_mono) + + { fix D E m t assume "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E" "prefix E A'" "A' \ set (tr\<^sub>p\<^sub>c A D)" + hence "\F. prefix F A \ E \ set (tr\<^sub>p\<^sub>c F D)" + proof (induction A D arbitrary: A' E rule: tr\<^sub>p\<^sub>c.induct) + case (1 D) thus ?case by simp + next + case (2 i t' S D) + note prems = "2.prems" + note IH = "2.IH" + obtain A'' where *: "A' = (i,send\t'\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(3) by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = (i,send\t'\\<^sub>s\<^sub>t)#E'" + using *(1) prems(2) by (cases E) auto + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" + using *(2) ** IH by metis + hence "prefix ((i,Send t')#F) ((i,Send t')#S)" "E \ set (tr\<^sub>p\<^sub>c ((i,Send t')#F) D)" + using ** by auto + thus ?case by metis + next + case (3 i t' S D) + note prems = "3.prems" + note IH = "3.IH" + obtain A'' where *: "A' = (i,receive\t'\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(3) by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = (i,receive\t'\\<^sub>s\<^sub>t)#E'" + using *(1) prems(2) by (cases E) auto + show ?case + proof (cases "(m, receive\t\\<^sub>s\<^sub>t) = (i, receive\t'\\<^sub>s\<^sub>t)") + case True + note T = True + show ?thesis + proof (cases "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'") + case True + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using ** *(1) prems(1,2) by auto + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" + using *(2) ** IH by metis + hence "prefix ((i,receive\t'\)#F) ((i,receive\t'\)#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,receive\t'\)#F) D)" + using ** by auto + thus ?thesis by metis + next + case False + hence "E' = []" + using **(1) T prems(1) + suffix_Cons[of "[(m, receive\t\\<^sub>s\<^sub>t)]" "(m, receive\t\\<^sub>s\<^sub>t)" E'] + by auto + hence "prefix [(i,receive\t'\)] ((i,receive\t'\) # S) \ E \ set (tr\<^sub>p\<^sub>c [(i,receive\t'\)] D)" + using * ** prems by auto + thus ?thesis by metis + qed + next + case False + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using ** *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" using *(2) ** IH by metis + hence "prefix ((i,receive\t'\)#F) ((i,receive\t'\)#S)" "E \ set (tr\<^sub>p\<^sub>c ((i,receive\t'\)#F) D)" + using ** by auto + thus ?thesis by metis + qed + next + case (4 i ac t' t'' S D) + note prems = "4.prems" + note IH = "4.IH" + obtain A'' where *: "A' = (i,\ac: t' \ t''\\<^sub>s\<^sub>t)#A''" "A'' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(3) by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = (i,\ac: t' \ t''\\<^sub>s\<^sub>t)#E'" + using *(1) prems(2) by (cases E) auto + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" + using *(2) ** IH by metis + hence "prefix ((i,Equality ac t' t'')#F) ((i,Equality ac t' t'')#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,Equality ac t' t'')#F) D)" + using ** by auto + thus ?case by metis + next + case (5 i t' s S D) + note prems = "5.prems" + note IH = "5.IH" + have *: "A' \ set (tr\<^sub>p\<^sub>c S (List.insert (i,t',s) D))" using prems(3) by auto + have "E \ []" using prems(1) by auto + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E" "prefix E A'" + using *(1) prems(1,2) suffix_Cons[of _ _ E] by auto + then obtain F where "prefix F S" "E \ set (tr\<^sub>p\<^sub>c F (List.insert (i,t',s) D))" + using * IH by metis + hence "prefix ((i,insert\t',s\)#F) ((i,insert\t',s\)#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,insert\t',s\)#F) D)" + by auto + thus ?case by metis + next + case (6 i t' s S D) + note prems = "6.prems" + note IH = "6.IH" + + define constr where "constr = (\Di. + (map (\d. (i,\check: (pair (t',s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t',s), pair (snd d))]\\<^sub>s\<^sub>t)) + (filter (\d. d \ set Di) (dbproj i D))))" + + obtain A'' Di where *: + "A' = constr Di@A''" "A'' \ set (tr\<^sub>p\<^sub>c S (filter (\d. d \ set Di) D))" + "Di \ set (subseqs (dbproj i D))" + using prems(3) constr_def by auto + have ***: "(m, receive\t\\<^sub>s\<^sub>t) \ set (constr Di)" using constr_def by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = constr Di@E'" + using *(1) prems(1,2) *** + by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def + prefix_same_cases set_append suffix_def) + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using *(1) prems(1,2) suffix_append[of "[(m,receive\t\\<^sub>s\<^sub>t)]" "constr Di" E'] *** + by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust + snoc_suffix_snoc suffix_appendD, + auto) + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F (filter (\d. d \ set Di) D))" + using *(2,3) ** IH by metis + hence "prefix ((i,delete\t',s\)#F) ((i,delete\t',s\)#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,delete\t',s\)#F) D)" + using *(3) ** constr_def by auto + thus ?case by metis + next + case (7 i ac t' s S D) + note prems = "7.prems" + note IH = "7.IH" + + define constr where "constr = ( + \d::(('lbl strand_label \ ('fun,'var) term \ ('fun,'var) term)). + (i,\ac: (pair (t',s)) \ (pair (snd d))\\<^sub>s\<^sub>t))" + + obtain A'' d where *: "A' = constr d#A''" "A'' \ set (tr\<^sub>p\<^sub>c S D)" "d \ set (dbproj i D)" + using prems(3) constr_def by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = constr d#E'" using *(1) prems(2) by (cases E) auto + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using *(1) prems(1,2) suffix_Cons[of _ _ E'] using constr_def by auto + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" using *(2) ** IH by metis + hence "prefix ((i,InSet ac t' s)#F) ((i,InSet ac t' s)#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,InSet ac t' s)#F) D)" + using *(3) ** unfolding constr_def by auto + thus ?case by metis + next + case (8 i X G G' S D) + note prems = "8.prems" + note IH = "8.IH" + + define constr where + "constr = map (\H. (i,\X\\\: (G@H)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G' (map snd (dbproj i D)))" + + obtain A'' where *: "A' = constr@A''" "A'' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(3) constr_def by auto + have ***: "(m, receive\t\\<^sub>s\<^sub>t) \ set constr" using constr_def by auto + have "E \ []" using prems(1) by auto + then obtain E' where **: "E = constr@E'" + using *(1) prems(1,2) *** + by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def + prefix_same_cases set_append suffix_def) + hence "suffix [(m, receive\t\\<^sub>s\<^sub>t)] E'" "prefix E' A''" + using *(1) prems(1,2) suffix_append[of "[(m,receive\t\\<^sub>s\<^sub>t)]" constr E'] *** + by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust + snoc_suffix_snoc suffix_appendD, + auto) + then obtain F where "prefix F S" "E' \ set (tr\<^sub>p\<^sub>c F D)" using *(2) ** IH by metis + hence "prefix ((i,NegChecks X G G')#F) ((i,NegChecks X G G')#S)" + "E \ set (tr\<^sub>p\<^sub>c ((i,NegChecks X G G')#F) D)" + using ** constr_def by auto + thus ?case by metis + qed + } + moreover have "prefix [] A" "[] \ set (tr\<^sub>p\<^sub>c [] [])" by auto + ultimately have 4: "\D. prefix D A \ C \ set (tr\<^sub>p\<^sub>c D [])" using C(3) assms(1) 2 by blast + + show ?thesis by (metis 1 3 4) +qed + + +subsection \Theorem: Semantic Equivalence of Translation\ +context +begin + +text \ + An alternative version of the translation that does not perform database-state projections. + It is used as an intermediate step in the proof of semantic equivalence. +\ +private fun tr'\<^sub>p\<^sub>c:: + "('fun,'var,'lbl) labeled_stateful_strand \ ('fun,'var,'lbl) labeleddbstatelist + \ ('fun,'var,'lbl) labeled_strand list" +where + "tr'\<^sub>p\<^sub>c [] D = [[]]" +| "tr'\<^sub>p\<^sub>c ((i,send\t\)#A) D = map ((#) (i,send\t\\<^sub>s\<^sub>t)) (tr'\<^sub>p\<^sub>c A D)" +| "tr'\<^sub>p\<^sub>c ((i,receive\t\)#A) D = map ((#) (i,receive\t\\<^sub>s\<^sub>t)) (tr'\<^sub>p\<^sub>c A D)" +| "tr'\<^sub>p\<^sub>c ((i,\ac: t \ t'\)#A) D = map ((#) (i,\ac: t \ t'\\<^sub>s\<^sub>t)) (tr'\<^sub>p\<^sub>c A D)" +| "tr'\<^sub>p\<^sub>c ((i,insert\t,s\)#A) D = tr'\<^sub>p\<^sub>c A (List.insert (i,(t,s)) D)" +| "tr'\<^sub>p\<^sub>c ((i,delete\t,s\)#A) D = ( + concat (map (\Di. map (\B. (map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di)@ + (map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) + [d\D. d \ set Di])@B) + (tr'\<^sub>p\<^sub>c A [d\D. d \ set Di])) + (subseqs D)))" +| "tr'\<^sub>p\<^sub>c ((i,\ac: t \ s\)#A) D = + concat (map (\B. map (\d. (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#B) D) (tr'\<^sub>p\<^sub>c A D))" +| "tr'\<^sub>p\<^sub>c ((i,\X\\\: F \\: F'\)#A) D = + map ((@) (map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D)))) (tr'\<^sub>p\<^sub>c A D)" + +subsubsection \Part 1\ +private lemma tr'_par_iff_unlabel_tr: + assumes "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + p = q \ i = j" + shows "(\C \ set (tr'\<^sub>p\<^sub>c A D). B = unlabel C) \ B \ set (tr (unlabel A) (unlabel D))" + (is "?A \ ?B") +proof + { fix C have "C \ set (tr'\<^sub>p\<^sub>c A D) \ unlabel C \ set (tr (unlabel A) (unlabel D))" using assms + proof (induction A D arbitrary: C rule: tr'\<^sub>p\<^sub>c.induct) + case (5 i t s S D) + hence "unlabel C \ set (tr (unlabel S) (unlabel (List.insert (i, t, s) D)))" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + moreover have + "insert (i,t,s) (set D) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i,insert\t,s\)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "\(j,p) \ insert (i,t,s) (set D). \(k,q) \ insert (i,t,s) (set D). p = q \ j = k" + using "5.prems"(2) by blast + hence "unlabel (List.insert (i, t, s) D) = (List.insert (t, s) (unlabel D))" + using map_snd_list_insert_distrib[of "(i,t,s)" D] unfolding unlabel_def by simp + ultimately show ?case by auto + next + case (6 i t s S D) + let ?f1 = "\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t" + let ?g1 = "\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t" + let ?f2 = "\d. (i, ?f1 (snd d))" + let ?g2 = "\d. (i, ?g1 (snd d))" + + define constr1 where "constr1 = (\Di. (map ?f1 Di)@(map ?g1 [d\unlabel D. d \ set Di]))" + define constr2 where "constr2 = (\Di. (map ?f2 Di)@(map ?g2 [d\D. d \ set Di]))" + + obtain C' Di where C': + "Di \ set (subseqs D)" + "C = constr2 Di@C'" + "C' \ set (tr'\<^sub>p\<^sub>c S [d\D. d \ set Di])" + using "6.prems"(1) unfolding constr2_def by moura + + have 0: "set [d\D. d \ set Di] \ set D" + "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S)" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence 1: + "\(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]. + \(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]. + p = q \ j = k" + using "6.prems"(2) by blast + + have "\(i,p) \ set D \ set Di. \(j,q) \ set D \ set Di. p = q \ i = j" + using "6.prems"(2) subseqs_set_subset(1)[OF C'(1)] by blast + hence 2: "unlabel [d\D. d \ set Di] = [d\unlabel D. d \ set (unlabel Di)]" + using unlabel_filter_eq[of D "set Di"] unfolding unlabel_def by simp + + have 3: + "\f g::('a \ 'a \ 'c). \A B::(('b \ 'a \ 'a) list). + map snd ((map (\d. (i, f (snd d))) A)@(map (\d. (i, g (snd d))) B)) = + map f (map snd A)@map g (map snd B)" + by simp + have "unlabel (constr2 Di) = constr1 (unlabel Di)" + using 2 3[of ?f1 Di ?g1 "[d\D. d \ set Di]"] + by (simp add: constr1_def constr2_def unlabel_def) + hence 4: "unlabel C = constr1 (unlabel Di)@unlabel C'" + using C'(2) unlabel_append by metis + + have "unlabel Di \ set (map unlabel (subseqs D))" + using C'(1) unfolding unlabel_def by simp + hence 5: "unlabel Di \ set (subseqs (unlabel D))" + using map_subseqs[of snd D] unfolding unlabel_def by simp + + show ?case using "6.IH"[OF C'(1,3) 1] 2 4 5 unfolding constr1_def by auto + next + case (7 i ac t s S D) + obtain C' d where C': + "C = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#C'" + "C' \ set (tr'\<^sub>p\<^sub>c S D)" "d \ set D" + using "7.prems"(1) by moura + + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i,InSet ac t s)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "\(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D. + \(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D. + p = q \ j = k" + using "7.prems"(2) by blast + hence "unlabel C' \ set (tr (unlabel S) (unlabel D))" using "7.IH"[OF C'(2)] by auto + thus ?case using C' unfolding unlabel_def by force + next + case (8 i X F F' S D) + obtain C' where C': + "C = map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))@C'" + "C' \ set (tr'\<^sub>p\<^sub>c S D)" + using "8.prems"(1) by moura + + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i,NegChecks X F F')#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "\(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D. + \(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D. + p = q \ j = k" + using "8.prems"(2) by blast + hence "unlabel C' \ set (tr (unlabel S) (unlabel D))" using "8.IH"[OF C'(2)] by auto + thus ?case using C' unfolding unlabel_def by auto + qed (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + } thus "?A \ ?B" by blast + + show "?B \ ?A" using assms + proof (induction A arbitrary: B D) + case (Cons a A) + obtain ia sa where a: "a = (ia,sa)" by moura + + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A)" using a by (cases sa) (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence 1: "\(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + \(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + p = q \ j = k" + using Cons.prems(2) by blast + + show ?case + proof (cases sa) + case (Send t) + then obtain B' where B': + "B = send\t\\<^sub>s\<^sub>t#B'" + "B' \ set (tr (unlabel A) (unlabel D))" + using Cons.prems(1) a by auto + thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Send by auto + next + case (Receive t) + then obtain B' where B': + "B = receive\t\\<^sub>s\<^sub>t#B'" + "B' \ set (tr (unlabel A) (unlabel D))" + using Cons.prems(1) a by auto + thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Receive by auto + next + case (Equality ac t t') + then obtain B' where B': + "B = \ac: t \ t'\\<^sub>s\<^sub>t#B'" + "B' \ set (tr (unlabel A) (unlabel D))" + using Cons.prems(1) a by auto + thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Equality by auto + next + case (Insert t s) + hence B: "B \ set (tr (unlabel A) (List.insert (t,s) (unlabel D)))" + using Cons.prems(1) a by auto + + let ?P = "\i. List.insert (t,s) (unlabel D) = unlabel (List.insert (i,t,s) D)" + + { obtain j where j: "?P j" "j = ia \ (j,t,s) \ set D" + using labeled_list_insert_eq_ex_cases[of "(t,s)" D ia] by moura + hence "j = ia" using Cons.prems(2) a Insert by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "?P ia" using j(1) by metis + } hence j: "?P ia" by metis + + have 2: "\(k1, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set (List.insert (ia,t,s) D). + \(k2, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set (List.insert (ia,t,s) D). + p = q \ k1 = k2" + using Cons.prems(2) a Insert by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + + show ?thesis using Cons.IH[OF _ 2] j(1) B Insert a by auto + next + case (Delete t s) + define c where "c \ (\(i::'lbl strand_label) Di. + map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di@ + map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\D. d \ set Di])" + + define d where "d \ (\Di. + map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di@ + map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\unlabel D. d \ set Di])" + + obtain B' Di where B': + "B = d Di@B'" "Di \ set (subseqs (unlabel D))" + "B' \ set (tr (unlabel A) [d\unlabel D. d \ set Di])" + using Cons.prems(1) a Delete unfolding d_def by auto + + obtain Di' where Di': "Di' \ set (subseqs D)" "unlabel Di' = Di" + using unlabel_subseqsD[OF B'(2)] by moura + + have 2: "\(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set [d\D. d \ set Di']. + \(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set [d\D. d \ set Di']. + p = q \ j = k" + using 1 subseqs_subset[OF Di'(1)] + filter_is_subset[of "\d. d \ set Di'"] + by blast + + have "set Di' \ set D" by (rule subseqs_subset[OF Di'(1)]) + hence "\(j, p)\set D \ set Di'. \(k, q)\set D \ set Di'. p = q \ j = k" + using Cons.prems(2) by blast + hence 3: "[d\unlabel D. d \ set Di] = unlabel [d\D. d \ set Di']" + using Di'(2) unlabel_filter_eq[of D "set Di'"] unfolding unlabel_def by auto + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c A [d\D. d \ set Di'])" "B' = unlabel C" + using 3 Cons.IH[OF _ 2] B'(3) by auto + hence 4: "c ia Di'@C \ set (tr'\<^sub>p\<^sub>c (a#A) D)" using Di'(1) a Delete unfolding c_def by auto + + have "unlabel (c ia Di') = d Di" using Di' 3 unfolding c_def d_def unlabel_def by auto + hence 5: "B = unlabel (c ia Di'@C)" using B'(1) C(2) unlabel_append[of "c ia Di'" C] by simp + + show ?thesis using 4 5 by blast + next + case (InSet ac t s) + then obtain B' d where B': + "B = \ac: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#B'" + "B' \ set (tr (unlabel A) (unlabel D))" + "d \ set (unlabel D)" + using Cons.prems(1) a by auto + thus ?thesis using Cons.IH[OF _ 1] a InSet unfolding unlabel_def by auto + next + case (NegChecks X F F') + then obtain B' where B': + "B = map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (unlabel D))@B'" + "B' \ set (tr (unlabel A) (unlabel D))" + using Cons.prems(1) a by auto + thus ?thesis using Cons.IH[OF _ 1] a NegChecks unfolding unlabel_def by auto + qed + qed simp +qed + +subsubsection \Part 2\ +private lemma tr_par_iff_tr'_par: + assumes "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + (\\. Unifier \ (pair p) (pair q)) \ i = j" + (is "?R3 A D") + and "\(l,t,s) \ set D. (fv t \ fv s) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" (is "?R4 A D") + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" (is "?R5 A D") + shows "(\B \ set (tr\<^sub>p\<^sub>c A D). \M; unlabel B\\<^sub>d \) \ (\C \ set (tr'\<^sub>p\<^sub>c A D). \M; unlabel C\\<^sub>d \)" + (is "?P \ ?Q") +proof + { fix B assume "B \ set (tr\<^sub>p\<^sub>c A D)" "\M; unlabel B\\<^sub>d \" + hence ?Q using assms + proof (induction A D arbitrary: B M rule: tr\<^sub>p\<^sub>c.induct) + case (1 D) thus ?case by simp + next + case (2 i t S D) + note prems = "2.prems" + note IH = "2.IH" + + obtain B' where B': "B = (i,send\t\\<^sub>s\<^sub>t)#B'" "B' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(1) by moura + + have 1: "\M; unlabel B'\\<^sub>d \" using prems(2) B'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + have 7: "M \ t \ \" using prems(2) B'(1) by simp + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S D)" "\M; unlabel C\\<^sub>d \" + using IH[OF B'(2) 1 4 5 6] by moura + hence "((i,send\t\\<^sub>s\<^sub>t)#C) \ set (tr'\<^sub>p\<^sub>c ((i,Send t)#S) D)" "\M; unlabel ((i,send\t\\<^sub>s\<^sub>t)#C)\\<^sub>d \" + using 7 by auto + thus ?case by metis + next + case (3 i t S D) + note prems = "3.prems" + note IH = "3.IH" + + obtain B' where B': "B = (i,receive\t\\<^sub>s\<^sub>t)#B'" "B' \ set (tr\<^sub>p\<^sub>c S D)" using prems(1) by moura + + have 1: "\insert (t \ \) M; unlabel B'\\<^sub>d \ " using prems(2) B'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S D)" "\insert (t \ \) M; unlabel C\\<^sub>d \" + using IH[OF B'(2) 1 4 5 6] by moura + hence "((i,receive\t\\<^sub>s\<^sub>t)#C) \ set (tr'\<^sub>p\<^sub>c ((i,receive\t\)#S) D)" + "\insert (t \ \) M; unlabel ((i,receive\t\\<^sub>s\<^sub>t)#C)\\<^sub>d \" + by auto + thus ?case by auto + next + case (4 i ac t t' S D) + note prems = "4.prems" + note IH = "4.IH" + + obtain B' where B': "B = (i,\ac: t \ t'\\<^sub>s\<^sub>t)#B'" "B' \ set (tr\<^sub>p\<^sub>c S D)" + using prems(1) by moura + + have 1: "\M; unlabel B'\\<^sub>d \ " using prems(2) B'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + have 7: "t \ \ = t' \ \" using prems(2) B'(1) by simp + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S D)" "\M; unlabel C\\<^sub>d \" + using IH[OF B'(2) 1 4 5 6] by moura + hence "((i,\ac: t \ t'\\<^sub>s\<^sub>t)#C) \ set (tr'\<^sub>p\<^sub>c ((i,Equality ac t t')#S) D)" + "\M; unlabel ((i,\ac: t \ t'\\<^sub>s\<^sub>t)#C)\\<^sub>d \" + using 7 by auto + thus ?case by metis + next + case (5 i t s S D) + note prems = "5.prems" + note IH = "5.IH" + + have B: "B \ set (tr\<^sub>p\<^sub>c S (List.insert (i,t,s) D))" using prems(1) by simp + + have 1: "\M; unlabel B\\<^sub>d \ " using prems(2) B(1) by simp + have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force + have 6: "?R5 S D" using prems(5) by force + + show ?case using IH[OF B(1) 1 4 5 6] by simp + next + case (6 i t s S D) + note prems = "6.prems" + note IH = "6.IH" + + let ?cl1 = "\Di. map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + let ?cu1 = "\Di. map (\d. \check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) Di" + let ?cl2 = "\Di. map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d\set Di]" + let ?cu2 = "\Di. map (\d. \[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\dbproj i D. d\set Di]" + + let ?dl1 = "\Di. map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + let ?du1 = "\Di. map (\d. \check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) Di" + let ?dl2 = "\Di. map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\D. d\set Di]" + let ?du2 = "\Di. map (\d. \[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\D. d\set Di]" + + define c where c: "c = (\Di. ?cl1 Di@?cl2 Di)" + define d where d: "d = (\Di. ?dl1 Di@?dl2 Di)" + + obtain B' Di where B': + "Di \ set (subseqs (dbproj i D))" "B = c Di@B'" "B' \ set (tr\<^sub>p\<^sub>c S [d\D. d \ set Di])" + using prems(1) c by moura + + have 0: "ik\<^sub>s\<^sub>t (unlabel (c Di)) = {}" "ik\<^sub>s\<^sub>t (unlabel (d Di)) = {}" + "unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di" + "unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di" + unfolding c d unlabel_def by force+ + + have 1: "\M; unlabel B'\\<^sub>d \ " using prems(2) B'(2) 0(1) unfolding unlabel_def by auto + + { fix j p k q + assume "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence 4: "?R3 S [d\D. d \ set Di]" by blast + + have 5: "?R4 S (filter (\d. d \ set Di) D)" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S [d\D . d \ set Di])" "\M; unlabel C\\<^sub>d \" + using IH[OF B'(1,3) 1 4 5 6] by moura + + have 7: "\M; unlabel (c Di)\\<^sub>d \" "\M; unlabel B'\\<^sub>d \" + using prems(2) B'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel B'"] + unfolding c unlabel_def by auto + + have "\M; unlabel (?cl2 Di)\\<^sub>d \" using 7(1) 0(1) unfolding c unlabel_def by auto + hence "\M; ?cu2 Di\\<^sub>d \" by (metis 0(4)) + moreover { + fix j p k q + assume "(j, p) \ {(i, t, s)} \ set D \ set Di" + "(k, q) \ {(i, t, s)} \ set D \ set Di" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence "\(j, p) \ {(i, t, s)} \ set D \ set Di. + \(k, q) \ {(i, t, s)} \ set D \ set Di. + (\\. Unifier \ (pair p) (pair q)) \ j = k" + by blast + ultimately have "\M; ?du2 Di\\<^sub>d \" using labeled_sat_ineq_lift by simp + hence "\M; unlabel (?dl2 Di)\\<^sub>d \" by (metis 0(6)) + moreover have "\M; unlabel (?cl1 Di)\\<^sub>d \" using 7(1) unfolding c unlabel_def by auto + hence "\M; unlabel (?dl1 Di)\\<^sub>d \" by (metis 0(3,5)) + ultimately have "\M; unlabel (d Di)\\<^sub>d \" using 0(2) unfolding c d unlabel_def by force + hence 8: "\M; unlabel (d Di@C)\\<^sub>d \" using 0(2) C(2) unfolding unlabel_def by auto + + have 9: "d Di@C \ set (tr'\<^sub>p\<^sub>c ((i,delete\t,s\)#S) D)" + using C(1) dbproj_subseq_in_subseqs[OF B'(1)] + unfolding d unlabel_def by auto + + show ?case by (metis 8 9) + next + case (7 i ac t s S D) + note prems = "7.prems" + note IH = "7.IH" + + obtain B' d where B': + "B = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#B'" + "B' \ set (tr\<^sub>p\<^sub>c S D)" "d \ set (dbproj i D)" + using prems(1) by moura + + have 1: "\M; unlabel B'\\<^sub>d \ " using prems(2) B'(1) by simp + + { fix j p k q + assume "(j,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D" + "(k,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D" + hence "(j,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + "(k,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence 4: "?R3 S D" by blast + + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + have 7: "pair (t,s) \ \ = pair (snd d) \ \" using prems(2) B'(1) by simp + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S D)" "\M; unlabel C\\<^sub>d \" + using IH[OF B'(2) 1 4 5 6] by moura + hence "((i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#C) \ set (tr'\<^sub>p\<^sub>c ((i,InSet ac t s)#S) D)" + "\M; unlabel ((i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#C)\\<^sub>d \" + using 7 B'(3) by auto + thus ?case by metis + next + case (8 i X F F' S D) + note prems = "8.prems" + note IH = "8.IH" + + let ?cl = "map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + let ?cu = "map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + + let ?dl = "map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))" + let ?du = "map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))" + + define c where c: "c = ?cl" + define d where d: "d = ?dl" + + obtain B' where B': "B = c@B'" "B' \ set (tr\<^sub>p\<^sub>c S D)" using prems(1) c by moura + + have 0: "ik\<^sub>s\<^sub>t (unlabel c) = {}" "ik\<^sub>s\<^sub>t (unlabel d) = {}" + "unlabel ?cl = ?cu" "unlabel ?dl = ?du" + unfolding c d unlabel_def by force+ + + have "ik\<^sub>s\<^sub>t (unlabel c) = {}" unfolding c unlabel_def by force + hence 1: "\M; unlabel B'\\<^sub>d \ " using prems(2) B'(1) unfolding unlabel_def by auto + + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S)" by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence 4: "?R3 S D" using prems(3) by blast + + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain C where C: "C \ set (tr'\<^sub>p\<^sub>c S D)" "\M; unlabel C\\<^sub>d \" + using IH[OF B'(2) 1 4 5 6] by moura + + have 7: "\M; unlabel c\\<^sub>d \" "\M; unlabel B'\\<^sub>d \" + using prems(2) B'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel B'"] + unfolding c unlabel_def by auto + + have 8: "d@C \ set (tr'\<^sub>p\<^sub>c ((i,NegChecks X F F')#S) D)" + using C(1) unfolding d unlabel_def by auto + + have "\M; unlabel ?cl\\<^sub>d \" using 7(1) unfolding c unlabel_def by auto + hence "\M; ?cu\\<^sub>d \" by (metis 0(3)) + moreover { + fix j p k q + assume "(j, p) \ ((\(t,s). (i,t,s)) ` set F') \ set D" + "(k, q) \ ((\(t,s). (i,t,s)) ` set F') \ set D" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence "\(j, p) \ ((\(t,s). (i,t,s)) ` set F') \ set D. + \(k, q) \ ((\(t,s). (i,t,s)) ` set F') \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" + by blast + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (map snd D) \ set X = {}" + using prems(4) by fastforce + ultimately have "\M; ?du\\<^sub>d \" using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp + hence "\M; unlabel ?dl\\<^sub>d \" by (metis 0(4)) + hence "\M; unlabel d\\<^sub>d \" using 0(2) unfolding c d unlabel_def by force + hence 9: "\M; unlabel (d@C)\\<^sub>d \" using 0(2) C(2) unfolding unlabel_def by auto + + show ?case by (metis 8 9) + qed + } thus "?P \ ?Q" by metis + + { fix C assume "C \ set (tr'\<^sub>p\<^sub>c A D)" "\M; unlabel C\\<^sub>d \" + hence ?P using assms + proof (induction A D arbitrary: C M rule: tr'\<^sub>p\<^sub>c.induct) + case (1 D) thus ?case by simp + next + case (2 i t S D) + note prems = "2.prems" + note IH = "2.IH" + + obtain C' where C': "C = (i,send\t\\<^sub>s\<^sub>t)#C'" "C' \ set (tr'\<^sub>p\<^sub>c S D)" + using prems(1) by moura + + have 1: "\M; unlabel C'\\<^sub>d \ " using prems(2) C'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + have 7: "M \ t \ \" using prems(2) C'(1) by simp + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S D)" "\M; unlabel B\\<^sub>d \" + using IH[OF C'(2) 1 4 5 6] by moura + hence "((i,send\t\\<^sub>s\<^sub>t)#B) \ set (tr\<^sub>p\<^sub>c ((i,Send t)#S) D)" + "\M; unlabel ((i,send\t\\<^sub>s\<^sub>t)#B)\\<^sub>d \" + using 7 by auto + thus ?case by metis + next + case (3 i t S D) + note prems = "3.prems" + note IH = "3.IH" + + obtain C' where C': "C = (i,receive\t\\<^sub>s\<^sub>t)#C'" "C' \ set (tr'\<^sub>p\<^sub>c S D)" + using prems(1) by moura + + have 1: "\insert (t \ \) M; unlabel C'\\<^sub>d \ " using prems(2) C'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S D)" "\insert (t \ \) M; unlabel B\\<^sub>d \" + using IH[OF C'(2) 1 4 5 6] by moura + hence "((i,receive\t\\<^sub>s\<^sub>t)#B) \ set (tr\<^sub>p\<^sub>c ((i,receive\t\)#S) D)" + "\insert (t \ \) M; unlabel ((i,receive\t\\<^sub>s\<^sub>t)#B)\\<^sub>d \" + by auto + thus ?case by auto + next + case (4 i ac t t' S D) + note prems = "4.prems" + note IH = "4.IH" + + obtain C' where C': "C = (i,\ac: t \ t'\\<^sub>s\<^sub>t)#C'" "C' \ set (tr'\<^sub>p\<^sub>c S D)" + using prems(1) by moura + + have 1: "\M; unlabel C'\\<^sub>d \ " using prems(2) C'(1) by simp + have 4: "?R3 S D" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + have 7: "t \ \ = t' \ \" using prems(2) C'(1) by simp + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S D)" "\M; unlabel B\\<^sub>d \" + using IH[OF C'(2) 1 4 5 6] by moura + hence "((i,\ac: t \ t'\\<^sub>s\<^sub>t)#B) \ set (tr\<^sub>p\<^sub>c ((i,Equality ac t t')#S) D)" + "\M; unlabel ((i,\ac: t \ t'\\<^sub>s\<^sub>t)#B)\\<^sub>d \" + using 7 by auto + thus ?case by metis + next + case (5 i t s S D) + note prems = "5.prems" + note IH = "5.IH" + + have C: "C \ set (tr'\<^sub>p\<^sub>c S (List.insert (i,t,s) D))" using prems(1) by simp + + have 1: "\M; unlabel C\\<^sub>d \ " using prems(2) C(1) by simp + have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force + have 6: "?R5 S (List.insert (i,t,s) D)" using prems(5) by force + + show ?case using IH[OF C(1) 1 4 5 6] by simp + next + case (6 i t s S D) + note prems = "6.prems" + note IH = "6.IH" + + let ?dl1 = "\Di. map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + let ?du1 = "\Di. map (\d. \check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) Di" + let ?dl2 = "\Di. map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\dbproj i D. d\set Di]" + let ?du2 = "\Di. map (\d. \[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\dbproj i D. d\set Di]" + + let ?cl1 = "\Di. map (\d. (i,\check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)) Di" + let ?cu1 = "\Di. map (\d. \check: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t) Di" + let ?cl2 = "\Di. map (\d. (i,\[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t)) [d\D. d\set Di]" + let ?cu2 = "\Di. map (\d. \[]\\\: [(pair (t,s), pair (snd d))]\\<^sub>s\<^sub>t) [d\D. d\set Di]" + + define c where c: "c = (\Di. ?cl1 Di@?cl2 Di)" + define d where d: "d = (\Di. ?dl1 Di@?dl2 Di)" + + obtain C' Di where C': + "Di \ set (subseqs D)" "C = c Di@C'" "C' \ set (tr'\<^sub>p\<^sub>c S [d\D. d \ set Di])" + using prems(1) c by moura + + have 0: "ik\<^sub>s\<^sub>t (unlabel (c Di)) = {}" "ik\<^sub>s\<^sub>t (unlabel (d Di)) = {}" + "unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di" + "unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di" + unfolding c d unlabel_def by force+ + + have 1: "\M; unlabel C'\\<^sub>d \ " using prems(2) C'(2) 0(1) unfolding unlabel_def by auto + + { fix j p k q + assume "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set [d\D. d \ set Di]" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence 4: "?R3 S [d\D. d \ set Di]" by blast + + have 5: "?R4 S (filter (\d. d \ set Di) D)" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S [d\D. d \ set Di])" "\M; unlabel B\\<^sub>d \" + using IH[OF C'(1,3) 1 4 5 6] by moura + + have 7: "\M; unlabel (c Di)\\<^sub>d \" "\M; unlabel C'\\<^sub>d \" + using prems(2) C'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel C'"] + unfolding c unlabel_def by auto + + { fix j p k q + assume "(j, p) \ {(i, t, s)} \ set D" + "(k, q) \ {(i, t, s)} \ set D" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, delete\t,s\)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence "\(j, p) \ {(i, t, s)} \ set D. + \(k, q) \ {(i, t, s)} \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" + by blast + moreover have "\M; unlabel (?cl1 Di)\\<^sub>d \" using 7(1) unfolding c unlabel_append by auto + hence "\M; ?cu1 Di\\<^sub>d \" by (metis 0(3)) + ultimately have *: "Di \ set (subseqs (dbproj i D))" + using labeled_sat_eqs_subseqs[OF C'(1)] by simp + hence 8: "d Di@B \ set (tr\<^sub>p\<^sub>c ((i,delete\t,s\)#S) D)" + using B(1) unfolding d unlabel_def by auto + + have "\M; unlabel (?cl2 Di)\\<^sub>d \" using 7(1) 0(1) unfolding c unlabel_def by auto + hence "\M; ?cu2 Di\\<^sub>d \" by (metis 0(4)) + hence "\M; ?du2 Di\\<^sub>d \" by (metis labeled_sat_ineq_dbproj) + hence "\M; unlabel (?dl2 Di)\\<^sub>d \" by (metis 0(6)) + moreover have "\M; unlabel (?cl1 Di)\\<^sub>d \" using 7(1) unfolding c unlabel_def by auto + hence "\M; unlabel (?dl1 Di)\\<^sub>d \" by (metis 0(3,5)) + ultimately have "\M; unlabel (d Di)\\<^sub>d \" using 0(2) unfolding c d unlabel_def by force + hence 9: "\M; unlabel (d Di@B)\\<^sub>d \" using 0(2) B(2) unfolding unlabel_def by auto + + show ?case by (metis 8 9) + next + case (7 i ac t s S D) + note prems = "7.prems" + note IH = "7.IH" + + obtain C' d where C': + "C = (i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#C'" + "C' \ set (tr'\<^sub>p\<^sub>c S D)" "d \ set D" + using prems(1) by moura + + have 1: "\M; unlabel C'\\<^sub>d \ " using prems(2) C'(1) by simp + + { fix j p k q + assume "(j,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D" + "(k,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ set D" + hence "(j,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + "(k,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence 4: "?R3 S D" by blast + + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S D)" "\M; unlabel B\\<^sub>d \" + using IH[OF C'(2) 1 4 5 6] by moura + + have 7: "pair (t,s) \ \ = pair (snd d) \ \" using prems(2) C'(1) by simp + + have "(i,t,s) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + "(fst d, snd d) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, InSet ac t s)#S) \ set D" + using C'(3) by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "\\. Unifier \ (pair (t,s)) (pair (snd d)) \ i = fst d" + using prems(3) by blast + hence "fst d = i" using 7 by auto + hence 8: "d \ set (dbproj i D)" using C'(3) by auto + + have 9: "((i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#B) \ set (tr\<^sub>p\<^sub>c ((i,InSet ac t s)#S) D)" + using B 8 by auto + have 10: "\M; unlabel ((i,\ac: (pair (t,s)) \ (pair (snd d))\\<^sub>s\<^sub>t)#B)\\<^sub>d \" + using B 7 8 by auto + + show ?case by (metis 9 10) + next + case (8 i X F F' S D) + note prems = "8.prems" + note IH = "8.IH" + + let ?dl = "map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + let ?du = "map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd (dbproj i D)))" + + let ?cl = "map (\G. (i,\X\\\: (F@G)\\<^sub>s\<^sub>t)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))" + let ?cu = "map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' (map snd D))" + + define c where c: "c = ?cl" + define d where d: "d = ?dl" + + obtain C' where C': "C = c@C'" "C' \ set (tr'\<^sub>p\<^sub>c S D)" using prems(1) c by moura + + have 0: "ik\<^sub>s\<^sub>t (unlabel c) = {}" "ik\<^sub>s\<^sub>t (unlabel d) = {}" + "unlabel ?cl = ?cu" "unlabel ?dl = ?du" + unfolding c d unlabel_def by force+ + + have "ik\<^sub>s\<^sub>t (unlabel c) = {}" unfolding c unlabel_def by force + hence 1: "\M; unlabel C'\\<^sub>d \ " using prems(2) C'(1) unfolding unlabel_def by auto + + have "setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S)" by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence 4: "?R3 S D" using prems(3) by blast + + have 5: "?R4 S D" using prems(4) by force + have 6: "?R5 S D" using prems(5) by force + + obtain B where B: "B \ set (tr\<^sub>p\<^sub>c S D)" "\M; unlabel B\\<^sub>d \" + using IH[OF C'(2) 1 4 5 6] by moura + + have 7: "\M; unlabel c\\<^sub>d \" "\M; unlabel C'\\<^sub>d \" + using prems(2) C'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel C'"] + unfolding c unlabel_def by auto + + have 8: "d@B \ set (tr\<^sub>p\<^sub>c ((i,NegChecks X F F')#S) D)" + using B(1) unfolding d unlabel_def by auto + + have "\M; unlabel ?cl\\<^sub>d \" using 7(1) unfolding c unlabel_def by auto + hence "\M; ?cu\\<^sub>d \" by (metis 0(3)) + moreover { + fix j p k q + assume "(j, p) \ ((\(t,s). (i,t,s)) ` set F') \ set D" + "(k, q) \ ((\(t,s). (i,t,s)) ` set F') \ set D" + hence "(j, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S) \ set D" + "(k, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((i, NegChecks X F F')#S) \ set D" + by (auto simp add: setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def) + hence "(\\. Unifier \ (pair p) (pair q)) \ j = k" using prems(3) by blast + } hence "\(j, p) \ ((\(t,s). (i,t,s)) ` set F') \ set D. + \(k, q) \ ((\(t,s). (i,t,s)) ` set F') \ set D. + (\\. Unifier \ (pair p) (pair q)) \ j = k" + by blast + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (map snd D) \ set X = {}" + using prems(4) by fastforce + ultimately have "\M; ?du\\<^sub>d \" using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp + hence "\M; unlabel ?dl\\<^sub>d \" by (metis 0(4)) + hence "\M; unlabel d\\<^sub>d \" using 0(2) unfolding c d unlabel_def by force + hence 9: "\M; unlabel (d@B)\\<^sub>d \" using 0(2) B(2) unfolding unlabel_def by auto + + show ?case by (metis 8 9) + qed + } thus "?Q \ ?P" by metis +qed + + +subsubsection \Part 3\ +private lemma tr'_par_sem_equiv: + assumes "\(l,t,s) \ set D. (fv t \ fv s) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" "ground M" + and "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + (\\. Unifier \ (pair p) (pair q)) \ i = j" (is "?R A D") + and \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\M; set (unlabel D) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; unlabel A\\<^sub>s \ \ (\B \ set (tr'\<^sub>p\<^sub>c A D). \M; unlabel B\\<^sub>d \)" + (is "?P \ ?Q") +proof - + have 1: "\(t,s) \ set (unlabel D). (fv t \ fv s) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + using assms(1) unfolding unlabel_def by force + + have 2: "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. p = q \ i = j" + using assms(4) subst_apply_term_empty by blast + + show ?thesis by (metis tr_sem_equiv'[OF 1 assms(2,3) \] tr'_par_iff_unlabel_tr[OF 2]) +qed + + +subsubsection \Part 4\ +lemma tr_par_sem_equiv: + assumes "\(l,t,s) \ set D. (fv t \ fv s) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" + and "fv\<^sub>s\<^sub>s\<^sub>t (unlabel A) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel A) = {}" "ground M" + and "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ set D. + (\\. Unifier \ (pair p) (pair q)) \ i = j" + and \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\M; set (unlabel D) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; unlabel A\\<^sub>s \ \ (\B \ set (tr\<^sub>p\<^sub>c A D). \M; unlabel B\\<^sub>d \)" + (is "?P \ ?Q") +using tr_par_iff_tr'_par[OF assms(4,1,2), of M \] tr'_par_sem_equiv[OF assms] by metis + +end + + +subsection \Theorem: The Stateful Compositionality Result, on the Constraint Level\ +theorem par_comp_constr_stateful: + assumes \: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ Sec" "typing_cond\<^sub>s\<^sub>s\<^sub>t (unlabel \)" + and \: "\ \\<^sub>s unlabel \" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ (\\<^sub>\ \\<^sub>s unlabel \) \ + ((\n. \\<^sub>\ \\<^sub>s proj_unl n \) \ (\\'. prefix \' \ \ (\' leaks Sec under \\<^sub>\)))" +proof - + let ?P = "\n A D. + \(i, p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) \ set D. + \(j, q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) \ set D. + (\\. Unifier \ (pair p) (pair q)) \ i = j" + + have 1: "\(l, t, t')\set []. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel \) = {}" + "fv\<^sub>s\<^sub>s\<^sub>t (unlabel \) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel \) = {}" "ground {}" + using \(2) unfolding typing_cond\<^sub>s\<^sub>s\<^sub>t_def by simp_all + + have 2: "\n. \(l, t, t')\set []. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n \) = {}" + "\n. fv\<^sub>s\<^sub>s\<^sub>t (proj_unl n \) \ bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n \) = {}" + using 1(1,2) sst_vars_proj_subset[of _ \] by fast+ + + have 3: "\n. par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n \) Sec" + using par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj[OF \(1)] by metis + + have 4: + "\{}; set (unlabel []) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \'; unlabel \\\<^sub>s \' \ + (\B\set (tr\<^sub>p\<^sub>c \ []). \{}; unlabel B\\<^sub>d \')" + when \': "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \'" for \' + using tr_par_sem_equiv[OF 1 _ \'] \(1) + unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def constr_sem_d_def by auto + + obtain \' where \': "\' \ set (tr\<^sub>p\<^sub>c \ [])" "\ \ \unlabel \'\" + using 4[OF \(2)] \(1) unfolding constr_sem_d_def by moura + + obtain \\<^sub>\ where \\<^sub>\: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" "\\<^sub>\ \ \unlabel \'\" + "(\n. (\\<^sub>\ \ \proj_unl n \'\)) \ (\\''. prefix \'' \' \ (strand_leaks\<^sub>l\<^sub>s\<^sub>t \'' Sec \\<^sub>\))" + using par_comp_constr[OF tr_par_preserves_par_comp[OF \(1) \'(1)] + tr_par_preserves_typing_cond[OF \ \'(1)] + \'(2) \(2)] + by moura + + have \\<^sub>\': "\\<^sub>\ \\<^sub>s unlabel \" using 4[OF \\<^sub>\(1)] \'(1) \\<^sub>\(4) unfolding constr_sem_d_def by auto + + show ?thesis + proof (cases "\n. (\\<^sub>\ \ \proj_unl n \'\)") + case True + { fix n assume "\\<^sub>\ \ \proj_unl n \'\" + hence "\{}; {}; unlabel (proj n \)\\<^sub>s \\<^sub>\" + using tr_par_proj[OF \'(1), of n] + tr_par_sem_equiv[OF 2(1,2) 1(3) _ \\<^sub>\(1), of n] 3(1) + unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def proj_def constr_sem_d_def by force + } thus ?thesis using True \\<^sub>\(1,2,3) \\<^sub>\' by metis + next + case False + then obtain \''::"('fun,'var,'lbl) labeled_strand" where \'': + "prefix \'' \'" "strand_leaks\<^sub>l\<^sub>s\<^sub>t \'' Sec \\<^sub>\" + using \\<^sub>\ by blast + moreover { + fix t l assume *: "\{}; unlabel (proj l \'')@[send\t\\<^sub>s\<^sub>t]\\<^sub>d \\<^sub>\" + have "\\<^sub>\ \ \unlabel (proj l \'')\" "ik\<^sub>s\<^sub>t (unlabel (proj l \'')) \\<^sub>s\<^sub>e\<^sub>t \\<^sub>\ \ t \ \\<^sub>\" + using strand_sem_split(3,4)[OF *] unfolding constr_sem_d_def by auto + } ultimately have "\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \'' \\<^sub>\. \l. + (\\<^sub>\ \ \unlabel (proj l \'')\) \ ik\<^sub>s\<^sub>t (unlabel (proj l \'')) \\<^sub>s\<^sub>e\<^sub>t \\<^sub>\ \ t \ \\<^sub>\" + unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>t_def constr_sem_d_def by metis + then obtain s m where sm: + "s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t \'' \\<^sub>\" + "\\<^sub>\ \ \unlabel (proj m \'')\" + "ik\<^sub>s\<^sub>t (unlabel (proj m \'')) \\<^sub>s\<^sub>e\<^sub>t \\<^sub>\ \ s \ \\<^sub>\" + by moura + + \ \ + We now need to show that there is some prefix \B\ of \\''\ that also leaks + and where \B \ set (tr C D)\ for some prefix \C\ of \\\ + \ + obtain B::"('fun,'var,'lbl) labeled_strand" + and C::"('fun,'var,'lbl) labeled_stateful_strand" + where BC: + "prefix B \'" "prefix C \" "B \ set (tr\<^sub>p\<^sub>c C [])" + "ik\<^sub>s\<^sub>t (unlabel (proj m B)) \\<^sub>s\<^sub>e\<^sub>t \\<^sub>\ \ s \ \\<^sub>\" + "prefix B \''" + using tr_leaking_prefix_exists[OF \'(1) \''(1) sm(3)] prefix_order.order_trans[OF _ \''(1)] + by auto + have "\{}; unlabel (proj m B)\\<^sub>d \\<^sub>\" + using sm(2) BC(5) unfolding prefix_def unlabel_def proj_def constr_sem_d_def by auto + hence BC': "\\<^sub>\ \ \proj_unl m B@[send\s\\<^sub>s\<^sub>t]\" + using BC(4) unfolding constr_sem_d_def by auto + have BC'': "s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>t B \\<^sub>\" + using BC(5) sm(1) unfolding prefix_def declassified\<^sub>l\<^sub>s\<^sub>t_def by auto + have 5: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n C) Sec" for n + using \(1) BC(2) par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_split(1)[THEN par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj] + unfolding prefix_def by auto + have "fv\<^sub>s\<^sub>s\<^sub>t (unlabel \) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel \) = {}" + "fv\<^sub>s\<^sub>s\<^sub>t (unlabel C) \ fv\<^sub>s\<^sub>s\<^sub>t (unlabel \)" + "bvars\<^sub>s\<^sub>s\<^sub>t (unlabel C) \ bvars\<^sub>s\<^sub>s\<^sub>t (unlabel \)" + using \(2) BC(2) sst_vars_append_subset(1,2)[of "unlabel C"] + unfolding typing_cond\<^sub>s\<^sub>s\<^sub>t_def prefix_def unlabel_def by auto + hence "fv\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) \ bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) = {}" for n + using sst_vars_proj_subset[of _ C] sst_vars_proj_subset[of _ \] + by blast + hence 6: + "\(l, t, t')\set []. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) = {}" + "fv\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) \ bvars\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) = {}" + "ground {}" + for n + using 2 by auto + have 7: "?P n C []" for n using 5 unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp + have "s \ \\<^sub>\ = s" using \\<^sub>\(1) BC'' \(1) unfolding par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + hence "\n. (\\<^sub>\ \\<^sub>s proj_unl n C) \ ik\<^sub>s\<^sub>s\<^sub>t (proj_unl n C) \\<^sub>s\<^sub>e\<^sub>t \\<^sub>\ \ s \ \\<^sub>\" + using tr_par_proj[OF BC(3), of m] BC'(1) + tr_par_sem_equiv[OF 6 7 \\<^sub>\(1), of m] + tr_par_deduct_iff[OF tr_par_proj(1)[OF BC(3)], of \\<^sub>\ m s] + unfolding proj_def constr_sem_d_def by auto + hence "\n. \\<^sub>\ \\<^sub>s (proj_unl n C@[Send s])" using strand_sem_append_stateful by simp + moreover have "s \ Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t C \\<^sub>\" by (metis tr_par_declassified_eq BC(3) BC'') + ultimately show ?thesis using \\<^sub>\(1,2,3) \\<^sub>\' BC(2) unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by metis + qed +qed + + +subsection \Theorem: The Stateful Compositionality Result, on the Protocol Level\ +abbreviation wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t where + "wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t V \ \ wf'\<^sub>s\<^sub>s\<^sub>t V (unlabel \)" + +text \ + We state our result on the level of protocol traces (i.e., the constraints reachable in a + symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands + to intruder constraints in the following well-formedness definitions. +\ +definition wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s::"('fun,'var,'lbl) labeled_stateful_strand set \ bool" where + "wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s \ \ (\\ \ \. wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t {} \) \ (\\ \ \. \\' \ \. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' = {})" + +definition wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s':: + "('fun,'var,'lbl) labeled_stateful_strand set \ ('fun,'var,'lbl) labeled_stateful_strand \ bool" +where + "wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s' \ \ \ (\\' \ \. wf'\<^sub>s\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \) (unlabel \')) \ + (\\' \ \. \\'' \ \. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \'' = {}) \ + (\\' \ \. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = {}) \ + (\\' \ \. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' = {})" + +definition typing_cond_prot_stateful where + "typing_cond_prot_stateful \

\ + wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s \

\ + tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

) \ pair ` \(setops\<^sub>s\<^sub>s\<^sub>t ` unlabel ` \

)) \ + wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

)) \ + (\S \ \

. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel S))" + +definition par_comp_prot_stateful where + "par_comp_prot_stateful \

Sec \ + (\l1 l2. l1 \ l2 \ + GSMP_disjoint (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Sec) \ + ground Sec \ (\s \ Sec. \s' \ subterms s. {} \\<^sub>c s' \ s' \ Sec) \ + (\(i,p) \ \\ \ \

. setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. \(j,q) \ \\ \ \

. setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. + (\\. Unifier \ (pair p) (pair q)) \ i = j) \ + typing_cond_prot_stateful \

" + +definition component_secure_prot_stateful where + "component_secure_prot_stateful n P Sec attack \ + (\\ \ P. suffix [(ln n, Send (Fun attack []))] \ \ + (\\\<^sub>\. (interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)) \ + \(\\<^sub>\ \\<^sub>s (proj_unl n \)) \ + (\\'. prefix \' \ \ + (\t \ Sec-declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \\<^sub>\. \(\\<^sub>\ \\<^sub>s (proj_unl n \'@[Send t]))))))" + +definition component_leaks_stateful where + "component_leaks_stateful n \ Sec \ + (\\' \\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ prefix \' \ \ + (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \\<^sub>\. (\\<^sub>\ \\<^sub>s (proj_unl n \'@[Send t]))))" + +definition unsat_stateful where + "unsat_stateful \ \ (\\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \(\ \\<^sub>s unlabel \))" + +lemma wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s_eqs_wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s'[simp]: "wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s S = wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s' S []" +unfolding wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s_def wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s'_def unlabel_def wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma par_comp_prot_impl_par_comp_stateful: + assumes "par_comp_prot_stateful \

Sec" "\ \ \

" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ Sec" +proof - + have *: + "\l1 l2. l1 \ l2 \ + GSMP_disjoint (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Sec" + using assms(1) unfolding par_comp_prot_stateful_def by argo + { fix l1 l2::'lbl assume **: "l1 \ l2" + hence ***: + "GSMP_disjoint (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (\\ \ \

. trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Sec" + using * by auto + have "GSMP_disjoint (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Sec" + using GSMP_disjoint_subset[OF ***] assms(2) by auto + } hence "\l1 l2. l1 \ l2 \ + GSMP_disjoint (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l1 \)) + (trms\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l2 \)) Sec" + by metis + moreover have "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t \. + (\\. Unifier \ (pair p) (pair q)) \ i = j" + using assms(1,2) unfolding par_comp_prot_stateful_def by blast + ultimately show ?thesis + using assms + unfolding par_comp_prot_stateful_def par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def + by fast +qed + +lemma typing_cond_prot_impl_typing_cond_stateful: + assumes "typing_cond_prot_stateful \

" "\ \ \

" + shows "typing_cond\<^sub>s\<^sub>s\<^sub>t (unlabel \)" +proof - + have 1: "wf'\<^sub>s\<^sub>s\<^sub>t {} (unlabel \)" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ = {}" + using assms unfolding typing_cond_prot_stateful_def wf\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>s_def by auto + + have "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

) \ pair ` \(setops\<^sub>s\<^sub>s\<^sub>t ` unlabel ` \

))" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

))" + "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ \(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

)" + "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel \)) - Var`\ \ + SMP (\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

) \ pair ` \(setops\<^sub>s\<^sub>s\<^sub>t ` unlabel ` \

)) - Var`\" + using assms SMP_mono[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel \)" + "\(trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ` \

) \ pair ` \(setops\<^sub>s\<^sub>s\<^sub>t ` unlabel ` \

)"] + unfolding typing_cond_prot_stateful_def + by (metis, metis, auto) + hence 2: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel \))" and 3: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \)" + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (meson subsetD)+ + + have 4: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel \)" using assms unfolding typing_cond_prot_stateful_def by auto + + show ?thesis using 1 2 3 4 unfolding typing_cond\<^sub>s\<^sub>s\<^sub>t_def tfr\<^sub>s\<^sub>s\<^sub>t_def by blast +qed + +theorem par_comp_constr_prot_stateful: + assumes P: "P = composed_prot Pi" "par_comp_prot_stateful P Sec" "\n. component_prot n (Pi n)" + and left_secure: "component_secure_prot_stateful n (Pi n) Sec attack" + shows "\\ \ P. suffix [(ln n, Send (Fun attack []))] \ \ + unsat_stateful \ \ (\m. n \ m \ component_leaks_stateful m \ Sec)" +proof - + { fix \ \' assume \: "\ = \'@[(ln n, Send (Fun attack []))]" "\ \ P" + let ?P = "\\' \\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ prefix \' \ \ + (\t \ Sec-declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \\<^sub>\. \m. n \ m \ (\\<^sub>\ \\<^sub>s (proj_unl m \'@[Send t])))" + have tcp: "typing_cond_prot_stateful P" using P(2) unfolding par_comp_prot_stateful_def by simp + have par_comp: "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t \ Sec" "typing_cond\<^sub>s\<^sub>s\<^sub>t (unlabel \)" + using par_comp_prot_impl_par_comp_stateful[OF P(2) \(2)] + typing_cond_prot_impl_typing_cond_stateful[OF tcp \(2)] + by metis+ + + have "unlabel (proj n \) = proj_unl n \" "proj_unl n \ = proj_unl n (proj n \)" + "\A. A \ Pi n \ proj n A = A" + "proj n \ = (proj n \')@[(ln n, Send (Fun attack []))]" + using P(1,3) \ by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def) + moreover have "proj n \ \ Pi n" + using P(1) \ unfolding composed_prot_def by blast + moreover { + fix A assume "prefix A \" + hence *: "prefix (proj n A) (proj n \)" unfolding proj_def prefix_def by force + hence "proj_unl n A = proj_unl n (proj n A)" + "\I. declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A) I" + unfolding proj_def declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto + hence "\B. prefix B (proj n \) \ proj_unl n A = proj_unl n B \ + (\I. declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t B I)" + using * by metis + } + ultimately have *: + "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\) \ + \(\\<^sub>\ \\<^sub>s (proj_unl n \)) \ (\\'. prefix \' \ \ + (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \\<^sub>\. \(\\<^sub>\ \\<^sub>s (proj_unl n \'@[Send t]))))" + using left_secure + unfolding component_secure_prot_stateful_def composed_prot_def suffix_def + by metis + { fix \ assume \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\ \\<^sub>s unlabel \" + obtain \\<^sub>\ where \\<^sub>\: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + "\\'. prefix \' \ \ (\' leaks Sec under \\<^sub>\)" + using par_comp_constr_stateful[OF par_comp \(2,1)] * by moura + hence "\\'. prefix \' \ \ (\t \ Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \' \\<^sub>\. \m. + n \ m \ (\\<^sub>\ \\<^sub>s (proj_unl m \'@[Send t])))" + using \\<^sub>\(4) * unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by metis + hence ?P using \\<^sub>\(1,2,3) by auto + } hence "unsat_stateful \ \ (\m. n \ m \ component_leaks_stateful m \ Sec)" + by (metis unsat_stateful_def component_leaks_stateful_def) + } thus ?thesis unfolding suffix_def by metis +qed + +end + +subsection \Automated Compositionality Conditions\ +definition comp_GSMP_disjoint where + "comp_GSMP_disjoint public arity Ana \ A' B' A B C \ + let B\ = B \\<^sub>l\<^sub>i\<^sub>s\<^sub>t var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (set A))) + in has_all_wt_instances_of \ (set A') (set A) \ + has_all_wt_instances_of \ (set B') (set B\) \ + finite_SMP_representation arity Ana \ A \ + finite_SMP_representation arity Ana \ B\ \ + (\t \ set A. \s \ set B\. \ t = \ s \ mgu t s \ None \ + (intruder_synth' public arity {} t \ intruder_synth' public arity {} s) \ + (\u \ set C. is_wt_instance_of_cond \ t u) \ (\u \ set C. is_wt_instance_of_cond \ s u))" + +definition comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t where + "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \ pair_fun A M C \ + let L = remdups (map (the_LabelN \ fst) (filter (Not \ is_LabelS) A)); + MP0 = \B. remdups (trms_list\<^sub>s\<^sub>s\<^sub>t B@map (pair' pair_fun) (setops_list\<^sub>s\<^sub>s\<^sub>t B)); + pr = \l. MP0 (proj_unl l A) + in length L > 1 \ + list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (MP0 (unlabel A)) \ + list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) C \ + has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set C)) (set C) \ + is_TComp_var_instance_closed \ C \ + (\i \ set L. \j \ set L. i \ j \ + comp_GSMP_disjoint public arity Ana \ (pr i) (pr j) (M i) (M j) C) \ + (\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. i \ j \ + (let s = pair' pair_fun p; t = pair' pair_fun q + in mgu s (t \ var_rename (max_var s)) = None))" + +locale labeled_stateful_typed_model' = + stateful_typed_model' arity public Ana \ Pair ++ labeled_typed_model' arity public Ana \ label_witness1 label_witness2 + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,(('fun,'atom::finite) term_type \ nat)) term + \ (('fun,(('fun,'atom) term_type \ nat)) term list + \ ('fun,(('fun,'atom) term_type \ nat)) term list)" + and \::"('fun,(('fun,'atom) term_type \ nat)) term \ ('fun,'atom) term_type" + and Pair::"'fun" + and label_witness1::"'lbl" + and label_witness2::"'lbl" +begin + +sublocale labeled_stateful_typed_model +by unfold_locales + +lemma GSMP_disjoint_if_comp_GSMP_disjoint: + defines "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + assumes AB'_wf: "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) A'" "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) B'" + and C_wf: "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) C" + and AB'_disj: "comp_GSMP_disjoint public arity Ana \ A' B' A B C" + shows "GSMP_disjoint (set A') (set B') ((f (set C)) - {m. {} \\<^sub>c m})" +using GSMP_disjointI[of A' B' A B] AB'_wf AB'_disj C_wf +unfolding comp_GSMP_disjoint_def f_def wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff Let_def by fast + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_if_comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t: + defines "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + assumes A: "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \ Pair A M C" + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A ((f (set C)) - {m. {} \\<^sub>c m})" +proof (unfold par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def; intro conjI) + let ?Sec = "(f (set C)) - {m. {} \\<^sub>c m}" + let ?L = "remdups (map (the_LabelN \ fst) (filter (Not \ is_LabelS) A))" + let ?N1 = "\B. remdups (trms_list\<^sub>s\<^sub>s\<^sub>t B@map (pair' Pair) (setops_list\<^sub>s\<^sub>s\<^sub>t B))" + let ?N2 = "\B. trms\<^sub>s\<^sub>s\<^sub>t B \ pair ` setops\<^sub>s\<^sub>s\<^sub>t B" + let ?pr = "\l. ?N1 (proj_unl l A)" + let ?\ = "\p. var_rename (max_var (pair p))" + + have 0: + "length ?L > 1" + "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (?N1 (unlabel A))" + "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) C" + "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set C)) (set C)" + "is_TComp_var_instance_closed \ C" + "\i \ set ?L. \j \ set ?L. i \ j \ + comp_GSMP_disjoint public arity Ana \ (?pr i) (?pr j) (M i) (M j) C" + "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. i \ j \ mgu (pair p) (pair q \ ?\ p) = None" + using A unfolding comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def pair_code by meson+ + + have L_in_iff: "l \ set ?L \ (\a \ set A. is_LabelN l a)" for l by force + + have A_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A))" + using 0(2) + unfolding pair_code wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t setops_list\<^sub>s\<^sub>s\<^sub>t_is_setops\<^sub>s\<^sub>s\<^sub>t + by auto + hence A_proj_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (proj_unl l A))" for l + using trms\<^sub>s\<^sub>s\<^sub>t_proj_subset(1)[of l A] setops\<^sub>s\<^sub>s\<^sub>t_proj_subset(1)[of l A] by blast + hence A_proj_wf_trms': "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (?N1 (proj_unl l A))" for l + unfolding pair_code wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t setops_list\<^sub>s\<^sub>s\<^sub>t_is_setops\<^sub>s\<^sub>s\<^sub>t + by auto + + note C_wf_trms = 0(3)[unfolded list_all_iff wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric]] + + note 1 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF C_wf_trms] C_wf_trms 0(4)] + + have 2: "GSMP (?N2 (proj_unl l A)) \ GSMP (?N2 (proj_unl l' A))" when "l \ set ?L" for l l' + using that L_in_iff GSMP_mono[of "?N2 (proj_unl l A)" "?N2 (proj_unl l' A)"] + trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label[of l A] + setops\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label[of l A] + unfolding list_ex_iff by fast + + have 3: "GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec" + when "l1 \ set ?L" "l2 \ set ?L" "l1 \ l2" for l1 l2 + proof - + have "GSMP_disjoint (set (?N1 (proj_unl l1 A))) (set (?N1 (proj_unl l2 A))) ?Sec" + using 0(6) that + GSMP_disjoint_if_comp_GSMP_disjoint[ + OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3), + of "M l1" "M l2"] + unfolding f_def by blast + thus ?thesis + unfolding pair_code trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t setops_list\<^sub>s\<^sub>s\<^sub>t_is_setops\<^sub>s\<^sub>s\<^sub>t + by simp + qed + + obtain a1 a2 where a: "a1 \ set ?L" "a2 \ set ?L" "a1 \ a2" + using remdups_ex2[OF 0(1)] by moura + + show "ground ?Sec" unfolding f_def by fastforce + + { fix i p j q + assume p: "(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" and q: "(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" + and pq: "\\. Unifier \ (pair p) (pair q)" + + have "\\. Unifier \ (pair p) (pair q \ ?\ p)" + using pq vars_term_disjoint_imp_unifier[OF var_rename_fv_disjoint[of "pair p"], of _ "pair q"] + by (metis (no_types, lifting) subst_subst_compose var_rename_inv_comp) + hence "i = j" using 0(7) mgu_None_is_subst_neq[of "pair p" "pair q \ ?\ p"] p q by fast + } thus "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. (\\. Unifier \ (pair p) (pair q)) \ i = j" + by blast + + show "\l1 l2. l1 \ l2 \ GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec" + using 2 3 3[OF a] unfolding GSMP_disjoint_def by blast + + show "\s \ ?Sec. \s' \ subterms s. {} \\<^sub>c s' \ s' \ ?Sec" + proof (intro ballI) + fix s s' + assume s: "s \ ?Sec" and s': "s' \ s" + then obtain t \ where t: "t \ set C" "s = t \ \" "fv s = {}" "\{} \\<^sub>c s" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + unfolding f_def by blast + + obtain m \ where m: "m \ set C" "s' = m \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using TComp_var_and_subterm_instance_closed_has_subterms_instances[ + OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] \] + by blast + thus "{} \\<^sub>c s' \ s' \ ?Sec" + using ground_subterm[OF t(3) s'] + unfolding f_def by blast + qed +qed + +lemma par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_if_comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t': + defines "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + assumes a: "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \ Pair A M C" + and B: "\b \ set B. \a \ set A. \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + (is "\b \ set B. \a \ set A. \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ ?D \") + shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t B ((f (set C)) - {m. {} \\<^sub>c m})" +proof (unfold par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def; intro conjI) + define N1 where "N1 \ \B::('fun, ('fun,'atom) term_type \ nat) stateful_strand. + remdups (trms_list\<^sub>s\<^sub>s\<^sub>t B@map (pair' Pair) (setops_list\<^sub>s\<^sub>s\<^sub>t B))" + + define N2 where "N2 \ \B::('fun, ('fun,'atom) term_type \ nat) stateful_strand. + trms\<^sub>s\<^sub>s\<^sub>t B \ pair ` setops\<^sub>s\<^sub>s\<^sub>t B" + + define L where "L \ \A::('fun, ('fun,'atom) term_type \ nat, 'lbl) labeled_stateful_strand. + remdups (map (the_LabelN \ fst) (filter (Not \ is_LabelS) A))" + + define \ where "\ \ \p. var_rename (max_var (pair p::('fun, ('fun,'atom) term_type \ nat) term)) + ::('fun, ('fun,'atom) term_type \ nat) subst" + + let ?Sec = "(f (set C)) - {m. {} \\<^sub>c m}" + + have 0: + "length (L A) > 1" + "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (N1 (unlabel A))" + "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) C" + "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set C)) (set C)" + "is_TComp_var_instance_closed \ C" + "\i \ set (L A). \j \ set (L A). i \ j \ + comp_GSMP_disjoint public arity Ana \ (N1 (proj_unl i A)) (N1 (proj_unl j A)) (M i) (M j) C" + "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. i \ j \ mgu (pair p) (pair q \ \ p) = None" + using a unfolding comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def pair_code L_def N1_def \_def by meson+ + + note 1 = trms\<^sub>s\<^sub>s\<^sub>t_proj_subset(1) setops\<^sub>s\<^sub>s\<^sub>t_proj_subset(1) + + have N1_iff_N2: "set (N1 A) = N2 A" for A + unfolding pair_code trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t setops_list\<^sub>s\<^sub>s\<^sub>t_is_setops\<^sub>s\<^sub>s\<^sub>t N1_def N2_def by simp + + have N2_proj_subset: "N2 (proj_unl l A) \ N2 (unlabel A)" + for l::'lbl and A::"('fun, ('fun,'atom) term_type \ nat, 'lbl) labeled_stateful_strand" + using 1(1)[of l A] image_mono[OF 1(2)[of l A], of pair] unfolding N2_def by blast + + have L_in_iff: "l \ set (L A) \ (\a \ set A. is_LabelN l a)" for l A + unfolding L_def by force + + have L_B_subset_A: "l \ set (L A)" when l: "l \ set (L B)" for l + using L_in_iff[of l B] L_in_iff[of l A] B l by fastforce + + note B_setops = setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t_wt_instance_ex[OF B] + + have B_proj: "\b \ set (proj l B). \a \ set (proj l A). \\. b = a \\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \ ?D \" for l + using proj_instance_ex[OF B] by fast + + have B': "\t \ N2 (unlabel B). \s \ N2 (unlabel A). \\. t = s \ \ \ ?D \" + using trms\<^sub>s\<^sub>s\<^sub>t_setops\<^sub>s\<^sub>s\<^sub>t_wt_instance_ex[OF B] unfolding N2_def by blast + + have B'_proj: "\t \ N2 (proj_unl l B). \s \ N2 (proj_unl l A). \\. t = s \ \ \ ?D \" for l + using trms\<^sub>s\<^sub>s\<^sub>t_setops\<^sub>s\<^sub>s\<^sub>t_wt_instance_ex[OF B_proj] unfolding N2_def by presburger + + have A_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (N2 (unlabel A))" + using N1_iff_N2[of "unlabel A"] 0(2) unfolding wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff by auto + hence A_proj_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (N2 (proj_unl l A))" for l + using 1[of l] unfolding N2_def by blast + hence A_proj_wf_trms': "list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (N1 (proj_unl l A))" for l + using N1_iff_N2[of "proj_unl l A"] unfolding wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff by presburger + + note C_wf_trms = 0(3)[unfolded list_all_iff wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric]] + + have 2: "GSMP (N2 (proj_unl l A)) \ GSMP (N2 (proj_unl l' A))" + when "l \ set (L A)" for l l' + and A::"('fun, ('fun,'atom) term_type \ nat, 'lbl) labeled_stateful_strand" + using that L_in_iff[of _ A] GSMP_mono[of "N2 (proj_unl l A)" "N2 (proj_unl l' A)"] + trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label[of l A] + setops\<^sub>s\<^sub>s\<^sub>t_unlabel_subset_if_no_label[of l A] + unfolding list_ex_iff N2_def by fast + + have 3: "GSMP (N2 (proj_unl l B)) \ GSMP (N2 (proj_unl l A))" (is "?X \ ?Y") for l + proof + fix t assume "t \ ?X" + hence t: "t \ SMP (N2 (proj_unl l B))" "fv t = {}" unfolding GSMP_def by simp_all + have "t \ SMP (N2 (proj_unl l A))" + using t(1) B'_proj[of l] SMP_wt_instances_subset[of "N2 (proj_unl l B)" "N2 (proj_unl l A)"] + by metis + thus "t \ ?Y" using t(2) unfolding GSMP_def by fast + qed + + have "GSMP_disjoint (N2 (proj_unl l1 A)) (N2 (proj_unl l2 A)) ?Sec" + when "l1 \ set (L A)" "l2 \ set (L A)" "l1 \ l2" for l1 l2 + proof - + have "GSMP_disjoint (set (N1 (proj_unl l1 A))) (set (N1 (proj_unl l2 A))) ?Sec" + using 0(6) that + GSMP_disjoint_if_comp_GSMP_disjoint[ + OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3), + of "M l1" "M l2"] + unfolding f_def by blast + thus ?thesis using N1_iff_N2 by simp + qed + hence 4: "GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec" + when "l1 \ set (L A)" "l2 \ set (L A)" "l1 \ l2" for l1 l2 + using that 3 unfolding GSMP_disjoint_def by blast + + { fix i p j q + assume p: "(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" and q: "(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" + and pq: "\\. Unifier \ (pair p) (pair q)" + + obtain p' \p where p': "(i,p') \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "p = p' \\<^sub>p \p" "pair p = pair p' \ \p" + using p B_setops unfolding pair_def by auto + + obtain q' \q where q': "(j,q') \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "q = q' \\<^sub>p \q" "pair q = pair q' \ \q" + using q B_setops unfolding pair_def by auto + + obtain \ where "Unifier \ (pair p) (pair q)" using pq by blast + hence "\\. Unifier \ (pair p') (pair q' \ \ p')" + using p'(3) q'(3) var_rename_inv_comp[of "pair q'"] subst_subst_compose + vars_term_disjoint_imp_unifier[ + OF var_rename_fv_disjoint[of "pair p'"], + of "\p \\<^sub>s \" "pair q'" "var_rename_inv (max_var_set (fv (pair p'))) \\<^sub>s \q \\<^sub>s \"] + unfolding \_def by fastforce + hence "i = j" + using mgu_None_is_subst_neq[of "pair p'" "pair q' \ \ p'"] p'(1) q'(1) 0(7) + unfolding \_def by fast + } thus "\(i,p) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. \(j,q) \ setops\<^sub>l\<^sub>s\<^sub>s\<^sub>t B. (\\. Unifier \ (pair p) (pair q)) \ i = j" + by blast + + obtain a1 a2 where a: "a1 \ set (L A)" "a2 \ set (L A)" "a1 \ a2" + using remdups_ex2[OF 0(1)[unfolded L_def]] unfolding L_def by moura + + show "\l1 l2. l1 \ l2 \ GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec" + using 2[of _ B] 4 4[OF a] L_B_subset_A unfolding GSMP_disjoint_def by blast + + show "ground ?Sec" unfolding f_def by fastforce + + show "\s \ ?Sec. \s' \ subterms s. {} \\<^sub>c s' \ s' \ ?Sec" + proof (intro ballI) + fix s s' + assume s: "s \ ?Sec" and s': "s' \ s" + then obtain t \ where t: "t \ set C" "s = t \ \" "fv s = {}" "\{} \\<^sub>c s" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + unfolding f_def by blast + + obtain m \ where m: "m \ set C" "s' = m \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using TComp_var_and_subterm_instance_closed_has_subterms_instances[ + OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] \] + by blast + thus "{} \\<^sub>c s' \ s' \ ?Sec" + using ground_subterm[OF t(3) s'] + unfolding f_def by blast + qed +qed + +end + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Stateful_Strands.thy b/Stateful_Protocol_Composition_and_Typing/Stateful_Strands.thy new file mode 100644 index 0000000..1834645 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Stateful_Strands.thy @@ -0,0 +1,1756 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Stateful_Strands.thy + Author: Andreas Viktor Hess, DTU +*) + + +section \Stateful Strands\ +theory Stateful_Strands +imports Strands_and_Constraints +begin + +subsection \Stateful Constraints\ +datatype (funs\<^sub>s\<^sub>s\<^sub>t\<^sub>p: 'a, vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p: 'b) stateful_strand_step = + Send (the_msg: "('a,'b) term") ("send\_\" 80) +| Receive (the_msg: "('a,'b) term") ("receive\_\" 80) +| Equality (the_check: poscheckvariant) (the_lhs: "('a,'b) term") (the_rhs: "('a,'b) term") + ("\_: _ \ _\" [80,80]) +| Insert (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("insert\_,_\" 80) +| Delete (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("delete\_,_\" 80) +| InSet (the_check: poscheckvariant) (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") + ("\_: _ \ _\" [80,80]) +| NegChecks (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p: "'b list") + (the_eqs: "(('a,'b) term \ ('a,'b) term) list") + (the_ins: "(('a,'b) term \ ('a,'b) term) list") + ("\_\\\: _ \\: _\" [80,80]) +where + "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Send _) = []" +| "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Receive _) = []" +| "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Equality _ _ _) = []" +| "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert _ _) = []" +| "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete _ _) = []" +| "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ _ _) = []" + +type_synonym ('a,'b) stateful_strand = "('a,'b) stateful_strand_step list" +type_synonym ('a,'b) dbstatelist = "(('a,'b) term \ ('a,'b) term) list" +type_synonym ('a,'b) dbstate = "(('a,'b) term \ ('a,'b) term) set" + +abbreviation + "is_Assignment x \ (is_Equality x \ is_InSet x) \ the_check x = Assign" + +abbreviation + "is_Check x \ ((is_Equality x \ is_InSet x) \ the_check x = Check) \ is_NegChecks x" + +abbreviation + "is_Update x \ is_Insert x \ is_Delete x" + +abbreviation InSet_select ("select\_,_\") where "select\t,s\ \ InSet Assign t s" +abbreviation InSet_check ("\_ in _\") where "\t in s\ \ InSet Check t s" +abbreviation Equality_assign ("\_ := _\") where "\t := s\ \ Equality Assign t s" +abbreviation Equality_check ("\_ == _\") where "\t == s\ \ Equality Check t s" + +abbreviation NegChecks_Inequality1 ("\_ != _\") where + "\t != s\ \ NegChecks [] [(t,s)] []" + +abbreviation NegChecks_Inequality2 ("\_\_ != _\") where + "\x\t != s\ \ NegChecks [x] [(t,s)] []" + +abbreviation NegChecks_Inequality3 ("\_,_\_ != _\") where + "\x,y\t != s\ \ NegChecks [x,y] [(t,s)] []" + +abbreviation NegChecks_Inequality4 ("\_,_,_\_ != _\") where + "\x,y,z\t != s\ \ NegChecks [x,y,z] [(t,s)] []" + +abbreviation NegChecks_NotInSet1 ("\_ not in _\") where + "\t not in s\ \ NegChecks [] [] [(t,s)]" + +abbreviation NegChecks_NotInSet2 ("\_\_ not in _\") where + "\x\t not in s\ \ NegChecks [x] [] [(t,s)]" + +abbreviation NegChecks_NotInSet3 ("\_,_\_ not in _\") where + "\x,y\t not in s\ \ NegChecks [x,y] [] [(t,s)]" + +abbreviation NegChecks_NotInSet4 ("\_,_,_\_ not in _\") where + "\x,y,z\t not in s\ \ NegChecks [x,y,z] [] [(t,s)]" + +fun trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Send t) = {t}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Receive t) = {t}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = {t,t'}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert t t') = {t,t'}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete t t') = {t,t'}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ t t') = {t,t'}" +| "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks _ F F') = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F'" + +definition trms\<^sub>s\<^sub>s\<^sub>t where "trms\<^sub>s\<^sub>s\<^sub>t S \ \(trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p ` set S)" +declare trms\<^sub>s\<^sub>s\<^sub>t_def[simp] + +fun trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Send t) = [t]" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Receive t) = [t]" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = [t,t']" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert t t') = [t,t']" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete t t') = [t,t']" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ t t') = [t,t']" +| "trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks _ F F') = concat (map (\(t,t'). [t,t']) (F@F'))" + +definition trms_list\<^sub>s\<^sub>s\<^sub>t where "trms_list\<^sub>s\<^sub>s\<^sub>t S \ remdups (concat (map trms_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +definition ik\<^sub>s\<^sub>s\<^sub>t where "ik\<^sub>s\<^sub>s\<^sub>t A \ {t. Receive t \ set A}" + +definition bvars\<^sub>s\<^sub>s\<^sub>t::"('a,'b) stateful_strand \ 'b set" where + "bvars\<^sub>s\<^sub>s\<^sub>t S \ \(set (map (set \ bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p) S))" + +fun fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p::"('a,'b) stateful_strand_step \ 'b set" where + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Send t) = fv t" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Receive t) = fv t" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = fv t \ fv t'" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert t t') = fv t \ fv t'" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete t t') = fv t \ fv t'" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ t t') = fv t \ fv t'" +| "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks X F F') = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' - set X" + +definition fv\<^sub>s\<^sub>s\<^sub>t::"('a,'b) stateful_strand \ 'b set" where + "fv\<^sub>s\<^sub>s\<^sub>t S \ \(set (map fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +fun fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\) = fv_list t" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\) = fv_list t" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\_: t \ s\) = fv_list t@fv_list s" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\) = fv_list t@fv_list s" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\) = fv_list t@fv_list s" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\_: t \ s\) = fv_list t@fv_list s" +| "fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: F'\) = filter (\x. x \ set X) (fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@F'))" + +definition fv_list\<^sub>s\<^sub>s\<^sub>t where + "fv_list\<^sub>s\<^sub>s\<^sub>t S \ remdups (concat (map fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +declare bvars\<^sub>s\<^sub>s\<^sub>t_def[simp] +declare fv\<^sub>s\<^sub>s\<^sub>t_def[simp] + +definition vars\<^sub>s\<^sub>s\<^sub>t::"('a,'b) stateful_strand \ 'b set" where + "vars\<^sub>s\<^sub>s\<^sub>t S \ \(set (map vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +abbreviation wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p::"('a,'b) stateful_strand_step \ 'b set" where + "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ + case x of + NegChecks _ _ _ \ {} + | Equality Check _ _ \ {} + | InSet Check _ _ \ {} + | Delete _ _ \ {} + | _ \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x" + +definition wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t::"('a,'b) stateful_strand \ 'b set" where + "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ \(set (map wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +abbreviation wfvarsoccs\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ + case x of + Send t \ fv t + | Equality Assign s t \ fv s + | InSet Assign s t \ fv s \ fv t + | _ \ {}" + +definition wfvarsoccs\<^sub>s\<^sub>s\<^sub>t where + "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S \ \(set (map wfvarsoccs\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + +fun wf'\<^sub>s\<^sub>s\<^sub>t::"'b set \ ('a,'b) stateful_strand \ bool" where + "wf'\<^sub>s\<^sub>s\<^sub>t V [] = True" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Receive t#S) = (fv t \ V \ wf'\<^sub>s\<^sub>s\<^sub>t V S)" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Send t#S) = wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Equality Assign t t'#S) = (fv t' \ V \ wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S)" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Equality Check _ _#S) = wf'\<^sub>s\<^sub>s\<^sub>t V S" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Insert t s#S) = (fv t \ V \ fv s \ V \ wf'\<^sub>s\<^sub>s\<^sub>t V S)" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (Delete _ _#S) = wf'\<^sub>s\<^sub>s\<^sub>t V S" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (InSet Assign t s#S) = wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv s) S" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (InSet Check _ _#S) = wf'\<^sub>s\<^sub>s\<^sub>t V S" +| "wf'\<^sub>s\<^sub>s\<^sub>t V (NegChecks _ _ _#S) = wf'\<^sub>s\<^sub>s\<^sub>t V S" + +abbreviation "wf\<^sub>s\<^sub>s\<^sub>t S \ wf'\<^sub>s\<^sub>s\<^sub>t {} S \ fv\<^sub>s\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + +fun subst_apply_stateful_strand_step:: + "('a,'b) stateful_strand_step \ ('a,'b) subst \ ('a,'b) stateful_strand_step" + (infix "\\<^sub>s\<^sub>s\<^sub>t\<^sub>p" 51) where + "send\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = send\t \ \\" +| "receive\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = receive\t \ \\" +| "\a: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \a: (t \ \) \ (s \ \)\" +| "\a: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \a: (t \ \) \ (s \ \)\" +| "insert\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = insert\t \ \, s \ \\" +| "delete\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = delete\t \ \, s \ \\" +| "\X\\\: F \\: G\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \X\\\: (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \\: (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)\" + +definition subst_apply_stateful_strand:: + "('a,'b) stateful_strand \ ('a,'b) subst \ ('a,'b) stateful_strand" + (infix "\\<^sub>s\<^sub>s\<^sub>t" 51) where + "S \\<^sub>s\<^sub>s\<^sub>t \ \ map (\x. x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) S" + +fun dbupd\<^sub>s\<^sub>s\<^sub>t::"('f,'v) stateful_strand \ ('f,'v) subst \ ('f,'v) dbstate \ ('f,'v) dbstate" +where + "dbupd\<^sub>s\<^sub>s\<^sub>t [] I D = D" +| "dbupd\<^sub>s\<^sub>s\<^sub>t (Insert t s#A) I D = dbupd\<^sub>s\<^sub>s\<^sub>t A I (insert ((t,s) \\<^sub>p I) D)" +| "dbupd\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) I D = dbupd\<^sub>s\<^sub>s\<^sub>t A I (D - {((t,s) \\<^sub>p I)})" +| "dbupd\<^sub>s\<^sub>s\<^sub>t (_#A) I D = dbupd\<^sub>s\<^sub>s\<^sub>t A I D" + +fun db'\<^sub>s\<^sub>s\<^sub>t::"('f,'v) stateful_strand \ ('f,'v) subst \ ('f,'v) dbstatelist \ ('f,'v) dbstatelist" +where + "db'\<^sub>s\<^sub>s\<^sub>t [] I D = D" +| "db'\<^sub>s\<^sub>s\<^sub>t (Insert t s#A) I D = db'\<^sub>s\<^sub>s\<^sub>t A I (List.insert ((t,s) \\<^sub>p I) D)" +| "db'\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) I D = db'\<^sub>s\<^sub>s\<^sub>t A I (List.removeAll ((t,s) \\<^sub>p I) D)" +| "db'\<^sub>s\<^sub>s\<^sub>t (_#A) I D = db'\<^sub>s\<^sub>s\<^sub>t A I D" + +definition db\<^sub>s\<^sub>s\<^sub>t where + "db\<^sub>s\<^sub>s\<^sub>t S I \ db'\<^sub>s\<^sub>s\<^sub>t S I []" + +fun setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert t s) = {(t,s)}" +| "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete t s) = {(t,s)}" +| "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ t s) = {(t,s)}" +| "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks _ _ F') = set F'" +| "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p _ = {}" + +text \The set-operations of a stateful strand\ +definition setops\<^sub>s\<^sub>s\<^sub>t where + "setops\<^sub>s\<^sub>s\<^sub>t S \ \(setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p ` set S)" + +fun setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Insert t s) = [(t,s)]" +| "setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Delete t s) = [(t,s)]" +| "setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (InSet _ t s) = [(t,s)]" +| "setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks _ _ F') = F'" +| "setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p _ = []" + +text \The set-operations of a stateful strand (list variant)\ +definition setops_list\<^sub>s\<^sub>s\<^sub>t where + "setops_list\<^sub>s\<^sub>s\<^sub>t S \ remdups (concat (map setops_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p S))" + + +subsection \Small Lemmata\ +lemma trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t: "trms\<^sub>s\<^sub>s\<^sub>t S = set (trms_list\<^sub>s\<^sub>s\<^sub>t S)" +unfolding trms\<^sub>s\<^sub>t_def trms_list\<^sub>s\<^sub>s\<^sub>t_def +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma setops_list\<^sub>s\<^sub>s\<^sub>t_is_setops\<^sub>s\<^sub>s\<^sub>t: "setops\<^sub>s\<^sub>s\<^sub>t S = set (setops_list\<^sub>s\<^sub>s\<^sub>t S)" +unfolding setops\<^sub>s\<^sub>s\<^sub>t_def setops_list\<^sub>s\<^sub>s\<^sub>t_def +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p: "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = set (fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" +proof (cases a) + case (NegChecks X F G) thus ?thesis + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append[of F G] fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append[of F G] + fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of "F@G"] + by auto +qed (simp_all add: fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s fv_list_is_fv) + +lemma fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t: "fv\<^sub>s\<^sub>s\<^sub>t S = set (fv_list\<^sub>s\<^sub>s\<^sub>t S)" +unfolding fv\<^sub>s\<^sub>s\<^sub>t_def fv_list\<^sub>s\<^sub>s\<^sub>t_def by (induct S) (simp_all add: fv_list\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p) + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite[simp]: "finite (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) auto + +lemma trms\<^sub>s\<^sub>s\<^sub>t_finite[simp]: "finite (trms\<^sub>s\<^sub>s\<^sub>t S)" +using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by (induct S) auto + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite[simp]: "finite (vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) auto + +lemma vars\<^sub>s\<^sub>s\<^sub>t_finite[simp]: "finite (vars\<^sub>s\<^sub>s\<^sub>t S)" +using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite unfolding vars\<^sub>s\<^sub>s\<^sub>t_def by (induct S) auto + +lemma fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite[simp]: "finite (fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) auto + +lemma fv\<^sub>s\<^sub>s\<^sub>t_finite[simp]: "finite (fv\<^sub>s\<^sub>s\<^sub>t S)" +using fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite unfolding fv\<^sub>s\<^sub>s\<^sub>t_def by (induct S) auto + +lemma bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite[simp]: "finite (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x))" +by (rule finite_set) + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_finite[simp]: "finite (bvars\<^sub>s\<^sub>s\<^sub>t S)" +using bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_finite unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def by (induct S) auto + +lemma subst_sst_nil[simp]: "[] \\<^sub>s\<^sub>s\<^sub>t \ = []" +by (simp add: subst_apply_stateful_strand_def) + +lemma db\<^sub>s\<^sub>s\<^sub>t_nil[simp]: "db\<^sub>s\<^sub>s\<^sub>t [] \ = []" +by (simp add: db\<^sub>s\<^sub>s\<^sub>t_def) + +lemma ik\<^sub>s\<^sub>s\<^sub>t_nil[simp]: "ik\<^sub>s\<^sub>s\<^sub>t [] = {}" +by (simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + +lemma ik\<^sub>s\<^sub>s\<^sub>t_append[simp]: "ik\<^sub>s\<^sub>s\<^sub>t (A@B) = ik\<^sub>s\<^sub>s\<^sub>t A \ ik\<^sub>s\<^sub>s\<^sub>t B" + by (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + +lemma ik\<^sub>s\<^sub>s\<^sub>t_subst: "ik\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>s\<^sub>t \) = ik\<^sub>s\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" +proof (induction A) + case (Cons a A) thus ?case + by (cases a) (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def subst_apply_stateful_strand_def) +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t: "set (db'\<^sub>s\<^sub>s\<^sub>t A I D) = dbupd\<^sub>s\<^sub>s\<^sub>t A I (set D)" (is "?A = ?B") +proof + show "?A \ ?B" + proof + fix t s show "(t,s) \ ?A \ (t,s) \ ?B" by (induct rule: db'\<^sub>s\<^sub>s\<^sub>t.induct) auto + qed + + show "?B \ ?A" + proof + fix t s show "(t,s) \ ?B \ (t,s) \ ?A" by (induct arbitrary: D rule: dbupd\<^sub>s\<^sub>s\<^sub>t.induct) auto + qed +qed + +lemma dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd: + assumes "\a \ set A. \is_Insert a \ \is_Delete a" + shows "dbupd\<^sub>s\<^sub>s\<^sub>t A I D = D" +using assms +proof (induction A) + case (Cons a A) thus ?case by (cases a) auto +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_no_upd: + assumes "\a \ set A. \is_Insert a \ \is_Delete a" + shows "db'\<^sub>s\<^sub>s\<^sub>t A I D = D" +using assms +proof (induction A) + case (Cons a A) thus ?case by (cases a) auto +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_no_upd_append: + assumes "\b \ set B. \is_Insert b \ \is_Delete b" + shows "db'\<^sub>s\<^sub>s\<^sub>t A = db'\<^sub>s\<^sub>s\<^sub>t (A@B)" + using assms +proof (induction A) + case Nil thus ?case by (simp add: db\<^sub>s\<^sub>s\<^sub>t_no_upd) +next + case (Cons a A) thus ?case by (cases a) simp_all +qed + +lemma db\<^sub>s\<^sub>s\<^sub>t_append: + "db'\<^sub>s\<^sub>s\<^sub>t (A@B) I D = db'\<^sub>s\<^sub>s\<^sub>t B I (db'\<^sub>s\<^sub>s\<^sub>t A I D)" +proof (induction A arbitrary: D) + case (Cons a A) thus ?case by (cases a) auto +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_in_cases: + assumes "(t,s) \ set (db'\<^sub>s\<^sub>s\<^sub>t A I D)" + shows "(t,s) \ set D \ (\t' s'. insert\t',s'\ \ set A \ t = t' \ I \ s = s' \ I)" + using assms +proof (induction A arbitrary: D) + case (Cons a A) thus ?case by (cases a) fastforce+ +qed simp + +lemma db\<^sub>s\<^sub>s\<^sub>t_in_cases': + assumes "(t,s) \ set (db'\<^sub>s\<^sub>s\<^sub>t A I D)" + and "(t,s) \ set D" + shows "\B C t' s'. A = B@insert\t',s'\#C \ t = t' \ I \ s = s' \ I \ + (\t'' s''. delete\t'',s''\ \ set C \ t \ t'' \ I \ s \ s'' \ I)" + using assms(1) +proof (induction A rule: List.rev_induct) + case (snoc a A) + note * = snoc db\<^sub>s\<^sub>s\<^sub>t_append[of A "[a]" I D] + thus ?case + proof (cases a) + case (Insert t' s') + thus ?thesis using * by (cases "(t,s) \ set (db'\<^sub>s\<^sub>s\<^sub>t A I D)") force+ + next + case (Delete t' s') + hence **: "t \ t' \ I \ s \ s' \ I" using * by simp + + have "(t,s) \ set (db'\<^sub>s\<^sub>s\<^sub>t A I D)" using * Delete by force + then obtain B C u v where B: + "A = B@insert\u,v\#C" "t = u \ I" "s = v \ I" + "\t' s'. delete\t',s'\ \ set C \ t \ t' \ I \ s \ s' \ I" + using snoc.IH by moura + + have "A@[a] = B@insert\u,v\#(C@[a])" + "\t' s'. delete\t',s'\ \ set (C@[a]) \ t \ t' \ I \ s \ s' \ I" + using B(1,4) Delete ** by auto + thus ?thesis using B(2,3) by blast + qed force+ +qed (simp add: assms(2)) + +lemma db\<^sub>s\<^sub>s\<^sub>t_filter: + "db'\<^sub>s\<^sub>s\<^sub>t A I D = db'\<^sub>s\<^sub>s\<^sub>t (filter is_Update A) I D" +by (induct A I D rule: db'\<^sub>s\<^sub>s\<^sub>t.induct) simp_all + +lemma subst_sst_cons: "a#A \\<^sub>s\<^sub>s\<^sub>t \ = (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)#(A \\<^sub>s\<^sub>s\<^sub>t \)" +by (simp add: subst_apply_stateful_strand_def) + +lemma subst_sst_snoc: "A@[a] \\<^sub>s\<^sub>s\<^sub>t \ = (A \\<^sub>s\<^sub>s\<^sub>t \)@[a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \]" +by (simp add: subst_apply_stateful_strand_def) + +lemma subst_sst_append[simp]: "A@B \\<^sub>s\<^sub>s\<^sub>t \ = (A \\<^sub>s\<^sub>s\<^sub>t \)@(B \\<^sub>s\<^sub>s\<^sub>t \)" +by (simp add: subst_apply_stateful_strand_def) + +lemma sst_vars_append_subset: + "fv\<^sub>s\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>s\<^sub>t (A@B)" "bvars\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t (A@B)" + "fv\<^sub>s\<^sub>s\<^sub>t B \ fv\<^sub>s\<^sub>s\<^sub>t (A@B)" "bvars\<^sub>s\<^sub>s\<^sub>t B \ bvars\<^sub>s\<^sub>s\<^sub>t (A@B)" +by auto + +lemma sst_vars_disj_cons[simp]: "fv\<^sub>s\<^sub>s\<^sub>t (a#A) \ bvars\<^sub>s\<^sub>s\<^sub>t (a#A) = {} \ fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" +unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma fv\<^sub>s\<^sub>s\<^sub>t_cons_subset[simp]: "fv\<^sub>s\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>s\<^sub>t (a#A)" +by auto + +lemma fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases[simp]: + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) - set X" +by simp_all + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_cases[simp]: + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\) = fv t" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\) = fv t" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\) = fv t \ fv s" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\) = fv t \ fv s" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\) = fv t \ fv s" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\) = fv t \ fv s" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \ set X" (is ?A) + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: [(t,s)] \\: []\) = fv t \ fv s \ set X" (is ?B) + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: [] \\: [(t,s)]\) = fv t \ fv s \ set X" (is ?C) +proof + show ?A ?B ?C by auto +qed simp_all + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases[simp]: + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (s \ \)" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ set X" (is ?A) + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: [(t,s)] \\: []\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + fv (t \ rm_vars (set X) \) \ fv (s \ rm_vars (set X) \) \ set X" (is ?B) + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: [] \\: [(t,s)]\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + fv (t \ rm_vars (set X) \) \ fv (s \ rm_vars (set X) \) \ set X" (is ?C) +proof + show ?A ?B ?C by auto +qed simp_all + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset: "bvars\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t (a#A)" +by auto + +lemma bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" +by (cases a) auto + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_subst: "bvars\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>s\<^sub>t \) = bvars\<^sub>s\<^sub>s\<^sub>t A" +using bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[of _ \] +by (induct A) (simp_all add: subst_apply_stateful_strand_def) + +lemma bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_set_cases[simp]: + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\c: t \ s\)) = {}" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\)) = set X" +by simp_all + +lemma bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegChecks: "\is_NegChecks a \ bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = []" +by (cases a) simp_all + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_NegChecks: "bvars\<^sub>s\<^sub>s\<^sub>t A = bvars\<^sub>s\<^sub>s\<^sub>t (filter is_NegChecks A)" +proof (induction A) + case (Cons a A) thus ?case by (cases a) fastforce+ +qed simp + +lemma vars\<^sub>s\<^sub>s\<^sub>t_append[simp]: "vars\<^sub>s\<^sub>s\<^sub>t (A@B) = vars\<^sub>s\<^sub>s\<^sub>t A \ vars\<^sub>s\<^sub>s\<^sub>t B" +by (simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma vars\<^sub>s\<^sub>s\<^sub>t_Nil[simp]: "vars\<^sub>s\<^sub>s\<^sub>t [] = {}" +by (simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma vars\<^sub>s\<^sub>s\<^sub>t_Cons: "vars\<^sub>s\<^sub>s\<^sub>t (a#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \ vars\<^sub>s\<^sub>s\<^sub>t A" +by (simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma fv\<^sub>s\<^sub>s\<^sub>t_Cons: "fv\<^sub>s\<^sub>s\<^sub>t (a#A) = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \ fv\<^sub>s\<^sub>s\<^sub>t A" +unfolding fv\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_Cons: "bvars\<^sub>s\<^sub>s\<^sub>t (a#A) = set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \ bvars\<^sub>s\<^sub>s\<^sub>t A" +unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma vars\<^sub>s\<^sub>s\<^sub>t_Cons'[simp]: + "vars\<^sub>s\<^sub>s\<^sub>t (send\t\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\t\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (receive\t\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (receive\t\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (\a: t \ s\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\a: t \ s\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (insert\t,s\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,s\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (delete\t,s\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (delete\t,s\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (\a: t \ s\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\a: t \ s\) \ vars\<^sub>s\<^sub>s\<^sub>t A" + "vars\<^sub>s\<^sub>s\<^sub>t (\X\\\: F \\: G\#A) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\) \ vars\<^sub>s\<^sub>s\<^sub>t A" +by (simp_all add: vars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + fixes x::"('a,'b) stateful_strand_step" + shows "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x)" +proof (cases x) + case (NegChecks X F G) thus ?thesis by (induct F) force+ +qed simp_all + +lemma vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t: + fixes S::"('a,'b) stateful_strand" + shows "vars\<^sub>s\<^sub>s\<^sub>t S = fv\<^sub>s\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>s\<^sub>t S" +proof (induction S) + case (Cons x S) thus ?case + using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p[of x] + by (auto simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) +qed simp + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[simp]: + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\) = set X \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" +by (simp_all add: sup_commute sup_left_commute vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p) + +lemma bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[simp]: + "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\) = X" + "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\[]\\\: F \\: G\)) = {}" +by simp_all + +lemma fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegCheck[simp]: + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\X\\\: F \\: G\) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G - set X" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\[]\\\: F \\: G\) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\t != s\) = fv t \ fv s" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\t not in s\) = fv t \ fv s" +by simp_all + +lemma fv\<^sub>s\<^sub>s\<^sub>t_append[simp]: "fv\<^sub>s\<^sub>s\<^sub>t (A@B) = fv\<^sub>s\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>s\<^sub>t B" +by simp + +lemma bvars\<^sub>s\<^sub>s\<^sub>t_append[simp]: "bvars\<^sub>s\<^sub>s\<^sub>t (A@B) = bvars\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t B" +by auto + +lemma fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + assumes "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" + shows "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" +using assms var_is_subterm +proof (cases a) + case (NegChecks X F F') + hence "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' - set X" using assms by simp + thus ?thesis using NegChecks var_is_subterm by fastforce +qed force+ + +lemma fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t: "x \ fv\<^sub>s\<^sub>s\<^sub>t A \ Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t A)" +proof (induction A) + case (Cons a A) thus ?case using fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p by (cases "x \ fv\<^sub>s\<^sub>s\<^sub>t A") auto +qed simp + +lemma var_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + assumes "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" + shows "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" +using assms vars_iff_subtermeq +proof (cases a) + case (NegChecks X F F') + hence "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F')" using assms by simp + thus ?thesis using NegChecks vars_iff_subtermeq by force +qed force+ + +lemma var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t: "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t A) \ x \ vars\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) + show ?case + proof (cases "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t A)") + case True thus ?thesis using Cons.IH by (simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) + next + case False thus ?thesis + using Cons.prems var_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p + by (fastforce simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) + qed +qed simp + +lemma var_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t: "Var x \ trms\<^sub>s\<^sub>s\<^sub>t A \ x \ vars\<^sub>s\<^sub>s\<^sub>t A" +by (meson var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t UN_I term.order_refl) + +lemma ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset: "ik\<^sub>s\<^sub>s\<^sub>t A \ trms\<^sub>s\<^sub>s\<^sub>t A" +by (force simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + +lemma var_subterm_ik\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t: "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t A) \ x \ vars\<^sub>s\<^sub>s\<^sub>t A" +using var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset by fast + +lemma var_subterm_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t: + assumes "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t A)" + shows "x \ fv\<^sub>s\<^sub>s\<^sub>t A" +proof - + obtain t where t: "Receive t \ set A" "Var x \ t" using assms unfolding ik\<^sub>s\<^sub>s\<^sub>t_def by moura + hence "fv t \ fv\<^sub>s\<^sub>s\<^sub>t A" unfolding fv\<^sub>s\<^sub>s\<^sub>t_def by force + thus ?thesis using t(2) by (meson contra_subsetD subterm_is_var) +qed + +lemma fv_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t: + assumes "x \ fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t A)" + shows "x \ fv\<^sub>s\<^sub>s\<^sub>t A" +using var_subterm_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t assms var_is_subterm by fastforce + +lemma fv_trms\<^sub>s\<^sub>s\<^sub>t_subset: + "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S) \ vars\<^sub>s\<^sub>s\<^sub>t S" + "fv\<^sub>s\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" +proof (induction S) + case (Cons x S) + have *: "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t (x#S)) = fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x) \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" + "fv\<^sub>s\<^sub>s\<^sub>t (x#S) = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ fv\<^sub>s\<^sub>s\<^sub>t S" "vars\<^sub>s\<^sub>s\<^sub>t (x#S) = vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ vars\<^sub>s\<^sub>s\<^sub>t S" + unfolding trms\<^sub>s\<^sub>s\<^sub>t_def fv\<^sub>s\<^sub>s\<^sub>t_def vars\<^sub>s\<^sub>s\<^sub>t_def + by auto + + { case 1 + show ?case using Cons.IH(1) + proof (cases x) + case (NegChecks X F G) + hence "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" + "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \ set X" + by (simp, meson vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_cases(7)) + hence "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x) \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x" + using fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of F] fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of G] + by auto + thus ?thesis + using Cons.IH(1) *(1,3) + by blast + qed auto + } + + { case 2 + show ?case using Cons.IH(2) + proof (cases x) + case (NegChecks X F G) + hence "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" + "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G) - set X" + by auto + hence "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p x)" + using fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of F] fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of G] + by auto + thus ?thesis + using Cons.IH(2) *(1,2) + by blast + qed auto + } +qed simp_all + +lemma fv_ik_subset_fv_sst'[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t S) \ fv\<^sub>s\<^sub>s\<^sub>t S" +unfolding ik\<^sub>s\<^sub>s\<^sub>t_def by (induct S) auto + +lemma fv_ik_subset_vars_sst'[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t S) \ vars\<^sub>s\<^sub>s\<^sub>t S" +using fv_ik_subset_fv_sst' fv_trms\<^sub>s\<^sub>s\<^sub>t_subset by fast + +lemma ik\<^sub>s\<^sub>s\<^sub>t_var_is_fv: "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>s\<^sub>t A) \ x \ fv\<^sub>s\<^sub>s\<^sub>t A" +by (meson fv_ik_subset_fv_sst'[of A] fv_subset_subterms subsetCE term.set_intros(3)) + +lemma vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases': + assumes x: "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + shows "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s \ x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)" +using x vars_term_subst[of _ \] vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_cases(1,2,3,4,5,6) vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(1,2)[of _ \] + vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(3,6)[of _ _ _ \] vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(4,5)[of _ _ \] +proof (cases s) + case (NegChecks X F G) + let ?\' = "rm_vars (set X) \" + have "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\') \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\') \ x \ set X" + using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(7)[of X F G \] x NegChecks by simp + hence "x \ fv\<^sub>s\<^sub>e\<^sub>t (?\' ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ x \ fv\<^sub>s\<^sub>e\<^sub>t (?\' ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G) \ x \ set X" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst[of _ ?\'] by blast + hence "x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G) \ x \ set X" + using rm_vars_fv\<^sub>s\<^sub>e\<^sub>t_subst by fast + thus ?thesis + using NegChecks vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_cases(7)[of X F G] + by auto +qed simp_all + +lemma vars\<^sub>s\<^sub>s\<^sub>t_subst_cases: + assumes "x \ vars\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + shows "x \ vars\<^sub>s\<^sub>s\<^sub>t S \ x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` vars\<^sub>s\<^sub>s\<^sub>t S)" + using assms +proof (induction S) + case (Cons s S) thus ?case + proof (cases "x \ vars\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)") + case False + note * = subst_sst_cons[of s S \] vars\<^sub>s\<^sub>s\<^sub>t_Cons[of "s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "S \\<^sub>s\<^sub>s\<^sub>t \"] vars\<^sub>s\<^sub>s\<^sub>t_Cons[of s S] + have **: "x \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" using Cons.prems False * by simp + show ?thesis using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases'[OF **] * by auto + qed (auto simp add: vars\<^sub>s\<^sub>s\<^sub>t_def) +qed simp + +lemma subset_subst_pairs_diff_exists: + fixes \::"('a,'b) subst" and D D'::"('a,'b) dbstate" + shows "\Di. Di \ D \ Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ = (D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - D'" +by (metis (no_types, lifting) Diff_subset subset_image_iff) + +lemma subset_subst_pairs_diff_exists': + fixes \::"('a,'b) subst" and D::"('a,'b) dbstate" + assumes "finite D" + shows "\Di. Di \ D \ Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {d \\<^sub>p \} \ d \\<^sub>p \ \ (D - Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction D rule: finite_induct) + case (insert d' D) + then obtain Di where IH: "Di \ D" "Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {d \\<^sub>p \}" "d \\<^sub>p \ \ (D - Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" by moura + show ?case + proof (cases "d' \\<^sub>p \ = d \\<^sub>p \") + case True + hence "insert d' Di \ insert d' D" "insert d' Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {d \\<^sub>p \}" + "d \\<^sub>p \ \ (insert d' D - insert d' Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using IH by auto + thus ?thesis by metis + next + case False + hence "Di \ insert d' D" "Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {d \\<^sub>p \}" + "d \\<^sub>p \ \ (insert d' D - Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using IH by auto + thus ?thesis by metis + qed +qed simp + +lemma stateful_strand_step_subst_inI[intro]: + "send\t\ \ set A \ send\t \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "receive\t\ \ set A \ receive\t \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "\c: t \ s\ \ set A \ \c: (t \ \) \ (s \ \)\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "insert\t, s\ \ set A \ insert\t \ \, s \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "delete\t, s\ \ set A \ delete\t \ \, s \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "\c: t \ s\ \ set A \ \c: (t \ \) \ (s \ \)\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "\X\\\: F \\: G\ \ set A + \ \X\\\: (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \\: (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "\t != s\ \ set A \ \t \ \ != s \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" + "\t not in s\ \ set A \ \t \ \ not in s \ \\ \ set (A \\<^sub>s\<^sub>s\<^sub>t \)" +proof (induction A) + case (Cons a A) + note * = subst_sst_cons[of a A \] + { case 1 thus ?case using Cons.IH(1) * by (cases a) auto } + { case 2 thus ?case using Cons.IH(2) * by (cases a) auto } + { case 3 thus ?case using Cons.IH(3) * by (cases a) auto } + { case 4 thus ?case using Cons.IH(4) * by (cases a) auto } + { case 5 thus ?case using Cons.IH(5) * by (cases a) auto } + { case 6 thus ?case using Cons.IH(6) * by (cases a) auto } + { case 7 thus ?case using Cons.IH(7) * by (cases a) auto } + { case 8 thus ?case using Cons.IH(8) * by (cases a) auto } + { case 9 thus ?case using Cons.IH(9) * by (cases a) auto } +qed simp_all + +lemma stateful_strand_step_cases_subst: + "is_Send a = is_Send (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Receive a = is_Receive (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Equality a = is_Equality (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Insert a = is_Insert (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Delete a = is_Delete (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_InSet a = is_InSet (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_NegChecks a = is_NegChecks (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Assignment a = is_Assignment (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Check a = is_Check (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + "is_Update a = is_Update (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" +by (cases a; simp_all)+ + +lemma stateful_strand_step_subst_inv_cases: + "send\t\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t'. t = t' \ \ \ send\t'\ \ set S" + "receive\t\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t'. t = t' \ \ \ receive\t'\ \ set S" + "\c: t \ s\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t' s'. t = t' \ \ \ s = s' \ \ \ \c: t' \ s'\ \ set S" + "insert\t,s\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t' s'. t = t' \ \ \ s = s' \ \ \ insert\t',s'\ \ set S" + "delete\t,s\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t' s'. t = t' \ \ \ s = s' \ \ \ delete\t',s'\ \ set S" + "\c: t \ s\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ \t' s'. t = t' \ \ \ s = s' \ \ \ \c: t' \ s'\ \ set S" + "\X\\\: F \\: G\ \ set (S \\<^sub>s\<^sub>s\<^sub>t \) \ + \F' G'. F = F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \ \ G = G' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \ \ + \X\\\: F' \\: G'\ \ set S" +proof (induction S) + case (Cons a S) + have *: "x \ set (S \\<^sub>s\<^sub>s\<^sub>t \)" + when "x \ set (a#S \\<^sub>s\<^sub>s\<^sub>t \)" "x \ a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" for x + using that by (simp add: subst_apply_stateful_strand_def) + + { case 1 thus ?case using Cons.IH(1)[OF *] by (cases a) auto } + { case 2 thus ?case using Cons.IH(2)[OF *] by (cases a) auto } + { case 3 thus ?case using Cons.IH(3)[OF *] by (cases a) auto } + { case 4 thus ?case using Cons.IH(4)[OF *] by (cases a) auto } + { case 5 thus ?case using Cons.IH(5)[OF *] by (cases a) auto } + { case 6 thus ?case using Cons.IH(6)[OF *] by (cases a) auto } + { case 7 thus ?case using Cons.IH(7)[OF *] by (cases a) auto } +qed simp_all + +lemma stateful_strand_step_fv_subset_cases: + "send\t\ \ set S \ fv t \ fv\<^sub>s\<^sub>s\<^sub>t S" + "receive\t\ \ set S \ fv t \ fv\<^sub>s\<^sub>s\<^sub>t S" + "\c: t \ s\ \ set S \ fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t S" + "insert\t,s\ \ set S \ fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t S" + "delete\t,s\ \ set S \ fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t S" + "\c: t \ s\ \ set S \ fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t S" + "\X\\\: F \\: G\ \ set S \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G - set X \ fv\<^sub>s\<^sub>s\<^sub>t S" +proof (induction S) + case (Cons a S) + { case 1 thus ?case using Cons.IH(1) by auto } + { case 2 thus ?case using Cons.IH(2) by auto } + { case 3 thus ?case using Cons.IH(3) by auto } + { case 4 thus ?case using Cons.IH(4) by auto } + { case 5 thus ?case using Cons.IH(5) by auto } + { case 6 thus ?case using Cons.IH(6) by auto } + { case 7 thus ?case using Cons.IH(7) by fastforce } +qed simp_all + +lemma trms\<^sub>s\<^sub>s\<^sub>t_nil[simp]: + "trms\<^sub>s\<^sub>s\<^sub>t [] = {}" +unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_mono: + "set M \ set N \ trms\<^sub>s\<^sub>s\<^sub>t M \ trms\<^sub>s\<^sub>s\<^sub>t N" +by auto + +lemma trms\<^sub>s\<^sub>s\<^sub>t_in: + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t S" + shows "\a \ set S. t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" +using assms unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_cons: "trms\<^sub>s\<^sub>s\<^sub>t (a#A) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \ trms\<^sub>s\<^sub>s\<^sub>t A" +unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by force + +lemma trms\<^sub>s\<^sub>s\<^sub>t_append[simp]: "trms\<^sub>s\<^sub>s\<^sub>t (A@B) = trms\<^sub>s\<^sub>s\<^sub>t A \ trms\<^sub>s\<^sub>s\<^sub>t B" +unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by force + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: + assumes "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \ subst_domain \ = {}" + shows "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \" +proof (cases a) + case (NegChecks X F G) + hence "rm_vars (set X) \ = \" using assms rm_vars_apply'[of \ "set X"] by auto + hence "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \ = (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \\<^sub>s\<^sub>e\<^sub>t \) \ (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \\<^sub>s\<^sub>e\<^sub>t \)" + using NegChecks image_Un by simp_all + thus ?thesis by (metis trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst) +qed simp_all + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst': + assumes "\is_NegChecks a" + shows "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \" +using assms by (cases a) simp_all + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst'': + fixes t::"('a,'b) term" and \::"('a,'b) subst" + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + shows "\s \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p b. t = s \ rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \" +proof (cases "is_NegChecks b") + case True + then obtain X F G where *: "b = NegChecks X F G" by (cases b) moura+ + thus ?thesis using assms trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst[of _ "rm_vars (set X) \"] by auto +next + case False + hence "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \\<^sub>s\<^sub>e\<^sub>t rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \" + using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst' bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegChecks + by fastforce + thus ?thesis using assms by fast +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst''': + fixes t::"('a,'b) term" and \ \::"('a,'b) subst" + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \\<^sub>s\<^sub>e\<^sub>t \" + shows "\s \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p b. t = s \ rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \ \\<^sub>s \" +proof - + obtain s where s: "s \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" "t = s \ \" using assms by moura + show ?thesis using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst''[OF s(1)] s(2) by auto +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_subst: + assumes "bvars\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" + shows "trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) = trms\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction S) + case (Cons a S) + hence IH: "trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) = trms\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" and *: "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \ subst_domain \ = {}" + by auto + show ?case using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF *] IH by (auto simp add: subst_apply_stateful_strand_def) +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_subst_cons: + "trms\<^sub>s\<^sub>s\<^sub>t (a#A \\<^sub>s\<^sub>s\<^sub>t \) = trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ trms\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>s\<^sub>t \)" +using subst_sst_cons[of a A \] trms\<^sub>s\<^sub>s\<^sub>t_cons[of a A] trms\<^sub>s\<^sub>s\<^sub>t_append by simp + +lemma (in intruder_model) wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \))" + using assms +proof (cases a) + case (NegChecks X F G) + hence *: "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = + (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)) \ (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \))" + by simp + + have "trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \ = (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \\<^sub>s\<^sub>e\<^sub>t \) \ (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \\<^sub>s\<^sub>e\<^sub>t \)" + using NegChecks image_Un by simp + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \\<^sub>s\<^sub>e\<^sub>t \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \\<^sub>s\<^sub>e\<^sub>t \)" using * assms by auto + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \)" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \)" + using wf_trms_subst_rm_vars[of \ "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" "set X"] + wf_trms_subst_rm_vars[of \ "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" "set X"] + by fast+ + thus ?thesis + using * trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst[of _ "rm_vars (set X) \"] + by auto +qed auto + +lemma trms\<^sub>s\<^sub>s\<^sub>t_fv_vars\<^sub>s\<^sub>s\<^sub>t_subset: "t \ trms\<^sub>s\<^sub>s\<^sub>t A \ fv t \ vars\<^sub>s\<^sub>s\<^sub>t A" +proof (induction A) + case (Cons a A) thus ?case by (cases a) auto +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_fv_subst_subset: + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t S" "subst_domain \ \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "fv (t \ \) \ vars\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" +using assms +proof (induction S) + case (Cons s S) show ?case + proof (cases "t \ trms\<^sub>s\<^sub>s\<^sub>t S") + case True + hence "fv (t \ \) \ vars\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" using Cons.IH Cons.prems by auto + thus ?thesis using subst_sst_cons[of s S \] unfolding vars\<^sub>s\<^sub>s\<^sub>t_def by auto + next + case False + hence *: "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p s" "subst_domain \ \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) = {}" using Cons.prems by auto + hence "fv (t \ \) \ vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + proof (cases s) + case (NegChecks X F G) + hence **: "t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" using *(1) by auto + have ***: "rm_vars (set X) \ = \" using *(2) NegChecks rm_vars_apply' by auto + have "fv (t \ \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + using ** *** trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fv_subst_subset[of t _ \] by auto + thus ?thesis using *(2) using NegChecks vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(7)[of X F G \] by blast + qed auto + thus ?thesis using subst_sst_cons[of s S \] unfolding vars\<^sub>s\<^sub>s\<^sub>t_def by auto + qed +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t_fv_subst_subset': + assumes "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" "fv t \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" "fv (t \ \) \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "fv (t \ \) \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" +using assms +proof (induction S) + case (Cons s S) show ?case + proof (cases "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)") + case True + hence "fv (t \ \) \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" using Cons.IH Cons.prems by auto + thus ?thesis using subst_sst_cons[of s S \] unfolding vars\<^sub>s\<^sub>s\<^sub>t_def by auto + next + case False + hence 0: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)" "fv t \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) = {}" + "fv (t \ \) \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) = {}" + using Cons.prems by auto + + note 1 = UN_Un UN_insert fv\<^sub>s\<^sub>e\<^sub>t.simps subst_apply_fv_subset subst_apply_fv_unfold + subst_apply_term_empty sup_bot.comm_neutral fv_subterms_set fv_subset[OF 0(1)] + + note 2 = subst_apply_fv_union + + have "fv (t \ \) \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + proof (cases s) + case (NegChecks X F G) + hence 3: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G)" using 0(1) by auto + have "t \ rm_vars (set X) \ = t \ \" using 0(2) NegChecks rm_vars_ident[of t] by auto + hence "fv (t \ \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + using 3 trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fv_subst_subset'[of t _ "rm_vars (set X) \"] by fastforce + thus ?thesis using 0(2,3) NegChecks fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(7)[of X F G \] by auto + qed (metis (no_types, lifting) 1 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(1) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(1), + metis (no_types, lifting) 1 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(2) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(2), + metis (no_types, lifting) 1 2 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(3) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(3), + metis (no_types, lifting) 1 2 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(4) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(4), + metis (no_types, lifting) 1 2 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(5) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(5), + metis (no_types, lifting) 1 2 trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(6) fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases(6)) + thus ?thesis using subst_sst_cons[of s S \] unfolding fv\<^sub>s\<^sub>s\<^sub>t_def by auto + qed +qed simp + +lemma trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_funs_term_cases: + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" "f \ funs_term t" + shows "(\u \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p s. f \ funs_term u) \ (\x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p s. f \ funs_term (\ x))" + using assms +proof (cases s) + case (NegChecks X F G) + hence "t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + using assms(1) by auto + hence "(\u\trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. f \ funs_term u) \ (\x\fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. f \ funs_term (rm_vars (set X) \ x)) \ + (\u\trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G. f \ funs_term u) \ (\x\fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G. f \ funs_term (rm_vars (set X) \ x))" + using trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_funs_term_cases[OF _ assms(2), of _ "rm_vars (set X) \"] by meson + hence "(\u \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G. f \ funs_term u) \ + (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G. f \ funs_term (rm_vars (set X) \ x))" + by blast + thus ?thesis + proof + assume "\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G. f \ funs_term (rm_vars (set X) \ x)" + then obtain x where x: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" "f \ funs_term (rm_vars (set X) \ x)" + by auto + hence "x \ set X" "rm_vars (set X) \ x = \ x" by auto + thus ?thesis using x by (auto simp add: assms NegChecks) + qed (auto simp add: assms NegChecks) +qed (use assms funs_term_subst[of _ \] in auto) + +lemma trms\<^sub>s\<^sub>s\<^sub>t_funs_term_cases: + assumes "t \ trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" "f \ funs_term t" + shows "(\u \ trms\<^sub>s\<^sub>s\<^sub>t S. f \ funs_term u) \ (\x \ fv\<^sub>s\<^sub>s\<^sub>t S. f \ funs_term (\ x))" +using assms(1) +proof (induction S) + case (Cons s S) thus ?case + proof (cases "t \ trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)") + case False + hence "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" using Cons.prems(1) subst_sst_cons[of s S \] trms\<^sub>s\<^sub>s\<^sub>t_cons by auto + thus ?thesis using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_funs_term_cases[OF _ assms(2)] by fastforce + qed auto +qed simp + +lemma fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t_subst: + assumes "x \ fv\<^sub>s\<^sub>s\<^sub>t T" + and "bvars\<^sub>s\<^sub>s\<^sub>t T \ subst_domain \ = {}" + shows "\ x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t (T \\<^sub>s\<^sub>s\<^sub>t \))" +using trms\<^sub>s\<^sub>s\<^sub>t_subst[OF assms(2)] subterms_subst_subset'[of \ "trms\<^sub>s\<^sub>s\<^sub>t T"] + fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t[OF assms(1)] +by (metis (no_types, lifting) image_iff subset_iff subst_apply_term.simps(1)) + +lemma fv\<^sub>s\<^sub>s\<^sub>t_subst_fv_subset: + assumes "x \ fv\<^sub>s\<^sub>s\<^sub>t S" "x \ bvars\<^sub>s\<^sub>s\<^sub>t S" "fv (\ x) \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "fv (\ x) \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" +using assms +proof (induction S) + case (Cons a S) + note 1 = fv_subst_subset[of _ _ \] + note 2 = subst_apply_fv_union subst_apply_fv_unfold[of _ \] fv_subset image_eqI + note 3 = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst_cases + note 4 = fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps + from Cons show ?case + proof (cases "x \ fv\<^sub>s\<^sub>s\<^sub>t S") + case False + hence 5: "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" " fv (\ x) \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) = {}" "x \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" + using Cons.prems by auto + hence "fv (\ x) \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + proof (cases a) + case (NegChecks X F G) + let ?\ = "rm_vars (set X) \" + have *: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" using NegChecks 5(1) by auto + have **: "fv (\ x) \ set X = {}" using NegChecks 5(2) by simp + have ***: "\ x = ?\ x" using NegChecks 5(3) by auto + have "fv (\ x) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_fv_subset[of x _ ?\] * *** by auto + thus ?thesis using NegChecks ** by auto + qed (metis (full_types) 1 5(1) 3(1) 4(1), metis (full_types) 1 5(1) 3(2) 4(2), + metis (full_types) 2 5(1) 3(3) 4(3), metis (full_types) 2 5(1) 3(4) 4(4), + metis (full_types) 2 5(1) 3(5) 4(5), metis (full_types) 2 5(1) 3(6) 4(6)) + thus ?thesis by (auto simp add: subst_sst_cons[of a S \]) + qed (auto simp add: subst_sst_cons[of a S \]) +qed simp + +lemma (in intruder_model) wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_trms\<^sub>s\<^sub>s\<^sub>t_subst: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>s\<^sub>t \))" + using assms +proof (induction A) + case (Cons a A) + hence IH: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>s\<^sub>t \))" and *: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \)" by auto + have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \))" by (rule wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF *]) + thus ?case using IH trms\<^sub>s\<^sub>s\<^sub>t_subst_cons[of a A \] by blast +qed simp + +lemma fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var: + assumes "x \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + shows "\y \ fv\<^sub>s\<^sub>s\<^sub>t S. x \ fv (\ y)" + using assms +proof (induction S) + case (Cons s S) + hence "x \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) \ \y \ fv\<^sub>s\<^sub>s\<^sub>t S. x \ fv (\ y)" + using bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset[of S s] + by blast + thus ?case + proof (cases "x \ fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)") + case False + hence *: "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + using Cons.prems(1) subst_sst_cons[of s S \] + by fastforce + + have "\y \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p s. x \ fv (\ y)" + proof (cases s) + case (NegChecks X F G) + hence "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + and **: "x \ set X" + using * by simp_all + then obtain y where y: "y \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ y \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" "x \ fv ((rm_vars (set X) \) y)" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_obtain_var[of _ _ "rm_vars (set X) \"] + by blast + have "y \ set X" + proof + assume y_in: "y \ set X" + hence "(rm_vars (set X) \) y = Var y" by auto + hence "x = y" using y(2) by simp + thus False using ** y_in by metis + qed + thus ?thesis using NegChecks y by auto + qed (use * fv_subst_obtain_var in force)+ + thus ?thesis by auto + qed auto +qed simp + +lemma fv\<^sub>s\<^sub>s\<^sub>t_subst_subset_range_vars_if_subset_domain: + assumes "fv\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \" + shows "fv\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) \ range_vars \" +using assms fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var[of _ S \] subst_dom_vars_in_subst[of _ \] subst_fv_imgI[of \] +by (metis (no_types) in_mono subsetI) + +lemma fv\<^sub>s\<^sub>s\<^sub>t_in_fv_trms\<^sub>s\<^sub>s\<^sub>t: "x \ fv\<^sub>s\<^sub>s\<^sub>t S \ x \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" +proof (induction S) + case (Cons s S) thus ?case + proof (cases "x \ fv\<^sub>s\<^sub>s\<^sub>t S") + case False + hence *: "x \ fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p s" using Cons.prems by simp + hence "x \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)" + proof (cases s) + case (NegChecks X F G) + hence "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" using * by simp_all + thus ?thesis using * fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_in_fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of x] NegChecks by auto + qed auto + thus ?thesis by simp + qed simp +qed simp + +lemma stateful_strand_step_subst_comp: + assumes "range_vars \ \ set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x) = {}" + shows "x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \\<^sub>s \ = (x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" +proof (cases x) + case (NegChecks X F G) + hence *: "range_vars \ \ set X = {}" using assms by simp + have "H \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) (\ \\<^sub>s \) = (H \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \" for H + using pairs_subst_comp rm_vars_comp[OF *] by (induct H) (auto simp add: subst_apply_pairs_def) + thus ?thesis using NegChecks by simp +qed simp_all + +lemma stateful_strand_subst_comp: + assumes "range_vars \ \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "S \\<^sub>s\<^sub>s\<^sub>t \ \\<^sub>s \ = (S \\<^sub>s\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>s\<^sub>t \" +using assms +proof (induction S) + case (Cons s S) + hence IH: "S \\<^sub>s\<^sub>s\<^sub>t \ \\<^sub>s \ = (S \\<^sub>s\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>s\<^sub>t \" using Cons by auto + + have "s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ \\<^sub>s \ = (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" + using Cons.prems stateful_strand_step_subst_comp[of \ s \] + unfolding range_vars_alt_def by auto + thus ?case using IH by (simp add: subst_apply_stateful_strand_def) +qed simp + +lemma subst_apply_bvars_disj_NegChecks: + assumes "set X \ subst_domain \ = {}" + shows "NegChecks X F G \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = NegChecks X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +proof - + have "rm_vars (set X) \ = \" using assms rm_vars_apply'[of \ "set X"] by auto + thus ?thesis by simp +qed + +lemma subst_apply_NegChecks_no_bvars[simp]: + "\[]\\\: F \\: F'\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \[]\\\: (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \\: (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)\" + "\[]\\\: [] \\: F'\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \[]\\\: [] \\: (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)\" + "\[]\\\: F \\: []\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \[]\\\: (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \\: []\" + "\[]\\\: [] \\: [(t,s)]\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \[]\\\: [] \\: ([(t \ \,s \ \)])\" (is ?A) + "\[]\\\: [(t,s)] \\: []\ \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ = \[]\\\: ([(t \ \,s \ \)]) \\: []\" (is ?B) +by simp_all + +lemma setops\<^sub>s\<^sub>s\<^sub>t_mono: + "set M \ set N \ setops\<^sub>s\<^sub>s\<^sub>t M \ setops\<^sub>s\<^sub>s\<^sub>t N" +by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_nil[simp]: "setops\<^sub>s\<^sub>s\<^sub>t [] = {}" +by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_cons[simp]: "setops\<^sub>s\<^sub>s\<^sub>t (a#A) = setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \ setops\<^sub>s\<^sub>s\<^sub>t A" +by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_cons_subset[simp]: "setops\<^sub>s\<^sub>s\<^sub>t A \ setops\<^sub>s\<^sub>s\<^sub>t (a#A)" +using setops\<^sub>s\<^sub>s\<^sub>t_cons[of a A] by blast + +lemma setops\<^sub>s\<^sub>s\<^sub>t_append: "setops\<^sub>s\<^sub>s\<^sub>t (A@B) = setops\<^sub>s\<^sub>s\<^sub>t A \ setops\<^sub>s\<^sub>s\<^sub>t B" +proof (induction A) + case (Cons a A) thus ?case by (cases a) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_member_iff: + "(t,s) \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ + (x = Insert t s \ x = Delete t s \ (\ac. x = InSet ac t s) \ + (\X F F'. x = NegChecks X F F' \ (t,s) \ set F'))" +by (cases x) auto + +lemma setops\<^sub>s\<^sub>s\<^sub>t_member_iff: + "(t,s) \ setops\<^sub>s\<^sub>s\<^sub>t A \ + (Insert t s \ set A \ Delete t s \ set A \ (\ac. InSet ac t s \ set A) \ + (\X F F'. NegChecks X F F' \ set A \ (t,s) \ set F'))" + (is "?P \ ?Q") +proof (induction A) + case (Cons a A) thus ?case + proof (cases "(t, s) \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p a") + case True thus ?thesis using setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_member_iff[of t s a] by auto + qed auto +qed simp + +lemma setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: + assumes "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \ subst_domain \ = {}" + shows "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +proof (cases a) + case (NegChecks X F G) + hence "rm_vars (set X) \ = \" using assms rm_vars_apply'[of \ "set X"] by auto + hence "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = set (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ = set G \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using NegChecks image_Un by simp_all + thus ?thesis by (simp add: subst_apply_pairs_def) +qed simp_all + +lemma setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst': + assumes "\is_NegChecks a" + shows "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +using assms by (cases a) auto + +lemma setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst'': + fixes t::"('a,'b) term \ ('a,'b) term" and \::"('a,'b) subst" + assumes t: "t \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + shows "\s \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p b. t = s \\<^sub>p rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \" +proof (cases "is_NegChecks b") + case True + then obtain X F G where b: "b = NegChecks X F G" by (cases b) moura+ + hence "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p b = set G" "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = set (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \)" + by simp_all + thus ?thesis using t subst_apply_pairs_pset_subst[of G] by blast +next + case False + hence "setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (b \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) = setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \\<^sub>p\<^sub>s\<^sub>e\<^sub>t rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p b)) \" + using setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst' bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_NegChecks by fastforce + thus ?thesis using t by blast +qed + +lemma setops\<^sub>s\<^sub>s\<^sub>t_subst: + assumes "bvars\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" + shows "setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) = setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction S) + case (Cons a S) + have "bvars\<^sub>s\<^sub>s\<^sub>t S \ subst_domain \ = {}" and *: "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \ subst_domain \ = {}" + using Cons.prems by auto + hence IH: "setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) = setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using Cons.IH by auto + show ?case + using setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF *] IH unfolding setops\<^sub>s\<^sub>s\<^sub>t_def + by (auto simp add: subst_apply_stateful_strand_def) +qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_subst': + fixes p::"('a,'b) term \ ('a,'b) term" and \::"('a,'b) subst" + assumes "p \ setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + shows "\s \ setops\<^sub>s\<^sub>s\<^sub>t S. \X. set X \ bvars\<^sub>s\<^sub>s\<^sub>t S \ p = s \\<^sub>p rm_vars (set X) \" +using assms +proof (induction S) + case (Cons a S) + note 0 = setops\<^sub>s\<^sub>s\<^sub>t_cons[of a S] bvars\<^sub>s\<^sub>s\<^sub>t_Cons[of a S] + note 1 = setops\<^sub>s\<^sub>s\<^sub>t_cons[of "a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \" "S \\<^sub>s\<^sub>s\<^sub>t \"] subst_sst_cons[of a S \] + have "p \ setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \) \ p \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" using Cons.prems 1 by auto + thus ?case + proof + assume *: "p \ setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + show ?thesis using setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst''[OF *] 0 by blast + next + assume *: "p \ setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + show ?thesis using Cons.IH[OF *] 0 by blast + qed +qed simp + + +subsection \Stateful Constraint Semantics\ +context intruder_model +begin + +definition negchecks_model where + "negchecks_model (\::('a,'b) subst) (D::('a,'b) dbstate) X F G \ + (\\. subst_domain \ = set X \ ground (subst_range \) \ + (list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) F \ + list_ex (\f. f \\<^sub>p (\ \\<^sub>s \) \ D) G))" + +fun strand_sem_stateful:: + "('fun,'var) terms \ ('fun,'var) dbstate \ ('fun,'var) stateful_strand \ ('fun,'var) subst \ bool" + ("\_; _; _\\<^sub>s") +where + "\M; D; []\\<^sub>s = (\\. True)" +| "\M; D; Send t#S\\<^sub>s = (\\. M \ t \ \ \ \M; D; S\\<^sub>s \)" +| "\M; D; Receive t#S\\<^sub>s = (\\. \insert (t \ \) M; D; S\\<^sub>s \)" +| "\M; D; Equality _ t t'#S\\<^sub>s = (\\. t \ \ = t' \ \ \ \M; D; S\\<^sub>s \)" +| "\M; D; Insert t s#S\\<^sub>s = (\\. \M; insert ((t,s) \\<^sub>p \) D; S\\<^sub>s \)" +| "\M; D; Delete t s#S\\<^sub>s = (\\. \M; D - {(t,s) \\<^sub>p \}; S\\<^sub>s \)" +| "\M; D; InSet _ t s#S\\<^sub>s = (\\. (t,s) \\<^sub>p \ \ D \ \M; D; S\\<^sub>s \)" +| "\M; D; NegChecks X F F'#S\\<^sub>s = (\\. negchecks_model \ D X F F' \ \M; D; S\\<^sub>s \)" + + +lemmas strand_sem_stateful_induct = + strand_sem_stateful.induct[case_names Nil ConsSnd ConsRcv ConsEq + ConsIns ConsDel ConsIn ConsNegChecks] + +abbreviation constr_sem_stateful (infix "\\<^sub>s" 91) where "\ \\<^sub>s A \ \{}; {}; A\\<^sub>s \" + +lemma stateful_strand_sem_NegChecks_no_bvars: + "\M; D; [\t not in s\]\\<^sub>s \ \ (t \ \, s \ \) \ D" + "\M; D; [\t != s\]\\<^sub>s \ \ t \ \ \ s \ \" +by (simp_all add: negchecks_model_def empty_dom_iff_empty_subst) + +lemma strand_sem_ik_mono_stateful: + "\M; D; A\\<^sub>s \ \ \M \ M'; D; A\\<^sub>s \" +using ideduct_mono by (induct A arbitrary: M M' D rule: strand_sem_stateful.induct) force+ + +lemma strand_sem_append_stateful: + "\M; D; A@B\\<^sub>s \ \ \M; D; A\\<^sub>s \ \ \M \ (ik\<^sub>s\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \); dbupd\<^sub>s\<^sub>s\<^sub>t A \ D; B\\<^sub>s \" + (is "?P \ ?Q \ ?R") +proof - + have 1: "?P \ ?Q" by (induct A rule: strand_sem_stateful.induct) auto + + have 2: "?P \ ?R" + proof (induction A arbitrary: M D B) + case (Cons a A) thus ?case + proof (cases a) + case (Receive t) + have "insert (t \ \) (M \ (ik\<^sub>s\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \)) = M \ (ik\<^sub>s\<^sub>s\<^sub>t (a#A) \\<^sub>s\<^sub>e\<^sub>t \)" + "dbupd\<^sub>s\<^sub>s\<^sub>t A \ D = dbupd\<^sub>s\<^sub>s\<^sub>t (a#A) \ D" + using Receive by (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis using Cons Receive by force + qed (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + qed (simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + + have 3: "?Q \ ?R \ ?P" + proof (induction A arbitrary: M D) + case (Cons a A) thus ?case + proof (cases a) + case (Receive t) + have "insert (t \ \) (M \ (ik\<^sub>s\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \)) = M \ (ik\<^sub>s\<^sub>s\<^sub>t (a#A) \\<^sub>s\<^sub>e\<^sub>t \)" + "dbupd\<^sub>s\<^sub>s\<^sub>t A \ D = dbupd\<^sub>s\<^sub>s\<^sub>t (a#A) \ D" + using Receive by (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis using Cons Receive by simp + qed (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + qed (simp add: ik\<^sub>s\<^sub>s\<^sub>t_def) + + show ?thesis by (metis 1 2 3) +qed + +lemma negchecks_model_db_subset: + fixes F F'::"(('a,'b) term \ ('a,'b) term) list" + assumes "D' \ D" + and "negchecks_model \ D X F F'" + shows "negchecks_model \ D' X F F'" +proof - + have "list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ D') F'" + when "list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ D) F'" + for \::"('a,'b) subst" + using Bex_set[of F' "\f. f \\<^sub>p \ \\<^sub>s \ \ D'"] + Bex_set[of F' "\f. f \\<^sub>p \ \\<^sub>s \ \ D"] + that assms(1) + by blast + thus ?thesis using assms(2) by (auto simp add: negchecks_model_def) +qed + +lemma negchecks_model_db_supset: + fixes F F'::"(('a,'b) term \ ('a,'b) term) list" + assumes "D' \ D" + and "\f \ set F'. \\. subst_domain \ = set X \ ground (subst_range \) \ f \\<^sub>p (\ \\<^sub>s \) \ D - D'" + and "negchecks_model \ D' X F F'" + shows "negchecks_model \ D X F F'" +proof - + have "list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ D) F'" + when "list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ D') F'" "subst_domain \ = set X \ ground (subst_range \)" + for \::"('a,'b) subst" + using Bex_set[of F' "\f. f \\<^sub>p \ \\<^sub>s \ \ D'"] + Bex_set[of F' "\f. f \\<^sub>p \ \\<^sub>s \ \ D"] + that assms(1,2) + by blast + thus ?thesis using assms(3) by (auto simp add: negchecks_model_def) +qed + +lemma negchecks_model_subst: + fixes F F'::"(('a,'b) term \ ('a,'b) term) list" + assumes "(subst_domain \ \ range_vars \) \ set X = {}" + shows "negchecks_model (\ \\<^sub>s \) D X F F' \ negchecks_model \ D X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +proof - + have 0: "\ \\<^sub>s (\ \\<^sub>s \) = \ \\<^sub>s (\ \\<^sub>s \)" + when \: "subst_domain \ = set X" "ground (subst_range \)" for \ + by (metis (no_types, lifting) \ subst_compose_assoc assms(1) inf_sup_aci(1) + subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def) + + { fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. fst f \ (\ \\<^sub>s (\ \\<^sub>s \)) \ snd f \ (\ \\<^sub>s (\ \\<^sub>s \))) F" + obtain f where f: "f \ set F" "fst f \ \ \\<^sub>s (\ \\<^sub>s \) \ snd f \ \ \\<^sub>s (\ \\<^sub>s \)" + using * by (induct F) auto + hence "(fst f \ \) \ \ \\<^sub>s \ \ (snd f \ \) \ \ \\<^sub>s \" using 0[OF \] by simp + moreover have "(fst f \ \, snd f \ \) \ set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) by (auto simp add: subst_apply_pairs_def) + ultimately have "list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) Bex_set by fastforce + } moreover { + fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. f \\<^sub>p \ \\<^sub>s (\ \\<^sub>s \) \ D) F'" + obtain f where f: "f \ set F'" "f \\<^sub>p \ \\<^sub>s (\ \\<^sub>s \) \ D" + using * by (induct F') auto + hence "f \\<^sub>p \ \\<^sub>p \ \\<^sub>s \ \ D" using 0[OF \] by (metis subst_pair_compose) + moreover have "f \\<^sub>p \ \ set (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) by (auto simp add: subst_apply_pairs_def) + ultimately have "list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ D) (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) Bex_set by fastforce + } moreover { + fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + obtain f where f: "f \ set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" "fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \" + using * by (induct F) (auto simp add: subst_apply_pairs_def) + then obtain g where g: "g \ set F" "f = g \\<^sub>p \" by (auto simp add: subst_apply_pairs_def) + have "fst g \ \ \\<^sub>s (\ \\<^sub>s \) \ snd g \ \ \\<^sub>s (\ \\<^sub>s \)" + using f(2) g 0[OF \] by (simp add: prod.case_eq_if) + hence "list_ex (\f. fst f \ (\ \\<^sub>s (\ \\<^sub>s \)) \ snd f \ (\ \\<^sub>s (\ \\<^sub>s \))) F" + using g Bex_set by fastforce + } moreover { + fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. f \\<^sub>p (\ \\<^sub>s \) \ D) (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + obtain f where f: "f \ set (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" "f \\<^sub>p \ \\<^sub>s \ \ D" + using * by (induct F') (auto simp add: subst_apply_pairs_def) + then obtain g where g: "g \ set F'" "f = g \\<^sub>p \" by (auto simp add: subst_apply_pairs_def) + have "g \\<^sub>p \ \\<^sub>s (\ \\<^sub>s \) \ D" + using f(2) g 0[OF \] by (simp add: prod.case_eq_if) + hence "list_ex (\f. f \\<^sub>p (\ \\<^sub>s (\ \\<^sub>s \)) \ D) F'" + using g Bex_set by fastforce + } ultimately show ?thesis using assms unfolding negchecks_model_def by blast +qed + +lemma strand_sem_subst_stateful: + fixes \::"('fun,'var) subst" + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>s\<^sub>t S = {}" + shows "\M; D; S\\<^sub>s (\ \\<^sub>s \) \ \M; D; S \\<^sub>s\<^sub>s\<^sub>t \\\<^sub>s \" +proof + note [simp] = subst_sst_cons[of _ _ \] subst_subst_compose[of _ \ \] + + have "(subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + when \: "(subst_domain \ \ range_vars \) \ set X = {}" + and \: "subst_domain \ = set X" "ground (subst_range \)" + for X and \::"('fun,'var) subst" + using \ \ unfolding range_vars_alt_def by auto + hence 0: "\ \\<^sub>s \ = \ \\<^sub>s \" + when \: "(subst_domain \ \ range_vars \) \ set X = {}" + and \: "subst_domain \ = set X" "ground (subst_range \)" + for \ X + by (metis \ \ subst_comp_eq_if_disjoint_vars) + + show "\M; D; S\\<^sub>s (\ \\<^sub>s \) \ \M; D; S \\<^sub>s\<^sub>s\<^sub>t \\\<^sub>s \" using assms + proof (induction S arbitrary: M D rule: strand_sem_stateful_induct) + case (ConsNegChecks M D X F F' S) + hence *: "\M; D; S \\<^sub>s\<^sub>s\<^sub>t \\\<^sub>s \" and **: "(subst_domain \ \ range_vars \) \ set X = {}" + unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def negchecks_model_def by (force, auto) + have "negchecks_model (\ \\<^sub>s \) D X F F'" using ConsNegChecks by auto + hence "negchecks_model \ D X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using 0[OF **] negchecks_model_subst[OF **] by blast + moreover have "rm_vars (set X) \ = \" using ConsNegChecks.prems(2) by force + ultimately show ?case using * by auto + qed simp_all + + show "\M; D; S \\<^sub>s\<^sub>s\<^sub>t \\\<^sub>s \ \ \M; D; S\\<^sub>s (\ \\<^sub>s \)" using assms + proof (induction S arbitrary: M D rule: strand_sem_stateful_induct) + case (ConsNegChecks M D X F F' S) + have \: "rm_vars (set X) \ = \" using ConsNegChecks.prems(2) by force + hence *: "\M; D; S\\<^sub>s (\ \\<^sub>s \)" and **: "(subst_domain \ \ range_vars \) \ set X = {}" + using ConsNegChecks unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def negchecks_model_def by auto + have "negchecks_model \ D X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using ConsNegChecks.prems(1) \ by (auto simp add: subst_compose_assoc negchecks_model_def) + hence "negchecks_model (\ \\<^sub>s \) D X F F'" + using 0[OF **] negchecks_model_subst[OF **] by blast + thus ?case using * by auto + qed simp_all +qed + +end + + +subsection \Well-Formedness Lemmata\ +lemma wfvarsocc\<^sub>s\<^sub>s\<^sub>t_subset_wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t[simp]: + "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S" +by (induction S) + (auto simp add: wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def + split: stateful_strand_step.split poscheckvariant.split) + +lemma wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_append: "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (S@S') = wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S'" +by (simp add: wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_union[simp]: + "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t (S@T) = wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t T" +by (simp add: wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_singleton: + "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t [s] = wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s" +by (simp add: wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wf\<^sub>s\<^sub>s\<^sub>t_prefix[dest]: "wf'\<^sub>s\<^sub>s\<^sub>t V (S@S') \ wf'\<^sub>s\<^sub>s\<^sub>t V S" +by (induct S rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) auto + +lemma wf\<^sub>s\<^sub>s\<^sub>t_vars_mono: "wf'\<^sub>s\<^sub>s\<^sub>t V S \ wf'\<^sub>s\<^sub>s\<^sub>t (V \ W) S" +proof (induction S arbitrary: V) + case (Cons x S) thus ?case + proof (cases x) + case (Send t) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ W) S" using Cons.prems(1) Cons.IH by simp + thus ?thesis using Send by (simp add: sup_commute sup_left_commute) + next + case (Equality a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ W) S" "fv t' \ V \ W" using Equality Cons.prems(1) Cons.IH by auto + thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute) + next + case Check thus ?thesis using Equality Cons by auto + qed + next + case (InSet a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv t' \ W) S" using InSet Cons.prems(1) Cons.IH by auto + thus ?thesis using InSet Assign by (simp add: sup_commute sup_left_commute) + next + case Check thus ?thesis using InSet Cons by auto + qed + qed auto +qed simp + +lemma wf\<^sub>s\<^sub>s\<^sub>tI[intro]: "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ V \ wf'\<^sub>s\<^sub>s\<^sub>t V S" +proof (induction S) + case (Cons x S) thus ?case + proof (cases x) + case (Send t) + hence "wf'\<^sub>s\<^sub>s\<^sub>t V S" "V \ fv t = V" + using Cons + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def + by auto + thus ?thesis using Send by simp + next + case (Equality a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t V S" "fv t' \ V" + using Equality Cons + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def + by auto + thus ?thesis using wf\<^sub>s\<^sub>s\<^sub>t_vars_mono Equality Assign by simp + next + case Check + thus ?thesis + using Equality Cons + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def + by auto + qed + next + case (InSet a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t V S" "fv t \ fv t' \ V" + using InSet Cons + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def + by auto + thus ?thesis using wf\<^sub>s\<^sub>s\<^sub>t_vars_mono InSet Assign by (simp add: Un_assoc) + next + case Check + thus ?thesis + using InSet Cons + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def + by auto + qed + qed (simp_all add: wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def) +qed (simp add: wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wf\<^sub>s\<^sub>s\<^sub>tI'[intro]: + assumes "\((\x. case x of + Receive t \ fv t + | Equality Assign _ t' \ fv t' + | Insert t t' \ fv t \ fv t' + | _ \ {}) ` set S) \ V" + shows "wf'\<^sub>s\<^sub>s\<^sub>t V S" +using assms +proof (induction S) + case (Cons x S) thus ?case + proof (cases x) + case (Equality a t t') + thus ?thesis using Cons by (cases a) (auto simp add: wf\<^sub>s\<^sub>s\<^sub>t_vars_mono) + next + case (InSet a t t') + thus ?thesis using Cons by (cases a) (auto simp add: wf\<^sub>s\<^sub>s\<^sub>t_vars_mono Un_assoc) + qed (simp_all add: wf\<^sub>s\<^sub>s\<^sub>t_vars_mono) +qed simp + +lemma wf\<^sub>s\<^sub>s\<^sub>t_append_exec: "wf'\<^sub>s\<^sub>s\<^sub>t V (S@S') \ wf'\<^sub>s\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" +proof (induction S arbitrary: V) + case (Cons x S V) thus ?case + proof (cases x) + case (Send t) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" using Cons.prems Cons.IH by simp + thus ?thesis using Send unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by (auto simp add: sup_assoc) + next + case (Equality a t t') show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" using Equality Cons.prems Cons.IH by auto + thus ?thesis using Equality Assign unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by (auto simp add: sup_assoc) + next + case Check + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" using Equality Cons.prems Cons.IH by auto + thus ?thesis using Equality Check unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by (auto simp add: sup_assoc) + qed + next + case (InSet a t t') show ?thesis + proof (cases a) + case Assign + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv t' \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" using InSet Cons.prems Cons.IH by auto + thus ?thesis using InSet Assign unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by (auto simp add: sup_assoc) + next + case Check + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S) S'" using InSet Cons.prems Cons.IH by auto + thus ?thesis using InSet Check unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by (auto simp add: sup_assoc) + qed + qed (auto simp add: wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def) +qed (simp add: wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wf\<^sub>s\<^sub>s\<^sub>t_append: + "wf'\<^sub>s\<^sub>s\<^sub>t X S \ wf'\<^sub>s\<^sub>s\<^sub>t Y T \ wf'\<^sub>s\<^sub>s\<^sub>t (X \ Y) (S@T)" +proof (induction X S rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) + case 1 thus ?case by (metis wf\<^sub>s\<^sub>s\<^sub>t_vars_mono Un_commute append_Nil) +next + case 3 thus ?case by (metis append_Cons Un_commute Un_assoc wf'\<^sub>s\<^sub>s\<^sub>t.simps(3)) +next + case (4 V t t' S) + hence *: "fv t' \ V" and "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ Y) (S @ T)" by simp_all + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ Y \ fv t) (S @ T)" by (metis Un_commute Un_assoc) + thus ?case using * by auto +next + case (8 V t t' S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv t' \ Y) (S @ T)" by simp_all + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ Y \ fv t \ fv t') (S @ T)" by (metis Un_commute Un_assoc) + thus ?case by auto +qed auto + +lemma wf\<^sub>s\<^sub>s\<^sub>t_append_suffix: + "wf'\<^sub>s\<^sub>s\<^sub>t V S \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ V \ wf'\<^sub>s\<^sub>s\<^sub>t V (S@S')" +proof (induction V S rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) + case (2 V t S) + hence *: "fv t \ V" "wf'\<^sub>s\<^sub>s\<^sub>t V S" by simp_all + hence "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ V" + using "2.prems"(2) unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by auto + thus ?case using "2.IH" * by simp +next + case (3 V t S) + hence *: "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + hence "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ (V \ fv t)" + using "3.prems"(2) unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by auto + thus ?case using "3.IH" * by simp +next + case (4 V t t' S) + hence *: "fv t' \ V" "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + moreover have "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\t := t'\) = fv t \ fv t'" + by simp + moreover have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t (\t := t'\#S) = fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S" + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by auto + ultimately have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ (V \ fv t)" + using "4.prems"(2) by blast + thus ?case using "4.IH" * by simp +next + case (6 V t t' S) + hence *: "fv t \ fv t' \ V" "wf'\<^sub>s\<^sub>s\<^sub>t V S" by simp_all + moreover have "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (insert\t,t'\) = fv t \ fv t'" + by simp + moreover have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t (insert\t,t'\#S) = fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S" + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by auto + ultimately have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ V" + using "6.prems"(2) by blast + thus ?case using "6.IH" * by simp +next + case (8 V t t' S) + hence *: "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv t') S" by simp_all + moreover have "vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p (select\t,t'\) = fv t \ fv t'" + by simp + moreover have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t (select\t,t'\#S) = fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S" + unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by auto + ultimately have "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t S \ (V \ fv t \ fv t')" + using "8.prems"(2) by blast + thus ?case using "8.IH" * by simp +qed (simp_all add: wf\<^sub>s\<^sub>s\<^sub>tI wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wf\<^sub>s\<^sub>s\<^sub>t_append_suffix': + assumes "wf'\<^sub>s\<^sub>s\<^sub>t V S" + and "\((\x. case x of + Receive t \ fv t + | Equality Assign _ t' \ fv t' + | Insert t t' \ fv t \ fv t' + | _ \ {}) ` set S') \ wfvarsoccs\<^sub>s\<^sub>s\<^sub>t S \ V" + shows "wf'\<^sub>s\<^sub>s\<^sub>t V (S@S')" +using assms +by (induction V S rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) + (auto simp add: wf\<^sub>s\<^sub>s\<^sub>tI' wf\<^sub>s\<^sub>s\<^sub>t_vars_mono wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def) + +lemma wf\<^sub>s\<^sub>s\<^sub>t_subst_apply: + "wf'\<^sub>s\<^sub>s\<^sub>t V S \ wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (S \\<^sub>s\<^sub>s\<^sub>t \)" +proof (induction S arbitrary: V rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) + case (2 V t S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t V S" "fv t \ V" by simp_all + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (S \\<^sub>s\<^sub>s\<^sub>t \)" "fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using "2.IH" subst_apply_fv_subset by simp_all + thus ?case by (simp add: subst_apply_stateful_strand_def) +next + case (3 V t S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S" by simp + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t))) (S \\<^sub>s\<^sub>s\<^sub>t \)" using "3.IH" by metis + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \)) (S \\<^sub>s\<^sub>s\<^sub>t \)" by (metis subst_apply_fv_union) + thus ?case by (simp add: subst_apply_stateful_strand_def) +next + case (4 V t t' S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t) S" "fv t' \ V" by auto + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t))) (S \\<^sub>s\<^sub>s\<^sub>t \)" and *: "fv (t' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using "4.IH" subst_apply_fv_subset by force+ + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \)) (S \\<^sub>s\<^sub>s\<^sub>t \)" by (metis subst_apply_fv_union) + thus ?case using * by (simp add: subst_apply_stateful_strand_def) +next + case (6 V t t' S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t V S" "fv t \ fv t' \ V" by auto + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (S \\<^sub>s\<^sub>s\<^sub>t \)" "fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" "fv (t' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using "6.IH" subst_apply_fv_subset by force+ + thus ?case by (simp add: sup_assoc subst_apply_stateful_strand_def) +next + case (8 V t t' S) + hence "wf'\<^sub>s\<^sub>s\<^sub>t (V \ fv t \ fv t') S" by auto + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t \ fv t'))) (S \\<^sub>s\<^sub>s\<^sub>t \)" + using "8.IH" subst_apply_fv_subset by force + hence "wf'\<^sub>s\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \) \ fv (t' \ \)) (S \\<^sub>s\<^sub>s\<^sub>t \)" by (metis subst_apply_fv_union) + thus ?case by (simp add: subst_apply_stateful_strand_def) +qed (auto simp add: subst_apply_stateful_strand_def) + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Stateful_Typing.thy b/Stateful_Protocol_Composition_and_Typing/Stateful_Typing.thy new file mode 100644 index 0000000..9e71d12 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Stateful_Typing.thy @@ -0,0 +1,1871 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2018-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Stateful_Typing.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Extending the Typing Result to Stateful Constraints\ + +theory Stateful_Typing +imports Typing_Result Stateful_Strands +begin + +text \Locale setup\ +locale stateful_typed_model = typed_model arity public Ana \ + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,'var) term \ (('fun,'var) term list \ ('fun,'var) term list)" + and \::"('fun,'var) term \ ('fun,'atom::finite) term_type" + + + fixes Pair::"'fun" + assumes Pair_arity: "arity Pair = 2" + and Ana_subst': "\f T \ K M. Ana (Fun f T) = (K,M) \ Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +begin + +lemma Ana_invar_subst'[simp]: "Ana_invar_subst \" +using Ana_subst' unfolding Ana_invar_subst_def by force + +definition pair where + "pair d \ case d of (t,t') \ Fun Pair [t,t']" + +fun tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s:: + "(('fun,'var) term \ ('fun,'var) term) list \ + ('fun,'var) dbstatelist \ + (('fun,'var) term \ ('fun,'var) term) list list" +where + "tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s [] D = [[]]" +| "tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) D = + concat (map (\d. map ((#) (pair (s,t), pair d)) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)) D)" + +text \ + A translation/reduction \tr\ from stateful constraints to (lists of) "non-stateful" constraints. + The output represents a finite disjunction of constraints whose models constitute exactly the + models of the input constraint. The typing result for "non-stateful" constraints is later lifted + to the stateful setting through this reduction procedure. +\ +fun tr::"('fun,'var) stateful_strand \ ('fun,'var) dbstatelist \ ('fun,'var) strand list" +where + "tr [] D = [[]]" +| "tr (send\t\#A) D = map ((#) (send\t\\<^sub>s\<^sub>t)) (tr A D)" +| "tr (receive\t\#A) D = map ((#) (receive\t\\<^sub>s\<^sub>t)) (tr A D)" +| "tr (\ac: t \ t'\#A) D = map ((#) (\ac: t \ t'\\<^sub>s\<^sub>t)) (tr A D)" +| "tr (insert\t,s\#A) D = tr A (List.insert (t,s) D)" +| "tr (delete\t,s\#A) D = + concat (map (\Di. map (\B. (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])@B) + (tr A [d\D. d \ set Di])) + (subseqs D))" +| "tr (\ac: t \ s\#A) D = + concat (map (\B. map (\d. \ac: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#B) D) (tr A D))" +| "tr (\X\\\: F \\: F'\#A) D = + map ((@) (map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))) (tr A D)" + +text \Type-flaw resistance of stateful constraint steps\ +fun tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = ((\\. Unifier \ t t') \ \ t = \ t')" +| "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (NegChecks X F F') = ( + (F' = [] \ (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F-set X. \a. \ (Var x) = TAtom a)) \ + (\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') \ + T = [] \ (\s \ set T. s \ Var ` set X)))" +| "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p _ = True" + +text \Type-flaw resistance of stateful constraints\ +definition tfr\<^sub>s\<^sub>s\<^sub>t where "tfr\<^sub>s\<^sub>s\<^sub>t S \ tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S) \ list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p S" + + +subsection \Small Lemmata\ +lemma pair_in_pair_image_iff: + "pair (s,t) \ pair ` P \ (s,t) \ P" +unfolding pair_def by fast + +lemma subst_apply_pairs_pair_image_subst: + "pair ` set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = pair ` set F \\<^sub>s\<^sub>e\<^sub>t \" +unfolding subst_apply_pairs_def pair_def by (induct F) auto + +lemma Ana_subst_subterms_cases: + fixes \::"('fun,'var) subst" + assumes t: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + and s: "s \ set (snd (Ana t))" + shows "(\u \ subterms\<^sub>s\<^sub>e\<^sub>t M. t = u \ \ \ s \ set (snd (Ana u)) \\<^sub>s\<^sub>e\<^sub>t \) \ (\x \ fv\<^sub>s\<^sub>e\<^sub>t M. t \ \ x)" +proof (cases "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \") + case True + then obtain u where u: "u \ subterms\<^sub>s\<^sub>e\<^sub>t M" "t = u \ \" by moura + show ?thesis + proof (cases u) + case (Var x) + hence "x \ fv\<^sub>s\<^sub>e\<^sub>t M" using fv_subset_subterms[OF u(1)] by simp + thus ?thesis using u(2) Var by fastforce + next + case (Fun f T) + hence "set (snd (Ana t)) = set (snd (Ana u)) \\<^sub>s\<^sub>e\<^sub>t \" + using Ana_subst'[of f T _ _ \] u(2) by (cases "Ana u") auto + thus ?thesis using s u by blast + qed +qed (use s t subterms\<^sub>s\<^sub>e\<^sub>t_subst in blast) + +lemma tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_alt_def: + "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p S = + ((\ac t t'. Equality ac t t' \ set S \ (\\. Unifier \ t t') \ \ t = \ t') \ + (\X F F'. NegChecks X F F' \ set S \ ( + (F' = [] \ (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F-set X. \a. \ (Var x) = TAtom a)) \ + (\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') \ + T = [] \ (\s \ set T. s \ Var ` set X)))))" + (is "?P S = ?Q S") +proof + show "?P S \ ?Q S" + proof (induction S) + case (Cons x S) thus ?case by (cases x) auto + qed simp + + show "?Q S \ ?P S" + proof (induction S) + case (Cons x S) thus ?case by (cases x) auto + qed simp +qed + +lemma fun_pair_eq[dest]: "pair d = pair d' \ d = d'" +proof - + obtain t s t' s' where "d = (t,s)" "d' = (t',s')" by moura + thus "pair d = pair d' \ d = d'" unfolding pair_def by simp +qed + +lemma fun_pair_subst: "pair d \ \ = pair (d \\<^sub>p \)" +using surj_pair[of d] unfolding pair_def by force + +lemma fun_pair_subst_set: "pair ` M \\<^sub>s\<^sub>e\<^sub>t \ = pair ` (M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \)" +proof + show "pair ` M \\<^sub>s\<^sub>e\<^sub>t \ \ pair ` (M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \)" + using fun_pair_subst[of _ \] by fastforce + + show "pair ` (M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) \ pair ` M \\<^sub>s\<^sub>e\<^sub>t \" + proof + fix t assume t: "t \ pair ` (M \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \)" + then obtain p where p: "p \ M" "t = pair (p \\<^sub>p \)" by blast + thus "t \ pair ` M \\<^sub>s\<^sub>e\<^sub>t \" using fun_pair_subst[of p \] by force + qed +qed + +lemma fun_pair_eq_subst: "pair d \ \ = pair d' \ \ \ d \\<^sub>p \ = d' \\<^sub>p \" +by (metis fun_pair_subst fun_pair_eq[of "d \\<^sub>p \" "d' \\<^sub>p \"]) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_pair_image_cons[simp]: + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (x#S) = pair ` setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p x \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (send\t\#S) = pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (receive\t\#S) = pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\ac: t \ t'\#S) = pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (insert\t,s\#S) = {pair (t,s)} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (delete\t,s\#S) = {pair (t,s)} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\ac: t \ s\#S) = {pair (t,s)} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\X\\\: F \\: G\#S) = pair ` set G \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" +unfolding setops\<^sub>s\<^sub>s\<^sub>t_def by auto + +lemma setops\<^sub>s\<^sub>s\<^sub>t_pair_image_subst_cons[simp]: + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (x#S \\<^sub>s\<^sub>s\<^sub>t \) = pair ` setops\<^sub>s\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (send\t\#S \\<^sub>s\<^sub>s\<^sub>t \) = pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (receive\t\#S \\<^sub>s\<^sub>s\<^sub>t \) = pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\ac: t \ t'\#S \\<^sub>s\<^sub>s\<^sub>t \) = pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (insert\t,s\#S \\<^sub>s\<^sub>s\<^sub>t \) = {pair (t,s) \ \} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (delete\t,s\#S \\<^sub>s\<^sub>s\<^sub>t \) = {pair (t,s) \ \} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\ac: t \ s\#S \\<^sub>s\<^sub>s\<^sub>t \) = {pair (t,s) \ \} \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\X\\\: F \\: G\#S \\<^sub>s\<^sub>s\<^sub>t \) = + pair ` set (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" +using subst_sst_cons[of _ S \] unfolding setops\<^sub>s\<^sub>s\<^sub>t_def pair_def by auto + +lemma setops\<^sub>s\<^sub>s\<^sub>t_are_pairs: "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ \s s'. t = pair (s,s')" +proof (induction A) + case (Cons a A) thus ?case + by (cases a) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma fun_pair_wf\<^sub>t\<^sub>r\<^sub>m: "wf\<^sub>t\<^sub>r\<^sub>m t \ wf\<^sub>t\<^sub>r\<^sub>m t' \ wf\<^sub>t\<^sub>r\<^sub>m (pair (t,t'))" +using Pair_arity unfolding wf\<^sub>t\<^sub>r\<^sub>m_def pair_def by auto + +lemma wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_pairs: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (pair ` set F)" +using fun_pair_wf\<^sub>t\<^sub>r\<^sub>m by blast + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_Nil[simp]: "tfr\<^sub>s\<^sub>s\<^sub>t []" +by (simp add: tfr\<^sub>s\<^sub>s\<^sub>t_def setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_append: "tfr\<^sub>s\<^sub>s\<^sub>t (A@B) \ tfr\<^sub>s\<^sub>s\<^sub>t A" +proof - + assume assms: "tfr\<^sub>s\<^sub>s\<^sub>t (A@B)" + let ?M = "trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A" + let ?N = "trms\<^sub>s\<^sub>s\<^sub>t (A@B) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (A@B)" + let ?P = "\t t'. \x \ fv t \ fv t'. \a. \ (Var x) = Var a" + let ?Q = "\X t t'. X = [] \ (\x \ (fv t \ fv t')-set X. \a. \ (Var x) = Var a)" + have *: "SMP ?M - Var`\ \ SMP ?N - Var`\" "?M \ ?N" + using SMP_mono[of ?M ?N] setops\<^sub>s\<^sub>s\<^sub>t_append[of A B] + by auto + { fix s t assume **: "tfr\<^sub>s\<^sub>e\<^sub>t ?N" "s \ SMP ?M - Var`\" "t \ SMP ?M - Var`\" "(\\. Unifier \ s t)" + hence "s \ SMP ?N - Var`\" "t \ SMP ?N - Var`\" using * by auto + hence "\ s = \ t" using **(1,4) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + } moreover have "\t \ ?N. wf\<^sub>t\<^sub>r\<^sub>m t \ \t \ ?M. wf\<^sub>t\<^sub>r\<^sub>m t" using * by blast + ultimately have "tfr\<^sub>s\<^sub>e\<^sub>t ?N \ tfr\<^sub>s\<^sub>e\<^sub>t ?M" unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + hence "tfr\<^sub>s\<^sub>e\<^sub>t ?M" using assms unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by metis + thus "tfr\<^sub>s\<^sub>s\<^sub>t A" using assms unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by simp +qed + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_append': "tfr\<^sub>s\<^sub>s\<^sub>t (A@B) \ tfr\<^sub>s\<^sub>s\<^sub>t B" +proof - + assume assms: "tfr\<^sub>s\<^sub>s\<^sub>t (A@B)" + let ?M = "trms\<^sub>s\<^sub>s\<^sub>t B \ pair ` setops\<^sub>s\<^sub>s\<^sub>t B" + let ?N = "trms\<^sub>s\<^sub>s\<^sub>t (A@B) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (A@B)" + let ?P = "\t t'. \x \ fv t \ fv t'. \a. \ (Var x) = Var a" + let ?Q = "\X t t'. X = [] \ (\x \ (fv t \ fv t')-set X. \a. \ (Var x) = Var a)" + have *: "SMP ?M - Var`\ \ SMP ?N - Var`\" "?M \ ?N" + using SMP_mono[of ?M ?N] setops\<^sub>s\<^sub>s\<^sub>t_append[of A B] + by auto + { fix s t assume **: "tfr\<^sub>s\<^sub>e\<^sub>t ?N" "s \ SMP ?M - Var`\" "t \ SMP ?M - Var`\" "(\\. Unifier \ s t)" + hence "s \ SMP ?N - Var`\" "t \ SMP ?N - Var`\" using * by auto + hence "\ s = \ t" using **(1,4) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + } moreover have "\t \ ?N. wf\<^sub>t\<^sub>r\<^sub>m t \ \t \ ?M. wf\<^sub>t\<^sub>r\<^sub>m t" using * by blast + ultimately have "tfr\<^sub>s\<^sub>e\<^sub>t ?N \ tfr\<^sub>s\<^sub>e\<^sub>t ?M" unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + hence "tfr\<^sub>s\<^sub>e\<^sub>t ?M" using assms unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by metis + thus "tfr\<^sub>s\<^sub>s\<^sub>t B" using assms unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by simp +qed + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_cons: "tfr\<^sub>s\<^sub>s\<^sub>t (a#A) \ tfr\<^sub>s\<^sub>s\<^sub>t A" +using tfr\<^sub>s\<^sub>s\<^sub>t_append'[of "[a]" A] by simp + +lemma tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst: + assumes s: "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p s" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) \ range_vars \ = {}" + shows "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" +proof (cases s) + case (Equality a t t') + thus ?thesis + proof (cases "\\. Unifier \ (t \ \) (t' \ \)") + case True + hence "\\. Unifier \ t t'" by (metis subst_subst_compose[of _ \]) + moreover have "\ t = \ (t \ \)" "\ t' = \ (t' \ \)" by (metis wt_subst_trm''[OF assms(2)])+ + ultimately have "\ (t \ \) = \ (t' \ \)" using s Equality by simp + thus ?thesis using Equality True by simp + qed simp +next + case (NegChecks X F G) + let ?P = "\F G. G = [] \ (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F-set X. \a. \ (Var x) = TAtom a)" + let ?Q = "\F G. \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set G) \ + T = [] \ (\s \ set T. s \ Var ` set X)" + let ?\ = "rm_vars (set X) \" + + have "?P F G \ ?Q F G" using NegChecks assms(1) by simp + hence "?P (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) \ ?Q (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)" + proof + assume *: "?P F G" + have "G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\ = []" using * by simp + moreover have "\a. \ (Var x) = TAtom a" when x: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) - set X" for x + proof - + obtain t t' where t: "(t,t') \ set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)" "x \ fv t \ fv t' - set X" + using x(1) by auto + then obtain u u' where u: "(u,u') \ set F" "u \ ?\ = t" "u' \ ?\ = t'" + unfolding subst_apply_pairs_def by auto + obtain y where y: "y \ fv u \ fv u' - set X" "x \ fv (?\ y)" + using t(2) u(2,3) rm_vars_fv_obtain by fast + hence a: "\a. \ (Var y) = TAtom a" using u * by auto + + have a': "\ (Var y) = \ (?\ y)" + using wt_subst_trm''[OF wt_subst_rm_vars[OF \(1), of "set X"], of "Var y"] + by simp + + have "(\z. ?\ y = Var z) \ (\c. ?\ y = Fun c [])" + proof (cases "?\ y \ subst_range \") + case True thus ?thesis + using a a' \(2) const_type_inv_wf + by (cases "?\ y") fastforce+ + qed fastforce + hence "?\ y = Var x" using y(2) by fastforce + hence "\ (Var x) = \ (Var y)" using a' by simp + thus ?thesis using a by presburger + qed + ultimately show ?thesis by simp + next + assume *: "?Q F G" + have **: "set X \ range_vars ?\ = {}" + using \(3) NegChecks rm_vars_img_fv_subset[of "set X" \] by auto + have "?Q (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)" + using ineq_subterm_inj_cond_subst[OF ** *] + trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst[of F "rm_vars (set X) \"] + subst_apply_pairs_pair_image_subst[of G "rm_vars (set X) \"] + by (metis (no_types, lifting) image_Un) + thus ?thesis by simp + qed + thus ?thesis using NegChecks by simp +qed simp_all + +lemma tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_all_wt_subst_apply: + assumes S: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p S" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "bvars\<^sub>s\<^sub>s\<^sub>t S \ range_vars \ = {}" + shows "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (S \\<^sub>s\<^sub>s\<^sub>t \)" +proof - + have "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s) \ range_vars \ = {}" when "s \ set S" for s + using that \(3) unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def range_vars_alt_def by fastforce + thus ?thesis + using tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF _ \(1,2)] S + unfolding list_all_iff + by (auto simp add: subst_apply_stateful_strand_def) +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_empty_case: + assumes "tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D = []" + shows "D = []" "F \ []" +proof - + show "F \ []" using assms by (auto intro: ccontr) + + have "tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F (a#A) \ []" for a A + by (induct F "a#A" rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) fastforce+ + thus "D = []" using assms by (cases D) simp_all +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_elem_length_eq: + assumes "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" + shows "length G = length F" +using assms by (induct F D arbitrary: G rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) auto + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_index: + assumes "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "i < length F" + shows "\d \ set D. G ! i = (pair (F ! i), pair d)" +using assms +proof (induction F D arbitrary: i G rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D) + obtain d G' where G: + "d \ set D" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" + "G = (pair (s,t), pair d)#G'" + using "2.prems"(1) by moura + show ?case + using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3) + by (cases i) auto +qed simp + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_cons: + assumes "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "d \ set D" + shows "(pair (s,t), pair d)#G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) D)" +using assms by auto + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_has_pair_lists: + assumes "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "g \ set G" + shows "\f \ set F. \d \ set D. g = (pair f, pair d)" +using assms +proof (induction F D arbitrary: G rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D) + obtain d G' where G: + "d \ set D" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" + "G = (pair (s,t), pair d)#G'" + using "2.prems"(1) by moura + show ?case + using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3) + by (cases "g \ set G'") auto +qed simp + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_pair_lists: + assumes "f \ set F" "d \ set D" + shows "\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D). (pair f, pair d) \ set G" + (is "?P F D f d") +proof - + have "\f \ set F. \d \ set D. ?P F D f d" + proof (induction F D rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D) + hence IH: "\f \ set F. \d \ set D. ?P F D f d" by metis + moreover have "\d \ set D. ?P ((s,t)#F) D (s,t) d" + proof + fix d assume d: "d \ set D" + then obtain G where G: "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_empty_case(1) by force + hence "(pair (s, t), pair d)#G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) D)" + using d by auto + thus "?P ((s,t)#F) D (s,t) d" using d G by auto + qed + ultimately show ?case by fastforce + qed simp + thus ?thesis by (metis assms) +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_db_append_subset: + "set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D) \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F (D@E))" (is ?A) + "set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F E) \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F (D@E))" (is ?B) +proof - + show ?A + proof (induction F D rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D) + show ?case + proof + fix G assume "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) D)" + then obtain d G' where G': + "d \ set D" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "G = (pair (s,t), pair d)#G'" + by moura + have "d \ set (D@E)" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto + thus "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) (D@E))" using G'(3) by auto + qed + qed simp + + show ?B + proof (induction F E rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F E) + show ?case + proof + fix G assume "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) E)" + then obtain d G' where G': + "d \ set E" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F E)" "G = (pair (s,t), pair d)#G'" + by moura + have "d \ set (D@E)" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto + thus "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) (D@E))" using G'(3) by auto + qed + qed simp +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset: + "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D) \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \ pair ` set F \ pair ` set D" +proof (induction F D arbitrary: G rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D G) + obtain d G' where G: + "d \ set D" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "G = (pair (s,t), pair d)#G'" + using "2.prems"(1) by moura + + show ?case using "2.IH"[OF G(1,2)] G(1,3) by auto +qed simp + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset': + "\(trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)) \ pair ` set F \ pair ` set D" +using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset by blast + +lemma tr_trms_subset: + "A' \ set (tr A D) \ trms\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" +proof (induction A D arbitrary: A' rule: tr.induct) + case 1 thus ?case by simp +next + case (2 t A D) + then obtain A'' where A'': "A' = send\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" by moura + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" by (metis "2.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (3 t A D) + then obtain A'' where A'': "A' = receive\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" by moura + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" by (metis "3.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (4 ac t t' A D) + then obtain A'' where A'': "A' = \ac: t \ t'\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" by moura + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" by (metis "4.IH") + thus ?case using A'' by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (5 t s A D) + hence "A' \ set (tr A (List.insert (t,s) D))" by simp + hence "trms\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set (List.insert (t, s) D)" + by (metis "5.IH") + thus ?case by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (6 t s A D) + from 6 obtain Di A'' B C where A'': + "Di \ set (subseqs D)" "A'' \ set (tr A [d\D. d \ set Di])" "A' = (B@C)@A''" + "B = map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di" + "C = map (\d. Inequality [] [(pair (t,s) , pair d)]) [d\D. d \ set Di]" + by moura + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set [d\D. d \ set Di]" + by (metis "6.IH") + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) \ pair ` set D" + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + moreover have "trms\<^sub>s\<^sub>t (B@C) \ insert (pair (t,s)) (pair ` set D)" + using A''(4,5) subseqs_set_subset[OF A''(1)] by auto + moreover have "pair (t,s) \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (Delete t s#A)" by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + ultimately show ?case using A''(3) trms\<^sub>s\<^sub>t_append[of "B@C" A'] by auto +next + case (7 ac t s A D) + from 7 obtain d A'' where A'': + "d \ set D" "A'' \ set (tr A D)" + "A' = \ac: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#A''" + by moura + hence "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" by (metis "7.IH") + moreover have "trms\<^sub>s\<^sub>t A' = {pair (t,s), pair d} \ trms\<^sub>s\<^sub>t A''" + using A''(1,3) by auto + ultimately show ?case using A''(1) by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) +next + case (8 X F F' A D) + from 8 obtain A'' where A'': + "A'' \ set (tr A D)" "A' = (map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))@A''" + by moura + + define B where "B \ \(trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))" + + have "trms\<^sub>s\<^sub>t A'' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" by (metis A''(1) "8.IH") + hence "trms\<^sub>s\<^sub>t A' \ B \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D" + using A'' B_def by auto + moreover have "B \ pair ` set F' \ pair ` set D" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset'[of F' D] B_def by simp + moreover have "pair ` setops\<^sub>s\<^sub>s\<^sub>t (\X\\\: F \\: F'\#A) = pair ` set F' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A" + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + ultimately show ?case by auto +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_vars_subset: + "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s D" +proof (induction F D arbitrary: G rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F D G) + obtain d G' where G: + "d \ set D" "G' \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)" "G = (pair (s,t), pair d)#G'" + using "2.prems"(1) by moura + + show ?case using "2.IH"[OF G(1,2)] G(1,3) unfolding pair_def by auto +qed simp + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_vars_subset': "\(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F D)) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s D" +using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_vars_subset[of _ F D] by blast + +lemma tr_vars_subset: + assumes "A' \ set (tr A D)" + shows "fv\<^sub>s\<^sub>t A' \ fv\<^sub>s\<^sub>s\<^sub>t A \ (\(t,t') \ set D. fv t \ fv t')" (is ?P) + and "bvars\<^sub>s\<^sub>t A' \ bvars\<^sub>s\<^sub>s\<^sub>t A" (is ?Q) +proof - + show ?P using assms + proof (induction A arbitrary: A' D rule: strand_sem_stateful_induct) + case (ConsIn A' D ac t s A) + then obtain A'' d where *: + "d \ set D" "A' = \ac: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#A''" + "A'' \ set (tr A D)" + by moura + hence "fv\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t A \ (\(t,t')\set D. fv t \ fv t')" by (metis ConsIn.IH) + thus ?case using * unfolding pair_def by auto + next + case (ConsDel A' D t s A) + define Dfv where "Dfv \ \D::('fun,'var) dbstatelist. (\(t,t')\set D. fv t \ fv t')" + define fltD where "fltD \ \Di. filter (\d. d \ set Di) D" + define constr where + "constr \ \Di. (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) (fltD Di))" + from ConsDel obtain A'' Di where *: + "Di \ set (subseqs D)" "A' = (constr Di)@A''" "A'' \ set (tr A (fltD Di))" + unfolding constr_def fltD_def by moura + hence "fv\<^sub>s\<^sub>t A'' \ fv\<^sub>s\<^sub>s\<^sub>t A \ Dfv (fltD Di)" + unfolding Dfv_def constr_def fltD_def by (metis ConsDel.IH) + moreover have "Dfv (fltD Di) \ Dfv D" unfolding Dfv_def constr_def fltD_def by auto + moreover have "Dfv Di \ Dfv D" + using subseqs_set_subset(1)[OF *(1)] unfolding Dfv_def constr_def fltD_def by fast + moreover have "fv\<^sub>s\<^sub>t (constr Di) \ fv t \ fv s \ (Dfv Di \ Dfv (fltD Di))" + unfolding Dfv_def constr_def fltD_def pair_def by auto + moreover have "fv\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) = fv t \ fv s \ fv\<^sub>s\<^sub>s\<^sub>t A" by auto + moreover have "fv\<^sub>s\<^sub>t A' = fv\<^sub>s\<^sub>t (constr Di) \ fv\<^sub>s\<^sub>t A''" using * by force + ultimately have "fv\<^sub>s\<^sub>t A' \ fv\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) \ Dfv D" by auto + thus ?case unfolding Dfv_def fltD_def constr_def by simp + next + case (ConsNegChecks A' D X F F' A) + then obtain A'' where A'': + "A'' \ set (tr A D)" "A' = (map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))@A''" + by moura + + define B where "B \ \(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ` set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))" + + have 1: "fv\<^sub>s\<^sub>t (map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D)) \ (B \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X" + unfolding B_def by auto + + have 2: "B \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s D" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_vars_subset'[of F' D] + unfolding B_def by simp + + have "fv\<^sub>s\<^sub>t A' \ ((fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s D \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X) \ fv\<^sub>s\<^sub>t A''" + using 1 2 A''(2) by fastforce + thus ?case using ConsNegChecks.IH[OF A''(1)] by auto + qed fastforce+ + + show ?Q using assms by (induct A arbitrary: A' D rule: strand_sem_stateful_induct) fastforce+ +qed + +lemma tr_vars_disj: + assumes "A' \ set (tr A D)" "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + and "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + shows "fv\<^sub>s\<^sub>t A' \ bvars\<^sub>s\<^sub>t A' = {}" + using assms tr_vars_subset by fast + +lemma wf_fun_pair_ineqs_map: + assumes "wf\<^sub>s\<^sub>t X A" + shows "wf\<^sub>s\<^sub>t X (map (\d. \Y\\\: [(pair (t, s), pair d)]\\<^sub>s\<^sub>t) D@A)" +using assms by (induct D) auto + +lemma wf_fun_pair_negchecks_map: + assumes "wf\<^sub>s\<^sub>t X A" + shows "wf\<^sub>s\<^sub>t X (map (\G. \Y\\\: (F@G)\\<^sub>s\<^sub>t) M@A)" +using assms by (induct M) auto + +lemma wf_fun_pair_eqs_ineqs_map: + fixes A::"('fun,'var) strand" + assumes "wf\<^sub>s\<^sub>t X A" "Di \ set (subseqs D)" "\(t,t') \ set D. fv t \ fv t' \ X" + shows "wf\<^sub>s\<^sub>t X ((map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])@A)" +proof - + let ?c1 = "map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di" + let ?c2 = "map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]" + have 1: "wf\<^sub>s\<^sub>t X (?c2@A)" using wf_fun_pair_ineqs_map[OF assms(1)] by simp + have 2: "\(t,t') \ set Di. fv t \ fv t' \ X" + using assms(2,3) by (meson contra_subsetD subseqs_set_subset(1)) + have "wf\<^sub>s\<^sub>t X (?c1@B)" when "wf\<^sub>s\<^sub>t X B" for B::"('fun,'var) strand" + using 2 that by (induct Di) auto + thus ?thesis using 1 by simp +qed + +lemma trms\<^sub>s\<^sub>s\<^sub>t_wt_subst_ex: + assumes \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and t: "t \ trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + shows "\s \. s \ trms\<^sub>s\<^sub>s\<^sub>t S \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = s \ \" +using t +proof (induction S) + case (Cons s S) thus ?case + proof (cases "t \ trms\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)") + case False + hence "t \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (s \\<^sub>s\<^sub>s\<^sub>t\<^sub>p \)" + using Cons.prems trms\<^sub>s\<^sub>s\<^sub>t_subst_cons[of s S \] + by auto + then obtain u where u: "u \ trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p s" "t = u \ rm_vars (set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)) \" + using trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst'' by blast + thus ?thesis + using trms\<^sub>s\<^sub>s\<^sub>t_subst_cons[of s S \] + wt_subst_rm_vars[OF \(1), of "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)"] + wf_trms_subst_rm_vars'[OF \(2), of "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p s)"] + by fastforce + qed auto +qed simp + +lemma setops\<^sub>s\<^sub>s\<^sub>t_wt_subst_ex: + assumes \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and t: "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + shows "\s \. s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = s \ \" +using t +proof (induction S) + case (Cons x S) thus ?case + proof (cases x) + case (Insert t' s) + hence "t = pair (t',s) \ \ \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + using Cons.prems subst_sst_cons[of _ S \] + unfolding pair_def by (force simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis + using Insert Cons.IH \ by (cases "t = pair (t', s) \ \") (fastforce, auto) + next + case (Delete t' s) + hence "t = pair (t',s) \ \ \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + using Cons.prems subst_sst_cons[of _ S \] + unfolding pair_def by (force simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis + using Delete Cons.IH \ by (cases "t = pair (t', s) \ \") (fastforce, auto) + next + case (InSet ac t' s) + hence "t = pair (t',s) \ \ \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + using Cons.prems subst_sst_cons[of _ S \] + unfolding pair_def by (force simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis + using InSet Cons.IH \ by (cases "t = pair (t', s) \ \") (fastforce, auto) + next + case (NegChecks X F F') + hence "t \ pair ` set (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>s\<^sub>t \)" + using Cons.prems subst_sst_cons[of _ S \] + unfolding pair_def by (force simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + thus ?thesis + proof + assume "t \ pair ` set (F' \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + then obtain s where s: "t = s \ rm_vars (set X) \" "s \ pair ` set F'" + using subst_apply_pairs_pair_image_subst[of F' "rm_vars (set X) \"] by auto + thus ?thesis + using NegChecks setops\<^sub>s\<^sub>s\<^sub>t_pair_image_cons(8)[of X F F' S] + wt_subst_rm_vars[OF \(1), of "set X"] + wf_trms_subst_rm_vars'[OF \(2), of "set X"] + by fast + qed (use Cons.IH in auto) + qed (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def subst_sst_cons[of _ S \]) +qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + +lemma setops\<^sub>s\<^sub>s\<^sub>t_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" +proof - + show "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" + proof (induction A) + case (Cons a A) + hence 0: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" by auto + thus ?case + proof (cases a) + case (NegChecks X F F') + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F')" using 0 by simp + thus ?thesis using NegChecks wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_pairs[of F'] 0 by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + qed (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def dest: fun_pair_wf\<^sub>t\<^sub>r\<^sub>m) + qed (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + thus "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" by fast +qed + +lemma SMP_MP_split: + assumes "t \ SMP M" + and M: "\m \ M. is_Fun m" + shows "(\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t \ M \\<^sub>s\<^sub>e\<^sub>t \) \ + t \ SMP ((subterms\<^sub>s\<^sub>e\<^sub>t M \ \((set \ fst \ Ana) ` M)) - M)" + (is "?P t \ ?Q t") +using assms(1) +proof (induction t rule: SMP.induct) + case (MP t) + have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" "M \\<^sub>s\<^sub>e\<^sub>t Var = M" by simp_all + thus ?case using MP by metis +next + case (Subterm t t') + show ?case using Subterm.IH + proof + assume "?P t" + then obtain s \ where s: "s \ M" "t = s \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" by moura + then obtain f T where fT: "s = Fun f T" using M by fast + + have "(\s'. s' \ s \ t' = s' \ \) \ (\x \ fv s. t' \ \ x)" + using subterm_subst_unfold[OF Subterm.hyps(2)[unfolded s(2)]] by blast + thus ?thesis + proof + assume "\s'. s' \ s \ t' = s' \ \" + then obtain s' where s': "s' \ s" "t' = s' \ \" by moura + show ?thesis + proof (cases "s' \ M") + case True thus ?thesis using s' \ by blast + next + case False + hence "s' \ (subterms\<^sub>s\<^sub>e\<^sub>t M \ \((set \ fst \ Ana) ` M)) - M" using s'(1) s(1) by force + thus ?thesis using SMP.Substitution[OF SMP.MP[of s'] \] s' by presburger + qed + next + assume "\x \ fv s. t' \ \ x" + then obtain x where x: "x \ fv s" "t' \ \ x" by moura + have "Var x \ M" using M by blast + hence "Var x \ (subterms\<^sub>s\<^sub>e\<^sub>t M \ \((set \ fst \ Ana) ` M)) - M" + using s(1) var_is_subterm[OF x(1)] by blast + hence "\ x \ SMP ((subterms\<^sub>s\<^sub>e\<^sub>t M \ \((set \ fst \ Ana) ` M)) - M)" + using SMP.Substitution[OF SMP.MP[of "Var x"] \] by auto + thus ?thesis using SMP.Subterm x(2) by presburger + qed + qed (metis SMP.Subterm[OF _ Subterm.hyps(2)]) +next + case (Substitution t \) + show ?case using Substitution.IH + proof + assume "?P t" + then obtain \ where "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t \ M \\<^sub>s\<^sub>e\<^sub>t \" by moura + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" "t \ \ \ M \\<^sub>s\<^sub>e\<^sub>t (\ \\<^sub>s \)" + using wt_subst_compose[of \, OF _ Substitution.hyps(2)] + wf_trm_subst_compose[of \ _ \, OF _ wf_trm_subst_rangeD[OF Substitution.hyps(3)]] + wf_trm_subst_range_iff + by (argo, blast, auto) + thus ?thesis by blast + next + assume "?Q t" thus ?thesis using SMP.Substitution[OF _ Substitution.hyps(2,3)] by meson + qed +next + case (Ana t K T k) + show ?case using Ana.IH + proof + assume "?P t" + then obtain \ where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t \ M \\<^sub>s\<^sub>e\<^sub>t \" by moura + then obtain s where s: "s \ M" "t = s \ \" by auto + then obtain f S where fT: "s = Fun f S" using M by (cases s) auto + obtain K' T' where s_Ana: "Ana s = (K', T')" by (metis surj_pair) + hence "set K = set K' \\<^sub>s\<^sub>e\<^sub>t \" "set T = set T' \\<^sub>s\<^sub>e\<^sub>t \" + using Ana_subst'[of f S K' T'] fT Ana.hyps(2) s(2) by auto + then obtain k' where k': "k' \ set K'" "k = k' \ \" using Ana.hyps(3) by fast + show ?thesis + proof (cases "k' \ M") + case True thus ?thesis using k' \(1,2) by blast + next + case False + hence "k' \ (subterms\<^sub>s\<^sub>e\<^sub>t M \ \((set \ fst \ Ana) ` M)) - M" using k'(1) s_Ana s(1) by force + thus ?thesis using SMP.Substitution[OF SMP.MP[of k'] \(1,2)] k'(2) by presburger + qed + next + assume "?Q t" thus ?thesis using SMP.Ana[OF _ Ana.hyps(2,3)] by meson + qed +qed + +lemma setops_subterm_trms: + assumes t: "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" + and s: "s \ t" + shows "s \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" +proof - + obtain u u' where u: "pair (u,u') \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" "t = pair (u,u')" + using t setops\<^sub>s\<^sub>s\<^sub>t_are_pairs[of _ S] by blast + hence "s \ u \ s \ u'" using s unfolding pair_def by auto + thus ?thesis using u setops\<^sub>s\<^sub>s\<^sub>t_member_iff[of u u' S] unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by force +qed + +lemma setops_subterms_cases: + assumes t: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (pair ` setops\<^sub>s\<^sub>s\<^sub>t S)" + shows "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S) \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" +proof - + obtain s s' where s: "pair (s,s') \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" "t \ pair (s,s')" + using t setops\<^sub>s\<^sub>s\<^sub>t_are_pairs[of _ S] by blast + hence "t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \ t \ s \ t \ s'" unfolding pair_def by auto + thus ?thesis using s setops\<^sub>s\<^sub>s\<^sub>t_member_iff[of s s' S] unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by force +qed + +lemma setops_SMP_cases: + assumes "t \ SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t S)" + and "\p. Ana (pair p) = ([], [])" + shows "(\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \) \ t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S)" +proof - + have 0: "\((set \ fst \ Ana) ` pair ` setops\<^sub>s\<^sub>s\<^sub>t S) = {}" + proof (induction S) + case (Cons x S) thus ?case + using assms(2) by (cases x) (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + + have 1: "\m \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S. is_Fun m" + proof (induction S) + case (Cons x S) thus ?case + unfolding pair_def by (cases x) (auto simp add: assms(2) setops\<^sub>s\<^sub>s\<^sub>t_def) + qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + + have 2: + "subterms\<^sub>s\<^sub>e\<^sub>t (pair ` setops\<^sub>s\<^sub>s\<^sub>t S) \ + \((set \ fst \ Ana) ` (pair ` setops\<^sub>s\<^sub>s\<^sub>t S)) - pair ` setops\<^sub>s\<^sub>s\<^sub>t S + \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" + using 0 setops_subterms_cases by fast + + show ?thesis + using SMP_MP_split[OF assms(1) 1] SMP_mono[OF 2] SMP_subterms_eq[of "trms\<^sub>s\<^sub>s\<^sub>t S"] + by blast +qed + +lemma tfr_setops_if_tfr_trms: + assumes "Pair \ \(funs_term ` SMP (trms\<^sub>s\<^sub>s\<^sub>t S))" + and "\p. Ana (pair p) = ([], [])" + and "\s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S. \t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S. (\\. Unifier \ s t) \ \ s = \ t" + and "\s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S. \t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S. + (\\ \ \. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ + Unifier \ (s \ \) (t \ \)) + \ (\\. Unifier \ s t)" + and tfr: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S)" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S)" +proof - + have 0: "t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var \ t \ SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t S) - range Var" + when "t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S) - range Var" for t + using that SMP_union by blast + + have 1: "s \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + when st: "s \ SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "\\. Unifier \ s t" + for s t + proof - + have "(\\. s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \) \ s \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + using st setops_SMP_cases[of s S] assms(2) by blast + moreover { + fix \ assume \: "s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" + then obtain s' where s': "s' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" "s = s' \ \" by blast + then obtain u u' where u: "s' = Fun Pair [u,u']" + using setops\<^sub>s\<^sub>s\<^sub>t_are_pairs[of s'] unfolding pair_def by fast + hence *: "s = Fun Pair [u \ \, u' \ \]" using \ s' by simp + + obtain f T where fT: "t = Fun f T" using st(2) by (cases t) auto + hence "f \ Pair" using st(2) assms(1) by auto + hence False using st(3) * fT s' u by fast + } ultimately show ?thesis by meson + qed + + have 2: "\ s = \ t" + when "s \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "\\. Unifier \ s t" + for s t + using that tfr unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + + have 3: "\ s = \ t" + when st: "s \ SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "t \ SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "\\. Unifier \ s t" + for s t + proof - + let ?P = "\s \. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ s \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" + have "(\\. ?P s \) \ s \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + "(\\. ?P t \) \ t \ SMP (trms\<^sub>s\<^sub>s\<^sub>t S) - range Var" + using setops_SMP_cases[of _ S] assms(2) st(1,2) by auto + hence "(\\ \'. ?P s \ \ ?P t \') \ \ s = \ t" by (metis 1 2 st) + moreover { + fix \ \' assume *: "?P s \" "?P t \'" + then obtain s' t' where **: + "s' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" "t' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S" "s = s' \ \" "t = t' \ \'" + by blast + hence "\\. Unifier \ s' t'" using st(3) assms(4) * by blast + hence "\ s' = \ t'" using assms(3) ** by blast + hence "\ s = \ t" using * **(3,4) wt_subst_trm''[of \ s'] wt_subst_trm''[of \' t'] by argo + } ultimately show ?thesis by blast + qed + + show ?thesis using 0 1 2 3 unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by metis +qed + + +subsection \The Typing Result for Stateful Constraints\ +context +begin +private lemma tr_wf': + assumes "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + and "\(t,t') \ set D. fv t \ fv t' \ X" + and "wf'\<^sub>s\<^sub>s\<^sub>t X A" "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + and "A' \ set (tr A D)" + shows "wf\<^sub>s\<^sub>t X A'" +proof - + define P where + "P = (\(D::('fun,'var) dbstatelist) (A::('fun,'var) stateful_strand). + (\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}) \ fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {})" + + have "P D A" using assms(1,4) by (simp add: P_def) + with assms(5,3,2) show ?thesis + proof (induction A arbitrary: A' D X rule: wf'\<^sub>s\<^sub>s\<^sub>t.induct) + case 1 thus ?case by simp + next + case (2 X t A A') + then obtain A'' where A'': "A' = receive\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" "fv t \ X" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A" "\(s,s') \ set D. fv s \ fv s' \ X" "P D A" + using 2(1,2,3,4) apply (force, force) + using 2(5) unfolding P_def by force + show ?case using "2.IH"[OF A''(2) *] A''(1,3) by simp + next + case (3 X t A A') + then obtain A'' where A'': "A' = send\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t) A" "\(s,s') \ set D. fv s \ fv s' \ X \ fv t" "P D A" + using 3(1,2,3,4) apply (force, force) + using 3(5) unfolding P_def by force + show ?case using "3.IH"[OF A''(2) *] A''(1) by simp + next + case (4 X t t' A A') + then obtain A'' where A'': "A' = \assign: t \ t'\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" "fv t' \ X" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t) A" "\(s,s') \ set D. fv s \ fv s' \ X \ fv t" "P D A" + using 4(1,2,3,4) apply (force, force) + using 4(5) unfolding P_def by force + show ?case using "4.IH"[OF A''(2) *] A''(1,3) by simp + next + case (5 X t t' A A') + then obtain A'' where A'': "A' = \check: t \ t'\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A" "P D A" + using 5(3) apply force + using 5(5) unfolding P_def by force + show ?case using "5.IH"[OF A''(2) *(1) 5(4) *(2)] A''(1) by simp + next + case (6 X t s A A') + hence A': "A' \ set (tr A (List.insert (t,s) D))" "fv t \ X" "fv s \ X" by auto + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A" "\(s,s') \ set (List.insert (t,s) D). fv s \ fv s' \ X" using 6 by auto + have **: "P (List.insert (t,s) D) A" using 6(5) unfolding P_def by force + show ?case using "6.IH"[OF A'(1) * **] A'(2,3) by simp + next + case (7 X t s A A') + let ?constr = "\Di. (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])" + from 7 obtain Di A'' where A'': + "A' = ?constr Di@A''" "A'' \ set (tr A [d\D. d \ set Di])" + "Di \ set (subseqs D)" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A" "\(t',s') \ set [d\D. d \ set Di]. fv t' \ fv s' \ X" + using 7 by auto + have **: "P [d\D. d \ set Di] A" using 7 unfolding P_def by force + have ***: "\(t, t') \ set D. fv t \ fv t' \ X" using 7 by auto + show ?case + using "7.IH"[OF A''(2) * **] A''(1) wf_fun_pair_eqs_ineqs_map[OF _ A''(3) ***] + by simp + next + case (8 X t s A A') + then obtain d A'' where A'': + "A' = \assign: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#A''" + "A'' \ set (tr A D)" "d \ set D" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t (X \ fv t \ fv s) A" "\(t',s')\set D. fv t' \ fv s' \ X \ fv t \ fv s" "P D A" + using 8(1,2,3,4) apply (force, force) + using 8(5) unfolding P_def by force + have **: "fv (pair d) \ X" using A''(3) "8.prems"(3) unfolding pair_def by fastforce + have ***: "fv (pair (t,s)) = fv s \ fv t" unfolding pair_def by auto + show ?case using "8.IH"[OF A''(2) *] A''(1) ** *** unfolding pair_def by (simp add: Un_assoc) + next + case (9 X t s A A') + then obtain d A'' where A'': + "A' = \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#A''" + "A'' \ set (tr A D)" "d \ set D" + by moura + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A""P D A" + using 9(3) apply force + using 9(5) unfolding P_def by force + have **: "fv (pair d) \ X" using A''(3) "9.prems"(3) unfolding pair_def by fastforce + have ***: "fv (pair (t,s)) = fv s \ fv t" unfolding pair_def by auto + show ?case using "9.IH"[OF A''(2) *(1) 9(4) *(2)] A''(1) ** *** by (simp add: Un_assoc) + next + case (10 X Y F F' A A') + from 10 obtain A'' where A'': + "A' = (map (\G. \Y\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))@A''" "A'' \ set (tr A D)" + by moura + + have *: "wf'\<^sub>s\<^sub>s\<^sub>t X A" "\(t',s') \ set D. fv t' \ fv s' \ X" using 10 by auto + + have "bvars\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t (\Y\\\: F \\: F'\#A)" "fv\<^sub>s\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>s\<^sub>t (\Y\\\: F \\: F'\#A)" by auto + hence **: "P D A" using 10 unfolding P_def by blast + + show ?case using "10.IH"[OF A''(2) * **] A''(1) wf_fun_pair_negchecks_map by simp + qed +qed + +private lemma tr_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: + assumes "A' \ set (tr A [])" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t A')" +using tr_trms_subset[OF assms(1)] setops\<^sub>s\<^sub>s\<^sub>t_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s(2)[OF assms(2)] +by auto + +lemma tr_wf: + assumes "A' \ set (tr A [])" + and "wf\<^sub>s\<^sub>s\<^sub>t A" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t A)" + shows "wf\<^sub>s\<^sub>t {} A'" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t A')" + and "fv\<^sub>s\<^sub>t A' \ bvars\<^sub>s\<^sub>t A' = {}" +using tr_wf'[OF _ _ _ _ assms(1)] + tr_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s[OF assms(1,3)] + tr_vars_disj[OF assms(1)] + assms(2) +by fastforce+ + +private lemma tr_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p: + assumes "A' \ set (tr A D)" "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p A" + and "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" (is "?P0 A D") + and "\(t,s) \ set D. (fv t \ fv s) \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" (is "?P1 A D") + and "\t \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D. \t' \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set D. + (\\. Unifier \ t t') \ \ t = \ t'" (is "?P3 A D") + shows "list_all tfr\<^sub>s\<^sub>t\<^sub>p A'" +proof - + have sublmm: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p A" "?P0 A D" "?P1 A D" "?P3 A D" + when p: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a#A)" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D" + for a A D + using p(1) apply (simp add: tfr\<^sub>s\<^sub>s\<^sub>t_def) + using p(2) fv\<^sub>s\<^sub>s\<^sub>t_cons_subset bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset apply fast + using p(3) bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset apply fast + using p(4) setops\<^sub>s\<^sub>s\<^sub>t_cons_subset by fast + + show ?thesis using assms + proof (induction A D arbitrary: A' rule: tr.induct) + case 1 thus ?case by simp + next + case (2 t A D) + note prems = "2.prems" + note IH = "2.IH" + from prems(1) obtain A'' where A'': "A' = send\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" + by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson + thus ?case using A''(1) by simp + next + case (3 t A D) + note prems = "3.prems" + note IH = "3.IH" + from prems(1) obtain A'' where A'': "A' = receive\t\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" + by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson + thus ?case using A''(1) by simp + next + case (4 ac t t' A D) + note prems = "4.prems" + note IH = "4.IH" + from prems(1) obtain A'' where A'': + "A' = \ac: t \ t'\\<^sub>s\<^sub>t#A''" "A'' \ set (tr A D)" + by moura + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson + moreover have "(\\. Unifier \ t t') \ \ t = \ t'" using prems(2) by (simp add: tfr\<^sub>s\<^sub>s\<^sub>t_def) + ultimately show ?case using A''(1) by auto + next + case (5 t s A D) + note prems = "5.prems" + note IH = "5.IH" + from prems(1) have A': "A' \ set (tr A (List.insert (t,s) D))" by simp + + have 1: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p A" using sublmm[OF prems(2,3,4,5)] by simp + + have "pair ` setops\<^sub>s\<^sub>s\<^sub>t (Insert t s#A) \ pair`set D = + pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair`set (List.insert (t,s) D)" + by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + hence 3: "?P3 A (List.insert (t,s) D)" using prems(5) by metis + moreover have "?P1 A (List.insert (t, s) D)" using prems(3,4) bvars\<^sub>s\<^sub>s\<^sub>t_cons_subset[of A] by auto + ultimately have "list_all tfr\<^sub>s\<^sub>t\<^sub>p A'" using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis + thus ?case using A'(1) by auto + next + case (6 t s A D) + note prems = "6.prems" + note IH = "6.IH" + + define constr where constr: + "constr \ (\Di. (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]))" + + from prems(1) obtain Di A'' where A'': + "A' = constr Di@A''" "A'' \ set (tr A [d\D. d \ set Di])" + "Di \ set (subseqs D)" + unfolding constr by auto + + define Q1 where "Q1 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \x \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X. \a. \ (Var x) = TAtom a)" + + define Q2 where "Q2 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X))" + + have "set [d\D. d \ set Di] \ set D" + "pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ pair ` set [d\D. d \ set Di] + \ pair ` setops\<^sub>s\<^sub>s\<^sub>t (Delete t s#A) \ pair ` set D" + by (auto simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + hence *: "?P3 A [d\D. d \ set Di]" using prems(5) by blast + have **: "?P1 A [d\D. d \ set Di]" using prems(4,5) by auto + have 1: "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" + using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *] + by metis + + have 2: "\ac: u \ u'\\<^sub>s\<^sub>t \ set A'' \ + (\d \ set Di. u = pair (t,s) \ u' = pair d)" + when "\ac: u \ u'\\<^sub>s\<^sub>t \ set A'" for ac u u' + using that A''(1) unfolding constr by force + have 3: "Inequality X U \ set A' \ Inequality X U \ set A'' \ + (\d \ set [d\D. d \ set Di]. + U = [(pair (t,s), pair d)] \ Q2 [(pair (t,s), pair d)] X)" + for X U + using A''(1) unfolding Q2_def constr by force + have 4: + "\d\set D. (\\. Unifier \ (pair (t,s)) (pair d)) \ \ (pair (t,s)) = \ (pair d)" + using prems(5) by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + + { fix ac u u' + assume a: "\ac: u \ u'\\<^sub>s\<^sub>t \ set A'" "\\. Unifier \ u u'" + hence "\ac: u \ u'\\<^sub>s\<^sub>t \ set A'' \ (\d \ set Di. u = pair (t,s) \ u' = pair d)" + using 2 by metis + hence "\ u = \ u'" + using 1(1) 4 subseqs_set_subset[OF A''(3)] a(2) tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of A''] + by blast + } moreover { + fix u U + assume "\U\\\: u\\<^sub>s\<^sub>t \ set A'" + hence "\U\\\: u\\<^sub>s\<^sub>t \ set A'' \ + (\d \ set [d\D. d \ set Di]. u = [(pair (t,s), pair d)] \ Q2 u U)" + using 3 by metis + hence "Q1 u U \ Q2 u U" + using 1 4 subseqs_set_subset[OF A''(3)] tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of A''] + unfolding Q1_def Q2_def + by blast + } ultimately show ?case using tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of A'] unfolding Q1_def Q2_def by blast + next + case (7 ac t s A D) + note prems = "7.prems" + note IH = "7.IH" + + from prems(1) obtain d A'' where A'': + "A' = \ac: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t#A''" + "A'' \ set (tr A D)" "d \ set D" + by moura + + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" + using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]] + by metis + moreover have "(\\. Unifier \ (pair (t,s)) (pair d)) \ \ (pair (t,s)) = \ (pair d)" + using prems(2,5) A''(3) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def) + ultimately show ?case using A''(1) by fastforce + next + case (8 X F F' A D) + note prems = "8.prems" + note IH = "8.IH" + + define constr where "constr = (map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))" + + define Q1 where "Q1 \ (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \x \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X. \a. \ (Var x) = TAtom a)" + + define Q2 where "Q2 \ (\(M::('fun,'var) terms) X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t M \ T = [] \ (\s \ set T. s \ Var ` set X))" + + have Q2_subset: "Q2 M' X" when "M' \ M" "Q2 M X" for X M M' + using that unfolding Q2_def by auto + + have Q2_supset: "Q2 (M \ M') X" when "Q2 M X" "Q2 M' X" for X M M' + using that unfolding Q2_def by auto + + from prems(1) obtain A'' where A'': "A' = constr@A''" "A'' \ set (tr A D)" + using constr_def by moura + + have 0: "F' = [] \ constr = [\X\\\: F\\<^sub>s\<^sub>t]" unfolding constr_def by simp + + have 1: "list_all tfr\<^sub>s\<^sub>t\<^sub>p A''" + using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]] + by metis + + have 2: "(F' = [] \ Q1 F X) \ Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X" + using prems(2) unfolding Q1_def Q2_def by simp + + have 3: "list_all tfr\<^sub>s\<^sub>t\<^sub>p constr" when "F' = []" "Q1 F X" + using that 0 2 tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of constr] unfolding Q1_def by auto + + { fix c assume "c \ set constr" + hence "\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D). c = \X\\\: (F@G)\\<^sub>s\<^sub>t" unfolding constr_def by force + } moreover { + fix G + assume G: "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D)" + and c: "\X\\\: (F@G)\\<^sub>s\<^sub>t \ set constr" + and e: "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X" + + have d_Q2: "Q2 (pair ` set D) X" unfolding Q2_def + proof (intro allI impI) + fix f T assume "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (pair ` set D)" + then obtain d where d: "d \ set D" "Fun f T \ subterms (pair d)" by auto + hence "fv (pair d) \ set X = {}" using prems(4) unfolding pair_def by force + thus "T = [] \ (\s \ set T. s \ Var ` set X)" + by (metis fv_disj_Fun_subterm_param_cases d(2)) + qed + + have "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F' \ pair ` set D" + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_trms_subset[OF G] by auto + hence "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis + hence "tfr\<^sub>s\<^sub>t\<^sub>p (\X\\\: (F@G)\\<^sub>s\<^sub>t)" by (metis Q2_def tfr\<^sub>s\<^sub>t\<^sub>p.simps(2)) + } ultimately have 4: "list_all tfr\<^sub>s\<^sub>t\<^sub>p constr" when "Q2 (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F') X" + using that Ball_set by blast + + have 5: "list_all tfr\<^sub>s\<^sub>t\<^sub>p constr" using 2 3 4 by metis + + show ?case using 1 5 A''(1) by simp + qed +qed + +lemma tr_tfr: + assumes "A' \ set (tr A [])" and "tfr\<^sub>s\<^sub>s\<^sub>t A" and "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + shows "tfr\<^sub>s\<^sub>t A'" +proof - + have *: "trms\<^sub>s\<^sub>t A' \ trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A" using tr_trms_subset[OF assms(1)] by simp + hence "SMP (trms\<^sub>s\<^sub>t A') \ SMP (trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" using SMP_mono by simp + moreover have "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A)" using assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by fast + ultimately have 1: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t A')" by (metis tfr_subset(2)[OF _ *]) + + have **: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p A" using assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by fast + have "pair ` setops\<^sub>s\<^sub>s\<^sub>t A \ SMP (trms\<^sub>s\<^sub>s\<^sub>t A \ pair ` setops\<^sub>s\<^sub>s\<^sub>t A) - Var`\" + using setops\<^sub>s\<^sub>s\<^sub>t_are_pairs unfolding pair_def by auto + hence ***: "\t \ pair`setops\<^sub>s\<^sub>s\<^sub>t A. \t' \ pair`setops\<^sub>s\<^sub>s\<^sub>t A. (\\. Unifier \ t t') \ \ t = \ t'" + using assms(2) unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + have 2: "list_all tfr\<^sub>s\<^sub>t\<^sub>p A'" + using tr_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p[OF assms(1) ** assms(3)] *** unfolding pair_def by fastforce + + show ?thesis by (metis 1 2 tfr\<^sub>s\<^sub>t_def) +qed + +private lemma fun_pair_ineqs: + assumes "d \\<^sub>p \ \\<^sub>p \ \ d' \\<^sub>p \" + shows "pair d \ \ \ \ \ pair d' \ \" +proof - + have "d \\<^sub>p (\ \\<^sub>s \) \ d' \\<^sub>p \" using assms subst_pair_compose by metis + hence "pair d \ (\ \\<^sub>s \) \ pair d' \ \" using fun_pair_eq_subst by metis + thus ?thesis by simp +qed + +private lemma tr_Delete_constr_iff_aux1: + assumes "\d \ set Di. (t,s) \\<^sub>p \ = d \\<^sub>p \" + and "\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \" + shows "\M; (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])\\<^sub>d \" +proof - + from assms(2) have + "\M; map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]\\<^sub>d \" + proof (induction D) + case (Cons d D) + hence IH: "\M; map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D . d \ set Di]\\<^sub>d \" by auto + thus ?case + proof (cases "d \ set Di") + case False + hence "(t,s) \\<^sub>p \ \ d \\<^sub>p \" using Cons by simp + hence "pair (t,s) \ \ \ pair d \ \" using fun_pair_eq_subst by metis + moreover have "\t (\::('fun,'var) subst). subst_domain \ = {} \ t \ \ = t" by auto + ultimately have "\\. subst_domain \ = {} \ pair (t,s) \ \ \ \ \ pair d \ \ \ \" by metis + thus ?thesis using IH by (simp add: ineq_model_def) + qed simp + qed simp + moreover { + fix B assume "\M; B\\<^sub>d \" + with assms(1) have "\M; (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@B\\<^sub>d \" + unfolding pair_def by (induction Di) auto + } ultimately show ?thesis by metis +qed + +private lemma tr_Delete_constr_iff_aux2: + assumes "ground M" + and "\M; (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])\\<^sub>d \" + shows "(\d \ set Di. (t,s) \\<^sub>p \ = d \\<^sub>p \) \ (\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \)" +proof - + let ?c1 = "map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di" + let ?c2 = "map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]" + + have "M \\<^sub>s\<^sub>e\<^sub>t \ = M" using assms(1) subst_all_ground_ident by metis + moreover have "ik\<^sub>s\<^sub>t ?c1 = {}" by auto + ultimately have *: + "\M; map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di\\<^sub>d \" + "\M; map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]\\<^sub>d \" + using strand_sem_split(3,4)[of M ?c1 ?c2 \] assms(2) by auto + + from *(1) have 1: "\d \ set Di. (t,s) \\<^sub>p \ = d \\<^sub>p \" unfolding pair_def by (induct Di) auto + from *(2) have 2: "\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \" + proof (induction D arbitrary: Di) + case (Cons d D) thus ?case + proof (cases "d \ set Di") + case False + hence IH: "\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \" using Cons by force + have "\t (\::('fun,'var) subst). subst_domain \ = {} \ ground (subst_range \) \ \ = Var" + by auto + moreover have "ineq_model \ [] [((pair (t,s)), (pair d))]" + using False Cons.prems by simp + ultimately have "pair (t,s) \ \ \ pair d \ \" by (simp add: ineq_model_def) + thus ?thesis using IH unfolding pair_def by force + qed simp + qed simp + + show ?thesis by (metis 1 2) +qed + +private lemma tr_Delete_constr_iff: + fixes \::"('fun,'var) subst" + assumes "ground M" + shows "set Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {(t,s) \\<^sub>p \} \ (t,s) \\<^sub>p \ \ (set D - set Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ + \M; (map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])\\<^sub>d \" +proof - + let ?constr = "(map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di)@ + (map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di])" + { assume "set Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {(t,s) \\<^sub>p \}" "(t,s) \\<^sub>p \ \ (set D - set Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + hence "\d \ set Di. (t,s) \\<^sub>p \ = d \\<^sub>p \" "\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \" + by auto + hence "\M; ?constr\\<^sub>d \" using tr_Delete_constr_iff_aux1 by simp + } moreover { + assume "\M; ?constr\\<^sub>d \" + hence "\d \ set Di. (t,s) \\<^sub>p \ = d \\<^sub>p \" "\d \ set D - set Di. (t,s) \\<^sub>p \ \ d \\<^sub>p \" + using assms tr_Delete_constr_iff_aux2 by auto + hence "set Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {(t,s) \\<^sub>p \} \ (t,s) \\<^sub>p \ \ (set D - set Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" by force + } ultimately show ?thesis by metis +qed + +private lemma tr_NotInSet_constr_iff: + fixes \::"('fun,'var) subst" + assumes "\(t,t') \ set D. (fv t \ fv t') \ set X = {}" + shows "(\\. subst_domain \ = set X \ ground (subst_range \) \ (t,s) \\<^sub>p \ \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) + \ \M; map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) D\\<^sub>d \" +proof - + { assume "\\. subst_domain \ = set X \ ground (subst_range \) \ (t,s) \\<^sub>p \ \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + with assms have "\M; map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) D\\<^sub>d \" + proof (induction D) + case (Cons d D) + obtain t' s' where d: "d = (t',s')" by moura + have "\M; map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) D\\<^sub>d \" + "map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) (d#D) = + \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t#map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) D" + using Cons by auto + moreover have + "\\. subst_domain \ = set X \ ground (subst_range \) \ pair (t, s) \ \ \ \ \ pair d \ \" + using fun_pair_ineqs[of \ _ "(t,s)" \ d] Cons.prems(2) by auto + moreover have "(fv t' \ fv s') \ set X = {}" using Cons.prems(1) d by auto + hence "\\. subst_domain \ = set X \ pair d \ \ = pair d" using d unfolding pair_def by auto + ultimately show ?case by (simp add: ineq_model_def) + qed simp + } moreover { + fix \::"('fun,'var) subst" + assume "\M; map (\d. \X\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) D\\<^sub>d \" + and \: "subst_domain \ = set X" "ground (subst_range \)" + with assms have "(t,s) \\<^sub>p \ \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + proof (induction D) + case (Cons d D) + obtain t' s' where d: "d = (t',s')" by moura + have "(t,s) \\<^sub>p \ \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + "pair (t,s) \ \ \ \ \ pair d \ \ \ \" + using Cons d by (auto simp add: ineq_model_def simp del: subst_range.simps) + moreover have "pair d \ \ = pair d" + using Cons.prems(1) fun_pair_subst[of d \] d \(1) unfolding pair_def by auto + ultimately show ?case unfolding pair_def by force + qed simp + } ultimately show ?thesis by metis +qed + +lemma tr_NegChecks_constr_iff: + "(\G\set L. ineq_model \ X (F@G)) \ \M; map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) L\\<^sub>d \" (is ?A) + "negchecks_model \ D X F F' \ \M; D; [\X\\\: F \\: F'\]\\<^sub>s \" (is ?B) +proof - + show ?A by (induct L) auto + show ?B by simp +qed + +lemma tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_sem_equiv: + fixes \::"('fun,'var) subst" + assumes "\(t,t') \ set D. (fv t \ fv t') \ set X = {}" + shows "negchecks_model \ (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) X F F' \ + (\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D). ineq_model \ X (F@G))" +proof - + define P where + "P \ \\::('fun,'var) subst. subst_domain \ = set X \ ground (subst_range \)" + + define Ineq where + "Ineq \ \(\::('fun,'var) subst) F. list_ex (\f. fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \) F" + + define Ineq' where + "Ineq' \ \(\::('fun,'var) subst) F. list_ex (\f. fst f \ \ \\<^sub>s \ \ snd f \ \) F" + + define Notin where + "Notin \ \(\::('fun,'var) subst) D F'. list_ex (\f. f \\<^sub>p \ \\<^sub>s \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) F'" + + have sublmm: + "((s,t) \\<^sub>p \ \\<^sub>s \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) \ (list_all (\d. Ineq' \ [(pair (s,t),pair d)]) D)" + for s t \ D + unfolding pair_def by (induct D) (auto simp add: Ineq'_def) + + have "Notin \ D F' \ (\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D). Ineq' \ G)" + (is "?A \ ?B") + when "P \" for \ + proof + show "?A \ ?B" + proof (induction F' D rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F' D) + show ?case + proof (cases "Notin \ D F'") + case False + hence "(s,t) \\<^sub>p \ \\<^sub>s \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using "2.prems" + by (auto simp add: Notin_def) + hence "pair (s,t) \ \ \\<^sub>s \ \ pair d \ \" when "d \ set D" for d + using that sublmm Ball_set[of D "\d. Ineq' \ [(pair (s,t), pair d)]"] + by (simp add: Ineq'_def) + moreover have "\d \ set D. \G'. G = (pair (s,t), pair d)#G'" + when "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F') D)" for G + using that tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_index[OF that, of 0] by force + ultimately show ?thesis by (simp add: Ineq'_def) + qed (auto dest: "2.IH" simp add: Ineq'_def) + qed (simp add: Notin_def) + + have "\?A \ \?B" + proof (induction F' D rule: tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.induct) + case (2 s t F' D) + then obtain G where G: "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D)" "\Ineq' \ G" + by (auto simp add: Notin_def) + + obtain d where d: "d \ set D" "pair (s,t) \ \ \\<^sub>s \ = pair d \ \" + using "2.prems" + unfolding pair_def by (auto simp add: Notin_def) + thus ?case + using G(2) tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_cons[OF G(1) d(1)] + by (auto simp add: Ineq'_def) + qed (simp add: Ineq'_def) + thus "?B \ ?A" by metis + qed + hence *: "(\\. P \ \ Ineq \ F \ Notin \ D F') \ + (\G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D). \\. P \ \ Ineq \ F \ Ineq' \ G)" + by auto + + have "snd g \ \ = snd g" + when "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D)" "g \ set G" "P \" + for \ g G + using assms that(3) tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_has_pair_lists[OF that(1,2)] + unfolding pair_def by (fastforce simp add: P_def) + hence **: "Ineq' \ G = Ineq \ G" + when "G \ set (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D)" "P \" + for \ G + using Bex_set[of G "\f. fst f \ \ \\<^sub>s \ \ snd f \ \"] + Bex_set[of G "\f. fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \"] + that + by (simp add: Ineq_def Ineq'_def) + + show ?thesis + using * ** + by (simp add: Ineq_def Ineq'_def Notin_def P_def negchecks_model_def ineq_model_def) +qed + +lemma tr_sem_equiv': + assumes "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + and "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + and "ground M" + and \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \ \ (\A' \ set (tr A D). \M; A'\\<^sub>d \)" (is "?P \ ?Q") +proof + have \_grounds: "\t. fv (t \ \) = {}" by (rule interpretation_grounds[OF \]) + have "\A' \ set (tr A D). \M; A'\\<^sub>d \" when ?P using that assms(1,2,3) + proof (induction A arbitrary: D rule: strand_sem_stateful_induct) + case (ConsRcv M D t A) + have "\insert (t \ \) M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground (insert (t \ \) M)" + using \ ConsRcv.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain A' where A': "A' \ set (tr A D)" "\insert (t \ \) M; A'\\<^sub>d \" by (metis ConsRcv.IH) + thus ?case by auto + next + case (ConsSnd M D t A) + have "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "M \ t \ \" + using \ ConsSnd.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain A' where A': "A' \ set (tr A D)" "\M; A'\\<^sub>d \" by (metis ConsSnd.IH) + thus ?case using * by auto + next + case (ConsEq M D ac t t' A) + have "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "t \ \ = t' \ \" + using \ ConsEq.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain A' where A': "A' \ set (tr A D)" "\M; A'\\<^sub>d \" by (metis ConsEq.IH) + thus ?case using * by auto + next + case (ConsIns M D t s A) + have "\M; set (List.insert (t,s) D) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + "\(t,t') \ set (List.insert (t,s) D). (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + using ConsIns.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain A' where A': "A' \ set (tr A (List.insert (t,s) D))" "\M; A'\\<^sub>d \" + by (metis ConsIns.IH) + thus ?case by auto + next + case (ConsDel M D t s A) + have *: "\M; (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {(t,s) \\<^sub>p \}; A\\<^sub>s \" + "\(t,t')\set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + using ConsDel.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain Di where Di: + "Di \ set D" "Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {(t,s) \\<^sub>p \}" "(t,s) \\<^sub>p \ \ (set D - Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using subset_subst_pairs_diff_exists'[of "set D"] by moura + hence **: "(set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {(t,s) \\<^sub>p \} = (set D - Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" by blast + + obtain Di' where Di': "set Di' = Di" "Di' \ set (subseqs D)" + using subset_sublist_exists[OF Di(1)] by moura + hence ***: "(set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {(t,s) \\<^sub>p \} = (set [d\D. d \ set Di'] \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \)" + using Di ** by auto + + define constr where "constr \ + map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di'@ + map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di']" + + have ****: "\(t,t')\set [d\D. d \ set Di']. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + using *(2) Di(1) Di'(1) subseqs_set_subset[OF Di'(2)] by simp + have "set D - Di = set [d\D. d \ set Di']" using Di Di' by auto + hence *****: "\M; set [d\D. d \ set Di'] \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + using *(1) ** by metis + obtain A' where A': "A' \ set (tr A [d\D. d \ set Di'])" "\M; A'\\<^sub>d \" + using ConsDel.IH[OF ***** **** *(3,4)] by moura + hence constr_sat: "\M; constr\\<^sub>d \" + using Di Di' *(1) *** tr_Delete_constr_iff[OF *(4), of \ Di' t s D] + unfolding constr_def by auto + + have "constr@A' \ set (tr (Delete t s#A) D)" using A'(1) Di' unfolding constr_def by auto + moreover have "ik\<^sub>s\<^sub>t constr = {}" unfolding constr_def by auto + hence "\M \\<^sub>s\<^sub>e\<^sub>t \; constr\\<^sub>d \" "\M \ (ik\<^sub>s\<^sub>t constr \\<^sub>s\<^sub>e\<^sub>t \); A'\\<^sub>d \" + using constr_sat A'(2) subst_all_ground_ident[OF *(4)] by simp_all + ultimately show ?case + using strand_sem_append(2)[of _ _ \] + subst_all_ground_ident[OF *(4), of \] + by metis + next + case (ConsIn M D ac t s A) + have "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "(t,s) \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using \ ConsIn.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + then obtain A' where A': "A' \ set (tr A D)" "\M; A'\\<^sub>d \" by (metis ConsIn.IH) + moreover obtain d where "d \ set D" "pair (t,s) \ \ = pair d \ \" + using * unfolding pair_def by auto + ultimately show ?case using * by auto + next + case (ConsNegChecks M D X F F' A) + let ?ineqs = "(map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))" + have 1: "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" "ground M" using ConsNegChecks by auto + have 2: "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + using ConsNegChecks.prems(2,3) \ unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by fastforce+ + + have 3: "negchecks_model \ (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) X F F'" using ConsNegChecks.prems(1) by simp + from 1 2 obtain A' where A': "A' \ set (tr A D)" "\M; A'\\<^sub>d \" by (metis ConsNegChecks.IH) + + have 4: "\(t,t') \ set D. (fv t \ fv t') \ set X = {}" + using ConsNegChecks.prems(2) unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def by auto + + have "\M; ?ineqs\\<^sub>d \" + using 3 tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_sem_equiv[OF 4] tr_NegChecks_constr_iff + by metis + moreover have "ik\<^sub>s\<^sub>t ?ineqs = {}" by auto + moreover have "M \\<^sub>s\<^sub>e\<^sub>t \ = M" using 1(2) \ by (simp add: subst_all_ground_ident) + ultimately show ?case + using strand_sem_append(2)[of M ?ineqs \ A'] A' + by force + qed simp + thus "?P \ ?Q" by metis + + have "(\A' \ set (tr A D). \M; A'\\<^sub>d \) \ ?P" using assms(1,2,3) + proof (induction A arbitrary: D rule: strand_sem_stateful_induct) + case (ConsRcv M D t A) + have "\A' \ set (tr A D). \insert (t \ \) M; A'\\<^sub>d \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground (insert (t \ \) M)" + using \ ConsRcv.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + hence "\insert (t \ \) M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" by (metis ConsRcv.IH) + thus ?case by auto + next + case (ConsSnd M D t A) + have "\A' \ set (tr A D). \M; A'\\<^sub>d \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "M \ t \ \" + using \ ConsSnd.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + hence "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" by (metis ConsSnd.IH) + thus ?case using * by auto + next + case (ConsEq M D ac t t' A) + have "\A' \ set (tr A D). \M; A'\\<^sub>d \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "t \ \ = t' \ \" + using \ ConsEq.prems unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + hence "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" by (metis ConsEq.IH) + thus ?case using * by auto + next + case (ConsIns M D t s A) + hence "\A' \ set (tr A (List.insert (t,s) D)). \M; A'\\<^sub>d \" + "\(t,t') \ set (List.insert (t,s) D). (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by auto+ + hence "\M; set (List.insert (t,s) D) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" by (metis ConsIns.IH) + thus ?case by auto + next + case (ConsDel M D t s A) + define constr where "constr \ + \Di. map (\d. \check: (pair (t,s)) \ (pair d)\\<^sub>s\<^sub>t) Di@ + map (\d. \[]\\\: [(pair (t,s), pair d)]\\<^sub>s\<^sub>t) [d\D. d \ set Di]" + let ?flt = "\Di. filter (\d. d \ set Di) D" + + have "\Di \ set (subseqs D). \B' \ set (tr A (?flt Di)). B = constr Di@B'" + when "B \ set (tr (delete\t,s\#A) D)" for B + using that unfolding constr_def by auto + then obtain A' Di where A': + "constr Di@A' \ set (tr (Delete t s#A) D)" + "A' \ set (tr A (?flt Di))" + "Di \ set (subseqs D)" + "\M; constr Di@A'\\<^sub>d \" + using ConsDel.prems(1) by blast + + have 1: "\(t,t')\set (?flt Di). (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" using ConsDel.prems(2) by auto + have 2: "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" using ConsDel.prems(3) by force+ + have "ik\<^sub>s\<^sub>t (constr Di) = {}" unfolding constr_def by auto + hence 3: "\M; A'\\<^sub>d \" + using subst_all_ground_ident[OF ConsDel.prems(4)] A'(4) + strand_sem_split(4)[of M "constr Di" A' \] + by simp + have IH: "\M; set (?flt Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + by (metis ConsDel.IH[OF _ 1 2 ConsDel.prems(4)] 3 A'(2)) + + have "\M; constr Di\\<^sub>d \" + using subst_all_ground_ident[OF ConsDel.prems(4)] strand_sem_split(3) A'(4) + by metis + hence *: "set Di \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ {(t,s) \\<^sub>p \}" "(t,s) \\<^sub>p \ \ (set D - set Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using tr_Delete_constr_iff[OF ConsDel.prems(4), of \ Di t s D] unfolding constr_def by auto + have 4: "set (?flt Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ = (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {((t,s) \\<^sub>p \)}" + proof + show "set (?flt Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \ \ (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {((t,s) \\<^sub>p \)}" + proof + fix u u' assume u: "(u,u') \ set (?flt Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + then obtain v v' where v: "(v,v') \ set D - set Di" "(v,v') \\<^sub>p \ = (u,u')" by auto + hence "(u,u') \ (t,s) \\<^sub>p \" using * by force + thus "(u,u') \ (set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {((t,s) \\<^sub>p \)}" + using u v * subseqs_set_subset[OF A'(3)] by auto + qed + show "(set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \) - {((t,s) \\<^sub>p \)} \ set (?flt Di) \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using * subseqs_set_subset[OF A'(3)] by force + qed + + show ?case using 4 IH by simp + next + case (ConsIn M D ac t s A) + have "\A' \ set (tr A D). \M; A'\\<^sub>d \" + "\(t,t') \ set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "ground M" + and *: "(t,s) \\<^sub>p \ \ set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \" + using ConsIn.prems(1,2,3,4) apply (fastforce, fastforce, fastforce, fastforce) + using ConsIn.prems(1) tr.simps(7)[of ac t s A D] unfolding pair_def by fastforce + hence "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" by (metis ConsIn.IH) + moreover obtain d where "d \ set D" "pair (t,s) \ \ = pair d \ \" + using * unfolding pair_def by auto + ultimately show ?case using * by auto + next + case (ConsNegChecks M D X F F' A) + let ?ineqs = "(map (\G. \X\\\: (F@G)\\<^sub>s\<^sub>t) (tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' D))" + + obtain B where B: + "?ineqs@B \ set (tr (NegChecks X F F'#A) D)" "\M; ?ineqs@B\\<^sub>d \" "B \ set (tr A D)" + using ConsNegChecks.prems(1) by moura + moreover have "M \\<^sub>s\<^sub>e\<^sub>t \ = M" + using ConsNegChecks.prems(4) \ by (simp add: subst_all_ground_ident) + moreover have "ik\<^sub>s\<^sub>t ?ineqs = {}" by auto + ultimately have "\M; B\\<^sub>d \" using strand_sem_split(4)[of M ?ineqs B \] by simp + moreover have "\(t,t')\set D. (fv t \ fv t') \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" + using ConsNegChecks.prems(2,3) unfolding fv\<^sub>s\<^sub>s\<^sub>t_def bvars\<^sub>s\<^sub>s\<^sub>t_def by force+ + ultimately have "\M; set D \\<^sub>p\<^sub>s\<^sub>e\<^sub>t \; A\\<^sub>s \" + by (metis ConsNegChecks.IH B(3) ConsNegChecks.prems(4)) + moreover have "\(t, t')\set D. (fv t \ fv t') \ set X = {}" + using ConsNegChecks.prems(2) unfolding bvars\<^sub>s\<^sub>s\<^sub>t_def by force + ultimately show ?case + using tr\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_sem_equiv tr_NegChecks_constr_iff + B(2) strand_sem_split(3)[of M ?ineqs B \] \M \\<^sub>s\<^sub>e\<^sub>t \ = M\ + by simp + qed simp + thus "?Q \ ?P" by metis +qed + +lemma tr_sem_equiv: + assumes "fv\<^sub>s\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>s\<^sub>t A = {}" and "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\ \\<^sub>s A \ (\A' \ set (tr A []). (\ \ \A'\))" +using tr_sem_equiv'[OF _ assms(1) _ assms(2), of "[]" "{}"] +unfolding constr_sem_d_def +by auto + +theorem stateful_typing_result: + assumes "wf\<^sub>s\<^sub>s\<^sub>t \" + and "tfr\<^sub>s\<^sub>s\<^sub>t \" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t \)" + and "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "\ \\<^sub>s \" + obtains \\<^sub>\ + where "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" + and "\\<^sub>\ \\<^sub>s \" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" +proof - + obtain \' where \': + "\' \ set (tr \ [])" "\ \ \\'\" + using tr_sem_equiv[of \] assms(1,4,5) + by auto + + have *: "wf\<^sub>s\<^sub>t {} \'" + "fv\<^sub>s\<^sub>t \' \ bvars\<^sub>s\<^sub>t \' = {}" + "tfr\<^sub>s\<^sub>t \'" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t \')" + using tr_wf[OF \'(1) assms(1,3)] + tr_tfr[OF \'(1) assms(2)] assms(1) + by metis+ + + obtain \\<^sub>\ where \\<^sub>\: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "\{}; \'\\<^sub>d \\<^sub>\" + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + using wt_attack_if_tfr_attack_d + * Ana_invar_subst' assms(4) + \'(2) + unfolding constr_sem_d_def + by moura + + thus ?thesis + using that tr_sem_equiv[of \] assms(1,3) \'(1) + unfolding constr_sem_d_def + by auto +qed + +end + +end + +subsection \Proving type-flaw resistance automatically\ +definition pair' where + "pair' pair_fun d \ case d of (t,t') \ Fun pair_fun [t,t']" + +fun comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p where + "comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ pair_fun (\_: t \ t'\) = (mgu t t' \ None \ \ t = \ t')" +| "comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ pair_fun (\X\\\: F \\: F'\) = ( + (F' = [] \ (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. is_Var (\ (Var x)))) \ + (\u \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair' pair_fun ` set F'). + is_Fun u \ (args u = [] \ (\s \ set (args u). s \ Var ` set X))))" +| "comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p _ _ _ = True" + +definition comp_tfr\<^sub>s\<^sub>s\<^sub>t where + "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \ pair_fun M S \ + list_all (comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ pair_fun) S \ + list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (trms_list\<^sub>s\<^sub>s\<^sub>t S) \ + has_all_wt_instances_of \ (trms\<^sub>s\<^sub>s\<^sub>t S \ pair' pair_fun ` setops\<^sub>s\<^sub>s\<^sub>t S) (set M) \ + comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M" + +locale stateful_typed_model' = stateful_typed_model arity public Ana \ Pair + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,(('fun,'atom::finite) term_type \ nat)) term + \ (('fun,(('fun,'atom) term_type \ nat)) term list + \ ('fun,(('fun,'atom) term_type \ nat)) term list)" + and \::"('fun,(('fun,'atom) term_type \ nat)) term \ ('fun,'atom) term_type" + and Pair::"'fun" + + + assumes \_Var_fst': "\\ n m. \ (Var (\,n)) = \ (Var (\,m))" + and Ana_const': "\c T. arity c = 0 \ Ana (Fun c T) = ([], [])" +begin + +sublocale typed_model' +by (unfold_locales, rule \_Var_fst', metis Ana_const', metis Ana_subst') + +lemma pair_code: + "pair d = pair' Pair d" +by (simp add: pair_def pair'_def) + +lemma tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p: "tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p a = comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ Pair a" +proof (cases a) + case (Equality ac t t') + thus ?thesis + using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t'] + by auto +next + case (NegChecks X F F') + thus ?thesis + using tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(2)[of X F F'] + comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(2)[of \ Pair X F F'] + Fun_range_case(2)[of "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ pair ` set F')"] + unfolding is_Var_def pair_code[symmetric] + by auto +qed auto + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t: + assumes "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \ Pair M S" + shows "tfr\<^sub>s\<^sub>s\<^sub>t S" +unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def +proof + have comp_tfr\<^sub>s\<^sub>e\<^sub>t_M: "comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M" + using assms unfolding comp_tfr\<^sub>s\<^sub>s\<^sub>t_def by blast + + have wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_S: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S)" + and S_trms_instance_M: "has_all_wt_instances_of \ (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S) (set M)" + using assms setops\<^sub>s\<^sub>s\<^sub>t_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s(2)[of S] trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[of S] + unfolding comp_tfr\<^sub>s\<^sub>s\<^sub>t_def comp_tfr\<^sub>s\<^sub>e\<^sub>t_def list_all_iff pair_code[symmetric] wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric] + finite_SMP_representation_def + by (meson, meson, blast, meson) + + show "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t S \ pair ` setops\<^sub>s\<^sub>s\<^sub>t S)" + using tfr_subset(3)[OF tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t[OF comp_tfr\<^sub>s\<^sub>e\<^sub>t_M] SMP_SMP_subset] + SMP_I'[OF wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_S wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_M S_trms_instance_M] + by blast + + have "list_all (comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \ Pair) S" by (metis assms comp_tfr\<^sub>s\<^sub>s\<^sub>t_def) + thus "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p S" by (induct S) (simp_all add: tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p) +qed + +lemma tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t': + assumes "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \ Pair (SMP0 Ana \ (trms_list\<^sub>s\<^sub>s\<^sub>t S@map pair (setops_list\<^sub>s\<^sub>s\<^sub>t S))) S" + shows "tfr\<^sub>s\<^sub>s\<^sub>t S" +by (rule tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t[OF assms]) + +end + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Strands_and_Constraints.thy b/Stateful_Protocol_Composition_and_Typing/Strands_and_Constraints.thy new file mode 100644 index 0000000..a88a358 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Strands_and_Constraints.thy @@ -0,0 +1,2783 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Strands_and_Constraints.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Strands and Symbolic Intruder Constraints\ +theory Strands_and_Constraints +imports Messages More_Unification Intruder_Deduction +begin + +subsection \Constraints, Strands and Related Definitions\ +datatype poscheckvariant = Assign ("assign") | Check ("check") + +text \ + A strand (or constraint) step is either a message transmission (either a message being sent \Send\ + or being received \Receive\) or a check on messages (a positive check \Equality\---which can be + either an "assignment" or just a check---or a negative check \Inequality\) +\ +datatype (funs\<^sub>s\<^sub>t\<^sub>p: 'a, vars\<^sub>s\<^sub>t\<^sub>p: 'b) strand_step = + Send "('a,'b) term" ("send\_\\<^sub>s\<^sub>t" 80) +| Receive "('a,'b) term" ("receive\_\\<^sub>s\<^sub>t" 80) +| Equality poscheckvariant "('a,'b) term" "('a,'b) term" ("\_: _ \ _\\<^sub>s\<^sub>t" [80,80]) +| Inequality (bvars\<^sub>s\<^sub>t\<^sub>p: "'b list") "(('a,'b) term \ ('a,'b) term) list" ("\_\\\: _\\<^sub>s\<^sub>t" [80,80]) +where + "bvars\<^sub>s\<^sub>t\<^sub>p (Send _) = []" +| "bvars\<^sub>s\<^sub>t\<^sub>p (Receive _) = []" +| "bvars\<^sub>s\<^sub>t\<^sub>p (Equality _ _ _) = []" + +text \ + A strand is a finite sequence of strand steps (constraints and strands share the same datatype) +\ +type_synonym ('a,'b) strand = "('a,'b) strand_step list" + +type_synonym ('a,'b) strands = "('a,'b) strand set" + +abbreviation "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ \(t,t') \ set F. {t,t'}" + +fun trms\<^sub>s\<^sub>t\<^sub>p::"('a,'b) strand_step \ ('a,'b) terms" where + "trms\<^sub>s\<^sub>t\<^sub>p (Send t) = {t}" +| "trms\<^sub>s\<^sub>t\<^sub>p (Receive t) = {t}" +| "trms\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = {t,t'}" +| "trms\<^sub>s\<^sub>t\<^sub>p (Inequality _ F) = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + +lemma vars\<^sub>s\<^sub>t\<^sub>p_unfold[simp]: "vars\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p x) \ set (bvars\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) auto + +text \The set of terms occurring in a strand\ +definition trms\<^sub>s\<^sub>t where "trms\<^sub>s\<^sub>t S \ \(trms\<^sub>s\<^sub>t\<^sub>p ` set S)" + +fun trms_list\<^sub>s\<^sub>t\<^sub>p::"('a,'b) strand_step \ ('a,'b) term list" where + "trms_list\<^sub>s\<^sub>t\<^sub>p (Send t) = [t]" +| "trms_list\<^sub>s\<^sub>t\<^sub>p (Receive t) = [t]" +| "trms_list\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = [t,t']" +| "trms_list\<^sub>s\<^sub>t\<^sub>p (Inequality _ F) = concat (map (\(t,t'). [t,t']) F)" + +text \The set of terms occurring in a strand (list variant)\ +definition trms_list\<^sub>s\<^sub>t where "trms_list\<^sub>s\<^sub>t S \ remdups (concat (map trms_list\<^sub>s\<^sub>t\<^sub>p S))" + +text \The set of variables occurring in a sent message\ +definition fv\<^sub>s\<^sub>n\<^sub>d::"('a,'b) strand_step \ 'b set" where + "fv\<^sub>s\<^sub>n\<^sub>d x \ case x of Send t \ fv t | _ \ {}" + +text \The set of variables occurring in a received message\ +definition fv\<^sub>r\<^sub>c\<^sub>v::"('a,'b) strand_step \ 'b set" where + "fv\<^sub>r\<^sub>c\<^sub>v x \ case x of Receive t \ fv t | _ \ {}" + +text \The set of variables occurring in an equality constraint\ +definition fv\<^sub>e\<^sub>q::"poscheckvariant \ ('a,'b) strand_step \ 'b set" where + "fv\<^sub>e\<^sub>q ac x \ case x of Equality ac' s t \ if ac = ac' then fv s \ fv t else {} | _ \ {}" + +text \The set of variables occurring at the left-hand side of an equality constraint\ +definition fv_l\<^sub>e\<^sub>q::"poscheckvariant \ ('a,'b) strand_step \ 'b set" where + "fv_l\<^sub>e\<^sub>q ac x \ case x of Equality ac' s t \ if ac = ac' then fv s else {} | _ \ {}" + +text \The set of variables occurring at the right-hand side of an equality constraint\ +definition fv_r\<^sub>e\<^sub>q::"poscheckvariant \ ('a,'b) strand_step \ 'b set" where + "fv_r\<^sub>e\<^sub>q ac x \ case x of Equality ac' s t \ if ac = ac' then fv t else {} | _ \ {}" + +text \The free variables of inequality constraints\ +definition fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q::"('a,'b) strand_step \ 'b set" where + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x \ case x of Inequality X F \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X | _ \ {}" + +fun fv\<^sub>s\<^sub>t\<^sub>p::"('a,'b) strand_step \ 'b set" where + "fv\<^sub>s\<^sub>t\<^sub>p (Send t) = fv t" +| "fv\<^sub>s\<^sub>t\<^sub>p (Receive t) = fv t" +| "fv\<^sub>s\<^sub>t\<^sub>p (Equality _ t t') = fv t \ fv t'" +| "fv\<^sub>s\<^sub>t\<^sub>p (Inequality X F) = (\(t,t') \ set F. fv t \ fv t') - set X" + +text \The set of free variables of a strand\ +definition fv\<^sub>s\<^sub>t::"('a,'b) strand \ 'b set" where + "fv\<^sub>s\<^sub>t S \ \(set (map fv\<^sub>s\<^sub>t\<^sub>p S))" + +text \The set of bound variables of a strand\ +definition bvars\<^sub>s\<^sub>t::"('a,'b) strand \ 'b set" where + "bvars\<^sub>s\<^sub>t S \ \(set (map (set \ bvars\<^sub>s\<^sub>t\<^sub>p) S))" + +text \The set of all variables occurring in a strand\ +definition vars\<^sub>s\<^sub>t::"('a,'b) strand \ 'b set" where + "vars\<^sub>s\<^sub>t S \ \(set (map vars\<^sub>s\<^sub>t\<^sub>p S))" + +abbreviation wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p::"('a,'b) strand_step \ 'b set" where + "wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p x \ + case x of Inequality _ _ \ {} | Equality Check _ _ \ {} | _ \ vars\<^sub>s\<^sub>t\<^sub>p x" + +text \The variables of a strand whose occurrences might be restricted by well-formedness constraints\ +definition wfrestrictedvars\<^sub>s\<^sub>t::"('a,'b) strand \ 'b set" where + "wfrestrictedvars\<^sub>s\<^sub>t S \ \(set (map wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p S))" + +abbreviation wfvarsoccs\<^sub>s\<^sub>t\<^sub>p where + "wfvarsoccs\<^sub>s\<^sub>t\<^sub>p x \ case x of Send t \ fv t | Equality Assign s t \ fv s | _ \ {}" + +text \The variables of a strand that occur in sent messages or as variables in assignments\ +definition wfvarsoccs\<^sub>s\<^sub>t where + "wfvarsoccs\<^sub>s\<^sub>t S \ \(set (map wfvarsoccs\<^sub>s\<^sub>t\<^sub>p S))" + +text \The variables occurring at the right-hand side of assignment steps\ +fun assignment_rhs\<^sub>s\<^sub>t where + "assignment_rhs\<^sub>s\<^sub>t [] = {}" +| "assignment_rhs\<^sub>s\<^sub>t (Equality Assign t t'#S) = insert t' (assignment_rhs\<^sub>s\<^sub>t S)" +| "assignment_rhs\<^sub>s\<^sub>t (x#S) = assignment_rhs\<^sub>s\<^sub>t S" + +text \The set function symbols occurring in a strand\ +definition funs\<^sub>s\<^sub>t::"('a,'b) strand \ 'a set" where + "funs\<^sub>s\<^sub>t S \ \(set (map funs\<^sub>s\<^sub>t\<^sub>p S))" + +fun subst_apply_strand_step::"('a,'b) strand_step \ ('a,'b) subst \ ('a,'b) strand_step" + (infix "\\<^sub>s\<^sub>t\<^sub>p" 51) where + "Send t \\<^sub>s\<^sub>t\<^sub>p \ = Send (t \ \)" +| "Receive t \\<^sub>s\<^sub>t\<^sub>p \ = Receive (t \ \)" +| "Equality a t t' \\<^sub>s\<^sub>t\<^sub>p \ = Equality a (t \ \) (t' \ \)" +| "Inequality X F \\<^sub>s\<^sub>t\<^sub>p \ = Inequality X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + +text \Substitution application for strands\ +definition subst_apply_strand::"('a,'b) strand \ ('a,'b) subst \ ('a,'b) strand" + (infix "\\<^sub>s\<^sub>t" 51) where + "S \\<^sub>s\<^sub>t \ \ map (\x. x \\<^sub>s\<^sub>t\<^sub>p \) S" + +text \The semantics of inequality constraints\ +definition + "ineq_model (\::('a,'b) subst) X F \ + (\\. subst_domain \ = set X \ ground (subst_range \) \ + list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) F)" + +fun simple\<^sub>s\<^sub>t\<^sub>p where + "simple\<^sub>s\<^sub>t\<^sub>p (Receive t) = True" +| "simple\<^sub>s\<^sub>t\<^sub>p (Send (Var v)) = True" +| "simple\<^sub>s\<^sub>t\<^sub>p (Inequality X F) = (\\. ineq_model \ X F)" +| "simple\<^sub>s\<^sub>t\<^sub>p _ = False" + +text \Simple constraints\ +definition simple where "simple S \ list_all simple\<^sub>s\<^sub>t\<^sub>p S" + +text \The intruder knowledge of a constraint\ +fun ik\<^sub>s\<^sub>t::"('a,'b) strand \ ('a,'b) terms" where + "ik\<^sub>s\<^sub>t [] = {}" +| "ik\<^sub>s\<^sub>t (Receive t#S) = insert t (ik\<^sub>s\<^sub>t S)" +| "ik\<^sub>s\<^sub>t (_#S) = ik\<^sub>s\<^sub>t S" + +text \Strand well-formedness\ +fun wf\<^sub>s\<^sub>t::"'b set \ ('a,'b) strand \ bool" where + "wf\<^sub>s\<^sub>t V [] = True" +| "wf\<^sub>s\<^sub>t V (Receive t#S) = (fv t \ V \ wf\<^sub>s\<^sub>t V S)" +| "wf\<^sub>s\<^sub>t V (Send t#S) = wf\<^sub>s\<^sub>t (V \ fv t) S" +| "wf\<^sub>s\<^sub>t V (Equality Assign s t#S) = (fv t \ V \ wf\<^sub>s\<^sub>t (V \ fv s) S)" +| "wf\<^sub>s\<^sub>t V (Equality Check s t#S) = wf\<^sub>s\<^sub>t V S" +| "wf\<^sub>s\<^sub>t V (Inequality _ _#S) = wf\<^sub>s\<^sub>t V S" + +text \Well-formedness of constraint states\ +definition wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r::"('a,'b) strand \ ('a,'b) subst \ bool" where + "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \ \ (wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>s\<^sub>t {} S \ subst_domain \ \ vars\<^sub>s\<^sub>t S = {} \ + range_vars \ \ bvars\<^sub>s\<^sub>t S = {} \ fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {})" + +declare trms\<^sub>s\<^sub>t_def[simp] +declare fv\<^sub>s\<^sub>n\<^sub>d_def[simp] +declare fv\<^sub>r\<^sub>c\<^sub>v_def[simp] +declare fv\<^sub>e\<^sub>q_def[simp] +declare fv_l\<^sub>e\<^sub>q_def[simp] +declare fv_r\<^sub>e\<^sub>q_def[simp] +declare fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q_def[simp] +declare fv\<^sub>s\<^sub>t_def[simp] +declare vars\<^sub>s\<^sub>t_def[simp] +declare bvars\<^sub>s\<^sub>t_def[simp] +declare wfrestrictedvars\<^sub>s\<^sub>t_def[simp] +declare wfvarsoccs\<^sub>s\<^sub>t_def[simp] + +lemmas wf\<^sub>s\<^sub>t_induct = wf\<^sub>s\<^sub>t.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsEq2 ConsIneq] +lemmas ik\<^sub>s\<^sub>t_induct = ik\<^sub>s\<^sub>t.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsIneq] +lemmas assignment_rhs\<^sub>s\<^sub>t_induct = assignment_rhs\<^sub>s\<^sub>t.induct[case_names Nil ConsEq2 ConsSnd ConsRcv ConsEq ConsIneq] + + +subsubsection \Lexicographical measure on strands\ +definition size\<^sub>s\<^sub>t::"('a,'b) strand \ nat" where + "size\<^sub>s\<^sub>t S \ size_list (\x. Max (insert 0 (size ` trms\<^sub>s\<^sub>t\<^sub>p x))) S" + +definition measure\<^sub>s\<^sub>t::"((('a, 'b) strand \ ('a,'b) subst) \ ('a, 'b) strand \ ('a,'b) subst) set" +where + "measure\<^sub>s\<^sub>t \ measures [\(S,\). card (fv\<^sub>s\<^sub>t S), \(S,\). size\<^sub>s\<^sub>t S]" + +lemma measure\<^sub>s\<^sub>t_alt_def: + "((s,x),(t,y)) \ measure\<^sub>s\<^sub>t = + (card (fv\<^sub>s\<^sub>t s) < card (fv\<^sub>s\<^sub>t t) \ (card (fv\<^sub>s\<^sub>t s) = card (fv\<^sub>s\<^sub>t t) \ size\<^sub>s\<^sub>t s < size\<^sub>s\<^sub>t t))" +by (simp add: measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) + +lemma measure\<^sub>s\<^sub>t_trans: "trans measure\<^sub>s\<^sub>t" +by (simp add: trans_def measure\<^sub>s\<^sub>t_def size\<^sub>s\<^sub>t_def) + + +subsubsection \Some lemmata\ +lemma trms_list\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>t: "trms\<^sub>s\<^sub>t S = set (trms_list\<^sub>s\<^sub>t S)" +unfolding trms\<^sub>s\<^sub>t_def trms_list\<^sub>s\<^sub>t_def +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma subst_apply_strand_step_def: + "s \\<^sub>s\<^sub>t\<^sub>p \ = (case s of + Send t \ Send (t \ \) + | Receive t \ Receive (t \ \) + | Equality a t t' \ Equality a (t \ \) (t' \ \) + | Inequality X F \ Inequality X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \))" +by (cases s) simp_all + +lemma subst_apply_strand_nil[simp]: "[] \\<^sub>s\<^sub>t \ = []" +unfolding subst_apply_strand_def by simp + +lemma finite_funs\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (funs\<^sub>s\<^sub>t\<^sub>p x)" by (cases x) auto +lemma finite_funs\<^sub>s\<^sub>t[simp]: "finite (funs\<^sub>s\<^sub>t S)" unfolding funs\<^sub>s\<^sub>t_def by simp +lemma finite_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[simp]: "finite (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s x)" by (induct x) auto +lemma finite_trms\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (trms\<^sub>s\<^sub>t\<^sub>p x)" by (cases x) auto +lemma finite_vars\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (vars\<^sub>s\<^sub>t\<^sub>p x)" by auto +lemma finite_bvars\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (set (bvars\<^sub>s\<^sub>t\<^sub>p x))" by rule +lemma finite_fv\<^sub>s\<^sub>n\<^sub>d[simp]: "finite (fv\<^sub>s\<^sub>n\<^sub>d x)" by (cases x) auto +lemma finite_fv\<^sub>r\<^sub>c\<^sub>v[simp]: "finite (fv\<^sub>r\<^sub>c\<^sub>v x)" by (cases x) auto +lemma finite_fv\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (fv\<^sub>s\<^sub>t\<^sub>p x)" by (cases x) auto +lemma finite_vars\<^sub>s\<^sub>t[simp]: "finite (vars\<^sub>s\<^sub>t S)" by simp +lemma finite_bvars\<^sub>s\<^sub>t[simp]: "finite (bvars\<^sub>s\<^sub>t S)" by simp +lemma finite_fv\<^sub>s\<^sub>t[simp]: "finite (fv\<^sub>s\<^sub>t S)" by simp + +lemma finite_wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) (auto split: poscheckvariant.splits) + +lemma finite_wfrestrictedvars\<^sub>s\<^sub>t[simp]: "finite (wfrestrictedvars\<^sub>s\<^sub>t S)" +using finite_wfrestrictedvars\<^sub>s\<^sub>t\<^sub>p by auto + +lemma finite_wfvarsoccs\<^sub>s\<^sub>t\<^sub>p[simp]: "finite (wfvarsoccs\<^sub>s\<^sub>t\<^sub>p x)" +by (cases x) (auto split: poscheckvariant.splits) + +lemma finite_wfvarsoccs\<^sub>s\<^sub>t[simp]: "finite (wfvarsoccs\<^sub>s\<^sub>t S)" +using finite_wfvarsoccs\<^sub>s\<^sub>t\<^sub>p by auto + +lemma finite_ik\<^sub>s\<^sub>t[simp]: "finite (ik\<^sub>s\<^sub>t S)" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) simp_all + +lemma finite_assignment_rhs\<^sub>s\<^sub>t[simp]: "finite (assignment_rhs\<^sub>s\<^sub>t S)" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) simp_all + +lemma ik\<^sub>s\<^sub>t_is_rcv_set: "ik\<^sub>s\<^sub>t A = {t. Receive t \ set A}" +by (induct A rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>tD[dest]: "t \ ik\<^sub>s\<^sub>t S \ Receive t \ set S" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>tD'[dest]: "t \ ik\<^sub>s\<^sub>t S \ t \ trms\<^sub>s\<^sub>t S" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>tD''[dest]: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t S) \ t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>t_subterm_exD: + assumes "t \ ik\<^sub>s\<^sub>t S" + shows "\x \ set S. t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p x)" +using assms ik\<^sub>s\<^sub>tD by force + +lemma assignment_rhs\<^sub>s\<^sub>tD[dest]: "t \ assignment_rhs\<^sub>s\<^sub>t S \ \t'. Equality Assign t' t \ set S" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + +lemma assignment_rhs\<^sub>s\<^sub>tD'[dest]: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>s\<^sub>t S) \ t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + +lemma bvars\<^sub>s\<^sub>t_split: "bvars\<^sub>s\<^sub>t (S@S') = bvars\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S'" +unfolding bvars\<^sub>s\<^sub>t_def by auto + +lemma bvars\<^sub>s\<^sub>t_singleton: "bvars\<^sub>s\<^sub>t [x] = set (bvars\<^sub>s\<^sub>t\<^sub>p x)" +unfolding bvars\<^sub>s\<^sub>t_def by auto + +lemma strand_fv_bvars_disjointD: + assumes "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" "Inequality X F \ set S" + shows "set X \ bvars\<^sub>s\<^sub>t S" "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ fv\<^sub>s\<^sub>t S" +using assms by (induct S) fastforce+ + +lemma strand_fv_bvars_disjoint_unfold: + assumes "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" "Inequality X F \ set S" "Inequality Y G \ set S" + shows "set Y \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X) = {}" +proof - + have "set X \ bvars\<^sub>s\<^sub>t S" "set Y \ bvars\<^sub>s\<^sub>t S" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ fv\<^sub>s\<^sub>t S" "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G - set Y \ fv\<^sub>s\<^sub>t S" + using strand_fv_bvars_disjointD[OF assms(1)] assms(2,3) by auto + thus ?thesis using assms(1) by fastforce +qed + +lemma strand_subst_hom[iff]: + "(S@S') \\<^sub>s\<^sub>t \ = (S \\<^sub>s\<^sub>t \)@(S' \\<^sub>s\<^sub>t \)" "(x#S) \\<^sub>s\<^sub>t \ = (x \\<^sub>s\<^sub>t\<^sub>p \)#(S \\<^sub>s\<^sub>t \)" +unfolding subst_apply_strand_def by auto + +lemma strand_subst_comp: "range_vars \ \ bvars\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ \\<^sub>s \ = ((S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \)" +proof (induction S) + case (Cons x S) + have *: "range_vars \ \ bvars\<^sub>s\<^sub>t S = {}" "range_vars \ \ (set (bvars\<^sub>s\<^sub>t\<^sub>p x)) = {}" + using Cons bvars\<^sub>s\<^sub>t_split[of "[x]" S] append_Cons inf_sup_absorb + by (metis (no_types, lifting) Int_iff Un_commute disjoint_iff_not_equal self_append_conv2, + metis append_self_conv2 bvars\<^sub>s\<^sub>t_singleton inf_bot_right inf_left_commute) + hence IH: "S \\<^sub>s\<^sub>t \ \\<^sub>s \ = (S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \" using Cons.IH by auto + have "(x#S \\<^sub>s\<^sub>t \ \\<^sub>s \) = (x \\<^sub>s\<^sub>t\<^sub>p \ \\<^sub>s \)#(S \\<^sub>s\<^sub>t \ \\<^sub>s \)" by (metis strand_subst_hom(2)) + hence "... = (x \\<^sub>s\<^sub>t\<^sub>p \ \\<^sub>s \)#((S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \)" by (metis IH) + hence "... = ((x \\<^sub>s\<^sub>t\<^sub>p \) \\<^sub>s\<^sub>t\<^sub>p \)#((S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \)" using rm_vars_comp[OF *(2)] + proof (induction x) + case (Inequality X F) thus ?case + by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def) + qed (simp_all add: subst_apply_strand_step_def) + thus ?case using IH by auto +qed (simp add: subst_apply_strand_def) + +lemma strand_substI[intro]: + "subst_domain \ \ fv\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" + "subst_domain \ \ vars\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" +proof - + show "subst_domain \ \ vars\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" + proof (induction S) + case (Cons x S) + hence "S \\<^sub>s\<^sub>t \ = S" by auto + moreover have "vars\<^sub>s\<^sub>t\<^sub>p x \ subst_domain \ = {}" using Cons.prems by auto + hence "x \\<^sub>s\<^sub>t\<^sub>p \ = x" + proof (induction x) + case (Inequality X F) thus ?case + by (induct F) (force simp add: subst_apply_pairs_def)+ + qed auto + ultimately show ?case by simp + qed (simp add: subst_apply_strand_def) + + show "subst_domain \ \ fv\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" + proof (induction S) + case (Cons x S) + hence "S \\<^sub>s\<^sub>t \ = S" by auto + moreover have "fv\<^sub>s\<^sub>t\<^sub>p x \ subst_domain \ = {}" + using Cons.prems by auto + hence "x \\<^sub>s\<^sub>t\<^sub>p \ = x" + proof (induction x) + case (Inequality X F) thus ?case + by (induct F) (force simp add: subst_apply_pairs_def)+ + qed auto + ultimately show ?case by simp + qed (simp add: subst_apply_strand_def) +qed + +lemma strand_substI': + "fv\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" + "vars\<^sub>s\<^sub>t S = {} \ S \\<^sub>s\<^sub>t \ = S" +by (metis inf_bot_right strand_substI(1), + metis inf_bot_right strand_substI(2)) + +lemma strand_subst_set: "(set (S \\<^sub>s\<^sub>t \)) = ((\x. x \\<^sub>s\<^sub>t\<^sub>p \) ` (set S))" +by (auto simp add: subst_apply_strand_def) + +lemma strand_map_inv_set_snd_rcv_subst: + assumes "finite (M::('a,'b) terms)" + shows "set ((map Send (inv set M)) \\<^sub>s\<^sub>t \) = Send ` (M \\<^sub>s\<^sub>e\<^sub>t \)" (is ?A) + "set ((map Receive (inv set M)) \\<^sub>s\<^sub>t \) = Receive ` (M \\<^sub>s\<^sub>e\<^sub>t \)" (is ?B) +proof - + { fix f::"('a,'b) term \ ('a,'b) strand_step" assume f: "f = Send \ f = Receive" + from assms have "set ((map f (inv set M)) \\<^sub>s\<^sub>t \) = f ` (M \\<^sub>s\<^sub>e\<^sub>t \)" + proof (induction rule: finite_induct) + case empty thus ?case unfolding inv_def by auto + next + case (insert m M) + have "set (map f (inv set (insert m M)) \\<^sub>s\<^sub>t \) = + insert (f m \\<^sub>s\<^sub>t\<^sub>p \) (set (map f (inv set M) \\<^sub>s\<^sub>t \))" + by (simp add: insert.hyps(1) inv_set_fset subst_apply_strand_def) + thus ?case using f insert.IH by auto + qed + } + thus "?A" "?B" by auto +qed + +lemma strand_ground_subst_vars_subset: + assumes "ground (subst_range \)" shows "vars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ vars\<^sub>s\<^sub>t S" +proof (induction S) + case (Cons x S) + have "vars\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ vars\<^sub>s\<^sub>t\<^sub>p x" using ground_subst_fv_subset[OF assms] + proof (cases x) + case (Inequality X F) + let ?\ = "rm_vars (set X) \" + have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + proof (induction F) + case (Cons f F) + obtain t t' where f: "f = (t,t')" by (metis surj_pair) + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) = fv (t \ ?\) \ fv (t' \ ?\) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#F) = fv t \ fv t' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + by (auto simp add: subst_apply_pairs_def) + thus ?case + using ground_subst_fv_subset[OF ground_subset[OF rm_vars_img_subset assms, of "set X"]] + Cons.IH + by (metis (no_types, lifting) Un_mono) + qed (simp add: subst_apply_pairs_def) + moreover have + "vars\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) \ set X" + "vars\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ set X" + using Inequality + by (auto simp add: subst_apply_pairs_def) + ultimately show ?thesis by auto + qed auto + thus ?case using Cons.IH by auto +qed (simp add: subst_apply_strand_def) + +lemma ik_union_subset: "\(P ` ik\<^sub>s\<^sub>t S) \ (\x \ (set S). \(P ` trms\<^sub>s\<^sub>t\<^sub>p x))" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik_snd_empty[simp]: "ik\<^sub>s\<^sub>t (map Send X) = {}" +by (induct "map Send X" arbitrary: X rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik_snd_empty'[simp]: "ik\<^sub>s\<^sub>t [Send t] = {}" by simp + +lemma ik_append[iff]: "ik\<^sub>s\<^sub>t (S@S') = ik\<^sub>s\<^sub>t S \ ik\<^sub>s\<^sub>t S'" by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik_cons: "ik\<^sub>s\<^sub>t (x#S) = ik\<^sub>s\<^sub>t [x] \ ik\<^sub>s\<^sub>t S" using ik_append[of "[x]" S] by simp + +lemma assignment_rhs_append[iff]: "assignment_rhs\<^sub>s\<^sub>t (S@S') = assignment_rhs\<^sub>s\<^sub>t S \ assignment_rhs\<^sub>s\<^sub>t S'" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + +lemma eqs_rcv_map_empty: "assignment_rhs\<^sub>s\<^sub>t (map Receive M) = {}" +by auto + +lemma ik_rcv_map: assumes "t \ set L" shows "t \ ik\<^sub>s\<^sub>t (map Receive L)" +proof - + { fix L L' + have "t \ ik\<^sub>s\<^sub>t [Receive t]" by auto + hence "t \ ik\<^sub>s\<^sub>t (map Receive L@Receive t#map Receive L')" using ik_append by auto + hence "t \ ik\<^sub>s\<^sub>t (map Receive (L@t#L'))" by auto + } + thus ?thesis using assms split_list_last by force +qed + +lemma ik_subst: "ik\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) = ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \" +by (induct rule: ik\<^sub>s\<^sub>t_induct) auto + +lemma ik_rcv_map': assumes "t \ ik\<^sub>s\<^sub>t (map Receive L)" shows "t \ set L" +using assms by force + +lemma ik_append_subset[simp]: "ik\<^sub>s\<^sub>t S \ ik\<^sub>s\<^sub>t (S@S')" "ik\<^sub>s\<^sub>t S' \ ik\<^sub>s\<^sub>t (S@S')" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma assignment_rhs_append_subset[simp]: + "assignment_rhs\<^sub>s\<^sub>t S \ assignment_rhs\<^sub>s\<^sub>t (S@S')" + "assignment_rhs\<^sub>s\<^sub>t S' \ assignment_rhs\<^sub>s\<^sub>t (S@S')" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + +lemma trms\<^sub>s\<^sub>t_cons: "trms\<^sub>s\<^sub>t (x#S) = trms\<^sub>s\<^sub>t\<^sub>p x \ trms\<^sub>s\<^sub>t S" by simp + +lemma trm_strand_subst_cong: + "t \ trms\<^sub>s\<^sub>t S \ t \ \ \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) + \ (\X F. Inequality X F \ set S \ t \ rm_vars (set X) \ \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \))" + (is "t \ trms\<^sub>s\<^sub>t S \ ?P t \ S") + "t \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ (\t'. t = t' \ \ \ t' \ trms\<^sub>s\<^sub>t S) + \ (\X F. Inequality X F \ set S \ (\t' \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. t = t' \ rm_vars (set X) \))" + (is "t \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ ?Q t \ S") +proof - + show "t \ trms\<^sub>s\<^sub>t S \ ?P t \ S" + proof (induction S) + case (Cons x S) show ?case + proof (cases "t \ trms\<^sub>s\<^sub>t S") + case True + hence "?P t \ S" using Cons by simp + thus ?thesis + by (cases x) + (metis (no_types, lifting) Un_iff list.set_intros(2) strand_subst_hom(2) trms\<^sub>s\<^sub>t_cons)+ + next + case False + hence "t \ trms\<^sub>s\<^sub>t\<^sub>p x" using Cons.prems by auto + thus ?thesis + proof (induction x) + case (Inequality X F) + hence "t \ rm_vars (set X) \ \ trms\<^sub>s\<^sub>t\<^sub>p (Inequality X F \\<^sub>s\<^sub>t\<^sub>p \)" + by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def) + thus ?case by fastforce + qed (auto simp add: subst_apply_strand_step_def) + qed + qed simp + + show "t \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ ?Q t \ S" + proof (induction S) + case (Cons x S) show ?case + proof (cases "t \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)") + case True + hence "?Q t \ S" using Cons by simp + thus ?thesis by (cases x) force+ + next + case False + hence "t \ trms\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \)" using Cons.prems by auto + thus ?thesis + proof (induction x) + case (Inequality X F) + hence "t \ trms\<^sub>s\<^sub>t\<^sub>p (Inequality X F) \\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \" + by (induct F) (force simp add: subst_apply_pairs_def)+ + thus ?case by fastforce + qed (auto simp add: subst_apply_strand_step_def) + qed + qed simp +qed + + +subsection \Lemmata: Free Variables of Strands\ +lemma fv_trm_snd_rcv[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p (Send t)) = fv t" "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p (Receive t)) = fv t" +by simp_all + +lemma in_strand_fv_subset: "x \ set S \ vars\<^sub>s\<^sub>t\<^sub>p x \ vars\<^sub>s\<^sub>t S" by fastforce +lemma in_strand_fv_subset_snd: "Send t \ set S \ fv t \ \(set (map fv\<^sub>s\<^sub>n\<^sub>d S))" by auto +lemma in_strand_fv_subset_rcv: "Receive t \ set S \ fv t \ \(set (map fv\<^sub>r\<^sub>c\<^sub>v S))" by auto + +lemma fv\<^sub>s\<^sub>n\<^sub>dE: + assumes "v \ \(set (map fv\<^sub>s\<^sub>n\<^sub>d S))" + obtains t where "send\t\\<^sub>s\<^sub>t \ set S" "v \ fv t" +proof - + have "\t. send\t\\<^sub>s\<^sub>t \ set S \ v \ fv t" + by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if + fv\<^sub>s\<^sub>n\<^sub>d_def strand_step.collapse(1)) + thus ?thesis by (metis that) +qed + +lemma fv\<^sub>r\<^sub>c\<^sub>vE: + assumes "v \ \(set (map fv\<^sub>r\<^sub>c\<^sub>v S))" + obtains t where "receive\t\\<^sub>s\<^sub>t \ set S" "v \ fv t" +proof - + have "\t. receive\t\\<^sub>s\<^sub>t \ set S \ v \ fv t" + by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if + fv\<^sub>r\<^sub>c\<^sub>v_def strand_step.collapse(2)) + thus ?thesis by (metis that) +qed + +lemma vars\<^sub>s\<^sub>t\<^sub>pI[intro]: "x \ fv\<^sub>s\<^sub>t\<^sub>p s \ x \ vars\<^sub>s\<^sub>t\<^sub>p s" +by (induct s rule: fv\<^sub>s\<^sub>t\<^sub>p.induct) auto + +lemma vars\<^sub>s\<^sub>tI[intro]: "x \ fv\<^sub>s\<^sub>t S \ x \ vars\<^sub>s\<^sub>t S" using vars\<^sub>s\<^sub>t\<^sub>pI by fastforce + +lemma fv\<^sub>s\<^sub>t_subset_vars\<^sub>s\<^sub>t[simp]: "fv\<^sub>s\<^sub>t S \ vars\<^sub>s\<^sub>t S" using vars\<^sub>s\<^sub>tI by force + +lemma vars\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>t: "vars\<^sub>s\<^sub>t S = fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S" +proof (induction S) + case (Cons x S) thus ?case + proof (induction x) + case (Inequality X F) thus ?case by (induct F) auto + qed auto +qed simp + +lemma fv\<^sub>s\<^sub>t\<^sub>p_is_subterm_trms\<^sub>s\<^sub>t\<^sub>p: "x \ fv\<^sub>s\<^sub>t\<^sub>p a \ Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p a)" +using var_is_subterm by (cases a) force+ + +lemma fv\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>t: "x \ fv\<^sub>s\<^sub>t A \ Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t A)" +proof (induction A) + case (Cons a A) thus ?case using fv\<^sub>s\<^sub>t\<^sub>p_is_subterm_trms\<^sub>s\<^sub>t\<^sub>p by (cases "x \ fv\<^sub>s\<^sub>t A") auto +qed simp + +lemma vars_st_snd_map: "vars\<^sub>s\<^sub>t (map Send X) = fv (Fun f X)" by auto + +lemma vars_st_rcv_map: "vars\<^sub>s\<^sub>t (map Receive X) = fv (Fun f X)" by auto + +lemma vars_snd_rcv_union: + "vars\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>s\<^sub>n\<^sub>d x \ fv\<^sub>r\<^sub>c\<^sub>v x \ fv\<^sub>e\<^sub>q assign x \ fv\<^sub>e\<^sub>q check x \ fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x \ set (bvars\<^sub>s\<^sub>t\<^sub>p x)" +proof (cases x) + case (Equality ac t t') thus ?thesis by (cases ac) auto +qed auto + +lemma fv_snd_rcv_union: + "fv\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>s\<^sub>n\<^sub>d x \ fv\<^sub>r\<^sub>c\<^sub>v x \ fv\<^sub>e\<^sub>q assign x \ fv\<^sub>e\<^sub>q check x \ fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x" +proof (cases x) + case (Equality ac t t') thus ?thesis by (cases ac) auto +qed auto + +lemma fv_snd_rcv_empty[simp]: "fv\<^sub>s\<^sub>n\<^sub>d x = {} \ fv\<^sub>r\<^sub>c\<^sub>v x = {}" by (cases x) simp_all + +lemma vars_snd_rcv_strand[iff]: + "vars\<^sub>s\<^sub>t (S::('a,'b) strand) = + (\(set (map fv\<^sub>s\<^sub>n\<^sub>d S))) \ (\(set (map fv\<^sub>r\<^sub>c\<^sub>v S))) \ (\(set (map (fv\<^sub>e\<^sub>q assign) S))) + \ (\(set (map (fv\<^sub>e\<^sub>q check) S))) \ (\(set (map fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q S))) \ bvars\<^sub>s\<^sub>t S" +unfolding bvars\<^sub>s\<^sub>t_def +proof (induction S) + case (Cons x S) + have "\s V. vars\<^sub>s\<^sub>t\<^sub>p (s::('a,'b) strand_step) \ V = + fv\<^sub>s\<^sub>n\<^sub>d s \ fv\<^sub>r\<^sub>c\<^sub>v s \ fv\<^sub>e\<^sub>q assign s \ fv\<^sub>e\<^sub>q check s \ fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q s \ set (bvars\<^sub>s\<^sub>t\<^sub>p s) \ V" + by (metis vars_snd_rcv_union) + thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute) +qed simp + +lemma fv_snd_rcv_strand[iff]: + "fv\<^sub>s\<^sub>t (S::('a,'b) strand) = + (\(set (map fv\<^sub>s\<^sub>n\<^sub>d S))) \ (\(set (map fv\<^sub>r\<^sub>c\<^sub>v S))) \ (\(set (map (fv\<^sub>e\<^sub>q assign) S))) + \ (\(set (map (fv\<^sub>e\<^sub>q check) S))) \ (\(set (map fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q S)))" +unfolding bvars\<^sub>s\<^sub>t_def +proof (induction S) + case (Cons x S) + have "\s V. fv\<^sub>s\<^sub>t\<^sub>p (s::('a,'b) strand_step) \ V = + fv\<^sub>s\<^sub>n\<^sub>d s \ fv\<^sub>r\<^sub>c\<^sub>v s \ fv\<^sub>e\<^sub>q assign s \ fv\<^sub>e\<^sub>q check s \ fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q s \ V" + by (metis fv_snd_rcv_union) + thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute) +qed simp + +lemma vars_snd_rcv_strand2[iff]: + "wfrestrictedvars\<^sub>s\<^sub>t (S::('a,'b) strand) = + (\(set (map fv\<^sub>s\<^sub>n\<^sub>d S))) \ (\(set (map fv\<^sub>r\<^sub>c\<^sub>v S))) \ (\(set (map (fv\<^sub>e\<^sub>q assign) S)))" +by (induct S) (auto simp add: split: strand_step.split poscheckvariant.split) + +lemma fv_snd_rcv_strand_subset[simp]: + "\(set (map fv\<^sub>s\<^sub>n\<^sub>d S)) \ fv\<^sub>s\<^sub>t S" "\(set (map fv\<^sub>r\<^sub>c\<^sub>v S)) \ fv\<^sub>s\<^sub>t S" + "\(set (map (fv\<^sub>e\<^sub>q ac) S)) \ fv\<^sub>s\<^sub>t S" "\(set (map fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q S)) \ fv\<^sub>s\<^sub>t S" + "wfvarsoccs\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>t S" +proof - + show "\(set (map fv\<^sub>s\<^sub>n\<^sub>d S)) \ fv\<^sub>s\<^sub>t S" "\(set (map fv\<^sub>r\<^sub>c\<^sub>v S)) \ fv\<^sub>s\<^sub>t S" "\(set (map fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q S)) \ fv\<^sub>s\<^sub>t S" + using fv_snd_rcv_strand[of S] by auto + + show "\(set (map (fv\<^sub>e\<^sub>q ac) S)) \ fv\<^sub>s\<^sub>t S" + by (induct S) (auto split: strand_step.split poscheckvariant.split) + + show "wfvarsoccs\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>t S" + by (induct S) (auto split: strand_step.split poscheckvariant.split) +qed + +lemma vars_snd_rcv_strand_subset2[simp]: + "\(set (map fv\<^sub>s\<^sub>n\<^sub>d S)) \ wfrestrictedvars\<^sub>s\<^sub>t S" "\(set (map fv\<^sub>r\<^sub>c\<^sub>v S)) \ wfrestrictedvars\<^sub>s\<^sub>t S" + "\(set (map (fv\<^sub>e\<^sub>q assign) S)) \ wfrestrictedvars\<^sub>s\<^sub>t S" "wfvarsoccs\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>t S" +by (induction S) (auto split: strand_step.split poscheckvariant.split) + +lemma wfrestrictedvars\<^sub>s\<^sub>t_subset_vars\<^sub>s\<^sub>t: "wfrestrictedvars\<^sub>s\<^sub>t S \ vars\<^sub>s\<^sub>t S" +by (induction S) (auto split: strand_step.split poscheckvariant.split) + +lemma subst_sends_strand_step_fv_to_img: "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>t\<^sub>p x \ range_vars \" +using subst_sends_fv_to_img[of _ \] +proof (cases x) + case (Inequality X F) + let ?\ = "rm_vars (set X) \" + have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ range_vars ?\" + proof (induction F) + case (Cons f F) thus ?case + using subst_sends_fv_to_img[of _ ?\] + by (auto simp add: subst_apply_pairs_def) + qed (auto simp add: subst_apply_pairs_def) + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ range_vars \" + using rm_vars_img_subset[of "set X" \] fv_set_mono + unfolding range_vars_alt_def by blast+ + thus ?thesis using Inequality by (auto simp add: subst_apply_strand_step_def) +qed (auto simp add: subst_apply_strand_step_def) + +lemma subst_sends_strand_fv_to_img: "fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t S \ range_vars \" +proof (induction S) + case (Cons x S) + have *: "fv\<^sub>s\<^sub>t (x#S \\<^sub>s\<^sub>t \) = fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" + "fv\<^sub>s\<^sub>t (x#S) \ range_vars \ = fv\<^sub>s\<^sub>t\<^sub>p x \ fv\<^sub>s\<^sub>t S \ range_vars \" + by auto + thus ?case using Cons.IH subst_sends_strand_step_fv_to_img[of x \] by auto +qed simp + +lemma ineq_apply_subst: + assumes "subst_domain \ \ set X = {}" + shows "(Inequality X F) \\<^sub>s\<^sub>t\<^sub>p \ = Inequality X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +using rm_vars_apply'[OF assms] by (simp add: subst_apply_strand_step_def) + +lemma fv_strand_step_subst: + assumes "P = fv\<^sub>s\<^sub>t\<^sub>p \ P = fv\<^sub>r\<^sub>c\<^sub>v \ P = fv\<^sub>s\<^sub>n\<^sub>d \ P = fv\<^sub>e\<^sub>q ac \ P = fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q" + and "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + shows "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (P x)) = P (x \\<^sub>s\<^sub>t\<^sub>p \)" +proof (cases x) + case (Send t) + hence "vars\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>s\<^sub>n\<^sub>d x = fv t" by auto + thus ?thesis using assms Send subst_apply_fv_unfold[of _ \] by auto +next + case (Receive t) + hence "vars\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>r\<^sub>c\<^sub>v x = fv t" by auto + thus ?thesis using assms Receive subst_apply_fv_unfold[of _ \] by auto +next + case (Equality ac' t t') show ?thesis + proof (cases "ac = ac'") + case True + hence "vars\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>e\<^sub>q ac x = fv t \ fv t'" + using Equality + by auto + thus ?thesis + using assms Equality subst_apply_fv_unfold[of _ \] True + by auto + next + case False + hence "vars\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>e\<^sub>q ac x = {}" + using Equality + by auto + thus ?thesis + using assms Equality subst_apply_fv_unfold[of _ \] False + by auto + qed +next + case (Inequality X F) + hence 1: "set X \ (subst_domain \ \ range_vars \) = {}" + "x \\<^sub>s\<^sub>t\<^sub>p \ = Inequality X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + "rm_vars (set X) \ = \" + using assms ineq_apply_subst[of \ X F] rm_vars_apply'[of \ "set X"] + unfolding range_vars_alt_def by force+ + + have 2: "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" using Inequality by auto + hence "fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) - set X" + using fv\<^sub>s\<^sub>e\<^sub>t_subst_img_eq[OF 1(1), of "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"] by simp + hence 3: "fv\<^sub>s\<^sub>e\<^sub>t (\ ` fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" by (metis fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_step_subst) + + have 4: "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" using 1(2) by auto + + show ?thesis + using assms(1) Inequality subst_apply_fv_unfold[of _ \] 1(2) 2 3 4 + unfolding fv\<^sub>e\<^sub>q_def fv\<^sub>r\<^sub>c\<^sub>v_def fv\<^sub>s\<^sub>n\<^sub>d_def + by (metis (no_types) Sup_empty image_empty fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.simps fv\<^sub>s\<^sub>e\<^sub>t.simps + fv\<^sub>s\<^sub>t\<^sub>p.simps(4) strand_step.simps(20)) +qed + +lemma fv_strand_subst: + assumes "P = fv\<^sub>s\<^sub>t\<^sub>p \ P = fv\<^sub>r\<^sub>c\<^sub>v \ P = fv\<^sub>s\<^sub>n\<^sub>d \ P = fv\<^sub>e\<^sub>q ac \ P = fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q" + and "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (\(set (map P S)))) = \(set (map P (S \\<^sub>s\<^sub>t \)))" +using assms(2) +proof (induction S) + case (Cons x S) + hence *: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + unfolding bvars\<^sub>s\<^sub>t_def by force+ + hence **: "fv\<^sub>s\<^sub>e\<^sub>t (\ ` P x) = P (x \\<^sub>s\<^sub>t\<^sub>p \)" using fv_strand_step_subst[OF assms(1), of x \] by auto + have "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (\(set (map P (x#S))))) = fv\<^sub>s\<^sub>e\<^sub>t (\ ` P x) \ (\(set (map P ((S \\<^sub>s\<^sub>t \)))))" + using Cons unfolding range_vars_alt_def bvars\<^sub>s\<^sub>t_def by force + hence "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (\(set (map P (x#S))))) = P (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (\(set (map P S))))" + using ** by simp + thus ?case using Cons.IH[OF *(1)] unfolding bvars\<^sub>s\<^sub>t_def by simp +qed simp + +lemma fv_strand_subst2: + assumes "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (wfrestrictedvars\<^sub>s\<^sub>t S)) = wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +by (metis (no_types, lifting) assms fv\<^sub>s\<^sub>e\<^sub>t.simps vars_snd_rcv_strand2 fv_strand_subst UN_Un image_Un) + +lemma fv_strand_subst': + assumes "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv\<^sub>s\<^sub>e\<^sub>t (\ ` (fv\<^sub>s\<^sub>t S)) = fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +by (metis assms fv_strand_subst fv\<^sub>s\<^sub>t_def) + +lemma fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s: + "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" +by auto + +lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_in_fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ x \ fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)" +using fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of F] by blast + +lemma trms\<^sub>s\<^sub>t_append: "trms\<^sub>s\<^sub>t (A@B) = trms\<^sub>s\<^sub>t A \ trms\<^sub>s\<^sub>t B" +by auto + +lemma trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst: "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (a \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s a \\<^sub>s\<^sub>e\<^sub>t \" +by (auto simp add: subst_apply_pairs_def) + +lemma trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fv_subst_subset: + "t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ fv (t \ \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +by (force simp add: subst_apply_pairs_def) + +lemma trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fv_subst_subset': + fixes t::"('a,'b) term" and \::"('a,'b) subst" + assumes "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)" + shows "fv (t \ \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +proof - + { fix x assume "x \ fv t" + hence "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + using fv_subset[OF assms] fv_subterms_set[of "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"] fv_trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[of F] + by blast + hence "fv (\ x) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_fv_subset by fast + } thus ?thesis by (meson fv_subst_obtain_var subset_iff) +qed + +lemma trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_funs_term_cases: + assumes "t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" "f \ funs_term t" + shows "(\u \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. f \ funs_term u) \ (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. f \ funs_term (\ x))" +using assms(1) +proof (induction F) + case (Cons g F) + obtain s u where g: "g = (s,u)" by (metis surj_pair) + show ?case + proof (cases "t \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)") + case False + thus ?thesis + using assms(2) Cons.prems g funs_term_subst[of _ \] + by (auto simp add: subst_apply_pairs_def) + qed (use Cons.IH in fastforce) +qed simp + +lemma trm\<^sub>s\<^sub>t\<^sub>p_subst: + assumes "subst_domain \ \ set (bvars\<^sub>s\<^sub>t\<^sub>p a) = {}" + shows "trms\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>t\<^sub>p \) = trms\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \" +proof - + have "rm_vars (set (bvars\<^sub>s\<^sub>t\<^sub>p a)) \ = \" using assms by force + thus ?thesis + using assms + by (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def + split: strand_step.splits) +qed + +lemma trms\<^sub>s\<^sub>t_subst: + assumes "subst_domain \ \ bvars\<^sub>s\<^sub>t A = {}" + shows "trms\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>t \) = trms\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction A) + case (Cons a A) + have 1: "subst_domain \ \ bvars\<^sub>s\<^sub>t A = {}" "subst_domain \ \ set (bvars\<^sub>s\<^sub>t\<^sub>p a) = {}" + using Cons.prems by auto + hence IH: "trms\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \ = trms\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>t \)" using Cons.IH by simp + + have "trms\<^sub>s\<^sub>t (a#A) = trms\<^sub>s\<^sub>t\<^sub>p a \ trms\<^sub>s\<^sub>t A" by auto + hence 2: "trms\<^sub>s\<^sub>t (a#A) \\<^sub>s\<^sub>e\<^sub>t \ = (trms\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \) \ (trms\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \)" by (metis image_Un) + + have "trms\<^sub>s\<^sub>t (a#A \\<^sub>s\<^sub>t \) = (trms\<^sub>s\<^sub>t\<^sub>p (a \\<^sub>s\<^sub>t\<^sub>p \)) \ trms\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>t \)" + by (auto simp add: subst_apply_strand_def) + hence 3: "trms\<^sub>s\<^sub>t (a#A \\<^sub>s\<^sub>t \) = (trms\<^sub>s\<^sub>t\<^sub>p a \\<^sub>s\<^sub>e\<^sub>t \) \ trms\<^sub>s\<^sub>t (A \\<^sub>s\<^sub>t \)" + using trm\<^sub>s\<^sub>t\<^sub>p_subst[OF 1(2)] by auto + + show ?case using IH 2 3 by metis +qed (simp add: subst_apply_strand_def) + +lemma strand_map_set_subst: + assumes \: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "\(set (map trms\<^sub>s\<^sub>t\<^sub>p (S \\<^sub>s\<^sub>t \))) = (\(set (map trms\<^sub>s\<^sub>t\<^sub>p S))) \\<^sub>s\<^sub>e\<^sub>t \" +using assms +proof (induction S) + case (Cons x S) + hence "bvars\<^sub>s\<^sub>t [x] \ subst_domain \ = {}" "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + unfolding bvars\<^sub>s\<^sub>t_def by force+ + hence *: "subst_domain \ \ set (bvars\<^sub>s\<^sub>t\<^sub>p x) = {}" + "\(set (map trms\<^sub>s\<^sub>t\<^sub>p (S \\<^sub>s\<^sub>t \))) = \(set (map trms\<^sub>s\<^sub>t\<^sub>p S)) \\<^sub>s\<^sub>e\<^sub>t \" + using Cons.IH(1) bvars\<^sub>s\<^sub>t_singleton[of x] by auto + hence "trms\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = (trms\<^sub>s\<^sub>t\<^sub>p x) \\<^sub>s\<^sub>e\<^sub>t \" + proof (cases x) + case (Inequality X F) + thus ?thesis + using rm_vars_apply'[of \ "set X"] * + by (metis (no_types, lifting) image_cong trm\<^sub>s\<^sub>t\<^sub>p_subst) + qed simp_all + thus ?case using * subst_all_insert by auto +qed simp + +lemma subst_apply_fv_subset_strand_trm: + assumes P: "P = fv\<^sub>s\<^sub>t\<^sub>p \ P = fv\<^sub>r\<^sub>c\<^sub>v \ P = fv\<^sub>s\<^sub>n\<^sub>d \ P = fv\<^sub>e\<^sub>q ac \ P = fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q" + and fv_sub: "fv t \ \(set (map P S)) \ V" + and \: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" +using fv_strand_subst[OF P \] subst_apply_fv_subset[OF fv_sub, of \] by force + +lemma subst_apply_fv_subset_strand_trm2: + assumes fv_sub: "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + and \: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" +using fv_strand_subst2[OF \] subst_apply_fv_subset[OF fv_sub, of \] by force + +lemma subst_apply_fv_subset_strand: + assumes P: "P = fv\<^sub>s\<^sub>t\<^sub>p \ P = fv\<^sub>r\<^sub>c\<^sub>v \ P = fv\<^sub>s\<^sub>n\<^sub>d \ P = fv\<^sub>e\<^sub>q ac \ P = fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q" + and P_subset: "P x \ \(set (map P S)) \ V" + and \: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + shows "P (x \\<^sub>s\<^sub>t\<^sub>p \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" +proof (cases x) + case (Send t) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = fv t" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + by auto + hence **: "(P x = fv t \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)) \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + hence "fv t \ \(set (map P S)) \ V" using P_subset by auto + hence "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + unfolding vars\<^sub>s\<^sub>t_def using P subst_apply_fv_subset_strand_trm assms by blast + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)\ by force + } + ultimately show ?thesis by metis +next + case (Receive t) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = fv t" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + by auto + hence **: "(P x = fv t \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)) \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + hence "fv t \ \(set (map P S)) \ V" using P_subset by auto + hence "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + unfolding vars\<^sub>s\<^sub>t_def using P subst_apply_fv_subset_strand_trm assms by blast + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)\ by blast + } + ultimately show ?thesis by metis +next + case (Equality ac' t t') show ?thesis + proof (cases "ac' = ac") + case True + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = fv t \ fv t'" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + using Equality by auto + hence **: "(P x = fv t \ fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t \ fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + hence "fv t \ \(set (map P S)) \ V" "fv t' \ \(set (map P S)) \ V" using P_subset by auto + hence "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + "fv (t' \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + unfolding vars\<^sub>s\<^sub>t_def using P subst_apply_fv_subset_strand_trm assms by metis+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)\ by blast + } + ultimately show ?thesis by metis + next + case False + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + using Equality by auto + hence **: "(P x = fv t \ fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t \ fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + hence "fv t \ \(set (map P S)) \ V" "fv t' \ \(set (map P S)) \ V" using P_subset by auto + hence "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + "fv (t' \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + unfolding vars\<^sub>s\<^sub>t_def using P subst_apply_fv_subset_strand_trm assms by metis+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)\ by blast + } + ultimately show ?thesis by metis + qed +next + case (Inequality X F) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + using \(2) ineq_apply_subst[of \ X F] by force+ + hence **: "(P x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ \(set (map P S)) \ V" + using P_subset by auto + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + proof (induction F) + case (Cons f G) + hence IH: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff + list.simps(15) fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.simps) + obtain t t' where f: "f = (t,t')" by (metis surj_pair) + hence "fv t \ \(set (map P S)) \ (V \ set X)" "fv t' \ \(set (map P S)) \ (V \ set X)" + using Cons.prems by auto + hence "fv (t \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + "fv (t' \ \) \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + using subst_apply_fv_subset_strand_trm[OF P _ assms(3)] + by blast+ + thus ?case using f IH by (auto simp add: subst_apply_pairs_def) + qed (simp add: subst_apply_pairs_def) + moreover have "fv\<^sub>s\<^sub>e\<^sub>t (\ ` set X) = set X" using assms(4) Inequality by force + ultimately have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X \ \(set (map P (S \\<^sub>s\<^sub>t \))) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + by auto + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X\ by blast + } + ultimately show ?thesis by metis +qed + +lemma subst_apply_fv_subset_strand2: + assumes P: "P = fv\<^sub>s\<^sub>t\<^sub>p \ P = fv\<^sub>r\<^sub>c\<^sub>v \ P = fv\<^sub>s\<^sub>n\<^sub>d \ P = fv\<^sub>e\<^sub>q ac \ P = fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q \ P = fv_r\<^sub>e\<^sub>q ac" + and P_subset: "P x \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + and \: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + shows "P (x \\<^sub>s\<^sub>t\<^sub>p \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" +proof (cases x) + case (Send t) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = fv t" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv_r\<^sub>e\<^sub>q ac x = {}" "fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + by auto + hence **: "(P x = fv t \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)) \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)\ by blast + } + ultimately show ?thesis by metis +next + case (Receive t) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = fv t" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv_r\<^sub>e\<^sub>q ac x = {}" "fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + by auto + hence **: "(P x = fv t \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)) \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)\ by blast + } + ultimately show ?thesis by metis +next + case (Equality ac' t t') show ?thesis + proof (cases "ac' = ac") + case True + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = fv t \ fv t'" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv_r\<^sub>e\<^sub>q ac x = fv t'" "fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \)" + using Equality by auto + hence **: "(P x = fv t \ fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}) + \ (P x = fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \))" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t \ fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + "fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)\ by blast + } + moreover + { assume "P x = fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \)" + hence "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \)\ by blast + } + ultimately show ?thesis by metis + next + case False + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv t \ fv t'" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = {}" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv_r\<^sub>e\<^sub>q ac x = {}" "fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + using Equality by auto + hence **: "(P x = fv t \ fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}) + \ (P x = fv t' \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \))" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv t \ fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + using P_subset by auto + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + "fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)\ by blast + } + moreover + { assume "P x = fv t'" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \)" + hence "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using P subst_apply_fv_subset_strand_trm2 assms by blast+ + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv (t' \ \)\ by blast + } + ultimately show ?thesis by metis + qed +next + case (Inequality X F) + hence *: "fv\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + "fv\<^sub>r\<^sub>c\<^sub>v x = {}" "fv\<^sub>r\<^sub>c\<^sub>v (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>s\<^sub>n\<^sub>d x = {}" "fv\<^sub>s\<^sub>n\<^sub>d (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>e\<^sub>q ac x = {}" "fv\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" "fv\<^sub>i\<^sub>n\<^sub>e\<^sub>q (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + "fv_r\<^sub>e\<^sub>q ac x = {}" "fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" + using \(2) ineq_apply_subst[of \ X F] by force+ + hence **: "(P x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X) + \ (P x = {} \ P (x \\<^sub>s\<^sub>t\<^sub>p \) = {})" + by (metis P) + moreover + { assume "P x = {}" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = {}" hence ?thesis by simp } + moreover + { assume "P x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" "P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X" + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" using P_subset by auto + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + proof (induction F) + case (Cons f G) + hence IH: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff + list.simps(15) fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.simps) + obtain t t' where f: "f = (t,t')" by (metis surj_pair) + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ set X)" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ set X)" + using Cons.prems by auto + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + "fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ set X))" + using subst_apply_fv_subset_strand_trm2[OF _ assms(3)] P + by blast+ + thus ?case using f IH by (auto simp add: subst_apply_pairs_def) + qed (simp add: subst_apply_pairs_def) + moreover have "fv\<^sub>s\<^sub>e\<^sub>t (\ ` set X) = set X" using assms(4) Inequality by force + ultimately have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + by fastforce + hence ?thesis using \P (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) - set X\ by blast + } + ultimately show ?thesis by metis +qed + +lemma strand_subst_fv_bounded_if_img_bounded: + assumes "range_vars \ \ fv\<^sub>s\<^sub>t S" + shows "fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t S" +using subst_sends_strand_fv_to_img[of S \] assms by blast + +lemma strand_fv_subst_subset_if_subst_elim: + assumes "subst_elim \ v" and "v \ fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "v \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +proof (cases "v \ fv\<^sub>s\<^sub>t S") + case True thus ?thesis + proof (induction S) + case (Cons x S) + have *: "v \ fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \)" + using assms(1) + proof (cases x) + case (Inequality X F) + hence "subst_elim (rm_vars (set X) \) v \ v \ set X" using assms(1) by blast + moreover have "fv\<^sub>s\<^sub>t\<^sub>p (Inequality X F \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \) - set X" + using Inequality by auto + ultimately have "v \ fv\<^sub>s\<^sub>t\<^sub>p (Inequality X F \\<^sub>s\<^sub>t\<^sub>p \)" + by (induct F) (auto simp add: subst_elim_def subst_apply_pairs_def) + thus ?thesis using Inequality by simp + qed (simp_all add: subst_elim_def) + moreover have "v \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" using Cons.IH + proof (cases "v \ fv\<^sub>s\<^sub>t S") + case False + moreover have "v \ range_vars \" + by (simp add: subst_elimD''[OF assms(1)] range_vars_alt_def) + ultimately show ?thesis by (meson UnE subsetCE subst_sends_strand_fv_to_img) + qed simp + ultimately show ?case by auto + qed simp +next + case False + thus ?thesis + using assms fv_strand_subst' + unfolding subst_elim_def + by (metis (mono_tags, hide_lams) fv\<^sub>s\<^sub>e\<^sub>t.simps imageE mem_simps(8) subst_apply_term.simps(1)) +qed + +lemma strand_fv_subst_subset_if_subst_elim': + assumes "subst_elim \ v" "v \ fv\<^sub>s\<^sub>t S" "range_vars \ \ fv\<^sub>s\<^sub>t S" + shows "fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>t S" +using strand_fv_subst_subset_if_subst_elim[OF assms(1)] assms(2) + strand_subst_fv_bounded_if_img_bounded[OF assms(3)] +by blast + +lemma fv_ik_is_fv_rcv: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t S) = \(set (map fv\<^sub>r\<^sub>c\<^sub>v S))" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma fv_ik_subset_fv_st[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t S) \ wfrestrictedvars\<^sub>s\<^sub>t S" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma fv_assignment_rhs_subset_fv_st[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>s\<^sub>t S) \ wfrestrictedvars\<^sub>s\<^sub>t S" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) force+ + +lemma fv_ik_subset_fv_st'[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t S) \ fv\<^sub>s\<^sub>t S" +by (induct S rule: ik\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>t_var_is_fv: "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t A) \ x \ fv\<^sub>s\<^sub>t A" +by (meson fv_ik_subset_fv_st'[of A] fv_subset_subterms subsetCE term.set_intros(3)) + +lemma fv_assignment_rhs_subset_fv_st'[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>s\<^sub>t S) \ fv\<^sub>s\<^sub>t S" +by (induct S rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + +lemma ik\<^sub>s\<^sub>t_assignment_rhs\<^sub>s\<^sub>t_wfrestrictedvars_subset: + "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>s\<^sub>t A) \ wfrestrictedvars\<^sub>s\<^sub>t A" +using fv_ik_subset_fv_st[of A] fv_assignment_rhs_subset_fv_st[of A] +by simp+ + +lemma strand_step_id_subst[iff]: "x \\<^sub>s\<^sub>t\<^sub>p Var = x" by (cases x) auto + +lemma strand_id_subst[iff]: "S \\<^sub>s\<^sub>t Var = S" using strand_step_id_subst by (induct S) auto + +lemma strand_subst_vars_union_bound[simp]: "vars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ vars\<^sub>s\<^sub>t S \ range_vars \" +proof (induction S) + case (Cons x S) + moreover have "vars\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ vars\<^sub>s\<^sub>t\<^sub>p x \ range_vars \" using subst_sends_fv_to_img[of _ \] + proof (cases x) + case (Inequality X F) + define \' where "\' \ rm_vars (set X) \" + have 0: "range_vars \' \ range_vars \" + using rm_vars_img[of "set X" \] + by (auto simp add: \'_def subst_domain_def range_vars_alt_def) + + have "vars\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \') \ set X" "vars\<^sub>s\<^sub>t\<^sub>p x = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ set X" + using Inequality by (auto simp add: \'_def) + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \') \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ range_vars \" + proof (induction F) + case (Cons f G) + obtain t t' where f: "f = (t,t')" by moura + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \') = fv (t \ \') \ fv (t' \ \') \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \')" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#G) = fv t \ fv t' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" + by (auto simp add: subst_apply_pairs_def) + thus ?case + using 0 Cons.IH subst_sends_fv_to_img[of t \'] subst_sends_fv_to_img[of t' \'] + unfolding f by auto + qed (simp add: subst_apply_pairs_def) + ultimately show ?thesis by auto + qed auto + ultimately show ?case by auto +qed simp + +lemma strand_vars_split: + "vars\<^sub>s\<^sub>t (S@S') = vars\<^sub>s\<^sub>t S \ vars\<^sub>s\<^sub>t S'" + "wfrestrictedvars\<^sub>s\<^sub>t (S@S') = wfrestrictedvars\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>s\<^sub>t S'" + "fv\<^sub>s\<^sub>t (S@S') = fv\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>t S'" +by auto + +lemma bvars_subst_ident: "bvars\<^sub>s\<^sub>t S = bvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +unfolding bvars\<^sub>s\<^sub>t_def +by (induct S) (simp_all add: subst_apply_strand_step_def split: strand_step.splits) + +lemma strand_subst_subst_idem: + assumes "subst_idem \" "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t S" "subst_domain \ \ fv\<^sub>s\<^sub>t S = {}" + "range_vars \ \ bvars\<^sub>s\<^sub>t S = {}" "range_vars \ \ bvars\<^sub>s\<^sub>t S = {}" + shows "(S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = (S \\<^sub>s\<^sub>t \)" + and "(S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t (\ \\<^sub>s \) = (S \\<^sub>s\<^sub>t \)" +proof - + from assms(2,3) have "fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ subst_domain \ = {}" + using subst_sends_strand_fv_to_img[of S \] by blast + thus "(S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t \ = (S \\<^sub>s\<^sub>t \)" by blast + thus "(S \\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>t (\ \\<^sub>s \) = (S \\<^sub>s\<^sub>t \)" + by (metis assms(1,4,5) bvars_subst_ident strand_subst_comp subst_idem_def) +qed + +lemma strand_subst_img_bound: + assumes "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t S" + and "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "range_vars \ \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +proof - + have "subst_domain \ \ \(set (map fv\<^sub>s\<^sub>t\<^sub>p S))" by (metis (no_types) fv\<^sub>s\<^sub>t_def Un_subset_iff assms(1)) + thus ?thesis + unfolding range_vars_alt_def fv\<^sub>s\<^sub>t_def + by (metis subst_range.simps fv_set_mono fv_strand_subst Int_commute assms(2) image_Un + le_iff_sup) +qed + +lemma strand_subst_img_bound': + assumes "subst_domain \ \ range_vars \ \ vars\<^sub>s\<^sub>t S" + and "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "range_vars \ \ vars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +proof - + have "(subst_domain \ \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` subst_domain \)) \ vars\<^sub>s\<^sub>t S = + subst_domain \ \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` subst_domain \)" + using assms(1) by (metis inf.absorb_iff1 range_vars_alt_def subst_range.simps) + hence "range_vars \ \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" + using vars_snd_rcv_strand fv_snd_rcv_strand assms(2) strand_subst_img_bound + unfolding range_vars_alt_def + by (metis (no_types) inf_le2 inf_sup_distrib1 subst_range.simps sup_bot.right_neutral) + thus "range_vars \ \ vars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" + by (metis fv_snd_rcv_strand le_supI1 vars_snd_rcv_strand) +qed + +lemma strand_subst_all_fv_subset: + assumes "fv t \ fv\<^sub>s\<^sub>t S" "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "fv (t \ \) \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +using assms by (metis fv_strand_subst' Int_commute subst_apply_fv_subset) + +lemma strand_subst_not_dom_fixed: + assumes "v \ fv\<^sub>s\<^sub>t S" and "v \ subst_domain \" + shows "v \ fv\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" +using assms +proof (induction S) + case (Cons x S') + have 1: "\X. v \ subst_domain (rm_vars (set X) \)" + using Cons.prems(2) rm_vars_dom_subset by force + + show ?case + proof (cases "v \ fv\<^sub>s\<^sub>t S'") + case True thus ?thesis using Cons.IH[OF _ Cons.prems(2)] by auto + next + case False + hence 2: "v \ fv\<^sub>s\<^sub>t\<^sub>p x" using Cons.prems(1) by simp + hence "v \ fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \)" using Cons.prems(2) subst_not_dom_fixed + proof (cases x) + case (Inequality X F) + hence "v \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" using 2 by simp + hence "v \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" + using subst_not_dom_fixed[OF _ 1] + by (induct F) (auto simp add: subst_apply_pairs_def) + thus ?thesis using Inequality 2 by auto + qed (force simp add: subst_domain_def)+ + thus ?thesis by auto + qed +qed simp + +lemma strand_vars_unfold: "v \ vars\<^sub>s\<^sub>t S \ \S' x S''. S = S'@x#S'' \ v \ vars\<^sub>s\<^sub>t\<^sub>p x" +proof (induction S) + case (Cons x S) thus ?case + proof (cases "v \ vars\<^sub>s\<^sub>t\<^sub>p x") + case True thus ?thesis by blast + next + case False + hence "v \ vars\<^sub>s\<^sub>t S" using Cons.prems by auto + thus ?thesis using Cons.IH by (metis append_Cons) + qed +qed simp + +lemma strand_fv_unfold: "v \ fv\<^sub>s\<^sub>t S \ \S' x S''. S = S'@x#S'' \ v \ fv\<^sub>s\<^sub>t\<^sub>p x" +proof (induction S) + case (Cons x S) thus ?case + proof (cases "v \ fv\<^sub>s\<^sub>t\<^sub>p x") + case True thus ?thesis by blast + next + case False + hence "v \ fv\<^sub>s\<^sub>t S" using Cons.prems by auto + thus ?thesis using Cons.IH by (metis append_Cons) + qed +qed simp + +lemma subterm_if_in_strand_ik: + "t \ ik\<^sub>s\<^sub>t S \ \t'. Receive t' \ set S \ t \ t'" +by (induct S rule: ik\<^sub>s\<^sub>t_induct) auto + +lemma fv_subset_if_in_strand_ik: + "t \ ik\<^sub>s\<^sub>t S \ fv t \ \(set (map fv\<^sub>r\<^sub>c\<^sub>v S))" +proof - + assume "t \ ik\<^sub>s\<^sub>t S" + then obtain t' where "Receive t' \ set S" "t \ t'" by (metis subterm_if_in_strand_ik) + hence "fv t \ fv t'" by (simp add: subtermeq_vars_subset) + thus ?thesis using in_strand_fv_subset_rcv[OF \Receive t' \ set S\] by auto +qed + +lemma fv_subset_if_in_strand_ik': + "t \ ik\<^sub>s\<^sub>t S \ fv t \ fv\<^sub>s\<^sub>t S" +using fv_subset_if_in_strand_ik[of t S] fv_snd_rcv_strand_subset(2)[of S] by blast + +lemma vars_subset_if_in_strand_ik2: + "t \ ik\<^sub>s\<^sub>t S \ fv t \ wfrestrictedvars\<^sub>s\<^sub>t S" +using fv_subset_if_in_strand_ik[of t S] vars_snd_rcv_strand_subset2(2)[of S] by blast + + +subsection \Lemmata: Simple Strands\ +lemma simple_Cons[dest]: "simple (s#S) \ simple S" +unfolding simple_def by auto + +lemma simple_split[dest]: + assumes "simple (S@S')" + shows "simple S" "simple S'" +using assms unfolding simple_def by auto + +lemma simple_append[intro]: "\simple S; simple S'\ \ simple (S@S')" +unfolding simple_def by auto + +lemma simple_append_sym[sym]: "simple (S@S') \ simple (S'@S)" by auto + +lemma not_simple_if_snd_fun: "(\S' S'' f X. S = S'@Send (Fun f X)#S'') \ \simple S" +unfolding simple_def by auto + +lemma not_list_all_elim: "\list_all P A \ \B x C. A = B@x#C \ \P x \ list_all P B" +proof (induction A rule: List.rev_induct) + case (snoc a A) + show ?case + proof (cases "list_all P A") + case True + thus ?thesis using snoc.prems by auto + next + case False + then obtain B x C where "A = B@x#C" "\P x" "list_all P B" using snoc.IH[OF False] by auto + thus ?thesis by auto + qed +qed simp + +lemma not_simple\<^sub>s\<^sub>t\<^sub>p_elim: + assumes "\simple\<^sub>s\<^sub>t\<^sub>p x" + shows "(\f T. x = Send (Fun f T)) \ + (\a t t'. x = Equality a t t') \ + (\X F. x = Inequality X F \ \(\\. ineq_model \ X F))" +using assms by (cases x) (fastforce elim: simple\<^sub>s\<^sub>t\<^sub>p.elims)+ + +lemma not_simple_elim: + assumes "\simple S" + shows "(\A B f T. S = A@Send (Fun f T)#B \ simple A) \ + (\A B a t t'. S = A@Equality a t t'#B \ simple A) \ + (\A B X F. S = A@Inequality X F#B \ \(\\. ineq_model \ X F))" +by (metis assms not_list_all_elim not_simple\<^sub>s\<^sub>t\<^sub>p_elim simple_def) + +lemma simple_fun_prefix_unique: + assumes "A = S@Send (Fun f X)#S'" "simple S" + shows "\T g Y T'. A = T@Send (Fun g Y)#T' \ simple T \ S = T \ f = g \ X = Y \ S' = T'" +proof - + { fix T g Y T' assume *: "A = T@Send (Fun g Y)#T'" "simple T" + { assume "length S < length T" hence False using assms * + by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length) + } + moreover + { assume "length S > length T" hence False using assms * + by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length) + } + ultimately have "S = T" using assms * by (meson List.append_eq_append_conv linorder_neqE_nat) + } + thus ?thesis using assms(1) by blast +qed + +lemma simple_snd_is_var: "\Send t \ set S; simple S\ \ \v. t = Var v" +unfolding simple_def +by (metis list_all_append list_all_simps(1) simple\<^sub>s\<^sub>t\<^sub>p.elims(2) split_list_first + strand_step.distinct(1) strand_step.distinct(5) strand_step.inject(1)) + + +subsection \Lemmata: Strand Measure\ +lemma measure\<^sub>s\<^sub>t_wellfounded: "wf measure\<^sub>s\<^sub>t" unfolding measure\<^sub>s\<^sub>t_def by simp + +lemma strand_size_append[iff]: "size\<^sub>s\<^sub>t (S@S') = size\<^sub>s\<^sub>t S + size\<^sub>s\<^sub>t S'" +by (induct S) (auto simp add: size\<^sub>s\<^sub>t_def) + +lemma strand_size_map_fun_lt[simp]: + "size\<^sub>s\<^sub>t (map Send X) < size (Fun f X)" + "size\<^sub>s\<^sub>t (map Send X) < size\<^sub>s\<^sub>t [Send (Fun f X)]" + "size\<^sub>s\<^sub>t (map Send X) < size\<^sub>s\<^sub>t [Receive (Fun f X)]" +by (induct X) (auto simp add: size\<^sub>s\<^sub>t_def) + +lemma strand_size_rm_fun_lt[simp]: + "size\<^sub>s\<^sub>t (S@S') < size\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" + "size\<^sub>s\<^sub>t (S@S') < size\<^sub>s\<^sub>t (S@Receive (Fun f X)#S')" +by (induct S) (auto simp add: size\<^sub>s\<^sub>t_def) + +lemma strand_fv_card_map_fun_eq: + "card (fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S')) = card (fv\<^sub>s\<^sub>t (S@(map Send X)@S'))" +proof - + have "fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S') = fv\<^sub>s\<^sub>t (S@(map Send X)@S')" by auto + thus ?thesis by simp +qed + +lemma strand_fv_card_rm_fun_le[simp]: "card (fv\<^sub>s\<^sub>t (S@S')) \ card (fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" +by (force intro: card_mono) + +lemma strand_fv_card_rm_eq_le[simp]: "card (fv\<^sub>s\<^sub>t (S@S')) \ card (fv\<^sub>s\<^sub>t (S@Equality a t t'#S'))" +by (force intro: card_mono) + + +subsection \Lemmata: Well-formed Strands\ +lemma wf_prefix[dest]: "wf\<^sub>s\<^sub>t V (S@S') \ wf\<^sub>s\<^sub>t V S" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) auto + +lemma wf_vars_mono[simp]: "wf\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t (V \ W) S" +proof (induction S arbitrary: V) + case (Cons x S) thus ?case + proof (cases x) + case (Send t) + hence "wf\<^sub>s\<^sub>t (V \ fv t \ W) S" using Cons.prems(1) Cons.IH by simp + thus ?thesis using Send by (simp add: sup_commute sup_left_commute) + next + case (Equality a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf\<^sub>s\<^sub>t (V \ fv t \ W) S" "fv t' \ V \ W" using Equality Cons.prems(1) Cons.IH by auto + thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute) + next + case Check thus ?thesis using Equality Cons by auto + qed + qed auto +qed simp + +lemma wf\<^sub>s\<^sub>tI[intro]: "wfrestrictedvars\<^sub>s\<^sub>t S \ V \ wf\<^sub>s\<^sub>t V S" +proof (induction S) + case (Cons x S) thus ?case + proof (cases x) + case (Send t) + hence "wf\<^sub>s\<^sub>t V S" "V \ fv t = V" using Cons by auto + thus ?thesis using Send by simp + next + case (Equality a t t') + show ?thesis + proof (cases a) + case Assign + hence "wf\<^sub>s\<^sub>t V S" "fv t' \ V" using Equality Cons by auto + thus ?thesis using wf_vars_mono Equality Assign by simp + next + case Check thus ?thesis using Equality Cons by auto + qed + qed simp_all +qed simp + +lemma wf\<^sub>s\<^sub>tI'[intro]: "\(fv\<^sub>r\<^sub>c\<^sub>v ` set S) \ \(fv_r\<^sub>e\<^sub>q assign ` set S) \ V \ wf\<^sub>s\<^sub>t V S" +proof (induction S) + case (Cons x S) thus ?case + proof (cases x) + case (Equality a t t') thus ?thesis using Cons by (cases a) auto + qed simp_all +qed simp + +lemma wf_append_exec: "wf\<^sub>s\<^sub>t V (S@S') \ wf\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>t S) S'" +proof (induction S arbitrary: V) + case (Cons x S V) thus ?case + proof (cases x) + case (Send t) + hence "wf\<^sub>s\<^sub>t (V \ fv t \ wfvarsoccs\<^sub>s\<^sub>t S) S'" using Cons.prems Cons.IH by simp + thus ?thesis using Send by (auto simp add: sup_assoc) + next + case (Equality a t t') show ?thesis + proof (cases a) + case Assign + hence "wf\<^sub>s\<^sub>t (V \ fv t \ wfvarsoccs\<^sub>s\<^sub>t S) S'" using Equality Cons.prems Cons.IH by auto + thus ?thesis using Equality Assign by (auto simp add: sup_assoc) + next + case Check + hence "wf\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>t S) S'" using Equality Cons.prems Cons.IH by auto + thus ?thesis using Equality Check by (auto simp add: sup_assoc) + qed + qed auto +qed simp + +lemma wf_append_suffix: + "wf\<^sub>s\<^sub>t V S \ wfrestrictedvars\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V \ wf\<^sub>s\<^sub>t V (S@S')" +proof (induction V S rule: wf\<^sub>s\<^sub>t_induct) + case (ConsSnd V t S) + hence *: "wf\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + hence "wfrestrictedvars\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ fv t)" + using ConsSnd.prems(2) by fastforce + thus ?case using ConsSnd.IH * by simp +next + case (ConsRcv V t S) + hence *: "fv t \ V" "wf\<^sub>s\<^sub>t V S" by simp_all + hence "wfrestrictedvars\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + using ConsRcv.prems(2) by fastforce + thus ?case using ConsRcv.IH * by simp +next + case (ConsEq V t t' S) + hence *: "fv t' \ V" "wf\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + moreover have "vars\<^sub>s\<^sub>t\<^sub>p (Equality Assign t t') = fv t \ fv t'" + by simp + moreover have "wfrestrictedvars\<^sub>s\<^sub>t (Equality Assign t t'#S) = fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S" + by auto + ultimately have "wfrestrictedvars\<^sub>s\<^sub>t S' \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ fv t)" + using ConsEq.prems(2) by blast + thus ?case using ConsEq.IH * by simp +qed (simp_all add: wf\<^sub>s\<^sub>tI) + +lemma wf_append_suffix': + assumes "wf\<^sub>s\<^sub>t V S" + and "\(fv\<^sub>r\<^sub>c\<^sub>v ` set S') \ \(fv_r\<^sub>e\<^sub>q assign ` set S') \ wfvarsoccs\<^sub>s\<^sub>t S \ V" + shows "wf\<^sub>s\<^sub>t V (S@S')" +using assms +proof (induction V S rule: wf\<^sub>s\<^sub>t_induct) + case (ConsSnd V t S) + hence *: "wf\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + have "wfvarsoccs\<^sub>s\<^sub>t (send\t\\<^sub>s\<^sub>t#S) = fv t \ wfvarsoccs\<^sub>s\<^sub>t S" + unfolding wfvarsoccs\<^sub>s\<^sub>t_def by simp + hence "(\a\set S'. fv\<^sub>r\<^sub>c\<^sub>v a) \ (\a\set S'. fv_r\<^sub>e\<^sub>q assign a) \ wfvarsoccs\<^sub>s\<^sub>t S \ (V \ fv t)" + using ConsSnd.prems(2) unfolding wfvarsoccs\<^sub>s\<^sub>t_def by auto + thus ?case using ConsSnd.IH[OF *] by auto +next + case (ConsEq V t t' S) + hence *: "fv t' \ V" "wf\<^sub>s\<^sub>t (V \ fv t) S" by simp_all + have "wfvarsoccs\<^sub>s\<^sub>t (\assign: t \ t'\\<^sub>s\<^sub>t#S) = fv t \ wfvarsoccs\<^sub>s\<^sub>t S" + unfolding wfvarsoccs\<^sub>s\<^sub>t_def by simp + hence "(\a\set S'. fv\<^sub>r\<^sub>c\<^sub>v a) \ (\a\set S'. fv_r\<^sub>e\<^sub>q assign a) \ wfvarsoccs\<^sub>s\<^sub>t S \ (V \ fv t)" + using ConsEq.prems(2) unfolding wfvarsoccs\<^sub>s\<^sub>t_def by auto + thus ?case using ConsEq.IH[OF *(2)] *(1) by auto +qed (auto simp add: wf\<^sub>s\<^sub>tI') + +lemma wf_send_compose: "wf\<^sub>s\<^sub>t V (S@(map Send X)@S') = wf\<^sub>s\<^sub>t V (S@Send (Fun f X)#S')" +proof (induction S arbitrary: V) + case Nil thus ?case + proof (induction X arbitrary: V) + case (Cons y Y) thus ?case by (simp add: sup_assoc) + qed simp +next + case (Cons s S) thus ?case + proof (cases s) + case (Equality ac t t') thus ?thesis using Cons by (cases ac) auto + qed auto +qed + +lemma wf_snd_append[iff]: "wf\<^sub>s\<^sub>t V (S@[Send t]) = wf\<^sub>s\<^sub>t V S" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) simp_all + +lemma wf_snd_append': "wf\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t V (Send t#S)" +by simp + +lemma wf_rcv_append[dest]: "wf\<^sub>s\<^sub>t V (S@Receive t#S') \ wf\<^sub>s\<^sub>t V (S@S')" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) simp_all + +lemma wf_rcv_append'[intro]: + "\wf\<^sub>s\<^sub>t V (S@S'); fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V\ \ wf\<^sub>s\<^sub>t V (S@Receive t#S')" +proof (induction S rule: wf\<^sub>s\<^sub>t_induct) + case (ConsRcv V t' S) + hence "wf\<^sub>s\<^sub>t V (S@S')" "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + by auto+ + thus ?case using ConsRcv by auto +next + case (ConsEq V t' t'' S) + hence "fv t'' \ V" by simp + moreover have + "wfrestrictedvars\<^sub>s\<^sub>t (Equality Assign t' t''#S) = fv t' \ fv t'' \ wfrestrictedvars\<^sub>s\<^sub>t S" + by auto + ultimately have "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ fv t')" + using ConsEq.prems(2) by blast + thus ?case using ConsEq by auto +qed auto + +lemma wf_rcv_append''[intro]: "\wf\<^sub>s\<^sub>t V S; fv t \ \(set (map fv\<^sub>s\<^sub>n\<^sub>d S))\ \ wf\<^sub>s\<^sub>t V (S@[Receive t])" +by (induct S) + (simp, metis vars_snd_rcv_strand_subset2(1) append_Nil2 le_supI1 order_trans wf_rcv_append') + +lemma wf_rcv_append'''[intro]: "\wf\<^sub>s\<^sub>t V S; fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V\ \ wf\<^sub>s\<^sub>t V (S@[Receive t])" +by (simp add: wf_rcv_append'[of _ _ "[]"]) + +lemma wf_eq_append[dest]: "wf\<^sub>s\<^sub>t V (S@Equality a t t'#S') \ fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V \ wf\<^sub>s\<^sub>t V (S@S')" +proof (induction S rule: wf\<^sub>s\<^sub>t_induct) + case (Nil V) + hence "wf\<^sub>s\<^sub>t (V \ fv t) S'" by (cases a) auto + moreover have "V \ fv t = V" using Nil by auto + ultimately show ?case by simp +next + case (ConsRcv V u S) + hence "wf\<^sub>s\<^sub>t V (S @ Equality a t t' # S')" "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" "fv u \ V" + by fastforce+ + hence "wf\<^sub>s\<^sub>t V (S@S')" using ConsRcv.IH by auto + thus ?case using \fv u \ V\ by simp +next + case (ConsEq V u u' S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@Equality a t t'#S')" "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ fv u)" "fv u' \ V" + by auto + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" using ConsEq.IH by auto + thus ?case using \fv u' \ V\ by simp +qed auto + +lemma wf_eq_append'[intro]: + "\wf\<^sub>s\<^sub>t V (S@S'); fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V\ \ wf\<^sub>s\<^sub>t V (S@Equality a t t'#S')" +proof (induction S rule: wf\<^sub>s\<^sub>t_induct) + case Nil thus ?case by (cases a) auto +next + case (ConsEq V u u' S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V \ fv u" + by fastforce+ + thus ?case using ConsEq by auto +next + case (ConsEq2 V u u' S) + hence "wf\<^sub>s\<^sub>t V (S@S')" by auto + thus ?case using ConsEq2 by auto +next + case (ConsRcv V u S) + hence "wf\<^sub>s\<^sub>t V (S@S')" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V" + by fastforce+ + thus ?case using ConsRcv by auto +next + case (ConsSnd V u S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ (V \ fv u)" + by fastforce+ + thus ?case using ConsSnd by auto +qed auto + +lemma wf_eq_append''[intro]: + "\wf\<^sub>s\<^sub>t V (S@S'); fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ V\ \ wf\<^sub>s\<^sub>t V (S@[Equality a t t']@S')" +proof (induction S rule: wf\<^sub>s\<^sub>t_induct) + case Nil thus ?case by (cases a) auto +next + case (ConsEq V u u' S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" "fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ V \ fv u" by fastforce+ + thus ?case using ConsEq by auto +next + case (ConsEq2 V u u' S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" "fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ V \ fv u" by fastforce+ + thus ?case using ConsEq2 by auto +next + case (ConsRcv V u S) + hence "wf\<^sub>s\<^sub>t V (S@S')" "fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ V" by fastforce+ + thus ?case using ConsRcv by auto +next + case (ConsSnd V u S) + hence "wf\<^sub>s\<^sub>t (V \ fv u) (S@S')" "fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ (V \ fv u)" by auto + thus ?case using ConsSnd by auto +qed auto + +lemma wf_eq_append'''[intro]: + "\wf\<^sub>s\<^sub>t V S; fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S \ V\ \ wf\<^sub>s\<^sub>t V (S@[Equality a t t'])" +by (simp add: wf_eq_append'[of _ _ "[]"]) + +lemma wf_eq_check_append[dest]: "wf\<^sub>s\<^sub>t V (S@Equality Check t t'#S') \ wf\<^sub>s\<^sub>t V (S@S')" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) simp_all + +lemma wf_eq_check_append'[intro]: "wf\<^sub>s\<^sub>t V (S@S') \ wf\<^sub>s\<^sub>t V (S@Equality Check t t'#S')" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) auto + +lemma wf_eq_check_append''[intro]: "wf\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t V (S@[Equality Check t t'])" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) auto + +lemma wf_ineq_append[dest]: "wf\<^sub>s\<^sub>t V (S@Inequality X F#S') \ wf\<^sub>s\<^sub>t V (S@S')" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) simp_all + +lemma wf_ineq_append'[intro]: "wf\<^sub>s\<^sub>t V (S@S') \ wf\<^sub>s\<^sub>t V (S@Inequality X F#S')" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) auto + +lemma wf_ineq_append''[intro]: "wf\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t V (S@[Inequality X F])" +by (induct S rule: wf\<^sub>s\<^sub>t.induct) auto + +lemma wf_rcv_fv_single[elim]: "wf\<^sub>s\<^sub>t V (Receive t#S') \ fv t \ V" +by simp + +lemma wf_rcv_fv: "wf\<^sub>s\<^sub>t V (S@Receive t#S') \ fv t \ wfvarsoccs\<^sub>s\<^sub>t S \ V" +by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split) + +lemma wf_eq_fv: "wf\<^sub>s\<^sub>t V (S@Equality Assign t t'#S') \ fv t' \ wfvarsoccs\<^sub>s\<^sub>t S \ V" +by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split) + +lemma wf_simple_fv_occurrence: + assumes "wf\<^sub>s\<^sub>t {} S" "simple S" "v \ wfrestrictedvars\<^sub>s\<^sub>t S" + shows "\S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f. S = S\<^sub>p\<^sub>r\<^sub>e@Send (Var v)#S\<^sub>s\<^sub>u\<^sub>f \ v \ wfrestrictedvars\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e" +using assms +proof (induction S rule: List.rev_induct) + case (snoc x S) + from \wf\<^sub>s\<^sub>t {} (S@[x])\ have "wf\<^sub>s\<^sub>t {} S" "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>s\<^sub>t S) [x]" + using wf_append_exec[THEN wf_vars_mono, of "{}" S "[x]" "wfrestrictedvars\<^sub>s\<^sub>t S - wfvarsoccs\<^sub>s\<^sub>t S"] + vars_snd_rcv_strand_subset2(4)[of S] + Diff_partition[of "wfvarsoccs\<^sub>s\<^sub>t S" "wfrestrictedvars\<^sub>s\<^sub>t S"] + by auto + from \simple (S@[x])\ have "simple S" "simple\<^sub>s\<^sub>t\<^sub>p x" unfolding simple_def by auto + + show ?case + proof (cases "v \ wfrestrictedvars\<^sub>s\<^sub>t S") + case False + show ?thesis + proof (cases x) + case (Receive t) + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t S" using \wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>s\<^sub>t S) [x]\ by simp + hence "v \ wfrestrictedvars\<^sub>s\<^sub>t S" + using \v \ wfrestrictedvars\<^sub>s\<^sub>t (S@[x])\ \x = Receive t\ + by auto + thus ?thesis using \x = Receive t\ snoc.IH[OF \wf\<^sub>s\<^sub>t {} S\ \simple S\] by fastforce + next + case (Send t) + hence "v \ vars\<^sub>s\<^sub>t\<^sub>p x" using \v \ wfrestrictedvars\<^sub>s\<^sub>t (S@[x])\ False by auto + from Send obtain w where "t = Var w" using \simple\<^sub>s\<^sub>t\<^sub>p x\ by (cases t) simp_all + hence "v = w" using \x = Send t\ \v \ vars\<^sub>s\<^sub>t\<^sub>p x\ by simp + thus ?thesis using \x = Send t\ \v \ wfrestrictedvars\<^sub>s\<^sub>t S\ \t = Var w\ by auto + next + case (Equality ac t t') thus ?thesis using snoc.prems(2) unfolding simple_def by auto + next + case (Inequality t t') thus ?thesis using False snoc.prems(3) by auto + qed + qed (use snoc.IH[OF \wf\<^sub>s\<^sub>t {} S\ \simple S\] in fastforce) +qed simp + +lemma Unifier_strand_fv_subset: + assumes g_in_ik: "t \ ik\<^sub>s\<^sub>t S" + and \: "Unifier \ (Fun f X) t" + and disj: "bvars\<^sub>s\<^sub>t S \ (subst_domain \ \ range_vars \) = {}" + shows "fv (Fun f X \ \) \ \(set (map fv\<^sub>r\<^sub>c\<^sub>v (S \\<^sub>s\<^sub>t \)))" +by (metis (no_types) fv_subset_if_in_strand_ik[OF g_in_ik] + disj \ fv_strand_subst subst_apply_fv_subset) + +lemma wf\<^sub>s\<^sub>t_induct'[consumes 1, case_names Nil ConsSnd ConsRcv ConsEq ConsEq2 ConsIneq]: + fixes S::"('a,'b) strand" + assumes "wf\<^sub>s\<^sub>t V S" + "P []" + "\t S. \wf\<^sub>s\<^sub>t V S; P S\ \ P (S@[Send t])" + "\t S. \wf\<^sub>s\<^sub>t V S; P S; fv t \ V \ wfvarsoccs\<^sub>s\<^sub>t S\ \ P (S@[Receive t])" + "\t t' S. \wf\<^sub>s\<^sub>t V S; P S; fv t' \ V \ wfvarsoccs\<^sub>s\<^sub>t S\ \ P (S@[Equality Assign t t'])" + "\t t' S. \wf\<^sub>s\<^sub>t V S; P S\ \ P (S@[Equality Check t t'])" + "\X F S. \wf\<^sub>s\<^sub>t V S; P S\ \ P (S@[Inequality X F])" + shows "P S" +using assms +proof (induction S rule: List.rev_induct) + case (snoc x S) + hence *: "wf\<^sub>s\<^sub>t V S" "wf\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>t S) [x]" by (metis wf_prefix, metis wf_append_exec) + have IH: "P S" using snoc.IH[OF *(1)] snoc.prems by auto + note ** = snoc.prems(3,4,5,6,7)[OF *(1) IH] *(2) + show ?case using **(1,2,4,5,6) + proof (cases x) + case (Equality ac t t') + then show ?thesis using **(3,4,6) by (cases ac) auto + qed auto +qed simp + +lemma wf_subst_apply: + "wf\<^sub>s\<^sub>t V S \ wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (S \\<^sub>s\<^sub>t \)" +proof (induction S arbitrary: V rule: wf\<^sub>s\<^sub>t_induct) + case (ConsRcv V t S) + hence "wf\<^sub>s\<^sub>t V S" "fv t \ V" by simp_all + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (S \\<^sub>s\<^sub>t \)" "fv (t \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using ConsRcv.IH subst_apply_fv_subset by simp_all + thus ?case by simp +next + case (ConsSnd V t S) + hence "wf\<^sub>s\<^sub>t (V \ fv t) S" by simp + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t))) (S \\<^sub>s\<^sub>t \)" using ConsSnd.IH by metis + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \)) (S \\<^sub>s\<^sub>t \)" using subst_apply_fv_union by metis + thus ?case by simp +next + case (ConsEq V t t' S) + hence "wf\<^sub>s\<^sub>t (V \ fv t) S" "fv t' \ V" by auto + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` (V \ fv t))) (S \\<^sub>s\<^sub>t \)" and *: "fv (t' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using ConsEq.IH subst_apply_fv_subset by force+ + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \)) (S \\<^sub>s\<^sub>t \)" using subst_apply_fv_union by metis + thus ?case using * by simp +qed simp_all + +lemma wf_unify: + assumes wf: "wf\<^sub>s\<^sub>t V (S@Send (Fun f X)#S')" + and g_in_ik: "t \ ik\<^sub>s\<^sub>t S" + and \: "Unifier \ (Fun f X) t" + and disj: "bvars\<^sub>s\<^sub>t (S@Send (Fun f X)#S') \ (subst_domain \ \ range_vars \) = {}" + shows "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) ((S@S') \\<^sub>s\<^sub>t \)" +using assms +proof (induction S' arbitrary: V rule: List.rev_induct) + case (snoc x S' V) + have fun_fv_bound: "fv (Fun f X \ \) \ \(set (map fv\<^sub>r\<^sub>c\<^sub>v (S \\<^sub>s\<^sub>t \)))" + using snoc.prems(4) bvars\<^sub>s\<^sub>t_split Unifier_strand_fv_subset[OF g_in_ik \] by auto + hence "fv (Fun f X \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \))" using fv_ik_is_fv_rcv by metis + hence "fv (Fun f X \ \) \ wfrestrictedvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" using fv_ik_subset_fv_st[of "S \\<^sub>s\<^sub>t \"] by blast + hence *: "fv ((Fun f X) \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" by fastforce + + from snoc.prems(1) have "wf\<^sub>s\<^sub>t V (S@Send (Fun f X)#S')" + using wf_prefix[of V "S@Send (Fun f X)#S'" "[x]"] by simp + hence **: "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) ((S@S') \\<^sub>s\<^sub>t \)" + using snoc.IH[OF _ snoc.prems(2,3)] snoc.prems(4) by auto + + from snoc.prems(1) have ***: "wf\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>t (S@Send (Fun f X)#S')) [x]" + using wf_append_exec[of V "(S@Send (Fun f X)#S')" "[x]"] by simp + + from snoc.prems(4) have disj': + "bvars\<^sub>s\<^sub>t (S@S') \ (subst_domain \ \ range_vars \) = {}" + "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + by auto + + show ?case + proof (cases x) + case (Send t) + thus ?thesis using wf_snd_append[of "fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" "(S@S') \\<^sub>s\<^sub>t \"] ** by auto + next + case (Receive t) + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ wfvarsoccs\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" using *** by auto + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ wfrestrictedvars\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" + using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ fv (Fun f X) \ wfrestrictedvars\<^sub>s\<^sub>t (S@S')" by auto + hence "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv ((Fun f X) \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + by (metis (no_types) inf_sup_aci(5) subst_apply_fv_subset_strand2 subst_apply_fv_union disj') + hence "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" using * by blast + hence "fv (t \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) " using \x = Receive t\ by auto + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (((S@S') \\<^sub>s\<^sub>t \)@[Receive (t \ \)])" + using wf_rcv_append'''[OF **, of "t \ \"] by metis + thus ?thesis using \x = Receive t\ by auto + next + case (Equality ac s s') show ?thesis + proof (cases ac) + case Assign + hence "fv s' \ V \ wfvarsoccs\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" using Equality *** by auto + hence "fv s' \ V \ wfrestrictedvars\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" + using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast + hence "fv s' \ V \ fv (Fun f X) \ wfrestrictedvars\<^sub>s\<^sub>t (S@S')" by auto + moreover have "fv s' = fv_r\<^sub>e\<^sub>q ac x" "fv (s' \ \) = fv_r\<^sub>e\<^sub>q ac (x \\<^sub>s\<^sub>t\<^sub>p \)" + using Equality by simp_all + ultimately have "fv (s' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (Fun f X \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + using subst_apply_fv_subset_strand2[of "fv\<^sub>e\<^sub>q ac" ac x] + by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute) + hence "fv (s' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" using * by blast + hence "fv (s' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using \x = Equality ac s s'\ by auto + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (((S@S') \\<^sub>s\<^sub>t \)@[Equality ac (s \ \) (s' \ \)])" + using wf_eq_append'''[OF **] by metis + thus ?thesis using \x = Equality ac s s'\ by auto + next + case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp + qed + next + case (Inequality t t') thus ?thesis using wf_ineq_append''[OF **] by simp + qed +qed (auto dest: wf_subst_apply) + +lemma wf_equality: + assumes wf: "wf\<^sub>s\<^sub>t V (S@Equality ac t t'#S')" + and \: "mgu t t' = Some \" + and disj: "bvars\<^sub>s\<^sub>t (S@Equality ac t t'#S') \ (subst_domain \ \ range_vars \) = {}" + shows "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) ((S@S') \\<^sub>s\<^sub>t \)" +using assms +proof (induction S' arbitrary: V rule: List.rev_induct) + case Nil thus ?case using wf_prefix[of V S "[Equality ac t t']"] wf_subst_apply[of V S \] by auto +next + case (snoc x S' V) show ?case + proof (cases ac) + case Assign + hence "fv t' \ V \ wfvarsoccs\<^sub>s\<^sub>t S" + using wf_eq_fv[of V, of S t t' "S'@[x]"] snoc by auto + hence "fv t' \ V \ wfrestrictedvars\<^sub>s\<^sub>t S" + using vars_snd_rcv_strand_subset2(4)[of S] by blast + hence "fv t' \ V \ wfrestrictedvars\<^sub>s\<^sub>t (S@S')" by force + moreover have disj': + "bvars\<^sub>s\<^sub>t (S@S') \ (subst_domain \ \ range_vars \) = {}" + "set (bvars\<^sub>s\<^sub>t\<^sub>p x) \ (subst_domain \ \ range_vars \) = {}" + "bvars\<^sub>s\<^sub>t (S@Equality ac t t'#S') \ (subst_domain \ \ range_vars \) = {}" + using snoc.prems(3) by auto + ultimately have + "fv (t' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + by (metis inf_sup_aci(5) subst_apply_fv_subset_strand_trm2) + moreover have "fv (t \ \) = fv (t' \ \)" + by (metis MGU_is_Unifier[OF mgu_gives_MGU[OF \]]) + ultimately have *: + "fv (t \ \) \ fv (t' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + by simp + + from snoc.prems(1) have "wf\<^sub>s\<^sub>t V (S@Equality ac t t'#S')" + using wf_prefix[of V "S@Equality ac t t'#S'"] by simp + hence **: "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) ((S@S') \\<^sub>s\<^sub>t \)" by (metis snoc.IH \ disj'(3)) + + from snoc.prems(1) have ***: "wf\<^sub>s\<^sub>t (V \ wfvarsoccs\<^sub>s\<^sub>t (S@Equality ac t t'#S')) [x]" + using wf_append_exec[of V "(S@Equality ac t t'#S')" "[x]"] by simp + + show ?thesis + proof (cases x) + case (Send t) + thus ?thesis using wf_snd_append[of "fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" "(S@S') \\<^sub>s\<^sub>t \"] ** by auto + next + case (Receive s) + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ wfvarsoccs\<^sub>s\<^sub>t (S@Equality ac t t'#S')" using *** by auto + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ wfrestrictedvars\<^sub>s\<^sub>t (S@Equality ac t t'#S')" + using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast + hence "fv\<^sub>s\<^sub>t\<^sub>p x \ V \ fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>t (S@S')" + by (cases ac) auto + hence "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \) \ fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + using subst_apply_fv_subset_strand2[of fv\<^sub>s\<^sub>t\<^sub>p] + by (metis (no_types) inf_sup_aci(5) subst_apply_fv_union disj'(1,2)) + hence "fv\<^sub>s\<^sub>t\<^sub>p (x \\<^sub>s\<^sub>t\<^sub>p \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + when "ac = Assign" + using * that by blast + hence "fv (s \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V))" + when "ac = Assign" + using \x = Receive s\ that by auto + hence "wf\<^sub>s\<^sub>t (fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)) (((S@S') \\<^sub>s\<^sub>t \)@[Receive (s \ \)])" + when "ac = Assign" + using wf_rcv_append'''[OF **, of "s \ \"] that by metis + thus ?thesis using \x = Receive s\ Assign by auto + next + case (Equality ac' s s') show ?thesis + proof (cases ac') + case Assign + hence "fv s' \ V \ wfvarsoccs\<^sub>s\<^sub>t (S@Equality ac t t'#S')" using *** Equality by auto + hence "fv s' \ V \ wfrestrictedvars\<^sub>s\<^sub>t (S@Equality ac t t'#S')" + using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast + hence "fv s' \ V \ fv t \ fv t' \ wfrestrictedvars\<^sub>s\<^sub>t (S@S')" + by (cases ac) auto + moreover have "fv s' = fv_r\<^sub>e\<^sub>q ac' x" "fv (s' \ \) = fv_r\<^sub>e\<^sub>q ac' (x \\<^sub>s\<^sub>t\<^sub>p \)" + using Equality by simp_all + ultimately have + "fv (s' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ fv (t \ \) \ fv (t' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + using subst_apply_fv_subset_strand2[of "fv_r\<^sub>e\<^sub>q ac'" ac' x] + by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute) + hence "fv (s' \ \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \)" + using * \ac = Assign\ by blast + hence ****: + "fv (s' \ \) \ wfrestrictedvars\<^sub>s\<^sub>t ((S@S') \\<^sub>s\<^sub>t \) \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` V)" + using \x = Equality ac' s s'\ \ac = Assign\ by auto + thus ?thesis + using \x = Equality ac' s s'\ ** **** wf_eq_append' \ac = Assign\ + by (metis (no_types, lifting) append.assoc append_Nil2 strand_step.case(3) + strand_subst_hom subst_apply_strand_step_def) + next + case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp + qed + next + case (Inequality s s') thus ?thesis using wf_ineq_append''[OF **] by simp + qed + qed (metis snoc.prems(1) wf_eq_check_append wf_subst_apply) +qed + +lemma wf_rcv_prefix_ground: + "wf\<^sub>s\<^sub>t {} ((map Receive M)@S) \ vars\<^sub>s\<^sub>t (map Receive M) = {}" +by (induct M) auto + +lemma simple_wfvarsoccs\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>n\<^sub>d: + assumes "simple S" + shows "wfvarsoccs\<^sub>s\<^sub>t S = \(set (map fv\<^sub>s\<^sub>n\<^sub>d S))" +using assms unfolding simple_def +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma wf\<^sub>s\<^sub>t_simple_induct[consumes 2, case_names Nil ConsSnd ConsRcv ConsIneq]: + fixes S::"('a,'b) strand" + assumes "wf\<^sub>s\<^sub>t V S" "simple S" + "P []" + "\v S. \wf\<^sub>s\<^sub>t V S; simple S; P S\ \ P (S@[Send (Var v)])" + "\t S. \wf\<^sub>s\<^sub>t V S; simple S; P S; fv t \ V \ \(set (map fv\<^sub>s\<^sub>n\<^sub>d S))\ \ P (S@[Receive t])" + "\X F S. \wf\<^sub>s\<^sub>t V S; simple S; P S\ \ P (S@[Inequality X F])" + shows "P S" +using assms +proof (induction S rule: wf\<^sub>s\<^sub>t_induct') + case (ConsSnd t S) + hence "P S" by auto + obtain v where "t = Var v" using simple_snd_is_var[OF _ \simple (S@[Send t])\] by auto + thus ?case using ConsSnd.prems(3)[OF \wf\<^sub>s\<^sub>t V S\ _ \P S\] \simple (S@[Send t])\ by auto +next + case (ConsRcv t S) thus ?case using simple_wfvarsoccs\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>n\<^sub>d[of "S@[Receive t]"] by auto +qed (auto simp add: simple_def) + +lemma wf_trm_stp_dom_fv_disjoint: + "\wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \; t \ trms\<^sub>s\<^sub>t S\ \ subst_domain \ \ fv t = {}" +unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by force + +lemma wf_constr_bvars_disj: "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \ \ (subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" +unfolding range_vars_alt_def wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by fastforce + +lemma wf_constr_bvars_disj': + assumes "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "subst_domain \ \ range_vars \ \ fv\<^sub>s\<^sub>t S" + shows "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" (is ?A) + and "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) = {}" (is ?B) +proof - + have "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" + using assms(1) unfolding range_vars_alt_def wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by fastforce+ + thus ?A and ?B using assms(2) bvars_subst_ident[of S \] by blast+ +qed + +lemma (in intruder_model) wf_simple_strand_first_Send_var_split: + assumes "wf\<^sub>s\<^sub>t {} S" "simple S" "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ = \ v" + shows "\v S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f. S = S\<^sub>p\<^sub>r\<^sub>e@Send (Var v)#S\<^sub>s\<^sub>u\<^sub>f \ t \ \ = \ v + \ \(\w \ wfrestrictedvars\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e. t \ \ = \ w)" + (is "?P S") +using assms +proof (induction S rule: wf\<^sub>s\<^sub>t_simple_induct) + case (ConsSnd v S) show ?case + proof (cases "\w \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ = \ w") + case True thus ?thesis using ConsSnd.IH by fastforce + next + case False thus ?thesis using ConsSnd.prems by auto + qed +next + case (ConsRcv t' S) + have "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S" using ConsRcv.hyps(3) vars_snd_rcv_strand_subset2(1) by force + hence "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ = \ v" + using ConsRcv.prems(1) by fastforce + hence "?P S" by (metis ConsRcv.IH) + thus ?case by fastforce +next + case (ConsIneq X F S) + moreover have "wfrestrictedvars\<^sub>s\<^sub>t (S @ [Inequality X F]) = wfrestrictedvars\<^sub>s\<^sub>t S" by auto + ultimately have "?P S" by blast + thus ?case by fastforce +qed simp + +lemma (in intruder_model) wf_strand_first_Send_var_split: + assumes "wf\<^sub>s\<^sub>t {} S" "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ v" + shows "\S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f. \(\w \ wfrestrictedvars\<^sub>s\<^sub>t S\<^sub>p\<^sub>r\<^sub>e. t \ \ \ \ w) + \ ((\t'. S = S\<^sub>p\<^sub>r\<^sub>e@Send t'#S\<^sub>s\<^sub>u\<^sub>f \ t \ \ \ t' \ \) + \ (\t' t''. S = S\<^sub>p\<^sub>r\<^sub>e@Equality Assign t' t''#S\<^sub>s\<^sub>u\<^sub>f \ t \ \ \ t' \ \))" + (is "\S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f. ?P S\<^sub>p\<^sub>r\<^sub>e \ ?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f") +using assms +proof (induction S rule: wf\<^sub>s\<^sub>t_induct') + case (ConsSnd t' S) show ?case + proof (cases "\w \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ w") + case True + then obtain S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f where "?P S\<^sub>p\<^sub>r\<^sub>e" "?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f" + using ConsSnd.IH by moura + thus ?thesis by fastforce + next + case False + then obtain v where v: "v \ fv t'" "t \ \ \ \ v" + using ConsSnd.prems by auto + hence "t \ \ \ t' \ \" + using subst_mono[of "Var v" t' \] vars_iff_subtermeq[of v t'] term.order_trans + by auto + thus ?thesis using False v by auto + qed +next + case (ConsRcv t' S) + have "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t S" + using ConsRcv.hyps vars_snd_rcv_strand_subset2(4)[of S] by blast + hence "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ v" + using ConsRcv.prems by fastforce + then obtain S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f where "?P S\<^sub>p\<^sub>r\<^sub>e" "?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f" + using ConsRcv.IH by moura + thus ?case by fastforce +next + case (ConsEq s s' S) + have *: "fv s' \ wfrestrictedvars\<^sub>s\<^sub>t S" + using ConsEq.hyps vars_snd_rcv_strand_subset2(4)[of S] + by blast + show ?case + proof (cases "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ v") + case True + then obtain S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f where "?P S\<^sub>p\<^sub>r\<^sub>e" "?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f" + using ConsEq.IH by moura + thus ?thesis by fastforce + next + case False + then obtain v where "v \ fv s" "t \ \ \ \ v" using ConsEq.prems * by auto + hence "t \ \ \ s \ \" + using vars_iff_subtermeq[of v s] subst_mono[of "Var v" s \] term.order_trans + by auto + thus ?thesis using False by fastforce + qed +next + case (ConsEq2 s s' S) + have "wfrestrictedvars\<^sub>s\<^sub>t (S@[Equality Check s s']) = wfrestrictedvars\<^sub>s\<^sub>t S" by auto + hence "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ v" using ConsEq2.prems by metis + then obtain S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f where "?P S\<^sub>p\<^sub>r\<^sub>e" "?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f" + using ConsEq2.IH by moura + thus ?case by fastforce +next + case (ConsIneq X F S) + hence "\v \ wfrestrictedvars\<^sub>s\<^sub>t S. t \ \ \ \ v" by fastforce + then obtain S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f where "?P S\<^sub>p\<^sub>r\<^sub>e" "?Q S S\<^sub>p\<^sub>r\<^sub>e S\<^sub>s\<^sub>u\<^sub>f" + using ConsIneq.IH by moura + thus ?case by fastforce +qed simp + + +subsection \Constraint Semantics\ +context intruder_model +begin + +subsubsection \Definitions\ +text \The constraint semantics in which the intruder is limited to composition only\ +fun strand_sem_c::"('fun,'var) terms \ ('fun,'var) strand \ ('fun,'var) subst \ bool" ("\_; _\\<^sub>c") +where + "\M; []\\<^sub>c = (\\. True)" +| "\M; Send t#S\\<^sub>c = (\\. M \\<^sub>c t \ \ \ \M; S\\<^sub>c \)" +| "\M; Receive t#S\\<^sub>c = (\\. \insert (t \ \) M; S\\<^sub>c \)" +| "\M; Equality _ t t'#S\\<^sub>c = (\\. t \ \ = t' \ \ \ \M; S\\<^sub>c \)" +| "\M; Inequality X F#S\\<^sub>c = (\\. ineq_model \ X F \ \M; S\\<^sub>c \)" + +definition constr_sem_c ("_ \\<^sub>c \_,_\") where "\ \\<^sub>c \S,\\ \ (\ supports \ \ \{}; S\\<^sub>c \)" +abbreviation constr_sem_c' ("_ \\<^sub>c \_\" 90) where "\ \\<^sub>c \S\ \ \ \\<^sub>c \S,Var\" + +text \The full constraint semantics\ +fun strand_sem_d::"('fun,'var) terms \ ('fun,'var) strand \ ('fun,'var) subst \ bool" ("\_; _\\<^sub>d") +where + "\M; []\\<^sub>d = (\\. True)" +| "\M; Send t#S\\<^sub>d = (\\. M \ t \ \ \ \M; S\\<^sub>d \)" +| "\M; Receive t#S\\<^sub>d = (\\. \insert (t \ \) M; S\\<^sub>d \)" +| "\M; Equality _ t t'#S\\<^sub>d = (\\. t \ \ = t' \ \ \ \M; S\\<^sub>d \)" +| "\M; Inequality X F#S\\<^sub>d = (\\. ineq_model \ X F \ \M; S\\<^sub>d \)" + +definition constr_sem_d ("_ \ \_,_\") where "\ \ \S,\\ \ (\ supports \ \ \{}; S\\<^sub>d \)" +abbreviation constr_sem_d' ("_ \ \_\" 90) where "\ \ \S\ \ \ \ \S,Var\" + +lemmas strand_sem_induct = strand_sem_c.induct[case_names Nil ConsSnd ConsRcv ConsEq ConsIneq] + + +subsubsection \Lemmata\ +lemma strand_sem_d_if_c: "\ \\<^sub>c \S,\\ \ \ \ \S,\\" +proof - + assume *: "\ \\<^sub>c \S,\\" + { fix M have "\M; S\\<^sub>c \ \ \M; S\\<^sub>d \" + proof (induction S rule: strand_sem_induct) + case (ConsSnd M t S) + hence "M \\<^sub>c t \ \" "\M; S\\<^sub>d \" by auto + thus ?case using strand_sem_d.simps(2)[of M t S] by auto + qed (auto simp add: ineq_model_def) + } + thus ?thesis using * by (simp add: constr_sem_c_def constr_sem_d_def) +qed + +lemma strand_sem_mono_ik: + "\M \ M'; \M; S\\<^sub>c \\ \ \M'; S\\<^sub>c \" (is "\?A'; ?A''\ \ ?A") + "\M \ M'; \M; S\\<^sub>d \\ \ \M'; S\\<^sub>d \" (is "\?B'; ?B''\ \ ?B") +proof - + show "\?A'; ?A''\ \ ?A" + proof (induction M S arbitrary: M M' rule: strand_sem_induct) + case (ConsRcv M t S) + thus ?case using ConsRcv.IH[of "insert (t \ \) M" "insert (t \ \) M'"] by auto + next + case (ConsSnd M t S) + hence "M \\<^sub>c t \ \" "\M'; S\\<^sub>c \" by auto + hence "M' \\<^sub>c t \ \" using ideduct_synth_mono \M \ M'\ by metis + thus ?case using \\M'; S\\<^sub>c \\ by simp + qed auto + + show "\?B'; ?B''\ \ ?B" + proof (induction M S arbitrary: M M' rule: strand_sem_induct) + case (ConsRcv M t S) + thus ?case using ConsRcv.IH[of "insert (t \ \) M" "insert (t \ \) M'"] by auto + next + case (ConsSnd M t S) + hence "M \ t \ \" "\M'; S\\<^sub>d \" by auto + hence "M' \ t \ \" using ideduct_mono \M \ M'\ by metis + thus ?case using \\M'; S\\<^sub>d \\ by simp + qed auto +qed + +context +begin +private lemma strand_sem_split_left: + "\M; S@S'\\<^sub>c \ \ \M; S\\<^sub>c \" + "\M; S@S'\\<^sub>d \ \ \M; S\\<^sub>d \" +proof (induct S arbitrary: M) + case (Cons x S) + { case 1 thus ?case using Cons by (cases x) simp_all } + { case 2 thus ?case using Cons by (cases x) simp_all } +qed simp_all + +private lemma strand_sem_split_right: + "\M; S@S'\\<^sub>c \ \ \M \ (ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \); S'\\<^sub>c \" + "\M; S@S'\\<^sub>d \ \ \M \ (ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \); S'\\<^sub>d \" +proof (induction S arbitrary: M rule: ik\<^sub>s\<^sub>t_induct) + case (ConsRcv t S) + { case 1 thus ?case using ConsRcv.IH[of "insert (t \ \) M"] by simp } + { case 2 thus ?case using ConsRcv.IH[of "insert (t \ \) M"] by simp } +qed simp_all + +lemmas strand_sem_split[dest] = + strand_sem_split_left(1) strand_sem_split_right(1) + strand_sem_split_left(2) strand_sem_split_right(2) +end + +lemma strand_sem_Send_split[dest]: + "\\M; map Send T\\<^sub>c \; t \ set T\ \ \M; [Send t]\\<^sub>c \" (is "\?A'; ?A''\ \ ?A") + "\\M; map Send T\\<^sub>d \; t \ set T\ \ \M; [Send t]\\<^sub>d \" (is "\?B'; ?B''\ \ ?B") + "\\M; map Send T@S\\<^sub>c \; t \ set T\ \ \M; Send t#S\\<^sub>c \" (is "\?C'; ?C''\ \ ?C") + "\\M; map Send T@S\\<^sub>d \; t \ set T\ \ \M; Send t#S\\<^sub>d \" (is "\?D'; ?D''\ \ ?D") +proof - + show A: "\?A'; ?A''\ \ ?A" by (induct "map Send T" arbitrary: T rule: strand_sem_c.induct) auto + show B: "\?B'; ?B''\ \ ?B" by (induct "map Send T" arbitrary: T rule: strand_sem_d.induct) auto + show "\?C'; ?C''\ \ ?C" "\?D'; ?D''\ \ ?D" + using list.set_map list.simps(8) set_empty ik_snd_empty sup_bot.right_neutral + by (metis (no_types, lifting) A strand_sem_split(1,2) strand_sem_c.simps(2), + metis (no_types, lifting) B strand_sem_split(3,4) strand_sem_d.simps(2)) +qed + +lemma strand_sem_Send_map: + "(\t. t \ set T \ \M; [Send t]\\<^sub>c \) \ \M; map Send T\\<^sub>c \" + "(\t. t \ set T \ \M; [Send t]\\<^sub>d \) \ \M; map Send T\\<^sub>d \" +by (induct T) auto + +lemma strand_sem_Receive_map: "\M; map Receive T\\<^sub>c \" "\M; map Receive T\\<^sub>d \" +by (induct T arbitrary: M) auto + +lemma strand_sem_append[intro]: + "\\M; S\\<^sub>c \; \M \ (ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \); S'\\<^sub>c \\ \ \M; S@S'\\<^sub>c \" + "\\M; S\\<^sub>d \; \M \ (ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \); S'\\<^sub>d \\ \ \M; S@S'\\<^sub>d \" +proof (induction S arbitrary: M) + case (Cons x S) + { case 1 thus ?case using Cons by (cases x) auto } + { case 2 thus ?case using Cons by (cases x) auto } +qed simp_all + +lemma ineq_model_subst: + fixes F::"(('a,'b) term \ ('a,'b) term) list" + assumes "(subst_domain \ \ range_vars \) \ set X = {}" + and "ineq_model (\ \\<^sub>s \) X F" + shows "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" +proof - + { fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. fst f \ (\ \\<^sub>s (\ \\<^sub>s \)) \ snd f \ (\ \\<^sub>s (\ \\<^sub>s \))) F" + obtain f where f: "f \ set F" "fst f \ \ \\<^sub>s (\ \\<^sub>s \) \ snd f \ \ \\<^sub>s (\ \\<^sub>s \)" + using * by (induct F) auto + have "\ \\<^sub>s (\ \\<^sub>s \) = \ \\<^sub>s (\ \\<^sub>s \)" + by (metis (no_types, lifting) \ subst_compose_assoc assms(1) inf_sup_aci(1) + subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def) + hence "(fst f \ \) \ \ \\<^sub>s \ \ (snd f \ \) \ \ \\<^sub>s \" using f by auto + moreover have "(fst f \ \, snd f \ \) \ set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) by (auto simp add: subst_apply_pairs_def) + ultimately have "list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using f(1) Bex_set by fastforce + } + thus ?thesis using assms unfolding ineq_model_def by simp +qed + +lemma ineq_model_subst': + fixes F::"(('a,'b) term \ ('a,'b) term) list" + assumes "(subst_domain \ \ range_vars \) \ set X = {}" + and "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + shows "ineq_model (\ \\<^sub>s \) X F" +proof - + { fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)) (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + obtain f where f: "f \ set (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" "fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \" + using * by (induct F) (auto simp add: subst_apply_pairs_def) + then obtain g where g: "g \ set F" "f = g \\<^sub>p \" by (auto simp add: subst_apply_pairs_def) + have "\ \\<^sub>s (\ \\<^sub>s \) = \ \\<^sub>s (\ \\<^sub>s \)" + by (metis (no_types, lifting) \ subst_compose_assoc assms(1) inf_sup_aci(1) + subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def) + hence "fst g \ \ \\<^sub>s (\ \\<^sub>s \) \ snd g \ \ \\<^sub>s (\ \\<^sub>s \)" + using f(2) g by (simp add: prod.case_eq_if) + hence "list_ex (\f. fst f \ (\ \\<^sub>s (\ \\<^sub>s \)) \ snd f \ (\ \\<^sub>s (\ \\<^sub>s \))) F" + using g Bex_set by fastforce + } + thus ?thesis using assms unfolding ineq_model_def by simp +qed + +lemma ineq_model_ground_subst: + fixes F::"(('a,'b) term \ ('a,'b) term) list" + assumes "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ subst_domain \" + and "ground (subst_range \)" + and "ineq_model \ X F" + shows "ineq_model (\ \\<^sub>s \) X F" +proof - + { fix \::"('a,'b) subst" and t t' + assume \: "subst_domain \ = set X" "ground (subst_range \)" + and *: "list_ex (\f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \ )) F" + obtain f where f: "f \ set F" "fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \" + using * by (induct F) auto + hence "fv (fst f) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" "fv (snd f) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" by auto + hence "fv (fst f) - set X \ subst_domain \" "fv (snd f) - set X \ subst_domain \" + using assms(1) by auto + hence "fv (fst f \ \) \ subst_domain \" "fv (snd f \ \) \ subst_domain \" + using \ by (simp_all add: range_vars_alt_def subst_fv_unfold_ground_img) + hence "fv (fst f \ \ \\<^sub>s \) = {}" "fv (snd f \ \ \\<^sub>s \) = {}" + using assms(2) by (simp_all add: subst_fv_dom_ground_if_ground_img) + hence "fst f \ \ \\<^sub>s (\ \\<^sub>s \) \ snd f \ \ \\<^sub>s (\ \\<^sub>s \)" using f(2) subst_ground_ident by fastforce + hence "list_ex (\f. fst f \ (\ \\<^sub>s (\ \\<^sub>s \)) \ snd f \ (\ \\<^sub>s (\ \\<^sub>s \))) F" + using f(1) Bex_set by fastforce + } + thus ?thesis using assms unfolding ineq_model_def by simp +qed + +context +begin +private lemma strand_sem_subst_c: + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "\M; S\\<^sub>c (\ \\<^sub>s \) \ \M; S \\<^sub>s\<^sub>t \\\<^sub>c \" +using assms +proof (induction S arbitrary: \ M rule: strand_sem_induct) + case (ConsSnd M t S) + hence "\M; S \\<^sub>s\<^sub>t \\\<^sub>c \" "M \\<^sub>c t \ (\ \\<^sub>s \)" by auto + hence "M \\<^sub>c (t \ \) \ \" + using subst_comp_all[of \ \ M] subst_subst_compose[of t \ \] by simp + thus ?case + using \\M; S \\<^sub>s\<^sub>t \\\<^sub>c \\ + unfolding subst_apply_strand_def + by simp +next + case (ConsRcv M t S) + have *: "\insert (t \ \ \\<^sub>s \) M; S\\<^sub>c (\ \\<^sub>s \)" using ConsRcv.prems(1) by simp + have "bvars\<^sub>s\<^sub>t (Receive t#S) = bvars\<^sub>s\<^sub>t S" by auto + hence **: "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" using ConsRcv.prems(2) by blast + have "\M; Receive (t \ \)#(S \\<^sub>s\<^sub>t \)\\<^sub>c \" + using ConsRcv.IH[OF * **] by (simp add: subst_all_insert) + thus ?case by simp +next + case (ConsIneq M X F S) + hence *: "\M; S \\<^sub>s\<^sub>t \\\<^sub>c \" and + ***: "(subst_domain \ \ range_vars \) \ set X = {}" + unfolding bvars\<^sub>s\<^sub>t_def ineq_model_def by auto + have **: "ineq_model (\ \\<^sub>s \) X F" + using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def) + have "\\. subst_domain \ = set X \ ground (subst_range \) + \ (subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + using * ** *** unfolding range_vars_alt_def by auto + hence "\\. subst_domain \ = set X \ ground (subst_range \) \ \ \\<^sub>s \ = \ \\<^sub>s \" + by (metis subst_comp_eq_if_disjoint_vars) + hence "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using ineq_model_subst[OF *** **] + by blast + moreover have "rm_vars (set X) \ = \" using ConsIneq.prems(2) by force + ultimately show ?case using * by auto +qed simp_all + +private lemma strand_sem_subst_c': + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "\M; S \\<^sub>s\<^sub>t \\\<^sub>c \ \ \M; S\\<^sub>c (\ \\<^sub>s \)" +using assms +proof (induction S arbitrary: \ M rule: strand_sem_induct) + case (ConsSnd M t S) + hence "\M; [Send t] \\<^sub>s\<^sub>t \\\<^sub>c \" "\M; S \\<^sub>s\<^sub>t \\\<^sub>c \" by auto + hence "\M; S\\<^sub>c (\ \\<^sub>s \)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto + moreover have "\M; [Send t]\\<^sub>c (\ \\<^sub>s \)" + proof - + have "M \\<^sub>c t \ \ \ \" using \\M; [Send t] \\<^sub>s\<^sub>t \\\<^sub>c \\ by auto + hence "M \\<^sub>c t \ (\ \\<^sub>s \)" using subst_subst_compose by metis + thus "\M; [Send t]\\<^sub>c (\ \\<^sub>s \)" by auto + qed + ultimately show ?case by auto +next + case (ConsRcv M t S) + hence "\(insert (t \ \ \ \) M); S \\<^sub>s\<^sub>t \\\<^sub>c \" by (simp add: subst_all_insert) + thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto +next + case (ConsIneq M X F S) + have \: "rm_vars (set X) \ = \" using ConsIneq.prems(2) by force + hence *: "\M; S\\<^sub>c (\ \\<^sub>s \)" + and ***: "(subst_domain \ \ range_vars \) \ set X = {}" + using ConsIneq unfolding bvars\<^sub>s\<^sub>t_def ineq_model_def by auto + have **: "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using ConsIneq.prems(1) \ by (auto simp add: subst_compose_assoc ineq_model_def) + have "\\. subst_domain \ = set X \ ground (subst_range \) + \ (subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + using * ** *** unfolding range_vars_alt_def by auto + hence "\\. subst_domain \ = set X \ ground (subst_range \) \ \ \\<^sub>s \ = \ \\<^sub>s \" + by (metis subst_comp_eq_if_disjoint_vars) + hence "ineq_model (\ \\<^sub>s \) X F" + using ineq_model_subst'[OF *** **] + by blast + thus ?case using * by auto +next + case ConsEq thus ?case unfolding bvars\<^sub>s\<^sub>t_def by auto +qed simp_all + +private lemma strand_sem_subst_d: + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "\M; S\\<^sub>d (\ \\<^sub>s \) \ \M; S \\<^sub>s\<^sub>t \\\<^sub>d \" +using assms +proof (induction S arbitrary: \ M rule: strand_sem_induct) + case (ConsSnd M t S) + hence "\M; S \\<^sub>s\<^sub>t \\\<^sub>d \" "M \ t \ (\ \\<^sub>s \)" by auto + hence "M \ (t \ \) \ \" + using subst_comp_all[of \ \ M] subst_subst_compose[of t \ \] by simp + thus ?case using \\M; S \\<^sub>s\<^sub>t \\\<^sub>d \\ by simp +next + case (ConsRcv M t S) + have *: "\insert (t \ \ \\<^sub>s \) M; S\\<^sub>d (\ \\<^sub>s \)" using ConsRcv.prems(1) by simp + have "bvars\<^sub>s\<^sub>t (Receive t#S) = bvars\<^sub>s\<^sub>t S" by auto + hence **: "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" using ConsRcv.prems(2) by blast + have "\M; Receive (t \ \)#(S \\<^sub>s\<^sub>t \)\\<^sub>d \" + using ConsRcv.IH[OF * **] by (simp add: subst_all_insert) + thus ?case by simp +next + case (ConsIneq M X F S) + hence *: "\M; S \\<^sub>s\<^sub>t \\\<^sub>d \" and + ***: "(subst_domain \ \ range_vars \) \ set X = {}" + unfolding bvars\<^sub>s\<^sub>t_def ineq_model_def by auto + have **: "ineq_model (\ \\<^sub>s \) X F" + using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def) + have "\\. subst_domain \ = set X \ ground (subst_range \) + \ (subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + using * ** *** unfolding range_vars_alt_def by auto + hence "\\. subst_domain \ = set X \ ground (subst_range \) \ \ \\<^sub>s \ = \ \\<^sub>s \" + by (metis subst_comp_eq_if_disjoint_vars) + hence "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using ineq_model_subst[OF *** **] + by blast + moreover have "rm_vars (set X) \ = \" using ConsIneq.prems(2) by force + ultimately show ?case using * by auto +next + case ConsEq thus ?case unfolding bvars\<^sub>s\<^sub>t_def by auto +qed simp_all + +private lemma strand_sem_subst_d': + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "\M; S \\<^sub>s\<^sub>t \\\<^sub>d \ \ \M; S\\<^sub>d (\ \\<^sub>s \)" +using assms +proof (induction S arbitrary: \ M rule: strand_sem_induct) + case (ConsSnd M t S) + hence "\M; [Send t] \\<^sub>s\<^sub>t \\\<^sub>d \" "\M; S \\<^sub>s\<^sub>t \\\<^sub>d \" by auto + hence "\M; S\\<^sub>d (\ \\<^sub>s \)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto + moreover have "\M; [Send t]\\<^sub>d (\ \\<^sub>s \)" + proof - + have "M \ t \ \ \ \" using \\M; [Send t] \\<^sub>s\<^sub>t \\\<^sub>d \\ by auto + hence "M \ t \ (\ \\<^sub>s \)" using subst_subst_compose by metis + thus "\M; [Send t]\\<^sub>d (\ \\<^sub>s \)" by auto + qed + ultimately show ?case by auto +next + case (ConsRcv M t S) + hence "\insert (t \ \ \ \) M; S \\<^sub>s\<^sub>t \\\<^sub>d \" by (simp add: subst_all_insert) + thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto +next + case (ConsIneq M X F S) + have \: "rm_vars (set X) \ = \" using ConsIneq.prems(2) by force + hence *: "\M; S\\<^sub>d (\ \\<^sub>s \)" + and ***: "(subst_domain \ \ range_vars \) \ set X = {}" + using ConsIneq unfolding bvars\<^sub>s\<^sub>t_def ineq_model_def by auto + have **: "ineq_model \ X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + using ConsIneq.prems(1) \ by (auto simp add: subst_compose_assoc ineq_model_def) + have "\\. subst_domain \ = set X \ ground (subst_range \) + \ (subst_domain \ \ range_vars \) \ (subst_domain \ \ range_vars \) = {}" + using * ** *** unfolding range_vars_alt_def by auto + hence "\\. subst_domain \ = set X \ ground (subst_range \) \ \ \\<^sub>s \ = \ \\<^sub>s \" + by (metis subst_comp_eq_if_disjoint_vars) + hence "ineq_model (\ \\<^sub>s \) X F" + using ineq_model_subst'[OF *** **] + by blast + thus ?case using * by auto +next + case ConsEq thus ?case unfolding bvars\<^sub>s\<^sub>t_def by auto +qed simp_all + +lemmas strand_sem_subst = + strand_sem_subst_c strand_sem_subst_c' strand_sem_subst_d strand_sem_subst_d' +end + +lemma strand_sem_subst_subst_idem: + assumes \: "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + shows "\\M; S \\<^sub>s\<^sub>t \\\<^sub>c (\ \\<^sub>s \); subst_idem \\ \ \M; S\\<^sub>c (\ \\<^sub>s \)" +using strand_sem_subst(2)[OF assms, of M "\ \\<^sub>s \"] subst_compose_assoc[of \ \ \] +unfolding subst_idem_def by argo + +lemma strand_sem_subst_comp: + assumes "(subst_domain \ \ range_vars \) \ bvars\<^sub>s\<^sub>t S = {}" + and "\M; S\\<^sub>c \" "subst_domain \ \ (vars\<^sub>s\<^sub>t S \ fv\<^sub>s\<^sub>e\<^sub>t M) = {}" + shows "\M; S\\<^sub>c (\ \\<^sub>s \)" +proof - + from assms(3) have "subst_domain \ \ vars\<^sub>s\<^sub>t S = {}" "subst_domain \ \ fv\<^sub>s\<^sub>e\<^sub>t M = {}" by auto + hence "S \\<^sub>s\<^sub>t \ = S" "M \\<^sub>s\<^sub>e\<^sub>t \ = M" using strand_substI set_subst_ident[of M \] by (blast, blast) + thus ?thesis using assms(2) by (auto simp add: strand_sem_subst(2)[OF assms(1)]) +qed + +lemma strand_sem_c_imp_ineqs_neq: + assumes "\M; S\\<^sub>c \" "Inequality X [(t,t')] \ set S" + shows "t \ t' \ (\\. subst_domain \ = set X \ ground (subst_range \) + \ t \ \ \ t' \ \ \ t \ \ \ \ \ t' \ \ \ \)" +using assms +proof (induction rule: strand_sem_induct) + case (ConsIneq M Y F S) thus ?case + proof (cases "Inequality X [(t,t')] \ set S") + case False + hence "X = Y" "F = [(t,t')]" using ConsIneq by auto + hence *: "\\. subst_domain \ = set X \ ground (subst_range \) \ t \ \ \ \ \ t' \ \ \ \" + using ConsIneq by (auto simp add: ineq_model_def) + then obtain \ where \: "subst_domain \ = set X" "ground (subst_range \)" "t \ \ \ \ \ t' \ \ \ \" + using interpretation_subst_exists'[of "set X"] by moura + hence "t \ t'" by auto + moreover have "\\ \. t \ \ \ \ \ t' \ \ \ \ \ t \ \ \ t' \ \" by auto + ultimately show ?thesis using * by auto + qed simp +qed simp_all + +lemma strand_sem_c_imp_ineq_model: + assumes "\M; S\\<^sub>c \" "Inequality X F \ set S" + shows "ineq_model \ X F" +using assms by (induct S rule: strand_sem_induct) force+ + +lemma strand_sem_wf_simple_fv_sat: + assumes "wf\<^sub>s\<^sub>t {} S" "simple S" "\{}; S\\<^sub>c \" + shows "\v. v \ wfrestrictedvars\<^sub>s\<^sub>t S \ ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c \ v" +using assms +proof (induction S rule: wf\<^sub>s\<^sub>t_simple_induct) + case (ConsRcv t S) + have "v \ wfrestrictedvars\<^sub>s\<^sub>t S" + using ConsRcv.hyps(3) ConsRcv.prems(1) vars_snd_rcv_strand2 + by fastforce + moreover have "\{}; S\\<^sub>c \" using \\{}; S@[Receive t]\\<^sub>c \\ by blast + moreover have "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \ ik\<^sub>s\<^sub>t (S@[Receive t]) \\<^sub>s\<^sub>e\<^sub>t \" by auto + ultimately show ?case using ConsRcv.IH ideduct_synth_mono by meson +next + case (ConsIneq X F S) + hence "v \ wfrestrictedvars\<^sub>s\<^sub>t S" by fastforce + moreover have "\{}; S\\<^sub>c \" using \\{}; S@[Inequality X F]\\<^sub>c \\ by blast + moreover have "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \ ik\<^sub>s\<^sub>t (S@[Inequality X F]) \\<^sub>s\<^sub>e\<^sub>t \" by auto + ultimately show ?case using ConsIneq.IH ideduct_synth_mono by meson +next + case (ConsSnd w S) + hence *: "\{}; S\\<^sub>c \" "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c \ w" by auto + have **: "ik\<^sub>s\<^sub>t S \\<^sub>s\<^sub>e\<^sub>t \ \ ik\<^sub>s\<^sub>t (S@[Send (Var w)]) \\<^sub>s\<^sub>e\<^sub>t \" by simp + show ?case + proof (cases "v = w") + case True thus ?thesis using *(2) ideduct_synth_mono[OF _ **] by meson + next + case False + hence "v \ wfrestrictedvars\<^sub>s\<^sub>t S" using ConsSnd.prems(1) by auto + thus ?thesis using ConsSnd.IH[OF _ *(1)] ideduct_synth_mono[OF _ **] by metis + qed +qed simp + +lemma strand_sem_wf_ik_or_assignment_rhs_fun_subterm: + assumes "wf\<^sub>s\<^sub>t {} A" "\{}; A\\<^sub>c \" "Var x \ ik\<^sub>s\<^sub>t A" "\ x = Fun f T" + "t\<^sub>i \ set T" "\ik\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t\<^sub>i" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + obtains S where + "Fun f S \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t A) \ Fun f S \ subterms\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>s\<^sub>t A)" + "Fun f T = Fun f S \ \" +proof - + have "x \ wfrestrictedvars\<^sub>s\<^sub>t A" + by (metis (no_types) assms(3) set_rev_mp term.set_intros(3) vars_subset_if_in_strand_ik2) + moreover have "Fun f T \ \ = Fun f T" + by (metis subst_ground_ident interpretation_grounds_all assms(4,7)) + ultimately obtain A\<^sub>p\<^sub>r\<^sub>e A\<^sub>s\<^sub>u\<^sub>f where *: + "\(\w \ wfrestrictedvars\<^sub>s\<^sub>t A\<^sub>p\<^sub>r\<^sub>e. Fun f T \ \ w)" + "(\t. A = A\<^sub>p\<^sub>r\<^sub>e@Send t#A\<^sub>s\<^sub>u\<^sub>f \ Fun f T \ t \ \) \ + (\t t'. A = A\<^sub>p\<^sub>r\<^sub>e@Equality Assign t t'#A\<^sub>s\<^sub>u\<^sub>f \ Fun f T \ t \ \)" + using wf_strand_first_Send_var_split[OF assms(1)] assms(4) subtermeqI' by metis + moreover + { fix t assume **: "A = A\<^sub>p\<^sub>r\<^sub>e@Send t#A\<^sub>s\<^sub>u\<^sub>f" "Fun f T \ t \ \" + hence "ik\<^sub>s\<^sub>t A\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" "\ik\<^sub>s\<^sub>t A\<^sub>p\<^sub>r\<^sub>e \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t\<^sub>i" + using assms(2,6) by (auto intro: ideduct_synth_mono) + then obtain s where s: "s \ ik\<^sub>s\<^sub>t A\<^sub>p\<^sub>r\<^sub>e" "Fun f T \ s \ \" + using assms(5) **(2) by (induct rule: intruder_synth_induct) auto + then obtain g S where gS: "Fun g S \ s" "Fun f T = Fun g S \ \" + using subterm_subst_not_img_subterm[OF s(2)] *(1) by force + hence ?thesis using that **(1) s(1) by force + } + moreover + { fix t t' assume **: "A = A\<^sub>p\<^sub>r\<^sub>e@Equality Assign t t'#A\<^sub>s\<^sub>u\<^sub>f" "Fun f T \ t \ \" + with assms(2) have "t \ \ = t' \ \" by auto + hence "Fun f T \ t' \ \" using **(2) by auto + from assms(1) **(1) have "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t A\<^sub>p\<^sub>r\<^sub>e" + using wf_eq_fv[of "{}" A\<^sub>p\<^sub>r\<^sub>e t t' A\<^sub>s\<^sub>u\<^sub>f] vars_snd_rcv_strand_subset2(4)[of A\<^sub>p\<^sub>r\<^sub>e] + by blast + then obtain g S where gS: "Fun g S \ t'" "Fun f T = Fun g S \ \" + using subterm_subst_not_img_subterm[OF \Fun f T \ t' \ \\] *(1) by fastforce + hence ?thesis using that **(1) by auto + } + ultimately show ?thesis by auto +qed + +lemma strand_sem_not_unif_is_sat_ineq: + assumes "\\. Unifier \ t t'" + shows "\M; [Inequality X [(t,t')]]\\<^sub>c \" "\M; [Inequality X [(t,t')]]\\<^sub>d \" +using assms list_ex_simps(1)[of _ "(t,t')" "[]"] prod.sel[of t t'] + strand_sem_c.simps(1,5) strand_sem_d.simps(1,5) +unfolding ineq_model_def by presburger+ + +lemma ineq_model_singleI[intro]: + assumes "\\. subst_domain \ = set X \ ground (subst_range \) \ t \ \ \ \ \ t' \ \ \ \" + shows "ineq_model \ X [(t,t')]" +using assms unfolding ineq_model_def by auto + +lemma ineq_model_singleE: + assumes "ineq_model \ X [(t,t')]" + shows "\\. subst_domain \ = set X \ ground (subst_range \) \ t \ \ \ \ \ t' \ \ \ \" +using assms unfolding ineq_model_def by auto + +lemma ineq_model_single_iff: + fixes F::"(('a,'b) term \ ('a,'b) term) list" + shows "ineq_model \ X F \ + ineq_model \ X [(Fun f (Fun c []#map fst F),Fun f (Fun c []#map snd F))]" + (is "?A \ ?B") +proof - + let ?P = "\\ f. fst f \ (\ \\<^sub>s \) \ snd f \ (\ \\<^sub>s \)" + let ?Q = "\\ t t'. t \ (\ \\<^sub>s \) \ t' \ (\ \\<^sub>s \)" + let ?T = "\g. Fun c []#map g F" + let ?S = "\\ g. map (\x. x \ (\ \\<^sub>s \)) (Fun c []#map g F)" + let ?t = "Fun f (?T fst)" + let ?t' = "Fun f (?T snd)" + + have len: "\g h. length (?T g) = length (?T h)" + "\g h \. length (?S \ g) = length (?T h)" + "\g h \. length (?S \ g) = length (?T h)" + "\g h \ \. length (?S \ g) = length (?S \ h)" + by simp_all + + { fix \::"('a,'b) subst" + assume \: "subst_domain \ = set X" "ground (subst_range \)" + have "list_ex (?P \) F \ ?Q \ ?t ?t'" + proof + assume "list_ex (?P \) F" + then obtain a where a: "a \ set F" "?P \ a" by (metis (mono_tags, lifting) Bex_set) + thus "?Q \ ?t ?t'" by auto + qed (fastforce simp add: Bex_set) + } thus ?thesis unfolding ineq_model_def by auto +qed + + +subsection \Constraint Semantics (Alternative, Equivalent Version)\ +text \These are the constraint semantics used in the CSF 2017 paper\ +fun strand_sem_c'::"('fun,'var) terms \ ('fun,'var) strand \ ('fun,'var) subst \ bool" ("\_; _\\<^sub>c''") + where + "\M; []\\<^sub>c' = (\\. True)" +| "\M; Send t#S\\<^sub>c' = (\\. M \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \ \ \M; S\\<^sub>c' \)" +| "\M; Receive t#S\\<^sub>c' = \insert t M; S\\<^sub>c'" +| "\M; Equality _ t t'#S\\<^sub>c' = (\\. t \ \ = t' \ \ \ \M; S\\<^sub>c' \)" +| "\M; Inequality X F#S\\<^sub>c' = (\\. ineq_model \ X F \ \M; S\\<^sub>c' \)" + +fun strand_sem_d'::"('fun,'var) terms \ ('fun,'var) strand \ ('fun,'var) subst \ bool" ("\_; _\\<^sub>d''") +where + "\M; []\\<^sub>d' = (\\. True)" +| "\M; Send t#S\\<^sub>d' = (\\. M \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \ \ \M; S\\<^sub>d' \)" +| "\M; Receive t#S\\<^sub>d' = \insert t M; S\\<^sub>d'" +| "\M; Equality _ t t'#S\\<^sub>d' = (\\. t \ \ = t' \ \ \ \M; S\\<^sub>d' \)" +| "\M; Inequality X F#S\\<^sub>d' = (\\. ineq_model \ X F \ \M; S\\<^sub>d' \)" + +lemma strand_sem_eq_defs: + "\M; \\\<^sub>c' \ = \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>c \" + "\M; \\\<^sub>d' \ = \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>d \" +proof - + have 1: "\M; \\\<^sub>c' \ \ \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>c \" + by (induct \ arbitrary: M rule: strand_sem_induct) force+ + have 2: "\M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>c \ \ \M; \\\<^sub>c' \" + by (induct \ arbitrary: M rule: strand_sem_c'.induct) auto + have 3: "\M; \\\<^sub>d' \ \ \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>d \" + by (induct \ arbitrary: M rule: strand_sem_induct) force+ + have 4: "\M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>d \ \ \M; \\\<^sub>d' \" + by (induct \ arbitrary: M rule: strand_sem_d'.induct) auto + + show "\M; \\\<^sub>c' \ = \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>c \" "\M; \\\<^sub>d' \ = \M \\<^sub>s\<^sub>e\<^sub>t \; \\\<^sub>d \" + by (metis 1 2, metis 3 4) +qed + +lemma strand_sem_split'[dest]: + "\M; S@S'\\<^sub>c' \ \ \M; S\\<^sub>c' \" + "\M; S@S'\\<^sub>c' \ \ \M \ ik\<^sub>s\<^sub>t S; S'\\<^sub>c' \" + "\M; S@S'\\<^sub>d' \ \ \M; S\\<^sub>d' \" + "\M; S@S'\\<^sub>d' \ \ \M \ ik\<^sub>s\<^sub>t S; S'\\<^sub>d' \" +using strand_sem_eq_defs[of M "S@S'" \] + strand_sem_eq_defs[of M S \] + strand_sem_eq_defs[of "M \ ik\<^sub>s\<^sub>t S" S' \] + strand_sem_split(2,4) +by (auto simp add: image_Un) + +lemma strand_sem_append'[intro]: + "\M; S\\<^sub>c' \ \ \M \ ik\<^sub>s\<^sub>t S; S'\\<^sub>c' \ \ \M; S@S'\\<^sub>c' \" + "\M; S\\<^sub>d' \ \ \M \ ik\<^sub>s\<^sub>t S; S'\\<^sub>d' \ \ \M; S@S'\\<^sub>d' \" +using strand_sem_eq_defs[of M "S@S'" \] + strand_sem_eq_defs[of M S \] + strand_sem_eq_defs[of "M \ ik\<^sub>s\<^sub>t S" S' \] +by (auto simp add: image_Un) + +end + +subsection \Dual Strands\ +fun dual\<^sub>s\<^sub>t::"('a,'b) strand \ ('a,'b) strand" where + "dual\<^sub>s\<^sub>t [] = []" +| "dual\<^sub>s\<^sub>t (Receive t#S) = Send t#(dual\<^sub>s\<^sub>t S)" +| "dual\<^sub>s\<^sub>t (Send t#S) = Receive t#(dual\<^sub>s\<^sub>t S)" +| "dual\<^sub>s\<^sub>t (x#S) = x#(dual\<^sub>s\<^sub>t S)" + +lemma dual\<^sub>s\<^sub>t_append: "dual\<^sub>s\<^sub>t (A@B) = (dual\<^sub>s\<^sub>t A)@(dual\<^sub>s\<^sub>t B)" +by (induct A rule: dual\<^sub>s\<^sub>t.induct) auto + +lemma dual\<^sub>s\<^sub>t_self_inverse: "dual\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t S) = S" +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma dual\<^sub>s\<^sub>t_trms_eq: "trms\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t S) = trms\<^sub>s\<^sub>t S" +proof (induction S) + case (Cons x S) thus ?case by (cases x) auto +qed simp + +lemma dual\<^sub>s\<^sub>t_fv: "fv\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t A) = fv\<^sub>s\<^sub>t A" +by (induct A rule: dual\<^sub>s\<^sub>t.induct) auto + +lemma dual\<^sub>s\<^sub>t_bvars: "bvars\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t A) = bvars\<^sub>s\<^sub>t A" +by (induct A rule: dual\<^sub>s\<^sub>t.induct) fastforce+ + + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Typed_Model.thy b/Stateful_Protocol_Composition_and_Typing/Typed_Model.thy new file mode 100644 index 0000000..675752a --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Typed_Model.thy @@ -0,0 +1,2363 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Typed_Model.thy + Author: Andreas Viktor Hess, DTU +*) + +section \The Typed Model\ +theory Typed_Model +imports Lazy_Intruder +begin + +text \Term types\ +type_synonym ('f,'v) term_type = "('f,'v) term" + +text \Constructors for term types\ +abbreviation (input) TAtom::"'v \ ('f,'v) term_type" where + "TAtom a \ Var a" + +abbreviation (input) TComp::"['f, ('f,'v) term_type list] \ ('f,'v) term_type" where + "TComp f T \ Fun f T" + + +text \ + The typed model extends the intruder model with a typing function \\\ that assigns types to terms. +\ +locale typed_model = intruder_model arity public Ana + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,'var) term \ (('fun,'var) term list \ ('fun,'var) term list)" + + + fixes \::"('fun,'var) term \ ('fun,'atom::finite) term_type" + assumes const_type: "\c. arity c = 0 \ \a. \T. \ (Fun c T) = TAtom a" + and fun_type: "\f T. arity f > 0 \ \ (Fun f T) = TComp f (map \ T)" + and infinite_typed_consts: "\a. infinite {c. \ (Fun c []) = TAtom a \ public c}" + and \_wf: "\t f T. TComp f T \ \ t \ arity f > 0" + "\x. wf\<^sub>t\<^sub>r\<^sub>m (\ (Var x))" + and no_private_funs[simp]: "\f. arity f > 0 \ public f" +begin + +subsection \Definitions\ +text \The set of atomic types\ +abbreviation "\\<^sub>a \ UNIV::('atom set)" + +text \Well-typed substitutions\ +definition wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t where + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ (\v. \ (Var v) = \ (\ v))" + +text \The set of sub-message patterns (SMP)\ +inductive_set SMP::"('fun,'var) terms \ ('fun,'var) terms" for M where + MP[intro]: "t \ M \ t \ SMP M" +| Subterm[intro]: "\t \ SMP M; t' \ t\ \ t' \ SMP M" +| Substitution[intro]: "\t \ SMP M; wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \; wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)\ \ (t \ \) \ SMP M" +| Ana[intro]: "\t \ SMP M; Ana t = (K,T); k \ set K\ \ k \ SMP M" + +text \ + Type-flaw resistance for sets: + Unifiable sub-message patterns must have the same type (unless they are variables) +\ +definition tfr\<^sub>s\<^sub>e\<^sub>t where + "tfr\<^sub>s\<^sub>e\<^sub>t M \ (\s \ SMP M - (Var`\). \t \ SMP M - (Var`\). (\\. Unifier \ s t) \ \ s = \ t)" + +text \ + Type-flaw resistance for strand steps: + - The terms in a satisfiable equality step must have the same types + - Inequality steps must satisfy the conditions of the "inequality lemma"\ +fun tfr\<^sub>s\<^sub>t\<^sub>p where + "tfr\<^sub>s\<^sub>t\<^sub>p (Equality a t t') = ((\\. Unifier \ t t') \ \ t = \ t')" +| "tfr\<^sub>s\<^sub>t\<^sub>p (Inequality X F) = ( + (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \a. \ (Var x) = TAtom a) \ + (\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X)))" +| "tfr\<^sub>s\<^sub>t\<^sub>p _ = True" + +text \ + Type-flaw resistance for strands: + - The set of terms in strands must be type-flaw resistant + - The steps of strands must be type-flaw resistant +\ +definition tfr\<^sub>s\<^sub>t where + "tfr\<^sub>s\<^sub>t S \ tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S) \ list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + + +subsection \Small Lemmata\ +lemma tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def: + "list_all tfr\<^sub>s\<^sub>t\<^sub>p S \ + ((\a t t'. Equality a t t' \ set S \ (\\. Unifier \ t t') \ \ t = \ t') \ + (\X F. Inequality X F \ set S \ + (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \a. \ (Var x) = TAtom a) + \ (\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X))))" + (is "?P S \ ?Q S") +proof + show "?P S \ ?Q S" + proof (induction S) + case (Cons x S) thus ?case by (cases x) auto + qed simp + + show "?Q S \ ?P S" + proof (induction S) + case (Cons x S) thus ?case by (cases x) auto + qed simp +qed + + +lemma \_wf': "wf\<^sub>t\<^sub>r\<^sub>m t \ wf\<^sub>t\<^sub>r\<^sub>m (\ t)" +proof (induction t) + case (Fun f T) + hence *: "arity f = length T" "\t. t \ set T \ wf\<^sub>t\<^sub>r\<^sub>m (\ t)" unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + { assume "arity f = 0" hence ?case using const_type[of f] by auto } + moreover + { assume "arity f > 0" hence ?case using fun_type[of f] * by force } + ultimately show ?case by auto +qed (metis \_wf(2)) + +lemma fun_type_inv: assumes "\ t = TComp f T" shows "arity f > 0" "public f" +using \_wf(1)[of f T t] assms by simp_all + +lemma fun_type_inv_wf: assumes "\ t = TComp f T" "wf\<^sub>t\<^sub>r\<^sub>m t" shows "arity f = length T" +using \_wf'[OF assms(2)] assms(1) unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + +lemma const_type_inv: "\ (Fun c X) = TAtom a \ arity c = 0" +by (rule ccontr, simp add: fun_type) + +lemma const_type_inv_wf: assumes "\ (Fun c X) = TAtom a" and "wf\<^sub>t\<^sub>r\<^sub>m (Fun c X)" shows "X = []" +by (metis assms const_type_inv length_0_conv subtermeqI' wf\<^sub>t\<^sub>r\<^sub>m_def) + +lemma const_type': "\c \ \. \a \ \\<^sub>a. \X. \ (Fun c X) = TAtom a" using const_type by simp +lemma fun_type': "\f \ \\<^sub>f. \X. \ (Fun f X) = TComp f (map \ X)" using fun_type by simp + +lemma infinite_public_consts[simp]: "infinite {c. public c \ arity c = 0}" +proof - + fix a::'atom + define A where "A \ {c. \ (Fun c []) = TAtom a \ public c}" + define B where "B \ {c. public c \ arity c = 0}" + + have "arity c = 0" when c: "c \ A" for c + using c const_type_inv unfolding A_def by blast + hence "A \ B" unfolding A_def B_def by blast + hence "infinite B" + using infinite_typed_consts[of a, unfolded A_def[symmetric]] + by (metis infinite_super) + thus ?thesis unfolding B_def by blast +qed + +lemma infinite_fun_syms[simp]: + "infinite {c. public c \ arity c > 0} \ infinite \\<^sub>f" + "infinite \" "infinite \\<^sub>p\<^sub>u\<^sub>b" "infinite (UNIV::'fun set)" +by (metis \\<^sub>f_unfold finite_Collect_conjI, + metis infinite_public_consts finite_Collect_conjI, + use infinite_public_consts \pub_unfold in \force simp add: Collect_conj_eq\, + metis UNIV_I finite_subset subsetI infinite_public_consts(1)) + +lemma id_univ_proper_subset[simp]: "\\<^sub>f \ UNIV" "(\f. arity f > 0) \ \ \ UNIV" +by (metis finite.emptyI inf_top.right_neutral top.not_eq_extremum disjoint_fun_syms + infinite_fun_syms(2) inf_commute) + (metis top.not_eq_extremum UNIV_I const_arity_eq_zero less_irrefl) + +lemma exists_fun_notin_funs_term: "\f::'fun. f \ funs_term t" +by (metis UNIV_eq_I finite_fun_symbols infinite_fun_syms(4)) + +lemma exists_fun_notin_funs_terms: + assumes "finite M" shows "\f::'fun. f \ \(funs_term ` M)" +by (metis assms finite_fun_symbols infinite_fun_syms(4) ex_new_if_finite finite_UN) + +lemma exists_notin_funs\<^sub>s\<^sub>t: "\f. f \ funs\<^sub>s\<^sub>t (S::('fun,'var) strand)" +by (metis UNIV_eq_I finite_funs\<^sub>s\<^sub>t infinite_fun_syms(4)) + +lemma infinite_typed_consts': "infinite {c. \ (Fun c []) = TAtom a \ public c \ arity c = 0}" +proof - + { fix c assume "\ (Fun c []) = TAtom a" "public c" + hence "arity c = 0" using const_type[of c] fun_type[of c "[]"] by auto + } hence "{c. \ (Fun c []) = TAtom a \ public c \ arity c = 0} = + {c. \ (Fun c []) = TAtom a \ public c}" + by auto + thus "infinite {c. \ (Fun c []) = TAtom a \ public c \ arity c = 0}" + using infinite_typed_consts[of a] by metis +qed + +lemma atypes_inhabited: "\c. \ (Fun c []) = TAtom a \ wf\<^sub>t\<^sub>r\<^sub>m (Fun c []) \ public c \ arity c = 0" +proof - + obtain c where "\ (Fun c []) = TAtom a" "public c" "arity c = 0" + using infinite_typed_consts'(1)[of a] not_finite_existsD by blast + thus ?thesis using const_type_inv[OF \\ (Fun c []) = TAtom a\] unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto +qed + +lemma atype_ground_term_ex: "\t. fv t = {} \ \ t = TAtom a \ wf\<^sub>t\<^sub>r\<^sub>m t" +using atypes_inhabited[of a] by force + +lemma fun_type_id_eq: "\ (Fun f X) = TComp g Y \ f = g" +by (metis const_type fun_type neq0_conv "term.inject"(2) "term.simps"(4)) + +lemma fun_type_length_eq: "\ (Fun f X) = TComp g Y \ length X = length Y" +by (metis fun_type fun_type_id_eq fun_type_inv(1) length_map term.inject(2)) + +lemma type_ground_inhabited: "\t'. fv t' = {} \ \ t = \ t'" +proof - + { fix \::"('fun, 'atom) term_type" assume "\f T. Fun f T \ \ \ 0 < arity f" + hence "\t'. fv t' = {} \ \ = \ t'" + proof (induction \) + case (Fun f T) + hence "arity f > 0" by auto + + from Fun.IH Fun.prems(1) have "\Y. map \ Y = T \ (\x \ set Y. fv x = {})" + proof (induction T) + case (Cons x X) + hence "\g Y. Fun g Y \ Fun f X \ 0 < arity g" by auto + hence "\Y. map \ Y = X \ (\x\set Y. fv x = {})" using Cons by auto + moreover have "\t'. fv t' = {} \ x = \ t'" using Cons by auto + ultimately obtain y Y where + "fv y = {}" "\ y = x" "map \ Y = X" "\x\set Y. fv x = {}" + using Cons by moura + hence "map \ (y#Y) = x#X \ (\x\set (y#Y). fv x = {})" by auto + thus ?case by meson + qed simp + then obtain Y where "map \ Y = T" "\x \ set Y. fv x = {}" by metis + hence "fv (Fun f Y) = {}" "\ (Fun f Y) = TComp f T" using fun_type[OF \arity f > 0\] by auto + thus ?case by (metis exI[of "\t. fv t = {} \ \ t = TComp f T" "Fun f Y"]) + qed (metis atype_ground_term_ex) + } + thus ?thesis by (metis \_wf(1)) +qed + +lemma type_wfttype_inhabited: + assumes "\f T. Fun f T \ \ \ 0 < arity f" "wf\<^sub>t\<^sub>r\<^sub>m \" + shows "\t. \ t = \ \ wf\<^sub>t\<^sub>r\<^sub>m t" +using assms +proof (induction \) + case (Fun f Y) + have IH: "\t. \ t = y \ wf\<^sub>t\<^sub>r\<^sub>m t" when y: "y \ set Y " for y + proof - + have "wf\<^sub>t\<^sub>r\<^sub>m y" + using Fun y unfolding wf\<^sub>t\<^sub>r\<^sub>m_def + by (metis Fun_param_is_subterm term.le_less_trans) + moreover have "Fun g Z \ y \ 0 < arity g" for g Z + using Fun y by auto + ultimately show ?thesis using Fun.IH[OF y] by auto + qed + + from Fun have "arity f = length Y" "arity f > 0" unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by force+ + moreover from IH have "\X. map \ X = Y \ (\x \ set X. wf\<^sub>t\<^sub>r\<^sub>m x)" + by (induct Y, simp_all, metis list.simps(9) set_ConsD) + ultimately show ?case by (metis fun_type length_map wf_trmI) +qed (use atypes_inhabited wf\<^sub>t\<^sub>r\<^sub>m_def in blast) + +lemma type_pgwt_inhabited: "wf\<^sub>t\<^sub>r\<^sub>m t \ \t'. \ t = \ t' \ public_ground_wf_term t'" +proof - + assume "wf\<^sub>t\<^sub>r\<^sub>m t" + { fix \ assume "\ t = \" + hence "\t'. \ t = \ t' \ public_ground_wf_term t'" using \wf\<^sub>t\<^sub>r\<^sub>m t\ + proof (induction \ arbitrary: t) + case (Var a t) + then obtain c where "\ t = \ (Fun c [])" "arity c = 0" "public c" + using const_type_inv[of _ "[]" a] infinite_typed_consts(1)[of a] not_finite_existsD + by force + thus ?case using PGWT[OF \public c\, of "[]"] by auto + next + case (Fun f Y t) + have *: "arity f > 0" "public f" "arity f = length Y" + using fun_type_inv[OF \\ t = TComp f Y\] fun_type_inv_wf[OF \\ t = TComp f Y\ \wf\<^sub>t\<^sub>r\<^sub>m t\] + by auto + have "\y. y \ set Y \ \t'. y = \ t' \ public_ground_wf_term t'" + using Fun.prems(1) Fun.IH \_wf(1)[of _ _ t] \_wf'[OF \wf\<^sub>t\<^sub>r\<^sub>m t\] type_wfttype_inhabited + by (metis Fun_param_is_subterm term.order_trans wf_trm_subtermeq) + hence "\X. map \ X = Y \ (\x \ set X. public_ground_wf_term x)" + by (induct Y, simp_all, metis list.simps(9) set_ConsD) + then obtain X where X: "map \ X = Y" "\x. x \ set X \ public_ground_wf_term x" by moura + hence "arity f = length X" using *(3) by auto + have "\ t = \ (Fun f X)" "public_ground_wf_term (Fun f X)" + using fun_type[OF *(1), of X] Fun.prems(1) X(1) apply simp + using PGWT[OF *(2) \arity f = length X\ X(2)] by metis + thus ?case by metis + qed + } + thus ?thesis using \wf\<^sub>t\<^sub>r\<^sub>m t\ by auto +qed + +lemma pgwt_type_map: + assumes "public_ground_wf_term t" + shows "\ t = TAtom a \ \f. t = Fun f []" "\ t = TComp g Y \ \X. t = Fun g X \ map \ X = Y" +proof - + let ?A = "\ t = TAtom a \ (\f. t = Fun f [])" + let ?B = "\ t = TComp g Y \ (\X. t = Fun g X \ map \ X = Y)" + have "?A \ ?B" + proof (cases "\ t") + case (Var a) + obtain f X where "t = Fun f X" "arity f = length X" + using pgwt_fun[OF assms(1)] pgwt_arity[OF assms(1)] by fastforce+ + thus ?thesis using const_type_inv \\ t = TAtom a\ by auto + next + case (Fun g Y) + obtain f X where *: "t = Fun f X" using pgwt_fun[OF assms(1)] by force + hence "f = g" "map \ X = Y" + using fun_type_id_eq \\ t = TComp g Y\ fun_type[OF fun_type_inv(1)[OF \\ t = TComp g Y\]] + by fastforce+ + thus ?thesis using *(1) \\ t = TComp g Y\ by auto + qed + thus "\ t = TAtom a \ \f. t = Fun f []" "\ t = TComp g Y \ \X. t = Fun g X \ map \ X = Y" + by auto +qed + +lemma wt_subst_Var[simp]: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" by (metis wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + +lemma wt_subst_trm: "(\v. v \ fv t \ \ (Var v) = \ (\ v)) \ \ t = \ (t \ \)" +proof (induction t) + case (Fun f X) + hence *: "\x. x \ set X \ \ x = \ (x \ \)" by auto + show ?case + proof (cases "f \ \\<^sub>f") + case True + hence "\X. \ (Fun f X) = TComp f (map \ X)" using fun_type' by auto + thus ?thesis using * by auto + next + case False + hence "\a \ \\<^sub>a. \X. \ (Fun f X) = TAtom a" using const_type' by auto + thus ?thesis by auto + qed +qed auto + +lemma wt_subst_trm': "\wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \; \ s = \ t\ \ \ (s \ \) = \ (t \ \)" +by (metis wt_subst_trm wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + +lemma wt_subst_trm'': "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ \ t = \ (t \ \)" +by (metis wt_subst_trm wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + +lemma wt_subst_compose: + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" +proof - + have "\v. \ (\ v) = \ (\ v \ \)" using wt_subst_trm \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by metis + moreover have "\v. \ (Var v) = \ (\ v)" using \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by metis + ultimately have "\v. \ (Var v) = \ (\ v \ \)" by metis + thus ?thesis unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_compose_def by metis +qed + +lemma wt_subst_TAtom_Var_cases: + assumes \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and x: "\ (Var x) = TAtom a" + shows "(\y. \ x = Var y) \ (\c. \ x = Fun c [])" +proof (cases "(\y. \ x = Var y)") + case False + then obtain c T where c: "\ x = Fun c T" + by (cases "\ x") simp_all + hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun c T)" + using \(2) by fastforce + hence "T = []" + using const_type_inv_wf[of c T a] x c wt_subst_trm''[OF \(1), of "Var x"] + by fastforce + thus ?thesis + using c by blast +qed simp + +lemma wt_subst_TAtom_fv: + assumes \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\x. wf\<^sub>t\<^sub>r\<^sub>m (\ x)" + and "\x \ fv t - X. \a. \ (Var x) = TAtom a" + shows "\x \ fv (t \ \) - fv\<^sub>s\<^sub>e\<^sub>t (\ ` X). \a. \ (Var x) = TAtom a" +using assms(3) +proof (induction t) + case (Var x) thus ?case + proof (cases "x \ X") + case False + with Var obtain a where "\ (Var x) = TAtom a" by moura + hence *: "\ (\ x) = TAtom a" "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" using \ unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by auto + show ?thesis + proof (cases "\ x") + case (Var y) thus ?thesis using * by auto + next + case (Fun f T) + hence "T = []" using * const_type_inv[of f T a] unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + thus ?thesis using Fun by auto + qed + qed auto +qed fastforce + +lemma wt_subst_TAtom_subterms_subst: + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\x \ fv t. \a. \ (Var x) = TAtom a" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\ ` fv t)" + shows "subterms (t \ \) = subterms t \\<^sub>s\<^sub>e\<^sub>t \" +using assms(2,3) +proof (induction t) + case (Var x) + obtain a where a: "\ (Var x) = TAtom a" using Var.prems(1) by moura + hence "\ (\ x) = TAtom a" using wt_subst_trm''[OF assms(1), of "Var x"] by simp + hence "(\y. \ x = Var y) \ (\c. \ x = Fun c [])" + using const_type_inv_wf Var.prems(2) by (cases "\ x") auto + thus ?case by auto +next + case (Fun f T) + have "subterms (t \ \) = subterms t \\<^sub>s\<^sub>e\<^sub>t \" when "t \ set T" for t + using that Fun.prems(1,2) Fun.IH[OF that] + by auto + thus ?case by auto +qed + +lemma wt_subst_TAtom_subterms_set_subst: + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\x \ fv\<^sub>s\<^sub>e\<^sub>t M. \a. \ (Var x) = TAtom a" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\ ` fv\<^sub>s\<^sub>e\<^sub>t M)" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) = subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \" +proof + show "subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \) \ subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \" + proof + fix t assume "t \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + then obtain s where s: "s \ M" "t \ subterms (s \ \)" by auto + thus "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \" + using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s] + by auto + qed + + show "subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \ \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + proof + fix t assume "t \ subterms\<^sub>s\<^sub>e\<^sub>t M \\<^sub>s\<^sub>e\<^sub>t \" + then obtain s where s: "s \ M" "t \ subterms s \\<^sub>s\<^sub>e\<^sub>t \" by auto + thus "t \ subterms\<^sub>s\<^sub>e\<^sub>t (M \\<^sub>s\<^sub>e\<^sub>t \)" + using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s] + by auto + qed +qed + +lemma wt_subst_subst_upd: + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "\ (Var x) = \ t" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\(x := t))" +using assms unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def +by (metis fun_upd_other fun_upd_same) + +lemma wt_subst_const_fv_type_eq: + assumes "\x \ fv t. \a. \ (Var x) = TAtom a" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\x \ fv (t \ \). \y \ fv t. \ (Var x) = \ (Var y)" +using assms(1) +proof (induction t) + case (Var x) + then obtain a where a: "\ (Var x) = TAtom a" by moura + show ?case + proof (cases "\ x") + case (Fun f T) + hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" "\ (Fun f T) = TAtom a" + using a wt_subst_trm''[OF \(1), of "Var x"] \(2) by fastforce+ + thus ?thesis using const_type_inv_wf Fun by fastforce + qed (use a wt_subst_trm''[OF \(1), of "Var x"] in simp) +qed fastforce + +lemma TComp_term_cases: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "\ t = TComp f T" + shows "(\v. t = Var v) \ (\T'. t = Fun f T' \ T = map \ T' \ T' \ [])" +proof (cases "\v. t = Var v") + case False + then obtain T' where T': "t = Fun f T'" "T = map \ T'" + using assms fun_type[OF fun_type_inv(1)[OF assms(2)]] fun_type_id_eq + by (cases t) force+ + thus ?thesis using assms fun_type_inv(1) fun_type_inv_wf by fastforce +qed metis + +lemma TAtom_term_cases: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "\ t = TAtom \" + shows "(\v. t = Var v) \ (\f. t = Fun f [])" +using assms const_type_inv unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by (cases t) auto + +lemma subtermeq_imp_subtermtypeeq: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "s \ t" + shows "\ s \ \ t" +using assms(2,1) +proof (induction t) + case (Fun f T) thus ?case + proof (cases "s = Fun f T") + case False + then obtain x where x: "x \ set T" "s \ x" using Fun.prems(1) by auto + hence "wf\<^sub>t\<^sub>r\<^sub>m x" using wf_trm_subtermeq[OF Fun.prems(2)] Fun_param_is_subterm[of _ T f] by auto + hence "\ s \ \ x" using Fun.IH[OF x] by simp + moreover have "arity f > 0" using x fun_type_inv_wf Fun.prems + by (metis length_pos_if_in_set term.order_refl wf\<^sub>t\<^sub>r\<^sub>m_def) + ultimately show ?thesis using x Fun.prems fun_type[of f T] by auto + qed simp +qed simp + +lemma subterm_funs_term_in_type: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "Fun f T \ t" "\ (Fun f T) = TComp f (map \ T)" + shows "f \ funs_term (\ t)" +using assms(2,1,3) +proof (induction t) + case (Fun f' T') + hence [simp]: "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" by (metis wf_trm_subtermeq) + { fix a assume \: "\ (Fun f' T') = TAtom a" + hence "Fun f T = Fun f' T'" using Fun TAtom_term_cases subtermeq_Var_const by metis + hence False using Fun.prems(3) \ by simp + } + moreover + { fix g S assume \: "\ (Fun f' T') = TComp g S" + hence "g = f'" "S = map \ T'" + using Fun.prems(2) fun_type_id_eq[OF \] fun_type[OF fun_type_inv(1)[OF \]] + by auto + hence \': "\ (Fun f' T') = TComp f' (map \ T')" using \ by auto + hence "g \ funs_term (\ (Fun f' T'))" using \ by auto + moreover { + assume "Fun f T \ Fun f' T'" + then obtain x where "x \ set T'" "Fun f T \ x" using Fun.prems(1) by auto + hence "f \ funs_term (\ x)" + using Fun.IH[OF _ _ _ Fun.prems(3), of x] wf_trm_subtermeq[OF \wf\<^sub>t\<^sub>r\<^sub>m (Fun f' T')\, of x] + by force + moreover have "\ x \ set (map \ T')" using \' \x \ set T'\ by auto + ultimately have "f \ funs_term (\ (Fun f' T'))" using \' by auto + } + ultimately have ?case by (cases "Fun f T = Fun f' T'") (auto simp add: \g = f'\) + } + ultimately show ?case by (cases "\ (Fun f' T')") auto +qed simp + +lemma wt_subst_fv_termtype_subterm: + assumes "x \ fv (\ y)" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "wf\<^sub>t\<^sub>r\<^sub>m (\ y)" + shows "\ (Var x) \ \ (Var y)" +using subtermeq_imp_subtermtypeeq[OF assms(3) var_is_subterm[OF assms(1)]] + wt_subst_trm''[OF assms(2), of "Var y"] +by auto + +lemma wt_subst_fv\<^sub>s\<^sub>e\<^sub>t_termtype_subterm: + assumes "x \ fv\<^sub>s\<^sub>e\<^sub>t (\ ` Y)" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\y \ Y. \ (Var x) \ \ (Var y)" +using wt_subst_fv_termtype_subterm[OF _ assms(2), of x] assms(1,3) +by fastforce + +lemma funs_term_type_iff: + assumes t: "wf\<^sub>t\<^sub>r\<^sub>m t" + and f: "arity f > 0" + shows "f \ funs_term (\ t) \ (f \ funs_term t \ (\x \ fv t. f \ funs_term (\ (Var x))))" + (is "?P t \ ?Q t") +using t +proof (induction t) + case (Fun g T) + hence IH: "?P s \ ?Q s" when "s \ set T" for s + using that wf_trm_subterm[OF _ Fun_param_is_subterm] + by blast + have 0: "arity g = length T" using Fun.prems unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + show ?case + proof (cases "f = g") + case True thus ?thesis using fun_type[OF f] by simp + next + case False + have "?P (Fun g T) \ (\s \ set T. ?P s)" + proof + assume *: "?P (Fun g T)" + hence "\ (Fun g T) = TComp g (map \ T)" + using const_type[of g] fun_type[of g] by force + thus "\s \ set T. ?P s" using False * by force + next + assume *: "\s \ set T. ?P s" + hence "\ (Fun g T) = TComp g (map \ T)" + using 0 const_type[of g] fun_type[of g] by force + thus "?P (Fun g T)" using False * by force + qed + thus ?thesis using False f IH by auto + qed +qed simp + +lemma funs_term_type_iff': + assumes M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + and f: "arity f > 0" + shows "f \ \(funs_term ` \ ` M) \ + (f \ \(funs_term ` M) \ (\x \ fv\<^sub>s\<^sub>e\<^sub>t M. f \ funs_term (\ (Var x))))" (is "?A \ ?B") +proof + assume ?A + then obtain t where "t \ M" "wf\<^sub>t\<^sub>r\<^sub>m t" "f \ funs_term (\ t)" using M by moura + thus ?B using funs_term_type_iff[OF _ f, of t] by auto +next + assume ?B + then obtain t where "t \ M" "wf\<^sub>t\<^sub>r\<^sub>m t" "f \ funs_term t \ (\x \ fv t. f \ funs_term (\ (Var x)))" + using M by auto + thus ?A using funs_term_type_iff[OF _ f, of t] by blast +qed + +lemma Ana_subterm_type: + assumes "Ana t = (K,M)" + and "wf\<^sub>t\<^sub>r\<^sub>m t" + and "m \ set M" + shows "\ m \ \ t" +proof - + have "m \ t" using Ana_subterm[OF assms(1)] assms(3) by auto + thus ?thesis using subtermeq_imp_subtermtypeeq[OF assms(2)] by simp +qed + +lemma wf_trm_TAtom_subterms: + assumes "wf\<^sub>t\<^sub>r\<^sub>m t" "\ t = TAtom \" + shows "subterms t = {t}" +using assms const_type_inv unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by (cases t) force+ + +lemma wf_trm_TComp_subterm: + assumes "wf\<^sub>t\<^sub>r\<^sub>m s" "t \ s" + obtains f T where "\ s = TComp f T" +proof (cases s) + case (Var x) thus ?thesis using \t \ s\ by simp +next + case (Fun g S) + hence "length S > 0" using assms Fun_subterm_inside_params[of t g S] by auto + hence "arity g > 0" by (metis \wf\<^sub>t\<^sub>r\<^sub>m s\ \s = Fun g S\ term.order_refl wf\<^sub>t\<^sub>r\<^sub>m_def) + thus ?thesis using fun_type \s = Fun g S\ that by auto +qed + +lemma SMP_empty[simp]: "SMP {} = {}" +proof (rule ccontr) + assume "SMP {} \ {}" + then obtain t where "t \ SMP {}" by auto + thus False by (induct t rule: SMP.induct) auto +qed + +lemma SMP_I: + assumes "s \ M" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "t \ s \ \" "\v. wf\<^sub>t\<^sub>r\<^sub>m (\ v)" + shows "t \ SMP M" +using SMP.Substitution[OF SMP.MP[OF assms(1)] assms(2)] SMP.Subterm[of "s \ \" M t] assms(3,4) +by (cases "t = s \ \") simp_all + +lemma SMP_wf_trm: + assumes "t \ SMP M" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + shows "wf\<^sub>t\<^sub>r\<^sub>m t" +using assms(1) +by (induct t rule: SMP.induct) + (use assms(2) in blast, + use wf_trm_subtermeq in blast, + use wf_trm_subst in blast, + use Ana_keys_wf' in blast) + +lemma SMP_ikI[intro]: "t \ ik\<^sub>s\<^sub>t S \ t \ SMP (trms\<^sub>s\<^sub>t S)" by force + +lemma MP_setI[intro]: "x \ set S \ trms\<^sub>s\<^sub>t\<^sub>p x \ trms\<^sub>s\<^sub>t S" by force + +lemma SMP_setI[intro]: "x \ set S \ trms\<^sub>s\<^sub>t\<^sub>p x \ SMP (trms\<^sub>s\<^sub>t S)" by force + +lemma SMP_subset_I: + assumes M: "\t \ M. \s \. s \ N \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = s \ \" + shows "SMP M \ SMP N" +proof + fix t show "t \ SMP M \ t \ SMP N" + proof (induction t rule: SMP.induct) + case (MP t) + then obtain s \ where s: "s \ N" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t = s \ \" + using M by moura + show ?case using SMP_I[OF s(1,2), of "s \ \"] s(3,4) wf_trm_subst_range_iff by fast + qed (auto intro!: SMP.Substitution[of _ N]) +qed + +lemma SMP_union: "SMP (A \ B) = SMP A \ SMP B" +proof + show "SMP (A \ B) \ SMP A \ SMP B" + proof + fix t assume "t \ SMP (A \ B)" + thus "t \ SMP A \ SMP B" by (induct rule: SMP.induct) blast+ + qed + + { fix t assume "t \ SMP A" hence "t \ SMP (A \ B)" by (induct rule: SMP.induct) blast+ } + moreover { fix t assume "t \ SMP B" hence "t \ SMP (A \ B)" by (induct rule: SMP.induct) blast+ } + ultimately show "SMP A \ SMP B \ SMP (A \ B)" by blast +qed + +lemma SMP_append[simp]: "SMP (trms\<^sub>s\<^sub>t (S@S')) = SMP (trms\<^sub>s\<^sub>t S) \ SMP (trms\<^sub>s\<^sub>t S')" (is "?A = ?B") +using SMP_union by simp + +lemma SMP_mono: "A \ B \ SMP A \ SMP B" +proof - + assume "A \ B" + then obtain C where "B = A \ C" by moura + thus "SMP A \ SMP B" by (simp add: SMP_union) +qed + +lemma SMP_Union: "SMP (\m \ M. f m) = (\m \ M. SMP (f m))" +proof + show "SMP (\m\M. f m) \ (\m\M. SMP (f m))" + proof + fix t assume "t \ SMP (\m\M. f m)" + thus "t \ (\m\M. SMP (f m))" by (induct t rule: SMP.induct) force+ + qed + show "(\m\M. SMP (f m)) \ SMP (\m\M. f m)" + proof + fix t assume "t \ (\m\M. SMP (f m))" + then obtain m where "m \ M" "t \ SMP (f m)" by moura + thus "t \ SMP (\m\M. f m)" using SMP_mono[of "f m" "\m\M. f m"] by auto + qed +qed + +lemma SMP_singleton_ex: + "t \ SMP M \ (\m \ M. t \ SMP {m})" + "m \ M \ t \ SMP {m} \ t \ SMP M" +using SMP_Union[of "\t. {t}" M] by auto + +lemma SMP_Cons: "SMP (trms\<^sub>s\<^sub>t (x#S)) = SMP (trms\<^sub>s\<^sub>t [x]) \ SMP (trms\<^sub>s\<^sub>t S)" +using SMP_append[of "[x]" S] by auto + +lemma SMP_Nil[simp]: "SMP (trms\<^sub>s\<^sub>t []) = {}" +proof - + { fix t assume "t \ SMP (trms\<^sub>s\<^sub>t [])" hence False by induct auto } + thus ?thesis by blast +qed + +lemma SMP_subset_union_eq: assumes "M \ SMP N" shows "SMP N = SMP (M \ N)" +proof - + { fix t assume "t \ SMP (M \ N)" hence "t \ SMP N" + using assms by (induction rule: SMP.induct) blast+ + } + thus ?thesis using SMP_union by auto +qed + +lemma SMP_subterms_subset: "subterms\<^sub>s\<^sub>e\<^sub>t M \ SMP M" +proof + fix t assume "t \ subterms\<^sub>s\<^sub>e\<^sub>t M" + then obtain m where "m \ M" "t \ m" by auto + thus "t \ SMP M" using SMP_I[of _ _ Var] by auto +qed + +lemma SMP_SMP_subset: "N \ SMP M \ SMP N \ SMP M" +by (metis SMP_mono SMP_subset_union_eq Un_commute Un_upper2) + +lemma wt_subst_rm_vars: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (rm_vars X \)" +using rm_vars_dom unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by auto + +lemma wt_subst_SMP_subset: + assumes "trms\<^sub>s\<^sub>t S \ SMP S'" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \) \ SMP S'" +proof + fix t assume *: "t \ trms\<^sub>s\<^sub>t (S \\<^sub>s\<^sub>t \)" + show "t \ SMP S'" using trm_strand_subst_cong(2)[OF *] + proof + assume "\t'. t = t' \ \ \ t' \ trms\<^sub>s\<^sub>t S" + thus "t \ SMP S'" using assms SMP.Substitution by auto + next + assume "\X F. Inequality X F \ set S \ (\t'\trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F. t = t' \ rm_vars (set X) \)" + then obtain X F t' where **: + "Inequality X F \ set S" "t'\trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" "t = t' \ rm_vars (set X) \" + by force + then obtain s where s: "s \ trms\<^sub>s\<^sub>t\<^sub>p (Inequality X F)" "t = s \ rm_vars (set X) \" by moura + hence "s \ SMP (trms\<^sub>s\<^sub>t S)" using **(1) by force + hence "t \ SMP (trms\<^sub>s\<^sub>t S)" + using SMP.Substitution[OF _ wt_subst_rm_vars[OF assms(2)] wf_trms_subst_rm_vars'[OF assms(3)]] + unfolding s(2) by blast + thus "t \ SMP S'" by (metis SMP_union SMP_subset_union_eq UnCI assms(1)) + qed +qed + +lemma MP_subset_SMP: "\(trms\<^sub>s\<^sub>t\<^sub>p ` set S) \ SMP (trms\<^sub>s\<^sub>t S)" "trms\<^sub>s\<^sub>t S \ SMP (trms\<^sub>s\<^sub>t S)" "M \ SMP M" +by auto + +lemma SMP_fun_map_snd_subset: "SMP (trms\<^sub>s\<^sub>t (map Send X)) \ SMP (trms\<^sub>s\<^sub>t [Send (Fun f X)])" +proof + fix t assume "t \ SMP (trms\<^sub>s\<^sub>t (map Send X))" thus "t \ SMP (trms\<^sub>s\<^sub>t [Send (Fun f X)])" + proof (induction t rule: SMP.induct) + case (MP t) + hence "t \ set X" by auto + hence "t \ Fun f X" by (metis subtermI') + thus ?case using SMP.Subterm[of "Fun f X" "trms\<^sub>s\<^sub>t [Send (Fun f X)]" t] using SMP.MP by auto + qed blast+ +qed + +lemma SMP_wt_subst_subset: + assumes "t \ SMP (M \\<^sub>s\<^sub>e\<^sub>t \)" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "t \ SMP M" +using assms wf_trm_subst_range_iff[of \] by (induct t rule: SMP.induct) blast+ + +lemma SMP_wt_instances_subset: + assumes "\t \ M. \s \ N. \\. t = s \ \ \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and "t \ SMP M" + shows "t \ SMP N" +proof - + obtain m where m: "m \ M" "t \ SMP {m}" using SMP_singleton_ex(1)[OF assms(2)] by blast + then obtain n \ where n: "n \ N" "m = n \ \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using assms(1) by fast + + have "t \ SMP (N \\<^sub>s\<^sub>e\<^sub>t \)" using n(1,2) SMP_singleton_ex(2)[of m "N \\<^sub>s\<^sub>e\<^sub>t \", OF _ m(2)] by fast + thus ?thesis using SMP_wt_subst_subset[OF _ n(3,4)] by blast +qed + +lemma SMP_consts: + assumes "\t \ M. \c. t = Fun c []" + and "\t \ M. Ana t = ([], [])" + shows "SMP M = M" +proof + show "SMP M \ M" + proof + fix t show "t \ SMP M \ t \ M" + apply (induction t rule: SMP.induct) + by (use assms in auto) + qed +qed auto + +lemma SMP_subterms_eq: + "SMP (subterms\<^sub>s\<^sub>e\<^sub>t M) = SMP M" +proof + show "SMP M \ SMP (subterms\<^sub>s\<^sub>e\<^sub>t M)" using SMP_mono[of M "subterms\<^sub>s\<^sub>e\<^sub>t M"] by blast + show "SMP (subterms\<^sub>s\<^sub>e\<^sub>t M) \ SMP M" + proof + fix t show "t \ SMP (subterms\<^sub>s\<^sub>e\<^sub>t M) \ t \ SMP M" by (induction t rule: SMP.induct) blast+ + qed +qed + +lemma SMP_funs_term: + assumes t: "t \ SMP M" "f \ funs_term t \ (\x \ fv t. f \ funs_term (\ (Var x)))" + and f: "arity f > 0" + and M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + and Ana_f: "\s K T. Ana s = (K,T) \ f \ \(funs_term ` set K) \ f \ funs_term s" + shows "f \ \(funs_term ` M) \ (\x \ fv\<^sub>s\<^sub>e\<^sub>t M. f \ funs_term (\ (Var x)))" +using t +proof (induction t rule: SMP.induct) + case (Subterm t t') + thus ?case by (metis UN_I vars_iff_subtermeq funs_term_subterms_eq(1) term.order_trans) +next + case (Substitution t \) + show ?case + using M SMP_wf_trm[OF Substitution.hyps(1)] wf_trm_subst[of \ t, OF Substitution.hyps(3)] + funs_term_type_iff[OF _ f] wt_subst_trm''[OF Substitution.hyps(2), of t] + Substitution.prems Substitution.IH + by metis +next + case (Ana t K T t') + thus ?case + using Ana_f[OF Ana.hyps(2)] Ana_keys_fv[OF Ana.hyps(2)] + by fastforce +qed auto + +lemma id_type_eq: + assumes "\ (Fun f X) = \ (Fun g Y)" + shows "f \ \ \ g \ \" "f \ \\<^sub>f \ g \ \\<^sub>f" +using assms const_type' fun_type' id_union_univ(1) +by (metis UNIV_I UnE "term.distinct"(1))+ + +lemma fun_type_arg_cong: + assumes "f \ \\<^sub>f" "g \ \\<^sub>f" "\ (Fun f (x#X)) = \ (Fun g (y#Y))" + shows "\ x = \ y" "\ (Fun f X) = \ (Fun g Y)" +using assms fun_type' by auto + +lemma fun_type_arg_cong': + assumes "f \ \\<^sub>f" "g \ \\<^sub>f" "\ (Fun f (X@x#X')) = \ (Fun g (Y@y#Y'))" "length X = length Y" + shows "\ x = \ y" +using assms +proof (induction X arbitrary: Y) + case Nil thus ?case using fun_type_arg_cong(1)[of f g x X' y Y'] by auto +next + case (Cons x' X Y'') + then obtain y' Y where "Y'' = y'#Y" by (metis length_Suc_conv) + hence "\ (Fun f (X@x#X')) = \ (Fun g (Y@y#Y'))" "length X = length Y" + using Cons.prems(3,4) fun_type_arg_cong(2)[OF Cons.prems(1,2), of x' "X@x#X'"] by auto + thus ?thesis using Cons.IH[OF Cons.prems(1,2)] by auto +qed + +lemma fun_type_param_idx: "\ (Fun f T) = Fun g S \ i < length T \ \ (T ! i) = S ! i" +by (metis fun_type fun_type_id_eq fun_type_inv(1) nth_map term.inject(2)) + +lemma fun_type_param_ex: + assumes "\ (Fun f T) = Fun g (map \ S)" "t \ set S" + shows "\s \ set T. \ s = \ t" +using fun_type_length_eq[OF assms(1)] length_map[of \ S] assms(2) + fun_type_param_idx[OF assms(1)] nth_map in_set_conv_nth +by metis + +lemma tfr_stp_all_split: + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (x#S) \ list_all tfr\<^sub>s\<^sub>t\<^sub>p [x]" + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (x#S) \ list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S') \ list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S') \ list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@x#S') \ list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')" +by fastforce+ + +lemma tfr_stp_all_append: + assumes "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" + shows "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')" +using assms by fastforce + +lemma tfr_stp_all_wt_subst_apply: + assumes "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + "bvars\<^sub>s\<^sub>t S \ range_vars \ = {}" + shows "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S \\<^sub>s\<^sub>t \)" +using assms(1,4) +proof (induction S) + case (Cons x S) + hence IH: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S \\<^sub>s\<^sub>t \)" + using tfr_stp_all_split(2)[of x S] + unfolding range_vars_alt_def by fastforce + thus ?case + proof (cases x) + case (Equality a t t') + hence "(\\. Unifier \ t t') \ \ t = \ t'" using Cons.prems by auto + hence "(\\. Unifier \ (t \ \) (t' \ \)) \ \ (t \ \) = \ (t' \ \)" + by (metis Unifier_comp' wt_subst_trm'[OF assms(2)]) + moreover have "(x#S) \\<^sub>s\<^sub>t \ = Equality a (t \ \) (t' \ \)#(S \\<^sub>s\<^sub>t \)" + using \x = Equality a t t'\ by auto + ultimately show ?thesis using IH by auto + next + case (Inequality X F) + let ?\ = "rm_vars (set X) \" + let ?G = "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\" + + let ?P = "\F X. \x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \a. \ (Var x) = TAtom a" + let ?Q = "\F X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X)" + + have 0: "set X \ range_vars ?\ = {}" + using Cons.prems(2) Inequality rm_vars_img_subset[of "set X"] + by (auto simp add: subst_domain_def range_vars_alt_def) + + have 1: "?P F X \ ?Q F X" using Inequality Cons.prems by simp + + have 2: "fv\<^sub>s\<^sub>e\<^sub>t (?\ ` set X) = set X" by auto + + have "?P ?G X" when "?P F X" using that + proof (induction F) + case (Cons g G) + obtain t t' where g: "g = (t,t')" by (metis surj_pair) + + have "\x \ (fv (t \ ?\) \ fv (t' \ ?\)) - set X. \a. \ (Var x) = Var a" + proof - + have *: "\x \ fv t - set X. \a. \ (Var x) = Var a" + "\x \ fv t' - set X. \a. \ (Var x) = Var a" + using g Cons.prems by simp_all + + have **: "\x. wf\<^sub>t\<^sub>r\<^sub>m (?\ x)" + using \(2) wf_trm_subst_range_iff[of \] wf_trm_subst_rm_vars'[of \ _ "set X"] by simp + + show ?thesis + using wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF \(1)] ** *(1)] + wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF \(1)] ** *(2)] + wt_subst_trm'[OF wt_subst_rm_vars[OF \(1), of "set X"]] 2 + by blast + qed + moreover have "\x\fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\) - set X. \a. \ (Var x) = Var a" + using Cons by auto + ultimately show ?case using g by (auto simp add: subst_apply_pairs_def) + qed (simp add: subst_apply_pairs_def) + hence "?P ?G X \ ?Q ?G X" + using 1 ineq_subterm_inj_cond_subst[OF 0, of "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"] trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst[of F ?\] + by presburger + moreover have "(x#S) \\<^sub>s\<^sub>t \ = Inequality X (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ?\)#(S \\<^sub>s\<^sub>t \)" + using \x = Inequality X F\ by auto + ultimately show ?thesis using IH by simp + qed auto +qed simp + +lemma tfr_stp_all_same_type: + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@Equality a t t'#S') \ Unifier \ t t' \ \ t = \ t'" +by force+ + +lemma tfr_subset: + "\A B. tfr\<^sub>s\<^sub>e\<^sub>t (A \ B) \ tfr\<^sub>s\<^sub>e\<^sub>t A" + "\A B. tfr\<^sub>s\<^sub>e\<^sub>t B \ A \ B \ tfr\<^sub>s\<^sub>e\<^sub>t A" + "\A B. tfr\<^sub>s\<^sub>e\<^sub>t B \ SMP A \ SMP B \ tfr\<^sub>s\<^sub>e\<^sub>t A" +proof - + show 1: "tfr\<^sub>s\<^sub>e\<^sub>t (A \ B) \ tfr\<^sub>s\<^sub>e\<^sub>t A" for A B + using SMP_union[of A B] unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by simp + + fix A B assume B: "tfr\<^sub>s\<^sub>e\<^sub>t B" + + show "A \ B \ tfr\<^sub>s\<^sub>e\<^sub>t A" + proof - + assume "A \ B" + then obtain C where "B = A \ C" by moura + thus ?thesis using B 1 by blast + qed + + show "SMP A \ SMP B \ tfr\<^sub>s\<^sub>e\<^sub>t A" + proof - + assume "SMP A \ SMP B" + then obtain C where "SMP B = SMP A \ C" by moura + thus ?thesis using B unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + qed +qed + +lemma tfr_empty[simp]: "tfr\<^sub>s\<^sub>e\<^sub>t {}" +unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by simp + +lemma tfr_consts_mono: + assumes "\t \ M. \c. t = Fun c []" + and "\t \ M. Ana t = ([], [])" + and "tfr\<^sub>s\<^sub>e\<^sub>t N" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (N \ M)" +proof - + { fix s t + assume *: "s \ SMP (N \ M) - range Var" "t \ SMP (N \ M) - range Var" "\\. Unifier \ s t" + hence **: "is_Fun s" "is_Fun t" "s \ SMP N \ s \ M" "t \ SMP N \ t \ M" + using assms(3) SMP_consts[OF assms(1,2)] SMP_union[of N M] by auto + moreover have "\ s = \ t" when "s \ SMP N" "t \ SMP N" + using that assms(3) *(3) **(1,2) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + moreover have "\ s = \ t" when st: "s \ M" "t \ M" + proof - + obtain c d where "s = Fun c []" "t = Fun d []" using st assms(1) by moura + hence "s = t" using *(3) by fast + thus ?thesis by metis + qed + moreover have "\ s = \ t" when st: "s \ SMP N" "t \ M" + proof - + obtain c where "t = Fun c []" using st assms(1) by moura + hence "s = t" using *(3) **(1,2) by auto + thus ?thesis by metis + qed + moreover have "\ s = \ t" when st: "s \ M" "t \ SMP N" + proof - + obtain c where "s = Fun c []" using st assms(1) by moura + hence "s = t" using *(3) **(1,2) by auto + thus ?thesis by metis + qed + ultimately have "\ s = \ t" by metis + } thus ?thesis by (metis tfr\<^sub>s\<^sub>e\<^sub>t_def) +qed + +lemma dual\<^sub>s\<^sub>t_tfr\<^sub>s\<^sub>t\<^sub>p: "list_all tfr\<^sub>s\<^sub>t\<^sub>p S \ list_all tfr\<^sub>s\<^sub>t\<^sub>p (dual\<^sub>s\<^sub>t S)" +proof (induction S) + case (Cons x S) + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Cons.prems by simp + hence IH: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (dual\<^sub>s\<^sub>t S)" using Cons.IH by metis + from Cons show ?case + proof (cases x) + case (Equality a t t') + hence "(\\. Unifier \ t t') \ \ t = \ t'" using Cons by auto + thus ?thesis using Equality IH by fastforce + next + case (Inequality X F) + have "set (dual\<^sub>s\<^sub>t (x#S)) = insert x (set (dual\<^sub>s\<^sub>t S))" using Inequality by auto + moreover have "(\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \a. \ (Var x) = Var a) \ + (\f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X))" + using Cons.prems Inequality by auto + ultimately show ?thesis using Inequality IH by auto + qed auto +qed simp + +lemma subst_var_inv_wt: + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (subst_var_inv \ X)" +using assms f_inv_into_f[of _ \ X] +unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_var_inv_def +by presburger + +lemma subst_var_inv_wf_trms: + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (subst_var_inv \ X))" +using f_inv_into_f[of _ \ X] +unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_var_inv_def +by auto + +lemma unify_list_wt_if_same_type: + assumes "Unification.unify E B = Some U" "\(s,t) \ set E. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t \ \ s = \ t" + and "\(v,t) \ set B. \ (Var v) = \ t" + shows "\(v,t) \ set U. \ (Var v) = \ t" +using assms +proof (induction E B arbitrary: U rule: Unification.unify.induct) + case (2 f X g Y E B U) + hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun g Y)" "\ (Fun f X) = \ (Fun g Y)" by auto + + from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'" + and [simp]: "f = g" "length X = length Y" "E' = zip X Y" + and **: "Unification.unify (E'@E) B = Some U" + by (auto split: option.splits) + + have "\(s,t) \ set E'. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t \ \ s = \ t" + proof - + { fix s t assume "(s,t) \ set E'" + then obtain X' X'' Y' Y'' where "X = X'@s#X''" "Y = Y'@t#Y''" "length X' = length Y'" + using zip_arg_subterm_split[of s t X Y] \E' = zip X Y\ by metis + hence "\ (Fun f (X'@s#X'')) = \ (Fun g (Y'@t#Y''))" by (metis \\ (Fun f X) = \ (Fun g Y)\) + + from \E' = zip X Y\ have "\(s,t) \ set E'. s \ Fun f X \ t \ Fun g Y" + using zip_arg_subterm[of _ _ X Y] by blast + with \(s,t) \ set E'\ have "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" + using wf_trm_subterm \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\ \wf\<^sub>t\<^sub>r\<^sub>m (Fun g Y)\ by (blast,blast) + moreover have "f \ \\<^sub>f" + proof (rule ccontr) + assume "f \ \\<^sub>f" + hence "f \ \" "arity f = 0" using const_arity_eq_zero[of f] by simp_all + thus False using \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\ * \(s,t) \ set E'\ unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + qed + hence "\ s = \ t" + using fun_type_arg_cong' \f \ \\<^sub>f\ \\ (Fun f (X'@s#X'')) = \ (Fun g (Y'@t#Y''))\ + \length X' = length Y'\ \f = g\ + by metis + ultimately have "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" "\ s = \ t" by metis+ + } + thus ?thesis by blast + qed + moreover have "\(s,t) \ set E. wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t \ \ s = \ t" using "2.prems"(2) by auto + ultimately show ?case using "2.IH"[OF * ** _ "2.prems"(3)] by fastforce +next + case (3 v t E B U) + hence "\ (Var v) = \ t" "wf\<^sub>t\<^sub>r\<^sub>m t" by auto + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (subst v t)" + and *: "\(v, t) \ set ((v,t)#B). \ (Var v) = \ t" + "\t t'. (t,t') \ set E \ \ t = \ t'" + using "3.prems"(2,3) unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_def by auto + + show ?case + proof (cases "t = Var v") + assume "t = Var v" thus ?case using 3 by auto + next + assume "t \ Var v" + hence "v \ fv t" using "3.prems"(1) by auto + hence **: "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U" + using Unification.unify.simps(3)[of v t E B] "3.prems"(1) \t \ Var v\ by auto + + have "\(s, t) \ set (subst_list (subst v t) E). wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" + using wf_trm_subst_singleton[OF _ \wf\<^sub>t\<^sub>r\<^sub>m t\] "3.prems"(2) + unfolding subst_list_def subst_def by auto + moreover have "\(s, t) \ set (subst_list (subst v t) E). \ s = \ t" + using *(2)[THEN wt_subst_trm'[OF \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (subst v t)\]] by (simp add: subst_list_def) + ultimately show ?thesis using "3.IH"(2)[OF \t \ Var v\ \v \ fv t\ ** _ *(1)] by auto + qed +next + case (4 f X v E B U) + hence "\ (Var v) = \ (Fun f X)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)" by auto + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (subst v (Fun f X))" + and *: "\(v, t) \ set ((v,(Fun f X))#B). \ (Var v) = \ t" + "\t t'. (t,t') \ set E \ \ t = \ t'" + using "4.prems"(2,3) unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def subst_def by auto + + have "v \ fv (Fun f X)" using "4.prems"(1) by force + hence **: "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, (Fun f X))#B) = Some U" + using Unification.unify.simps(3)[of v "Fun f X" E B] "4.prems"(1) by auto + + have "\(s, t) \ set (subst_list (subst v (Fun f X)) E). wf\<^sub>t\<^sub>r\<^sub>m s \ wf\<^sub>t\<^sub>r\<^sub>m t" + using wf_trm_subst_singleton[OF _ \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\] "4.prems"(2) + unfolding subst_list_def subst_def by auto + moreover have "\(s, t) \ set (subst_list (subst v (Fun f X)) E). \ s = \ t" + using *(2)[THEN wt_subst_trm'[OF \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (subst v (Fun f X))\]] by (simp add: subst_list_def) + ultimately show ?case using "4.IH"[OF \v \ fv (Fun f X)\ ** _ *(1)] by auto +qed auto + +lemma mgu_wt_if_same_type: + assumes "mgu s t = Some \" "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" "\ s = \ t" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" +proof - + let ?fv_disj = "\v t S. \(\(v',t') \ S - {(v,t)}. (insert v (fv t)) \ (insert v' (fv t')) \ {})" + + from assms(1) obtain \' where "Unification.unify [(s,t)] [] = Some \'" "subst_of \' = \" + by (auto split: option.splits) + hence "\(v,t) \ set \'. \ (Var v) = \ t" "distinct (map fst \')" + using assms(2,3,4) unify_list_wt_if_same_type unify_list_distinct[of "[(s,t)]"] by auto + thus "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using \subst_of \' = \\ unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def + proof (induction \' arbitrary: \ rule: List.rev_induct) + case (snoc tt \' \) + then obtain v t where tt: "tt = (v,t)" by (metis surj_pair) + hence \: "\ = subst v t \\<^sub>s subst_of \'" using snoc.prems(3) by simp + + have "\(v,t) \ set \'. \ (Var v) = \ t" "distinct (map fst \')" using snoc.prems(1,2) by auto + then obtain \'' where \'': "subst_of \' = \''" "\v. \ (Var v) = \ (\'' v)" by (metis snoc.IH) + hence "\ t = \ (t \ \'')" for t using wt_subst_trm by blast + hence "\ (Var v) = \ (\'' v)" "\ t = \ (t \ \'')" using \''(2) by auto + moreover have "\ (Var v) = \ t" using snoc.prems(1) tt by simp + moreover have \2: "\ = Var(v := t) \\<^sub>s \'' " using \ \''(1) unfolding subst_def by simp + ultimately have "\ (Var v) = \ (\ v)" unfolding subst_compose_def by simp + + have "subst_domain (subst v t) \ {v}" unfolding subst_def by (auto simp add: subst_domain_def) + hence *: "subst_domain \ \ insert v (subst_domain \'')" + using tt \ \''(1) snoc.prems(2) subst_domain_compose[of _ \''] + by (auto simp add: subst_domain_def) + + have "v \ set (map fst \')" using tt snoc.prems(2) by auto + hence "v \ subst_domain \''" using \''(1) subst_of_dom_subset[of \'] by auto + + { fix w assume "w \ subst_domain \''" + hence "\ w = \'' w" using \2 \''(1) \v \ subst_domain \''\ unfolding subst_compose_def by auto + hence "\ (Var w) = \ (\ w)" using \''(2) by simp + } + thus ?case using \\ (Var v) = \ (\ v)\ * by force + qed simp +qed + +lemma wt_Unifier_if_Unifier: + assumes s_t: "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m t" "\ s = \ t" + and \: "Unifier \ s t" + shows "\\. Unifier \ s t \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +using mgu_always_unifies[OF \] mgu_gives_MGU[THEN MGU_is_Unifier[of s _ t]] + mgu_wt_if_same_type[OF _ s_t] mgu_wf_trm[OF _ s_t(1,2)] wf_trm_subst_range_iff +by fast + +end + + +subsection \Automatically Proving Type-Flaw Resistance\ +subsubsection \Definitions: Variable Renaming\ +abbreviation "max_var t \ Max (insert 0 (snd ` fv t))" +abbreviation "max_var_set X \ Max (insert 0 (snd ` X))" + +definition "var_rename n v \ Var (fst v, snd v + Suc n)" +definition "var_rename_inv n v \ Var (fst v, snd v - Suc n)" + + +subsubsection \Definitions: Computing a Finite Representation of the Sub-Message Patterns\ +text \A sufficient requirement for a term to be a well-typed instance of another term\ +definition is_wt_instance_of_cond where + "is_wt_instance_of_cond \ t s \ ( + \ t = \ s \ (case mgu t s of + None \ False + | Some \ \ inj_on \ (fv t) \ (\x \ fv t. is_Var (\ x))))" + +definition has_all_wt_instances_of where + "has_all_wt_instances_of \ N M \ \t \ N. \s \ M. is_wt_instance_of_cond \ t s" + +text \This function computes a finite representation of the set of sub-message patterns\ +definition SMP0 where + "SMP0 Ana \ M \ let + f = \t. Fun (the_Fun (\ t)) (map Var (zip (args (\ t)) [0.. t))])); + g = \M'. map f (filter (\t. is_Var t \ is_Fun (\ t)) M')@ + concat (map (fst \ Ana) M')@concat (map subterms_list M'); + h = remdups \ g + in while (\A. set (h A) \ set A) h M" + +text \These definitions are useful to refine an SMP representation set\ +fun generalize_term where + "generalize_term _ _ n (Var x) = (Var x, n)" +| "generalize_term \ p n (Fun f T) = (let \ = \ (Fun f T) + in if p \ then (Var (\, n), Suc n) + else let (T',n') = foldr (\t (S,m). let (t',m') = generalize_term \ p m t in (t'#S,m')) + T ([],n) + in (Fun f T', n'))" + +definition generalize_terms where + "generalize_terms \ p \ map (fst \ generalize_term \ p 0)" + +definition remove_superfluous_terms where + "remove_superfluous_terms \ T \ + let + f = \S t R. \s \ set S - R. s \ t \ is_wt_instance_of_cond \ t s; + g = \S t (U,R). if f S t R then (U, insert t R) else (t#U, R); + h = \S. remdups (fst (foldr (g S) S ([],{}))) + in while (\S. h S \ S) h T" + + +subsubsection \Definitions: Checking Type-Flaw Resistance\ +definition is_TComp_var_instance_closed where + "is_TComp_var_instance_closed \ M \ \x \ fv\<^sub>s\<^sub>e\<^sub>t (set M). is_Fun (\ (Var x)) \ + list_ex (\t. is_Fun t \ \ t = \ (Var x) \ list_all is_Var (args t) \ distinct (args t)) M" + +definition finite_SMP_representation where + "finite_SMP_representation arity Ana \ M \ + list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) M \ + has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M) \ + has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M) \ + is_TComp_var_instance_closed \ M" + +definition comp_tfr\<^sub>s\<^sub>e\<^sub>t where + "comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M \ + finite_SMP_representation arity Ana \ M \ + (let \ = var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (set M))) + in \s \ set M. \t \ set M. is_Fun s \ is_Fun t \ \ s \ \ t \ mgu s (t \ \) = None)" + +fun comp_tfr\<^sub>s\<^sub>t\<^sub>p where + "comp_tfr\<^sub>s\<^sub>t\<^sub>p \ (\_: t \ t'\\<^sub>s\<^sub>t) = (mgu t t' \ None \ \ t = \ t')" +| "comp_tfr\<^sub>s\<^sub>t\<^sub>p \ (\X\\\: F\\<^sub>s\<^sub>t) = ( + (\x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. is_Var (\ (Var x))) \ + (\u \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F). + is_Fun u \ (args u = [] \ (\s \ set (args u). s \ Var ` set X))))" +| "comp_tfr\<^sub>s\<^sub>t\<^sub>p _ _ = True" + +definition comp_tfr\<^sub>s\<^sub>t where + "comp_tfr\<^sub>s\<^sub>t arity Ana \ M S \ + list_all (comp_tfr\<^sub>s\<^sub>t\<^sub>p \) S \ + list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) (trms_list\<^sub>s\<^sub>t S) \ + has_all_wt_instances_of \ (trms\<^sub>s\<^sub>t S) (set M) \ + comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M" + + +subsubsection \Small Lemmata\ +lemma less_Suc_max_var_set: + assumes z: "z \ X" + and X: "finite X" + shows "snd z < Suc (max_var_set X)" +proof - + have "snd z \ snd ` X" using z by simp + hence "snd z \ Max (insert 0 (snd ` X))" using X by simp + thus ?thesis using X by simp +qed + +lemma (in typed_model) finite_SMP_representationD: + assumes "finite_SMP_representation arity Ana \ M" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + and "is_TComp_var_instance_closed \ M" +using assms unfolding finite_SMP_representation_def list_all_iff wf\<^sub>t\<^sub>r\<^sub>m_code by blast+ + +lemma (in typed_model) is_wt_instance_of_condD: + assumes t_instance_s: "is_wt_instance_of_cond \ t s" + obtains \ where + "\ t = \ s" "mgu t s = Some \" + "inj_on \ (fv t)" "\ ` (fv t) \ range Var" +using t_instance_s unfolding is_wt_instance_of_cond_def Let_def by (cases "mgu t s") fastforce+ + +lemma (in typed_model) is_wt_instance_of_condD': + assumes t_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m t" + and s_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m s" + and t_instance_s: "is_wt_instance_of_cond \ t s" + shows "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = s \ \" +proof - + obtain \ where s: + "\ t = \ s" "mgu t s = Some \" + "inj_on \ (fv t)" "\ ` (fv t) \ range Var" + by (metis is_wt_instance_of_condD[OF t_instance_s]) + + have 0: "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m s" using s(1) t_wf_trm s_wf_trm by auto + + note 1 = mgu_wt_if_same_type[OF s(2) 0 s(1)] + + note 2 = conjunct1[OF mgu_gives_MGU[OF s(2)]] + + show ?thesis + using s(1) inj_var_ran_unifiable_has_subst_match[OF 2 s(3,4)] + wt_subst_compose[OF 1 subst_var_inv_wt[OF 1, of "fv t"]] + wf_trms_subst_compose[OF mgu_wf_trms[OF s(2) 0] subst_var_inv_wf_trms[of \ "fv t"]] + by auto +qed + +lemma (in typed_model) is_wt_instance_of_condD'': + assumes s_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m s" + and t_instance_s: "is_wt_instance_of_cond \ t s" + and t_var: "t = Var x" + shows "\y. s = Var y \ \ (Var y) = \ (Var x)" +proof - + obtain \ where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" and s: "Var x = s \ \" + using is_wt_instance_of_condD'[OF _ s_wf_trm t_instance_s] t_var by auto + obtain y where y: "s = Var y" using s by (cases s) auto + show ?thesis using wt_subst_trm''[OF \] s y by metis +qed + +lemma (in typed_model) has_all_wt_instances_ofD: + assumes N_instance_M: "has_all_wt_instances_of \ N M" + and t_in_N: "t \ N" + obtains s \ where + "s \ M" "\ t = \ s" "mgu t s = Some \" + "inj_on \ (fv t)" "\ ` (fv t) \ range Var" +by (metis t_in_N N_instance_M is_wt_instance_of_condD has_all_wt_instances_of_def) + +lemma (in typed_model) has_all_wt_instances_ofD': + assumes N_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N" + and M_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + and N_instance_M: "has_all_wt_instances_of \ N M" + and t_in_N: "t \ N" + shows "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t \ M \\<^sub>s\<^sub>e\<^sub>t \" +using assms is_wt_instance_of_condD' unfolding has_all_wt_instances_of_def by fast + +lemma (in typed_model) has_all_wt_instances_ofD'': + assumes N_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N" + and M_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + and N_instance_M: "has_all_wt_instances_of \ N M" + and t_in_N: "Var x \ N" + shows "\y. Var y \ M \ \ (Var y) = \ (Var x)" +using assms is_wt_instance_of_condD'' unfolding has_all_wt_instances_of_def by fast + +lemma (in typed_model) has_all_instances_of_if_subset: + assumes "N \ M" + shows "has_all_wt_instances_of \ N M" +using assms inj_onI mgu_same_empty +unfolding has_all_wt_instances_of_def is_wt_instance_of_cond_def +by (smt option.case_eq_if option.discI option.sel subsetD term.discI(1) term.inject(1)) + +lemma (in typed_model) SMP_I': + assumes N_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N" + and M_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" + and N_instance_M: "has_all_wt_instances_of \ N M" + and t_in_N: "t \ N" + shows "t \ SMP M" +using has_all_wt_instances_ofD'[OF N_wf_trms M_wf_trms N_instance_M t_in_N] + SMP.Substitution[OF SMP.MP[of _ M]] +by blast + + +subsubsection \Lemma: Proving Type-Flaw Resistance\ +locale typed_model' = typed_model arity public Ana \ + for arity::"'fun \ nat" + and public::"'fun \ bool" + and Ana::"('fun,(('fun,'atom::finite) term_type \ nat)) term + \ (('fun,(('fun,'atom) term_type \ nat)) term list + \ ('fun,(('fun,'atom) term_type \ nat)) term list)" + and \::"('fun,(('fun,'atom) term_type \ nat)) term \ ('fun,'atom) term_type" + + + assumes \_Var_fst: "\\ n m. \ (Var (\,n)) = \ (Var (\,m))" + and Ana_const: "\c T. arity c = 0 \ Ana (Fun c T) = ([],[])" + and Ana_subst'_or_Ana_keys_subterm: + "(\f T \ K R. Ana (Fun f T) = (K,R) \ Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,R \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)) \ + (\t K R k. Ana t = (K,R) \ k \ set K \ k \ t)" +begin + +lemma var_rename_inv_comp: "t \ (var_rename n \\<^sub>s var_rename_inv n) = t" +proof (induction t) + case (Fun f T) + hence "map (\t. t \ var_rename n \\<^sub>s var_rename_inv n) T = T" by (simp add: map_idI) + thus ?case by (metis subst_apply_term.simps(2)) +qed (simp add: var_rename_def var_rename_inv_def) + +lemma var_rename_fv_disjoint: + "fv s \ fv (t \ var_rename (max_var s)) = {}" +proof - + have 1: "\v \ fv s. snd v \ max_var s" by simp + have 2: "\v \ fv (t \ var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto + show ?thesis using 1 2 by force +qed + +lemma var_rename_fv_set_disjoint: + assumes "finite M" "s \ M" + shows "fv s \ fv (t \ var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t M))) = {}" +proof - + have 1: "\v \ fv s. snd v \ max_var_set (fv\<^sub>s\<^sub>e\<^sub>t M)" using assms + proof (induction M rule: finite_induct) + case (insert t M) thus ?case + proof (cases "t = s") + case False + hence "\v \ fv s. snd v \ max_var_set (fv\<^sub>s\<^sub>e\<^sub>t M)" using insert by simp + moreover have "max_var_set (fv\<^sub>s\<^sub>e\<^sub>t M) \ max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (insert t M))" + using insert.hyps(1) insert.prems + by force + ultimately show ?thesis by auto + qed simp + qed simp + + have 2: "\v \ fv (t \ var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto + + show ?thesis using 1 2 by force +qed + +lemma var_rename_fv_set_disjoint': + assumes "finite M" + shows "fv\<^sub>s\<^sub>e\<^sub>t M \ fv\<^sub>s\<^sub>e\<^sub>t (N \\<^sub>s\<^sub>e\<^sub>t var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t M))) = {}" +using var_rename_fv_set_disjoint[OF assms] by auto + +lemma var_rename_is_renaming[simp]: + "subst_range (var_rename n) \ range Var" + "subst_range (var_rename_inv n) \ range Var" +unfolding var_rename_def var_rename_inv_def by auto + +lemma var_rename_wt[simp]: + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (var_rename n)" + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (var_rename_inv n)" +by (auto simp add: var_rename_def var_rename_inv_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def \_Var_fst) + +lemma var_rename_wt': + assumes "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "s = m \ \" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (var_rename_inv n \\<^sub>s \)" "s = m \ var_rename n \ var_rename_inv n \\<^sub>s \" +using assms(2) wt_subst_compose[OF var_rename_wt(2)[of n] assms(1)] var_rename_inv_comp[of m n] +by force+ + +lemma var_rename_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_range[simp]: + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (var_rename n))" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (var_rename_inv n))" +using var_rename_is_renaming by fastforce+ + +lemma Fun_range_case: + "(\f T. Fun f T \ M \ P f T) \ (\u \ M. case u of Fun f T \ P f T | _ \ True)" + "(\f T. Fun f T \ M \ P f T) \ (\u \ M. is_Fun u \ P (the_Fun u) (args u))" +by (auto split: "term.splits") + +lemma is_TComp_var_instance_closedD: + assumes x: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" "\ (Var x) = TComp f T" + and closed: "is_TComp_var_instance_closed \ M" + shows "\g U. Fun g U \ set M \ \ (Fun g U) = \ (Var x) \ (\u \ set U. is_Var u) \ distinct U" +using assms unfolding is_TComp_var_instance_closed_def list_all_iff list_ex_iff by fastforce + +lemma is_TComp_var_instance_closedD': + assumes "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" "TComp f T \ \ (Var x)" + and closed: "is_TComp_var_instance_closed \ M" + and wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + shows "\g U. Fun g U \ set M \ \ (Fun g U) = TComp f T \ (\u \ set U. is_Var u) \ distinct U" +using assms(1,2) +proof (induction "\ (Var x)" arbitrary: x) + case (Fun g U) + note IH = Fun.hyps(1) + have g: "arity g > 0" "public g" using Fun.hyps(2) fun_type_inv[of "Var x"] \_Var_fst by simp_all + then obtain V where V: + "Fun g V \ set M" "\ (Fun g V) = \ (Var x)" "\v \ set V. \x. v = Var x" + "distinct V" "length U = length V" + using is_TComp_var_instance_closedD[OF Fun.prems(1) Fun.hyps(2)[symmetric] closed(1)] + by (metis Fun.hyps(2) fun_type_id_eq fun_type_length_eq is_VarE) + hence U: "U = map \ V" using fun_type[OF g(1), of V] Fun.hyps(2) by simp + hence 1: "\ v \ set U" when v: "v \ set V" for v using v by simp + + have 2: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var z) = \ (Var y)" when z: "Var z \ set V" for z + using V(1) fv_subset_subterms Fun_param_in_subterms[OF z] by fastforce + + show ?case + proof (cases "TComp f T = \ (Var x)") + case False + then obtain u where u: "u \ set U" "TComp f T \ u" + using Fun.prems(2) Fun.hyps(2) by moura + then obtain y where y: "Var y \ set V" "\ (Var y) = u" using U V(3) \_Var_fst by auto + show ?thesis using IH[OF _ 2[OF y(1)]] u y(2) by metis + qed (use V in fastforce) +qed simp + +lemma TComp_var_instance_wt_subst_exists: + assumes gT: "\ (Fun g T) = TComp g (map \ U)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun g T)" + and U: "\u \ set U. \y. u = Var y" "distinct U" + shows "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ Fun g T = Fun g U \ \" +proof - + define the_i where "the_i \ \y. THE x. x < length U \ U ! x = Var y" + define \ where \: "\ \ \y. if Var y \ set U then T ! the_i y else Var y" + + have g: "arity g > 0" using gT(1,2) fun_type_inv(1) by blast + + have UT: "length U = length T" using fun_type_length_eq gT(1) by fastforce + + have 1: "the_i y < length U \ U ! the_i y = Var y" when y: "Var y \ set U" for y + using theI'[OF distinct_Ex1[OF U(2) y]] unfolding the_i_def by simp + + have 2: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + using \ 1 gT(1) fun_type[OF g] UT + unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def + by (metis (no_types, lifting) nth_map term.inject(2)) + + have "\i \ = T ! i" + using \ 1 U(1) UT distinct_Ex1[OF U(2)] in_set_conv_nth + by (metis (no_types, lifting) subst_apply_term.simps(1)) + hence "T = map (\t. t \ \) U" by (simp add: UT nth_equalityI) + hence 3: "Fun g T = Fun g U \ \" by simp + + have "subst_range \ \ set T" using \ 1 U(1) UT by (auto simp add: subst_domain_def) + hence 4: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" using gT(2) wf_trm_param by auto + + show ?thesis by (metis 2 3 4) +qed + +lemma TComp_var_instance_closed_has_Var: + assumes closed: "is_TComp_var_instance_closed \ M" + and wf_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and wf_\x: "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" + and y_ex: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" + and t: "t \ \ x" + and \_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var y) = \ t" +proof (cases "\ (Var x)") + case (Var a) + hence "t = \ x" + using t wf_\x \_wt + by (metis (full_types) const_type_inv_wf fun_if_subterm subtermeq_Var_const(2) wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + thus ?thesis using y_ex wt_subst_trm''[OF \_wt, of "Var x"] by fastforce +next + case (Fun f T) + hence \_\x: "\ (\ x) = TComp f T" using wt_subst_trm''[OF \_wt, of "Var x"] by auto + + show ?thesis + proof (cases "t = \ x") + case False + hence t_subt_\x: "t \ \ x" using t(1) \_\x by fastforce + + obtain T' where T': "\ x = Fun f T'" using \_\x t_subt_\x fun_type_id_eq by (cases "\ x") auto + + obtain g S where gS: "Fun g S \ \ x" "t \ set S" using Fun_ex_if_subterm[OF t_subt_\x] by blast + + have gS_wf: "wf\<^sub>t\<^sub>r\<^sub>m (Fun g S)" by (rule wf_trm_subtermeq[OF wf_\x gS(1)]) + hence "arity g > 0" using gS(2) by (metis length_pos_if_in_set wf_trm_arity) + hence gS_\: "\ (Fun g S) = TComp g (map \ S)" using fun_type by blast + + obtain h U where hU: + "Fun h U \ set M" "\ (Fun h U) = Fun g (map \ S)" "\u \ set U. is_Var u" + using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M] + subtermeq_imp_subtermtypeeq[OF wf_\x] gS \_\x Fun gS_\ + by metis + + obtain y where y: "Var y \ set U" "\ (Var y) = \ t" + using hU(3) fun_type_param_ex[OF hU(2) gS(2)] by fast + + have "y \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" using hU(1) y(1) by force + thus ?thesis using y(2) closed by metis + qed (metis y_ex Fun \_\x) +qed + +lemma TComp_var_instance_closed_has_Fun: + assumes closed: "is_TComp_var_instance_closed \ M" + and wf_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and wf_\x: "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" + and y_ex: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" + and t: "t \ \ x" + and \_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and t_\: "\ t = TComp g T" + and t_fun: "is_Fun t" + shows "\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \ \ is_Fun m" +proof - + obtain T'' where T'': "t = Fun g T''" using t_\ t_fun fun_type_id_eq by blast + + have g: "arity g > 0" using t_\ fun_type_inv[of t] by simp_all + + have "TComp g T \ \ (Var x)" using \_wt t t_\ + by (metis wf_\x subtermeq_imp_subtermtypeeq wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + then obtain U where U: + "Fun g U \ set M" "\ (Fun g U) = TComp g T" "\u \ set U. \y. u = Var y" + "distinct U" "length T'' = length U" + using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M] + by (metis t_\ T'' fun_type_id_eq fun_type_length_eq is_VarE) + hence UT': "T = map \ U" using fun_type[OF g, of U] by simp + + show ?thesis + using TComp_var_instance_wt_subst_exists UT' T'' U(1,3,4) t t_\ wf_\x wf_trm_subtermeq + by (metis term.disc(2)) +qed + +lemma TComp_var_and_subterm_instance_closed_has_subterms_instances: + assumes M_var_inst_cl: "is_TComp_var_instance_closed \ M" + and M_subterms_cl: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and t: "t \\<^sub>s\<^sub>e\<^sub>t set M" + and s: "s \ t \ \" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ s = m \ \" +using subterm_subst_unfold[OF s] +proof + assume "\s'. s' \ t \ s = s' \ \" + then obtain s' where s': "s' \ t" "s = s' \ \" by blast + then obtain \ where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "s' \ set M \\<^sub>s\<^sub>e\<^sub>t \" + using t has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl] + term.order_trans[of s' t] + by blast + then obtain m where m: "m \ set M" "s' = m \ \" by blast + + have "s = m \ (\ \\<^sub>s \)" using s'(2) m(2) by simp + thus ?thesis + using m(1) wt_subst_compose[OF \(1) \(1)] wf_trms_subst_compose[OF \(2) \(2)] by blast +next + assume "\x \ fv t. s \ \ x" + then obtain x where x: "x \ fv t" "s \ \ x" "s \ \ x" by blast + + note 0 = TComp_var_instance_closed_has_Var[OF M_var_inst_cl M_wf] + note 1 = has_all_wt_instances_ofD''[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl] + + have \x_wf: "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" and s_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m s" + using \(2) wf_trm_subterm[OF _ x(2)] by fastforce+ + + have x_fv_ex: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" + using x(1) s fv_subset_subterms[OF t] by auto + + obtain y where y: "y \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" "\ (Var y) = \ s" + using 0[of \ x s, OF \x_wf x_fv_ex x(3) \(1)] by metis + then obtain z where z: "Var z \ set M" "\ (Var z) = \ s" + using 1[of y] vars_iff_subtermeq_set[of y "set M"] by metis + + define \ where "\ \ Var(z := s)::('fun, ('fun, 'atom) term \ nat) subst" + + have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "s = Var z \ \" + using z(2) s_wf_trm unfolding \_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by force+ + thus ?thesis using z(1) by blast +qed + +context +begin +private lemma SMP_D_aux1: + assumes "t \ SMP (set M)" + and closed: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + "is_TComp_var_instance_closed \ M" + and wf_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + shows "\x \ fv t. \y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var y) = \ (Var x)" +using assms(1) +proof (induction t rule: SMP.induct) + case (MP t) show ?case + proof + fix x assume x: "x \ fv t" + hence "Var x \ subterms\<^sub>s\<^sub>e\<^sub>t (set M)" using MP.hyps vars_iff_subtermeq by fastforce + then obtain \ s where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and s: "s \ set M" "Var x = s \ \" + using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF wf_M] wf_M closed(1)] by blast + then obtain y where y: "s = Var y" by (cases s) auto + thus "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var y) = \ (Var x)" + using s wt_subst_trm''[OF \(1), of "Var y"] by force + qed +next + case (Subterm t t') + hence "fv t' \ fv t" using subtermeq_vars_subset by auto + thus ?case using Subterm.IH by auto +next + case (Substitution t \) + note IH = Substitution.IH + show ?case + proof + fix x assume x: "x \ fv (t \ \)" + then obtain y where y: "y \ fv t" "\ (Var x) \ \ (Var y)" + using Substitution.hyps(2,3) + by (metis subst_apply_img_var subtermeqI' subtermeq_imp_subtermtypeeq + vars_iff_subtermeq wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def wf_trm_subst_rangeD) + let ?P = "\x. \y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var y) = \ (Var x)" + show "?P x" using y IH + proof (induction "\ (Var y)" arbitrary: y t) + case (Var a) + hence "\ (Var x) = \ (Var y)" by auto + thus ?case using Var(2,4) by auto + next + case (Fun f T) + obtain z where z: "\w \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var z) = \ (Var w)" "\ (Var z) = \ (Var y)" + using Fun.prems(1,3) by blast + show ?case + proof (cases "\ (Var x) = \ (Var y)") + case True thus ?thesis using Fun.prems by auto + next + case False + then obtain \ where \: "\ \ set T" "\ (Var x) \ \" using Fun.prems(2) Fun.hyps(2) by auto + then obtain U where U: + "Fun f U \ set M" "\ (Fun f U) = \ (Var z)" "\u \ set U. \v. u = Var v" "distinct U" + using is_TComp_var_instance_closedD'[OF z(1) _ closed(2) wf_M] Fun.hyps(2) z(2) + by (metis fun_type_id_eq subtermeqI' is_VarE) + hence 1: "\x \ fv (Fun f U). \y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var y) = \ (Var x)" by force + + have "arity f > 0" using U(2) z(2) Fun.hyps(2) fun_type_inv(1) by metis + hence "\ (Fun f U) = TComp f (map \ U)" using fun_type by auto + then obtain u where u: "Var u \ set U" "\ (Var u) = \" + using \(1) U(2,3) z(2) Fun.hyps(2) by auto + show ?thesis + using Fun.hyps(1)[of u "Fun f U"] u \ 1 + by force + qed + qed + qed +next + case (Ana t K T k) + have "fv k \ fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto + thus ?case using Ana.IH by auto +qed + +private lemma SMP_D_aux2: + fixes t::"('fun, ('fun, 'atom) term \ nat) term" + assumes t_SMP: "t \ SMP (set M)" + and t_Var: "\x. t = Var x" + and M_SMP_repr: "finite_SMP_representation arity Ana \ M" + shows "\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \" +proof - + have M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and M_var_inst_cl: "is_TComp_var_instance_closed \ M" + and M_subterms_cl: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and M_Ana_cl: "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + using finite_SMP_representationD[OF M_SMP_repr] by blast+ + + have M_Ana_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\ ((set \ fst \ Ana) ` set M))" + proof + fix k assume "k \ \((set \ fst \ Ana) ` set M)" + then obtain m where m: "m \ set M" "k \ set (fst (Ana m))" by force + thus "wf\<^sub>t\<^sub>r\<^sub>m k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast + qed + + note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl] + note 1 = has_all_wt_instances_ofD'[OF M_Ana_wf M_wf M_Ana_cl] + + obtain x y where x: "t = Var x" and y: "y \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" "\ (Var y) = \ (Var x)" + using t_Var SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce + then obtain m \ where m: "m \ set M" "m \ \ = Var y" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + using 0[of "Var y"] vars_iff_subtermeq_set[of y "set M"] by fastforce + obtain z where z: "m = Var z" using m(2) by (cases m) auto + + define \ where "\ \ Var(z := Var x)::('fun, ('fun, 'atom) term \ nat) subst" + + have "\ (Var z) = \ (Var x)" using y(2) m(2) z wt_subst_trm''[OF \, of m] by argo + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" unfolding \_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by force+ + moreover have "t = m \ \" using x z unfolding \_def by simp + ultimately show ?thesis using m(1) by blast +qed + +private lemma SMP_D_aux3: + assumes hyps: "t' \ t" and wf_t: "wf\<^sub>t\<^sub>r\<^sub>m t" and prems: "is_Fun t'" + and IH: + "((\f. t = Fun f []) \ (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \)) \ + (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \ \ is_Fun m)" + and M_SMP_repr: "finite_SMP_representation arity Ana \ M" + shows "((\f. t' = Fun f []) \ (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t' = m \ \)) \ + (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t' = m \ \ \ is_Fun m)" +proof (cases "\f. t = Fun f [] \ t' = Fun f []") + case True + have M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and M_var_inst_cl: "is_TComp_var_instance_closed \ M" + and M_subterms_cl: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and M_Ana_cl: "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + using finite_SMP_representationD[OF M_SMP_repr] by blast+ + + note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl] + note 1 = TComp_var_instance_closed_has_Fun[OF M_var_inst_cl M_wf] + note 2 = TComp_var_and_subterm_instance_closed_has_subterms_instances[ + OF M_var_inst_cl M_subterms_cl M_wf] + + have wf_t': "wf\<^sub>t\<^sub>r\<^sub>m t'" using hyps wf_t wf_trm_subterm by blast + + obtain c where "t = Fun c [] \ t' = Fun c []" using True by moura + thus ?thesis + proof + assume c: "t' = Fun c []" + show ?thesis + proof (cases "\f. t = Fun f []") + case True + hence "t = t'" using c hyps by force + thus ?thesis using IH by fast + next + case False + note F = this + then obtain m \ where m: "m \ set M" "t = m \ \" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using IH by blast + + show ?thesis using subterm_subst_unfold[OF hyps[unfolded m(2)]] + proof + assume "\m'. m' \ m \ t' = m' \ \" + then obtain m' where m': "m' \ m" "t' = m' \ \" by moura + obtain n \ where n: "n \ set M" "m' = n \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using 0[of m'] m(1) m'(1) by blast + have "t' = n \ (\ \\<^sub>s \)" using m'(2) n(2) by auto + thus ?thesis + using c n(1) wt_subst_compose[OF \(1) \(1)] wf_trms_subst_compose[OF \(2) \(2)] by blast + next + assume "\x \ fv m. t' \ \ x" + then obtain x where x: "x \ fv m" "t' \ \ x" "t' \ \ x" by moura + have \x_wf: "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" using \(2) by fastforce + + have x_fv_ex: "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" using x m by auto + + show ?thesis + proof (cases "\ t'") + case (Var a) + show ?thesis + using c m 2[OF _ hyps[unfolded m(2)] \] + by fast + next + case (Fun g S) + show ?thesis + using c 1[of \ x t', OF \x_wf x_fv_ex x(3) \(1) Fun] + by blast + qed + qed + qed + qed (use IH hyps in simp) +next + case False + note F = False + then obtain m \ where m: + "m \ set M" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "t = m \ \" "is_Fun m" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using IH by moura + obtain f T where fT: "t' = Fun f T" "arity f > 0" "\ t' = TComp f (map \ T)" + using F prems fun_type wf_trm_subtermeq[OF wf_t hyps] + by (metis is_FunE length_greater_0_conv subtermeqI' wf\<^sub>t\<^sub>r\<^sub>m_def) + + have closed: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + "is_TComp_var_instance_closed \ M" + using M_SMP_repr unfolding finite_SMP_representation_def by metis+ + + have M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + using finite_SMP_representationD[OF M_SMP_repr] by blast + + show ?thesis + proof (cases "\x \ fv m. t' \ \ x") + case True + then obtain x where x: "x \ fv m" "t' \ \ x" by moura + have 1: "x \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" using m(1) x(1) by auto + have 2: "is_Fun (\ x)" using prems x(2) by auto + have 3: "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" using m(5) by (simp add: wf_trm_subst_rangeD) + have "\(\f. \ x = Fun f [])" using F x(2) by auto + hence "\f T. \ (Var x) = TComp f T" using 2 3 m(2) + by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wf\<^sub>t\<^sub>r\<^sub>m_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def) + moreover have "\f T. \ t' = Fun f T" + using False prems wf_trm_subtermeq[OF wf_t hyps] + by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wf\<^sub>t\<^sub>r\<^sub>m_def) + ultimately show ?thesis + using TComp_var_instance_closed_has_Fun 1 x(2) m(2) prems closed 3 M_wf + by metis + next + case False + then obtain m' where m': "m' \ m" "t' = m' \ \" "is_Fun m'" + using hyps m(3) subterm_subst_not_img_subterm + by blast + then obtain \ m'' where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "m'' \ set M" "m' = m'' \ \" + using m(1) has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf closed(1)] by blast + hence t'_m'': "t' = m'' \ \ \\<^sub>s \" using m'(2) by fastforce + + note \\ = wt_subst_compose[OF \(1) m(2)] wf_trms_subst_compose[OF \(2) m(5)] + + show ?thesis + proof (cases "is_Fun m''") + case True thus ?thesis using \(3,4) m'(2,3) m(4) fT t'_m'' \\ by blast + next + case False + then obtain x where x: "m'' = Var x" by moura + hence "\y \ fv\<^sub>s\<^sub>e\<^sub>t (set M). \ (Var x) = \ (Var y)" "t' \ (\ \\<^sub>s \) x" + "\ (Var x) = Fun f (map \ T)" "wf\<^sub>t\<^sub>r\<^sub>m ((\ \\<^sub>s \) x)" + using \\ t'_m'' \(3) fv_subset[OF \(3)] fT(3) subst_apply_term.simps(1)[of x "\ \\<^sub>s \"] + wt_subst_trm''[OF \\(1), of "Var x"] + by (fastforce, blast, argo, fastforce) + thus ?thesis + using x TComp_var_instance_closed_has_Fun[ + of M "\ \\<^sub>s \" x t' f "map \ T", OF closed(2) M_wf _ _ _ \\(1) fT(3) prems] + by blast + qed + qed +qed + +lemma SMP_D: + assumes "t \ SMP (set M)" "is_Fun t" + and M_SMP_repr: "finite_SMP_representation arity Ana \ M" + shows "((\f. t = Fun f []) \ (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \)) \ + (\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \ \ is_Fun m)" +proof - + have wf_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and closed: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + "is_TComp_var_instance_closed \ M" + using finite_SMP_representationD[OF M_SMP_repr] by blast+ + + show ?thesis using assms(1,2) + proof (induction t rule: SMP.induct) + case (MP t) + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" "t = t \ Var" by simp_all + ultimately show ?case by blast + next + case (Subterm t t') + hence t_fun: "is_Fun t" by auto + note * = Subterm.hyps(2) SMP_wf_trm[OF Subterm.hyps(1) wf_M(1)] + Subterm.prems Subterm.IH[OF t_fun] M_SMP_repr + show ?case by (rule SMP_D_aux3[OF *]) + next + case (Substitution t \) + have wf: "wf\<^sub>t\<^sub>r\<^sub>m t" by (metis Substitution.hyps(1) wf_M(1) SMP_wf_trm) + hence wf': "wf\<^sub>t\<^sub>r\<^sub>m (t \ \)" using Substitution.hyps(3) wf_trm_subst by blast + show ?case + proof (cases "\ t") + case (Var a) + hence 1: "\ (t \ \) = TAtom a" using Substitution.hyps(2) by (metis wt_subst_trm'') + then obtain c where c: "t \ \ = Fun c []" + using TAtom_term_cases[OF wf' 1] Substitution.prems by fastforce + hence "(\x. t = Var x) \ t = t \ \" by (cases t) auto + thus ?thesis + proof + assume t_Var: "\x. t = Var x" + then obtain x where x: "t = Var x" "\ x = Fun c []" "\ (Var x) = TAtom a" + using c 1 wt_subst_trm''[OF Substitution.hyps(2), of t] by force + + obtain m \ where m: "m \ set M" "t = m \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using SMP_D_aux2[OF Substitution.hyps(1) t_Var M_SMP_repr] by moura + + have "m \ (\ \\<^sub>s \) = Fun c []" using c m(2) by auto + thus ?thesis + using c m(1) wt_subst_compose[OF \(1) Substitution.hyps(2)] + wf_trms_subst_compose[OF \(2) Substitution.hyps(3)] + by metis + qed (use c Substitution.IH in auto) + next + case (Fun f T) + hence 1: "\ (t \ \) = TComp f T" using Substitution.hyps(2) by (metis wt_subst_trm'') + have 2: "\(\f. t = Fun f [])" using Fun TComp_term_cases[OF wf] by auto + obtain T'' where T'': "t \ \ = Fun f T''" + using 1 2 fun_type_id_eq Fun Substitution.prems + by fastforce + have f: "arity f > 0" "public f" using fun_type_inv[OF 1] by metis+ + + show ?thesis + proof (cases t) + case (Fun g U) + then obtain m \ where m: + "m \ set M" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "t = m \ \" "is_Fun m" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using Substitution.IH Fun 2 by moura + have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" "t \ \ = m \ (\ \\<^sub>s \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" + using wt_subst_compose[OF m(2) Substitution.hyps(2)] m(3) + wf_trms_subst_compose[OF m(5) Substitution.hyps(3)] + by auto + thus ?thesis using m(1,4) by metis + next + case (Var x) + then obtain y where y: "y \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" "\ (Var y) = \ (Var x)" + using SMP_D_aux1[OF Substitution.hyps(1) closed(1,3) wf_M] Fun + by moura + hence 3: "\ (Var y) = TComp f T" using Var Fun \_Var_fst by simp + + obtain h V where V: + "Fun h V \ set M" "\ (Fun h V) = \ (Var y)" "\u \ set V. \z. u = Var z" "distinct V" + by (metis is_VarE is_TComp_var_instance_closedD[OF _ 3 closed(3)] y(1)) + moreover have "length T'' = length V" using 3 V(2) fun_type_length_eq 1 T'' by metis + ultimately have TV: "T = map \ V" + by (metis fun_type[OF f(1)] 3 fun_type_id_eq term.inject(2)) + + obtain \ where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t \ \ = Fun h V \ \" + using TComp_var_instance_wt_subst_exists 1 3 T'' TV V(2,3,4) wf' + by (metis fun_type_id_eq) + + have 9: "\ (Fun h V) = \ (\ x)" using y(2) Substitution.hyps(2) V(2) 1 3 Var by auto + + show ?thesis using Var \ 9 V(1) by force + qed + qed + next + case (Ana t K T k) + have 1: "is_Fun t" using Ana.hyps(2,3) by auto + then obtain f U where U: "t = Fun f U" by moura + + have 2: "fv k \ fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto + + have wf_t: "wf\<^sub>t\<^sub>r\<^sub>m t" + using SMP_wf_trm[OF Ana.hyps(1)] wf\<^sub>t\<^sub>r\<^sub>m_code wf_M + by auto + hence wf_k: "wf\<^sub>t\<^sub>r\<^sub>m k" + using Ana_keys_wf'[OF Ana.hyps(2)] wf\<^sub>t\<^sub>r\<^sub>m_code Ana.hyps(3) + by auto + + have wf_M_keys: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\((set \ fst \ Ana) ` set M))" + proof + fix t assume "t \ (\((set \ fst \ Ana) ` set M))" + then obtain s where s: "s \ set M" "t \ (set \ fst \ Ana) s" by blast + obtain K R where KR: "Ana s = (K,R)" by (metis surj_pair) + hence "t \ set K" using s(2) by simp + thus "wf\<^sub>t\<^sub>r\<^sub>m t" using Ana_keys_wf'[OF KR] wf_M s(1) by blast + qed + + show ?case using Ana_subst'_or_Ana_keys_subterm + proof + assume "\t K T k. Ana t = (K, T) \ k \ set K \ k \ t" + hence *: "k \ t" using Ana.hyps(2,3) by auto + show ?thesis by (rule SMP_D_aux3[OF * wf_t Ana.prems Ana.IH[OF 1] M_SMP_repr]) + next + assume Ana_subst': + "\f T \ K M. Ana (Fun f T) = (K, M) \ Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + + have "arity f > 0" using Ana_const[of f U] U Ana.hyps(2,3) by fastforce + hence "U \ []" using wf_t U unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by force + then obtain m \ where m: "m \ set M" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t = m \ \" "is_Fun m" + using Ana.IH[OF 1] U by auto + hence "Ana (t \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,T \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" using Ana_subst' U Ana.hyps(2) by auto + obtain Km Tm where Ana_m: "Ana m = (Km,Tm)" by moura + hence "Ana (m \ \) = (Km \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,Tm \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + using Ana_subst' U m(4) is_FunE[OF m(5)] Ana.hyps(2) + by metis + then obtain km where km: "km \ set Km" "k = km \ \" using Ana.hyps(2,3) m(4) by auto + then obtain \ km' where \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and km': "km' \ set M" "km = km' \ \" + using Ana_m m(1) has_all_wt_instances_ofD'[OF wf_M_keys wf_M closed(2), of km] by force + + have k\\: "k = km' \ \ \\<^sub>s \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" + using km(2) km' wt_subst_compose[OF \(1) m(2)] wf_trms_subst_compose[OF \(2) m(3)] + by auto + + show ?case + proof (cases "is_Fun km'") + case True thus ?thesis using k\\ km'(1) by blast + next + case False + note F = False + then obtain x where x: "km' = Var x" by auto + hence 3: "x \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" using fv_subset[OF km'(1)] by auto + obtain kf kT where kf: "k = Fun kf kT" using Ana.prems by auto + show ?thesis + proof (cases "kT = []") + case True thus ?thesis using k\\(1) k\\(2) k\\(3) kf km'(1) by blast + next + case False + hence 4: "arity kf > 0" using wf_k kf TAtom_term_cases const_type by fastforce + then obtain kT' where kT': "\ k = TComp kf kT'" by (simp add: fun_type kf) + then obtain V where V: + "Fun kf V \ set M" "\ (Fun kf V) = \ (Var x)" "\u \ set V. \v. u = Var v" + "distinct V" "is_Fun (Fun kf V)" + using is_TComp_var_instance_closedD[OF _ _ closed(3), of x] + x m(2) k\\(1) 3 wt_subst_trm''[OF k\\(2)] + by (metis fun_type_id_eq term.disc(2) is_VarE) + have 5: "kT' = map \ V" + using fun_type[OF 4] x kT' k\\ m(2) V(2) + by (metis term.inject(2) wt_subst_trm'') + thus ?thesis + using TComp_var_instance_wt_subst_exists wf_k kf 4 V(3,4) kT' V(1,5) + by metis + qed + qed + qed + qed +qed + +lemma SMP_D': + fixes M + defines "\ \ var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (set M)))" + assumes M_SMP_repr: "finite_SMP_representation arity Ana \ M" + and s: "s \ SMP (set M)" "is_Fun s" "\f. s = Fun f []" + and t: "t \ SMP (set M)" "is_Fun t" "\f. t = Fun f []" + obtains \ s0 \ t0 + where "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "s0 \ set M" "is_Fun s0" "s = s0 \ \" "\ s = \ s0" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t0 \ set M" "is_Fun t0" "t = t0 \ \ \ \" "\ t = \ t0" +proof - + obtain \ s0 where + s0: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "s0 \ set M" "s = s0 \ \" "is_Fun s0" + using s(3) SMP_D[OF s(1,2) M_SMP_repr] unfolding \_def by metis + + obtain \ t0 where t0: + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t0 \ set M" "t = t0 \ \ \ \" "is_Fun t0" + using t(3) SMP_D[OF t(1,2) M_SMP_repr] var_rename_wt'[of _ t] + wf_trms_subst_compose_Var_range(1)[OF _ var_rename_is_renaming(2)] + unfolding \_def by metis + + have "\ s = \ s0" "\ t = \ (t0 \ \)" "\ (t0 \ \) = \ t0" + using s0 t0 wt_subst_trm'' by (metis, metis, metis \_def var_rename_wt(1)) + thus ?thesis using s0 t0 that by simp +qed + +lemma SMP_D'': + fixes t::"('fun, ('fun, 'atom) term \ nat) term" + assumes t_SMP: "t \ SMP (set M)" + and M_SMP_repr: "finite_SMP_representation arity Ana \ M" + shows "\m \ set M. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ t = m \ \" +proof (cases "(\x. t = Var x) \ (\c. t = Fun c [])") + case True + have M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and M_var_inst_cl: "is_TComp_var_instance_closed \ M" + and M_subterms_cl: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and M_Ana_cl: "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + using finite_SMP_representationD[OF M_SMP_repr] by blast+ + + have M_Ana_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\ ((set \ fst \ Ana) ` set M))" + proof + fix k assume "k \ \((set \ fst \ Ana) ` set M)" + then obtain m where m: "m \ set M" "k \ set (fst (Ana m))" by force + thus "wf\<^sub>t\<^sub>r\<^sub>m k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast + qed + + show ?thesis using True + proof + assume "\x. t = Var x" + then obtain x y where x: "t = Var x" and y: "y \ fv\<^sub>s\<^sub>e\<^sub>t (set M)" "\ (Var y) = \ (Var x)" + using SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce + then obtain m \ where m: "m \ set M" "m \ \ = Var y" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl, of "Var y"] + vars_iff_subtermeq_set[of y "set M"] + by fastforce + + obtain z where z: "m = Var z" using m(2) by (cases m) auto + + define \ where "\ \ Var(z := Var x)::('fun, ('fun, 'atom) term \ nat) subst" + + have "\ (Var z) = \ (Var x)" using y(2) m(2) z wt_subst_trm''[OF \, of m] by argo + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" unfolding \_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by force+ + moreover have "t = m \ \" using x z unfolding \_def by simp + ultimately show ?thesis using m(1) by blast + qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast) +qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast) +end + +lemma tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t: + assumes "comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (set M)" +proof - + let ?\ = "var_rename (max_var_set (fv\<^sub>s\<^sub>e\<^sub>t (set M)))" + have M_SMP_repr: "finite_SMP_representation arity Ana \ M" + by (metis comp_tfr\<^sub>s\<^sub>e\<^sub>t_def assms) + + have M_finite: "finite (set M)" + using assms card_gt_0_iff unfolding comp_tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + + show ?thesis + proof (unfold tfr\<^sub>s\<^sub>e\<^sub>t_def; intro ballI impI) + fix s t assume "s \ SMP (set M) - Var`\" "t \ SMP (set M) - Var`\" + hence st: "s \ SMP (set M)" "is_Fun s" "t \ SMP (set M)" "is_Fun t" by auto + have "\(\\. Unifier \ s t)" when st_type_neq: "\ s \ \ t" + proof (cases "\f. s = Fun f [] \ t = Fun f []") + case False + then obtain \ s0 \ t0 where + s0: "s0 \ set M" "is_Fun s0" "s = s0 \ \" "\ s = \ s0" + and t0: "t0 \ set M" "is_Fun t0" "t = t0 \ ?\ \ \" "\ t = \ t0" + using SMP_D'[OF M_SMP_repr st(1,2) _ st(3,4)] by metis + hence "\(\\. Unifier \ s0 (t0 \ ?\))" + using assms mgu_None_is_subst_neq st_type_neq wt_subst_trm''[OF var_rename_wt(1)] + unfolding comp_tfr\<^sub>s\<^sub>e\<^sub>t_def Let_def by metis + thus ?thesis + using vars_term_disjoint_imp_unifier[OF var_rename_fv_set_disjoint[OF M_finite]] s0(1) t0(1) + unfolding s0(3) t0(3) by (metis (no_types, hide_lams) subst_subst_compose) + qed (use st_type_neq st(2,4) in auto) + thus "\ s = \ t" when "\\. Unifier \ s t" by (metis that) + qed +qed + +lemma tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t': + assumes "let N = SMP0 Ana \ M in set M \ set N \ comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ N" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (set M)" +by (rule tfr_subset(2)[ + OF tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t[OF conjunct2[OF assms[unfolded Let_def]]] + conjunct1[OF assms[unfolded Let_def]]]) + +lemma tfr\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>t\<^sub>p: "tfr\<^sub>s\<^sub>t\<^sub>p a = comp_tfr\<^sub>s\<^sub>t\<^sub>p \ a" +proof (cases a) + case (Equality ac t t') + thus ?thesis + using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t'] + by auto +next + case (Inequality X F) + thus ?thesis + using tfr\<^sub>s\<^sub>t\<^sub>p.simps(2)[of X F] + comp_tfr\<^sub>s\<^sub>t\<^sub>p.simps(2)[of \ X F] + Fun_range_case(2)[of "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)"] + unfolding is_Var_def + by auto +qed auto + +lemma tfr\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>t: + assumes "comp_tfr\<^sub>s\<^sub>t arity Ana \ M S" + shows "tfr\<^sub>s\<^sub>t S" +unfolding tfr\<^sub>s\<^sub>t_def +proof + have comp_tfr\<^sub>s\<^sub>e\<^sub>t_M: "comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \ M" + using assms unfolding comp_tfr\<^sub>s\<^sub>t_def by blast + + have wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_S: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + and S_trms_instance_M: "has_all_wt_instances_of \ (trms\<^sub>s\<^sub>t S) (set M)" + using assms wf\<^sub>t\<^sub>r\<^sub>m_code trms_list\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>t + unfolding comp_tfr\<^sub>s\<^sub>t_def comp_tfr\<^sub>s\<^sub>e\<^sub>t_def finite_SMP_representation_def list_all_iff + by blast+ + + show "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" + using tfr_subset(3)[OF tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t[OF comp_tfr\<^sub>s\<^sub>e\<^sub>t_M] SMP_SMP_subset] + SMP_I'[OF wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_S wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_M S_trms_instance_M] + by blast + + have "list_all (comp_tfr\<^sub>s\<^sub>t\<^sub>p \) S" by (metis assms comp_tfr\<^sub>s\<^sub>t_def) + thus "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" by (induct S) (simp_all add: tfr\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>t\<^sub>p) +qed + +lemma tfr\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>t': + assumes "comp_tfr\<^sub>s\<^sub>t arity Ana \ (SMP0 Ana \ (trms_list\<^sub>s\<^sub>t S)) S" + shows "tfr\<^sub>s\<^sub>t S" +by (rule tfr\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>t[OF assms]) + + + +subsubsection \Lemmata for Checking Ground SMP (GSMP) Disjointness\ +context +begin +private lemma ground_SMP_disjointI_aux1: + fixes M::"('fun, ('fun, 'atom) term \ nat) term set" + assumes f_def: "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and g_def: "g \ \M. {t \ M. fv t = {}}" + shows "f (SMP M) = g (SMP M)" +proof + have "t \ f (SMP M)" when t: "t \ SMP M" "fv t = {}" for t + proof - + define \ where "\ \ Var::('fun, ('fun, 'atom) term \ nat) subst" + have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "t = t \ \" + using subst_apply_term_empty[of t] that(2) wt_subst_Var wf_trm_subst_range_Var + unfolding \_def by auto + thus ?thesis using SMP.Substitution[OF t(1), of \] t(2) unfolding f_def by fastforce + qed + thus "g (SMP M) \ f (SMP M)" unfolding g_def by blast +qed (use f_def g_def in blast) + +private lemma ground_SMP_disjointI_aux2: + fixes M::"('fun, ('fun, 'atom) term \ nat) term list" + assumes f_def: "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and M_SMP_repr: "finite_SMP_representation arity Ana \ M" + shows "f (set M) = f (SMP (set M))" +proof + have M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)" + and M_var_inst_cl: "is_TComp_var_instance_closed \ M" + and M_subterms_cl: "has_all_wt_instances_of \ (subterms\<^sub>s\<^sub>e\<^sub>t (set M)) (set M)" + and M_Ana_cl: "has_all_wt_instances_of \ (\((set \ fst \ Ana) ` set M)) (set M)" + using finite_SMP_representationD[OF M_SMP_repr] by blast+ + + show "f (SMP (set M)) \ f (set M)" + proof + fix t assume "t \ f (SMP (set M))" + then obtain s \ where s: "t = s \ \" "s \ SMP (set M)" "fv (s \ \) = {}" + and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + unfolding f_def by blast + + have t_wf: "wf\<^sub>t\<^sub>r\<^sub>m t" using SMP_wf_trm[OF s(2) M_wf] s(1) wf_trm_subst[OF \(2)] by blast + + obtain m \ where m: "m \ set M" "s = m \ \" and \: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using SMP_D''[OF s(2) M_SMP_repr] by blast + + have "t = m \ (\ \\<^sub>s \)" "fv (m \ (\ \\<^sub>s \)) = {}" using s(1,3) m(2) by simp_all + thus "t \ f (set M)" + using m(1) wt_subst_compose[OF \(1) \(1)] wf_trms_subst_compose[OF \(2) \(2)] + unfolding f_def by blast + qed +qed (auto simp add: f_def) + +private lemma ground_SMP_disjointI_aux3: + fixes A B C::"('fun, ('fun, 'atom) term \ nat) term set" + defines "P \ \t s. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ Unifier \ t s" + assumes f_def: "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and Q_def: "Q \ \t. intruder_synth' public arity {} t" + and R_def: "R \ \t. \u \ C. is_wt_instance_of_cond \ t u" + and AB: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s A" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s B" "fv\<^sub>s\<^sub>e\<^sub>t A \ fv\<^sub>s\<^sub>e\<^sub>t B = {}" + and C: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s C" + and ABC: "\t \ A. \s \ B. P t s \ (Q t \ Q s) \ (R t \ R s)" + shows "f A \ f B \ f C \ {m. {} \\<^sub>c m}" +proof + fix t assume "t \ f A \ f B" + then obtain ta tb \a \b where + ta: "t = ta \ \a" "ta \ A" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \a" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \a)" "fv (ta \ \a) = {}" + and tb: "t = tb \ \b" "tb \ B" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \b" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \b)" "fv (tb \ \b) = {}" + unfolding f_def by blast + + have ta_tb_wf: "wf\<^sub>t\<^sub>r\<^sub>m ta" "wf\<^sub>t\<^sub>r\<^sub>m tb" "fv ta \ fv tb = {}" "\ ta = \ tb" + using ta(1,2) tb(1,2) AB fv_subset_subterms + wt_subst_trm''[OF ta(3), of ta] wt_subst_trm''[OF tb(3), of tb] + by (fast, fast, blast, simp) + + obtain \ where \: "Unifier \ ta tb" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using vars_term_disjoint_imp_unifier[OF ta_tb_wf(3), of \a \b] + ta(1) tb(1) wt_Unifier_if_Unifier[OF ta_tb_wf(1,2,4)] + by blast + hence "(Q ta \ Q tb) \ (R ta \ R tb)" using ABC ta(2) tb(2) unfolding P_def by blast+ + thus "t \ f C \ {m. {} \\<^sub>c m}" + proof + show "Q ta \ Q tb \ ?thesis" + using ta(1) pgwt_ground[of ta] pgwt_is_empty_synth[of ta] subst_ground_ident[of ta \a] + unfolding Q_def f_def intruder_synth_code[symmetric] by simp + next + assume "R ta \ R tb" + then obtain ua \a where ua: "ta = ua \ \a" "ua \ C" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \a" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \a)" + using \ ABC ta_tb_wf(1,2) ta(2) tb(2) C is_wt_instance_of_condD' + unfolding P_def R_def by metis + + have "t = ua \ (\a \\<^sub>s \a)" "fv t = {}" + using ua(1) ta(1,5) tb(1,5) by auto + thus ?thesis + using ua(2) wt_subst_compose[OF ua(3) ta(3)] wf_trms_subst_compose[OF ua(4) ta(4)] + unfolding f_def by blast + qed +qed + +lemma ground_SMP_disjointI: + fixes A B::"('fun, ('fun, 'atom) term \ nat) term list" and C + defines "f \ \M. {t \ \ | t \. t \ M \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and "g \ \M. {t \ M. fv t = {}}" + and "Q \ \t. intruder_synth' public arity {} t" + and "R \ \t. \u \ C. is_wt_instance_of_cond \ t u" + assumes AB_fv_disj: "fv\<^sub>s\<^sub>e\<^sub>t (set A) \ fv\<^sub>s\<^sub>e\<^sub>t (set B) = {}" + and A_SMP_repr: "finite_SMP_representation arity Ana \ A" + and B_SMP_repr: "finite_SMP_representation arity Ana \ B" + and C_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s C" + and ABC: "\t \ set A. \s \ set B. \ t = \ s \ mgu t s \ None \ (Q t \ Q s) \ (R t \ R s)" + shows "g (SMP (set A)) \ g (SMP (set B)) \ f C \ {m. {} \\<^sub>c m}" +proof - + have AB_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set A)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set B)" + using A_SMP_repr B_SMP_repr + unfolding finite_SMP_representation_def wf\<^sub>t\<^sub>r\<^sub>m_code list_all_iff + by blast+ + + let ?P = "\t s. \\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ Unifier \ t s" + have ABC': "\t \ set A. \s \ set B. ?P t s \ (Q t \ Q s) \ (R t \ R s)" + by (metis (no_types) ABC mgu_None_is_subst_neq wt_subst_trm'') + + show ?thesis + using ground_SMP_disjointI_aux1[OF f_def g_def, of "set A"] + ground_SMP_disjointI_aux1[OF f_def g_def, of "set B"] + ground_SMP_disjointI_aux2[OF f_def A_SMP_repr] + ground_SMP_disjointI_aux2[OF f_def B_SMP_repr] + ground_SMP_disjointI_aux3[OF f_def Q_def R_def AB_wf AB_fv_disj C_wf ABC'] + by argo +qed + +end + +end + +end diff --git a/Stateful_Protocol_Composition_and_Typing/Typing_Result.thy b/Stateful_Protocol_Composition_and_Typing/Typing_Result.thy new file mode 100644 index 0000000..f696e12 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/Typing_Result.thy @@ -0,0 +1,3463 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Typing_Result.thy + Author: Andreas Viktor Hess, DTU +*) + +section \The Typing Result\ + +theory Typing_Result +imports Typed_Model +begin + +subsection \The Typing Result for the Composition-Only Intruder\ +context typed_model +begin + +subsubsection \Well-typedness and Type-Flaw Resistance Preservation\ +context +begin + +private lemma LI_preserves_tfr_stp_all_single: + assumes "(S,\) \ (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + shows "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" +using assms +proof (induction rule: LI_rel.induct) + case (Compose S X f S' \) + hence "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" by simp_all + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (map Send X)" by (induct X) auto + ultimately show ?case by simp +next + case (Unify S f Y \ X S' \) + hence "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')" by simp + + have "fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S') \ bvars\<^sub>s\<^sub>t (S@S') = {}" + using Unify.prems(1) by (auto simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + moreover have "fv (Fun f X) \ fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" by auto + moreover have "fv (Fun f Y) \ fv\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" + using Unify.hyps(2) fv_subset_if_in_strand_ik'[of "Fun f Y" S] by force + ultimately have bvars_disj: + "bvars\<^sub>s\<^sub>t (S@S') \ fv (Fun f X) = {}" "bvars\<^sub>s\<^sub>t (S@S') \ fv (Fun f Y) = {}" + by blast+ + + have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)" using Unify.prems(5) by simp + moreover have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)" + proof - + obtain x where "x \ set S" "Fun f Y \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p x)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p x)" + using Unify.hyps(2) Unify.prems(5) by force+ + thus ?thesis using wf_trm_subterm by auto + qed + moreover have + "Fun f X \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" "Fun f Y \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S'] + SMP_ikI[OF Unify.hyps(2)] + by auto + hence "\ (Fun f X) = \ (Fun f Y)" + using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]] + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Unify.hyps(3)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\ \wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)\] + by (metis wf_trm_subst_range_iff) + moreover have "bvars\<^sub>s\<^sub>t (S@S') \ range_vars \ = {}" + using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] bvars_disj by fast + ultimately show ?case using tfr_stp_all_wt_subst_apply[OF \list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')\] by metis +next + case (Equality S \ t t' a S' \) + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')" "\ t = \ t'" + using tfr_stp_all_same_type[of S a t t' S'] + tfr_stp_all_split(5)[of S _ S'] + MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]] + Equality.prems(3) + by blast+ + moreover have "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" using Equality.prems(5) by auto + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]] + by metis + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Equality.hyps(2)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m t\ \wf\<^sub>t\<^sub>r\<^sub>m t'\] + by (metis wf_trm_subst_range_iff) + moreover have "fv\<^sub>s\<^sub>t (S@Equality a t t'#S') \ bvars\<^sub>s\<^sub>t (S@Equality a t t'#S') = {}" + using Equality.prems(1) by (auto simp add: wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def) + hence "bvars\<^sub>s\<^sub>t (S@S') \ fv t = {}" "bvars\<^sub>s\<^sub>t (S@S') \ fv t' = {}" by auto + hence "bvars\<^sub>s\<^sub>t (S@S') \ range_vars \ = {}" + using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by fast + ultimately show ?case using tfr_stp_all_wt_subst_apply[OF \list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@S')\] by metis +qed + +private lemma LI_in_SMP_subset_single: + assumes "(S,\) \ (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + and "trms\<^sub>s\<^sub>t S \ SMP M" + shows "trms\<^sub>s\<^sub>t S' \ SMP M" +using assms +proof (induction rule: LI_rel.induct) + case (Compose S X f S' \) + hence "SMP (trms\<^sub>s\<^sub>t [Send (Fun f X)]) \ SMP M" + proof - + have "SMP (trms\<^sub>s\<^sub>t [Send (Fun f X)]) \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + using trms\<^sub>s\<^sub>t_append SMP_mono by auto + thus ?thesis + using SMP_union[of "trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S')" M] + SMP_subset_union_eq[OF Compose.prems(6)] + by auto + qed + thus ?case using Compose.prems(6) by auto +next + case (Unify S f Y \ X S' \) + have "Fun f X \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" by auto + moreover have "MGU \ (Fun f X) (Fun f Y)" + by (metis mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]) + moreover have + "\x. x \ set S \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p x)" "wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)" + using Unify.prems(4) by force+ + moreover have "Fun f Y \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + by (meson SMP_ikI Unify.hyps(2) contra_subsetD ik_append_subset(1)) + ultimately have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)" "\ (Fun f X) = \ (Fun f Y)" + using ik\<^sub>s\<^sub>t_subterm_exD[OF \Fun f Y \ ik\<^sub>s\<^sub>t S\] \tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))\ + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (metis (full_types) SMP_wf_trm Unify.prems(4), blast) + hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" by (metis mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\]) + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Unify.hyps(3)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\ \wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)\] by simp + ultimately have "trms\<^sub>s\<^sub>t ((S@Send (Fun f X)#S') \\<^sub>s\<^sub>t \) \ SMP M" + using SMP.Substitution Unify.prems(6) wt_subst_SMP_subset by metis + thus ?case by auto +next + case (Equality S \ t t' a S' \) + hence "\ t = \ t'" + using tfr_stp_all_same_type MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]] + by metis + moreover have "t \ SMP (trms\<^sub>s\<^sub>t (S@Equality a t t'#S'))" "t' \ SMP (trms\<^sub>s\<^sub>t (S@Equality a t t'#S'))" + using Equality.prems(1) by auto + moreover have "MGU \ t t'" using mgu_gives_MGU[OF Equality.hyps(2)[symmetric]] by metis + moreover have "\x. x \ set S \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p x)" "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" + using Equality.prems(4) by force+ + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" by (metis mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m t\]) + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using mgu_wf_trm[OF Equality.hyps(2)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m t\ \wf\<^sub>t\<^sub>r\<^sub>m t'\] by simp + ultimately have "trms\<^sub>s\<^sub>t ((S@Equality a t t'#S') \\<^sub>s\<^sub>t \) \ SMP M" + using SMP.Substitution Equality.prems wt_subst_SMP_subset by metis + thus ?case by auto +qed + +private lemma LI_preserves_tfr_single: + assumes "(S,\) \ (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S') \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S')" +using assms +proof (induction rule: LI_rel.induct) + case (Compose S X f S' \) + let ?SMPmap = "SMP (trms\<^sub>s\<^sub>t (S@map Send X@S')) - (Var`\)" + have "?SMPmap \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S')) - (Var`\)" + using SMP_fun_map_snd_subset[of X f] + SMP_append[of "map Send X" S'] SMP_Cons[of "Send (Fun f X)" S'] + SMP_append[of S "Send (Fun f X)#S'"] SMP_append[of S "map Send X@S'"] + by auto + hence "\s \ ?SMPmap. \t \ ?SMPmap. (\\. Unifier \ s t) \ \ s = \ t" + using Compose unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (meson subsetCE) + thus ?case + using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Compose[OF Compose.hyps]], of S'] + Compose.prems(5) + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast +next + case (Unify S f Y \ X S' \) + let ?SMP\ = "SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \)) - (Var`\)" + + have "SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \)) \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + proof + fix s assume "s \ SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \))" thus "s \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + using LI_in_SMP_subset_single[ + OF LI_rel.Unify[OF Unify.hyps] Unify.prems(1,2,4,5,6) + MP_subset_SMP(2)[of "S@Send (Fun f X)#S'"]] + by (metis SMP_union SMP_subset_union_eq Un_iff) + qed + hence "\s \ ?SMP\. \t \ ?SMP\. (\\. Unifier \ s t) \ \ s = \ t" + using Unify.prems(4) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (meson Diff_iff subsetCE) + thus ?case + using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Unify[OF Unify.hyps]], of S'] + Unify.prems(5) + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast +next + case (Equality S \ t t' a S' \) + let ?SMP\ = "SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \)) - (Var`\)" + + have "SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \)) \ SMP (trms\<^sub>s\<^sub>t (S@Equality a t t'#S'))" + proof + fix s assume "s \ SMP (trms\<^sub>s\<^sub>t (S@S' \\<^sub>s\<^sub>t \))" thus "s \ SMP (trms\<^sub>s\<^sub>t (S@Equality a t t'#S'))" + using LI_in_SMP_subset_single[ + OF LI_rel.Equality[OF Equality.hyps] Equality.prems(1,2,4,5,6) + MP_subset_SMP(2)[of "S@Equality a t t'#S'"]] + by (metis SMP_union SMP_subset_union_eq Un_iff) + qed + hence "\s \ ?SMP\. \t \ ?SMP\. (\\. Unifier \ s t) \ \ s = \ t" + using Equality.prems unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (meson Diff_iff subsetCE) + thus ?case + using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Equality[OF Equality.hyps]], of _ S'] + Equality.prems + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast +qed + +private lemma LI_preserves_welltypedness_single: + assumes "(S,\) \ (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \' \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \')" +using assms +proof (induction rule: LI_rel.induct) + case (Unify S f Y \ X S' \) + have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)" using Unify.prems(5) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by simp + moreover have "wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)" + proof - + obtain x where "x \ set S" "Fun f Y \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t\<^sub>p x)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t\<^sub>p x)" + using Unify.hyps(2) Unify.prems(5) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by force + thus ?thesis using wf_trm_subterm by auto + qed + moreover have + "Fun f X \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" "Fun f Y \ SMP (trms\<^sub>s\<^sub>t (S@Send (Fun f X)#S'))" + using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S'] + SMP_ikI[OF Unify.hyps(2)] + by auto + hence "\ (Fun f X) = \ (Fun f Y)" + using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]] + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by blast + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis + + have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + by (meson mgu_wf_trm[OF Unify.hyps(3)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m (Fun f X)\ \wf\<^sub>t\<^sub>r\<^sub>m (Fun f Y)\] + wf_trm_subst_range_iff) + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" + using wf_trm_subst_range_iff wf_trm_subst \wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)\ + unfolding subst_compose_def + by (metis (no_types, lifting)) + thus ?case by (metis wt_subst_compose[OF \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\]) +next + case (Equality S \ t t' a S' \) + have "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m t'" using Equality.prems(5) by simp_all + moreover have "\ t = \ t'" + using \list_all tfr\<^sub>s\<^sub>t\<^sub>p (S@Equality a t t'#S')\ + MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]] + by auto + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]] by metis + + have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + by (meson mgu_wf_trm[OF Equality.hyps(2)[symmetric] \wf\<^sub>t\<^sub>r\<^sub>m t\ \wf\<^sub>t\<^sub>r\<^sub>m t'\] wf_trm_subst_range_iff) + hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \))" + using wf_trm_subst_range_iff wf_trm_subst \wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)\ + unfolding subst_compose_def + by (metis (no_types, lifting)) + thus ?case by (metis wt_subst_compose[OF \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\]) +qed metis + +lemma LI_preserves_welltypedness: + assumes "(S,\) \\<^sup>* (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \'" (is "?A \'") + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \')" (is "?B \'") +proof - + have "?A \' \ ?B \'" using assms + proof (induction S \ rule: converse_rtrancl_induct2) + case (step S1 \1 S2 \2) + hence "?A \2 \ ?B \2" using LI_preserves_welltypedness_single by presburger + moreover have "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S2 \2" + by (fact LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)]) + moreover have "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S2)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S2)" + using LI_preserves_tfr_single[OF step.hyps(1)] step.prems by presburger+ + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S2" + using LI_preserves_tfr_stp_all_single[OF step.hyps(1)] step.prems by fastforce + ultimately show ?case using step.IH by presburger + qed simp + thus "?A \'" "?B \'" by simp_all +qed + +lemma LI_preserves_tfr: + assumes "(S,\) \\<^sup>* (S',\')" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + and "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S')" (is "?A S'") + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S')" (is "?B S'") + and "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" (is "?C S'") +proof - + have "?A S' \ ?B S' \ ?C S'" using assms + proof (induction S \ rule: converse_rtrancl_induct2) + case (step S1 \1 S2 \2) + have "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S2 \2" "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S2)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S2)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S2" + using LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)] + LI_preserves_tfr_single[OF step.hyps(1) step.prems(1,2)] + LI_preserves_tfr_stp_all_single[OF step.hyps(1) step.prems(1,2)] + step.prems(3,4,5,6) + by metis+ + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \2" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \2)" + using LI_preserves_welltypedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems] + by simp_all + ultimately show ?case using step.IH by presburger + qed blast + thus "?A S'" "?B S'" "?C S'" by simp_all +qed +end + +subsubsection \Simple Constraints are Well-typed Satisfiable\ +text \Proving the existence of a well-typed interpretation\ +context +begin +lemma wt_interpretation_exists: + obtains \::"('fun,'var) subst" + where "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "subst_range \ \ public_ground_wf_terms" +proof + define \ where "\ = (\x. (SOME t. \ (Var x) = \ t \ public_ground_wf_term t))" + + { fix x t assume "\ x = t" + hence "\ (Var x) = \ t \ public_ground_wf_term t" + using someI_ex[of "\t. \ (Var x) = \ t \ public_ground_wf_term t", + OF type_pgwt_inhabited[of "Var x"]] + unfolding \_def wf\<^sub>t\<^sub>r\<^sub>m_def by simp + } hence props: "\ v = t \ \ (Var v) = \ t \ public_ground_wf_term t" for v t by metis + + have "\ v \ Var v" for v using props pgwt_ground by force + hence "subst_domain \ = UNIV" by auto + moreover have "ground (subst_range \)" by (simp add: props pgwt_ground) + ultimately show "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" by metis + show "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def using props by simp + show "subst_range \ \ public_ground_wf_terms" by (auto simp add: props) +qed + +lemma wt_grounding_subst_exists: + "\\. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}" +proof - + obtain \ where \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "subst_range \ \ public_ground_wf_terms" + using wt_interpretation_exists by blast + show ?thesis using pgwt_wellformed interpretation_grounds[OF \(1)] \(2,3) by blast +qed + +private fun fresh_pgwt::"'fun set \ ('fun,'atom) term_type \ ('fun,'var) term" where + "fresh_pgwt S (TAtom a) = + Fun (SOME c. c \ S \ \ (Fun c []) = TAtom a \ public c) []" +| "fresh_pgwt S (TComp f T) = Fun f (map (fresh_pgwt S) T)" + +private lemma fresh_pgwt_same_type: + assumes "finite S" "wf\<^sub>t\<^sub>r\<^sub>m t" + shows "\ (fresh_pgwt S (\ t)) = \ t" +proof - + let ?P = "\\::('fun,'atom) term_type. wf\<^sub>t\<^sub>r\<^sub>m \ \ (\f T. TComp f T \ \ \ 0 < arity f)" + { fix \ assume "?P \" hence "\ (fresh_pgwt S \) = \" + proof (induction \) + case (Var a) + let ?P = "\c. c \ S \ \ (Fun c []) = Var a \ public c" + let ?Q = "\c. \ (Fun c []) = Var a \ public c" + have " {c. ?Q c} - S = {c. ?P c}" by auto + hence "infinite {c. ?P c}" + using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]] + by metis + hence "\c. ?P c" using not_finite_existsD by blast + thus ?case using someI_ex[of ?P] by auto + next + case (Fun f T) + have f: "0 < arity f" using Fun.prems fun_type_inv by auto + have "\t. t \ set T \ ?P t" + using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm + by metis + hence "\t. t \ set T \ \ (fresh_pgwt S t) = t" using Fun.prems Fun.IH by auto + hence "map \ (map (fresh_pgwt S) T) = T" by (induct T) auto + thus ?case using fun_type[OF f] by simp + qed + } thus ?thesis using assms(1) \_wf'[OF assms(2)] \_wf(1) by auto +qed + +private lemma fresh_pgwt_empty_synth: + assumes "finite S" "wf\<^sub>t\<^sub>r\<^sub>m t" + shows "{} \\<^sub>c fresh_pgwt S (\ t)" +proof - + let ?P = "\\::('fun,'atom) term_type. wf\<^sub>t\<^sub>r\<^sub>m \ \ (\f T. TComp f T \ \ \ 0 < arity f)" + { fix \ assume "?P \" hence "{} \\<^sub>c fresh_pgwt S \" + proof (induction \) + case (Var a) + let ?P = "\c. c \ S \ \ (Fun c []) = Var a \ public c" + let ?Q = "\c. \ (Fun c []) = Var a \ public c" + have " {c. ?Q c} - S = {c. ?P c}" by auto + hence "infinite {c. ?P c}" + using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]] + by metis + hence "\c. ?P c" using not_finite_existsD by blast + thus ?case + using someI_ex[of ?P] intruder_synth.ComposeC[of "[]" _ "{}"] const_type_inv + by auto + next + case (Fun f T) + have f: "0 < arity f" "length T = arity f" "public f" + using Fun.prems fun_type_inv unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + have "\t. t \ set T \ ?P t" + using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm + by metis + hence "\t. t \ set T \ {} \\<^sub>c fresh_pgwt S t" using Fun.prems Fun.IH by auto + moreover have "length (map (fresh_pgwt S) T) = arity f" using f(2) by auto + ultimately show ?case using intruder_synth.ComposeC[of "map (fresh_pgwt S) T" f] f by auto + qed + } thus ?thesis using assms(1) \_wf'[OF assms(2)] \_wf(1) by auto +qed + +private lemma fresh_pgwt_has_fresh_const: + assumes "finite S" "wf\<^sub>t\<^sub>r\<^sub>m t" + obtains c where "Fun c [] \ fresh_pgwt S (\ t)" "c \ S" +proof - + let ?P = "\\::('fun,'atom) term_type. wf\<^sub>t\<^sub>r\<^sub>m \ \ (\f T. TComp f T \ \ \ 0 < arity f)" + { fix \ assume "?P \" hence "\c. Fun c [] \ fresh_pgwt S \ \ c \ S" + proof (induction \) + case (Var a) + let ?P = "\c. c \ S \ \ (Fun c []) = Var a \ public c" + let ?Q = "\c. \ (Fun c []) = Var a \ public c" + have " {c. ?Q c} - S = {c. ?P c}" by auto + hence "infinite {c. ?P c}" + using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]] + by metis + hence "\c. ?P c" using not_finite_existsD by blast + thus ?case using someI_ex[of ?P] by auto + next + case (Fun f T) + have f: "0 < arity f" "length T = arity f" "public f" "T \ []" + using Fun.prems fun_type_inv unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + obtain t' where t': "t' \ set T" by (meson all_not_in_conv f(4) set_empty) + have "\t. t \ set T \ ?P t" + using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm + by metis + hence "\t. t \ set T \ \c. Fun c [] \ fresh_pgwt S t \ c \ S" + using Fun.prems Fun.IH by auto + then obtain c where c: "Fun c [] \ fresh_pgwt S t'" "c \ S" using t' by metis + thus ?case using t' by auto + qed + } thus ?thesis using that assms \_wf'[OF assms(2)] \_wf(1) by blast +qed + +private lemma fresh_pgwt_subterm_fresh: + assumes "finite S" "wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m s" "funs_term s \ S" + shows "s \ subterms (fresh_pgwt S (\ t))" +proof - + let ?P = "\\::('fun,'atom) term_type. wf\<^sub>t\<^sub>r\<^sub>m \ \ (\f T. TComp f T \ \ \ 0 < arity f)" + { fix \ assume "?P \" hence "s \ subterms (fresh_pgwt S \)" + proof (induction \) + case (Var a) + let ?P = "\c. c \ S \ \ (Fun c []) = Var a \ public c" + let ?Q = "\c. \ (Fun c []) = Var a \ public c" + have " {c. ?Q c} - S = {c. ?P c}" by auto + hence "infinite {c. ?P c}" + using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]] + by metis + hence "\c. ?P c" using not_finite_existsD by blast + thus ?case using someI_ex[of ?P] assms(4) by auto + next + case (Fun f T) + have f: "0 < arity f" "length T = arity f" "public f" + using Fun.prems fun_type_inv unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by auto + have "\t. t \ set T \ ?P t" + using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm + by metis + hence "\t. t \ set T \ s \ subterms (fresh_pgwt S t)" using Fun.prems Fun.IH by auto + moreover have "s \ fresh_pgwt S (Fun f T)" + proof - + obtain c where c: "Fun c [] \ fresh_pgwt S (Fun f T)" "c \ S" + using fresh_pgwt_has_fresh_const[OF assms(1)] type_wfttype_inhabited Fun.prems + by metis + hence "\Fun c [] \ s" using assms(4) subtermeq_imp_funs_term_subset by force + thus ?thesis using c(1) by auto + qed + ultimately show ?case by auto + qed + } thus ?thesis using assms(1) \_wf'[OF assms(2)] \_wf(1) by auto +qed + +private lemma wt_fresh_pgwt_term_exists: + assumes "finite T" "wf\<^sub>t\<^sub>r\<^sub>m s" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s T" + obtains t where "\ t = \ s" "{} \\<^sub>c t" "\s \ T. \u \ subterms s. u \ subterms t" +proof - + have finite_S: "finite (\(funs_term ` T))" using assms(1) by auto + + have 1: "\ (fresh_pgwt (\(funs_term ` T)) (\ s)) = \ s" + using fresh_pgwt_same_type[OF finite_S assms(2)] by auto + + have 2: "{} \\<^sub>c fresh_pgwt (\(funs_term ` T)) (\ s)" + using fresh_pgwt_empty_synth[OF finite_S assms(2)] by auto + + have 3: "\v \ T. \u \ subterms v. u \ subterms (fresh_pgwt (\(funs_term ` T)) (\ s))" + using fresh_pgwt_subterm_fresh[OF finite_S assms(2)] assms(3) + wf_trm_subtermeq subtermeq_imp_funs_term_subset + by force + + show ?thesis by (rule that[OF 1 2 3]) +qed + +lemma wt_bij_finite_subst_exists: + assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s T" + shows "\\::('fun,'var) subst. + subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ {t. {} \\<^sub>c t} - T + \ (\s \ subst_range \. \u \ subst_range \. (\v. v \ s \ v \ u) \ s = u) + \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ + \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +using assms +proof (induction rule: finite_induct) + case empty + have "subst_domain Var = {}" + "bij_betw Var (subst_domain Var) (subst_range Var)" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range Var) \ {t. {} \\<^sub>c t} - T" + "\s \ subst_range Var. \u \ subst_range Var. (\v. v \ s \ v \ u) \ s = u" + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" + unfolding bij_betw_def + by auto + thus ?case by (force simp add: subst_domain_def) +next + case (insert x S) + then obtain \ where \: + "subst_domain \ = S" "bij_betw \ (subst_domain \) (subst_range \)" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ {t. {} \\<^sub>c t} - T" + "\s \ subst_range \. \u \ subst_range \. (\v. v \ s \ v \ u) \ s = u" + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + by (auto simp del: subst_range.simps) + + have *: "finite (T \ subst_range \)" + using insert.prems(1) insert.hyps(1) \(1) by simp + have **: "wf\<^sub>t\<^sub>r\<^sub>m (Var x)" by simp + have ***: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (T \ subst_range \)" using assms(3) \(6) by blast + obtain t where t: + "\ t = \ (Var x)" "{} \\<^sub>c t" + "\s \ T \ subst_range \. \u \ subterms s. u \ subterms t" + using wt_fresh_pgwt_term_exists[OF * ** ***] by auto + + obtain \ where \: "\ \ \y. if x = y then t else \ y" by simp + + have t_ground: "fv t = {}" using t(2) pgwt_ground[of t] pgwt_is_empty_synth[of t] by auto + hence x_dom: "x \ subst_domain \" "x \ subst_domain \" using insert.hyps(2) \(1) \ by auto + moreover have "subst_range \ \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" by auto + hence ground_imgs: "ground (subst_range \)" + using \(3) pgwt_ground pgwt_is_empty_synth + by force + ultimately have x_img: "\ x \ subst_range \" + using ground_subst_dom_iff_img + by (auto simp add: subst_domain_def) + + have "ground (insert t (subst_range \))" + using ground_imgs x_dom t_ground + by auto + have \_dom: "subst_domain \ = insert x (subst_domain \)" + using \ t_ground by (auto simp add: subst_domain_def) + have \_img: "subst_range \ = insert t (subst_range \)" + proof + show "subst_range \ \ insert t (subst_range \)" + proof + fix t' assume "t' \ subst_range \" + then obtain y where "y \ subst_domain \" "t' = \ y" by auto + thus "t' \ insert t (subst_range \)" using \ by (auto simp add: subst_domain_def) + qed + show "insert t (subst_range \) \ subst_range \" + proof + fix t' assume t': "t' \ insert t (subst_range \)" + hence "fv t' = {}" using ground_imgs x_img t_ground by auto + hence "t' \ Var x" by auto + show "t' \ subst_range \" + proof (cases "t' = t") + case False + hence "t' \ subst_range \" using t' by auto + then obtain y where "\ y \ subst_range \" "t' = \ y" by auto + hence "y \ subst_domain \" "t' \ Var y" + using ground_subst_dom_iff_img[OF ground_imgs(1)] + by (auto simp add: subst_domain_def simp del: subst_range.simps) + hence "x \ y" using x_dom by auto + hence "\ y = \ y" unfolding \ by auto + thus ?thesis using \t' \ Var y\ \t' = \ y\ subst_imgI[of \ y] by auto + qed (metis subst_imgI \ \t' \ Var x\) + qed + qed + hence \_ground_img: "ground (subst_range \)" + using ground_imgs t_ground + by auto + + have "subst_domain \ = insert x S" using \_dom \(1) by auto + moreover have "bij_betw \ (subst_domain \) (subst_range \)" + proof (intro bij_betwI') + fix y z assume *: "y \ subst_domain \" "z \ subst_domain \" + hence "fv (\ y) = {}" "fv (\ z) = {}" using \_ground_img by auto + { assume "\ y = \ z" hence "y = z" + proof (cases "\ y \ subst_range \ \ \ z \ subst_range \") + case True + hence **: "y \ subst_domain \" "z \ subst_domain \" + using \ \_dom True * t(3) by (metis Un_iff term.order_refl insertE)+ + hence "y \ x" "z \ x" using x_dom by auto + hence "\ y = \ y" "\ z = \ z" using \ by auto + thus ?thesis using \\ y = \ z\ \(2) ** unfolding bij_betw_def inj_on_def by auto + qed (metis \ * \\ y = \ z\ \_dom ground_imgs(1) ground_subst_dom_iff_img insertE) + } + thus "(\ y = \ z) = (y = z)" by auto + next + fix y assume "y \ subst_domain \" thus "\ y \ subst_range \" by auto + next + fix t assume "t \ subst_range \" thus "\z \ subst_domain \. t = \ z" by auto + qed + moreover have "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ {t. {} \\<^sub>c t} - T" + proof - + { fix s assume "s \ t" + hence "s \ {t. {} \\<^sub>c t} - T" + using t(2,3) + by (metis Diff_eq_empty_iff Diff_iff Un_upper1 term.order_refl + deduct_synth_subterm mem_Collect_eq) + } thus ?thesis using \(3) \ \_img by auto + qed + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using \ t(1) \(5) unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by auto + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using \ \(6) t(2) pgwt_is_empty_synth pgwt_wellformed + wf_trm_subst_range_iff[of \] wf_trm_subst_range_iff[of \] + by metis + moreover have "\s\subst_range \. \u\subst_range \. (\v. v \ s \ v \ u) \ s = u" + using \(4) \_img t(3) by (auto simp del: subst_range.simps) + ultimately show ?case by blast +qed + +private lemma wt_bij_finite_tatom_subst_exists_single: + assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)" + and "\x. x \ S \ \ (Var x) = TAtom a" + shows "\\::('fun,'var) subst. subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subst_range \ \ ((\c. Fun c []) ` {c. \ (Fun c []) = TAtom a \ + public c \ arity c = 0}) - T + \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ + \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +proof - + let ?U = "{c. \ (Fun c []) = TAtom a \ public c \ arity c = 0}" + + obtain \ where \: + "subst_domain \ = S" "bij_betw \ (subst_domain \) (subst_range \)" + "subst_range \ \ ((\c. Fun c []) ` ?U) - T" + using bij_finite_const_subst_exists'[OF assms(1,2) infinite_typed_consts'[of a]] + by auto + + { fix x assume "x \ subst_domain \" hence "\ (Var x) = \ (\ x)" by auto } + moreover + { fix x assume "x \ subst_domain \" + hence "\c \ ?U. \ x = Fun c [] \ arity c = 0" using \ by auto + hence "\ (\ x) = TAtom a" "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" using assms(3) const_type wf_trmI[of "[]"] by auto + hence "\ (Var x) = \ (\ x)" "wf\<^sub>t\<^sub>r\<^sub>m (\ x)" using assms(3) \(1) by force+ + } + ultimately have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using wf_trm_subst_range_iff[of \] + unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def + by force+ + thus ?thesis using \ by auto +qed + +lemma wt_bij_finite_tatom_subst_exists: + assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)" + and "\x. x \ S \ \a. \ (Var x) = TAtom a" + shows "\\::('fun,'var) subst. subst_domain \ = S + \ bij_betw \ (subst_domain \) (subst_range \) + \ subst_range \ \ ((\c. Fun c []) ` \\<^sub>p\<^sub>u\<^sub>b) - T + \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ + \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +using assms +proof (induction rule: finite_induct) + case empty + have "subst_domain Var = {}" + "bij_betw Var (subst_domain Var) (subst_range Var)" + "subst_range Var \ ((\c. Fun c []) ` \\<^sub>p\<^sub>u\<^sub>b) - T" + "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" + unfolding bij_betw_def + by auto + thus ?case by (auto simp add: subst_domain_def) +next + case (insert x S) + then obtain a where a: "\ (Var x) = TAtom a" by fastforce + + from insert obtain \ where \: + "subst_domain \ = S" "bij_betw \ (subst_domain \) (subst_range \)" + "subst_range \ \ ((\c. Fun c []) ` \\<^sub>p\<^sub>u\<^sub>b) - T" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + by auto + + let ?S' = "{y \ S. \ (Var y) = TAtom a}" + let ?T' = "T \ subst_range \" + + have *: "finite (insert x ?S')" using insert by simp + have **: "finite ?T'" using insert.prems(1) insert.hyps(1) \(1) by simp + have ***: "\y. y \ insert x ?S' \ \ (Var y) = TAtom a" using a by auto + + obtain \ where \: + "subst_domain \ = insert x ?S'" "bij_betw \ (subst_domain \) (subst_range \)" + "subst_range \ \ ((\c. Fun c []) ` \\<^sub>p\<^sub>u\<^sub>b) - ?T'" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using wt_bij_finite_tatom_subst_exists_single[OF * ** ***] const_type_inv[of _ "[]" a] + by blast + + obtain \ where \: "\ \ \y. if x = y then \ y else \ y" by simp + + have x_dom: "x \ subst_domain \" "x \ subst_domain \" "x \ subst_domain \" + using insert.hyps(2) \(1) \(1) \ by (auto simp add: subst_domain_def) + moreover have ground_imgs: "ground (subst_range \)" "ground (subst_range \)" + using pgwt_ground \(3) \(3) by auto + ultimately have x_img: "\ x \ subst_range \" "\ x \ subst_range \" + using ground_subst_dom_iff_img by (auto simp add: subst_domain_def) + + have "ground (insert (\ x) (subst_range \))" using ground_imgs x_dom by auto + have \_dom: "subst_domain \ = insert x (subst_domain \)" + using \(1) \ by (auto simp add: subst_domain_def) + have \_img: "subst_range \ = insert (\ x) (subst_range \)" + proof + show "subst_range \ \ insert (\ x) (subst_range \)" + proof + fix t assume "t \ subst_range \" + then obtain y where "y \ subst_domain \" "t = \ y" by auto + thus "t \ insert (\ x) (subst_range \)" using \ by (auto simp add: subst_domain_def) + qed + show "insert (\ x) (subst_range \) \ subst_range \" + proof + fix t assume t: "t \ insert (\ x) (subst_range \)" + hence "fv t = {}" using ground_imgs x_img(2) by auto + hence "t \ Var x" by auto + show "t \ subst_range \" + proof (cases "t = \ x") + case True thus ?thesis using subst_imgI \ \t \ Var x\ by metis + next + case False + hence "t \ subst_range \" using t by auto + then obtain y where "\ y \ subst_range \" "t = \ y" by auto + hence "y \ subst_domain \" "t \ Var y" + using ground_subst_dom_iff_img[OF ground_imgs(1)] + by (auto simp add: subst_domain_def simp del: subst_range.simps) + hence "x \ y" using x_dom by auto + hence "\ y = \ y" unfolding \ by auto + thus ?thesis using \t \ Var y\ \t = \ y\ subst_imgI[of \ y] by auto + qed + qed + qed + hence \_ground_img: "ground (subst_range \)" using ground_imgs x_img by auto + + have "subst_domain \ = insert x S" using \_dom \(1) by auto + moreover have "bij_betw \ (subst_domain \) (subst_range \)" + proof (intro bij_betwI') + fix y z assume *: "y \ subst_domain \" "z \ subst_domain \" + hence "fv (\ y) = {}" "fv (\ z) = {}" using \_ground_img by auto + { assume "\ y = \ z" hence "y = z" + proof (cases "\ y \ subst_range \ \ \ z \ subst_range \") + case True + hence **: "y \ subst_domain \" "z \ subst_domain \" + using \ \_dom x_img(2) \(3) True + by (metis (no_types) *(1) DiffE Un_upper2 insertE subsetCE, + metis (no_types) *(2) DiffE Un_upper2 insertE subsetCE) + hence "y \ x" "z \ x" using x_dom by auto + hence "\ y = \ y" "\ z = \ z" using \ by auto + thus ?thesis using \\ y = \ z\ \(2) ** unfolding bij_betw_def inj_on_def by auto + qed (metis \ * \\ y = \ z\ \_dom ground_imgs(1) ground_subst_dom_iff_img insertE) + } + thus "(\ y = \ z) = (y = z)" by auto + next + fix y assume "y \ subst_domain \" thus "\ y \ subst_range \" by auto + next + fix t assume "t \ subst_range \" thus "\z \ subst_domain \. t = \ z" by auto + qed + moreover have "subst_range \ \ (\c. Fun c []) ` \\<^sub>p\<^sub>u\<^sub>b - T" + using \(3) \(3) \ by (auto simp add: subst_domain_def) + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" using \(4) \(4) \ unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by auto + moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using \ \(5) \(5) wf_trm_subst_range_iff[of \] + wf_trm_subst_range_iff[of \] wf_trm_subst_range_iff[of \] + by presburger + ultimately show ?case by blast +qed + +theorem wt_sat_if_simple: + assumes "simple S" "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + and \': "\X F. Inequality X F \ set S \ ineq_model \' X F" + "ground (subst_range \')" + "subst_domain \' = {x \ vars\<^sub>s\<^sub>t S. \X F. Inequality X F \ set S \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X}" + and tfr_stp_all: "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "\\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ (\ \\<^sub>c \S, \\) \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" +proof - + from \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \\ have "wf\<^sub>s\<^sub>t {} S" "subst_idem \" and S_\_disj: "\v \ vars\<^sub>s\<^sub>t S. \ v = Var v" + using subst_idemI[of \] unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by force+ + + obtain \::"('fun,'var) subst" + where \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "subst_range \ \ public_ground_wf_terms" + using wt_interpretation_exists by blast + hence \_deduct: "\x M. M \\<^sub>c \ x" and \_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using pgwt_deducible pgwt_wellformed by fastforce+ + + let ?P = "\\ X. subst_domain \ = set X \ ground (subst_range \)" + let ?Sineqsvars = "{x \ vars\<^sub>s\<^sub>t S. \X F. Inequality X F \ set S \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ x \ set X}" + let ?Strms = "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" + + have finite_vars: "finite ?Sineqsvars" "finite ?Strms" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s ?Strms" + using wf_trm_subtermeq assms(5) by fastforce+ + + define Q1 where "Q1 = (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \a. \ (Var x) = TAtom a)" + + define Q2 where "Q2 = (\(F::(('fun,'var) term \ ('fun,'var) term) list) X. + \f T. Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ T = [] \ (\s \ set T. s \ Var ` set X))" + + define Q1' where "Q1' = (\(t::('fun,'var) term) (t'::('fun,'var) term) X. + \x \ (fv t \ fv t') - set X. \a. \ (Var x) = TAtom a)" + + define Q2' where "Q2' = (\(t::('fun,'var) term) (t'::('fun,'var) term) X. + \f T. Fun f T \ subterms t \ subterms t' \ T = [] \ (\s \ set T. s \ Var ` set X))" + + have ex_P: "\X. \\. ?P \ X" using interpretation_subst_exists' by blast + + have tfr_ineq: "\X F. Inequality X F \ set S \ Q1 F X \ Q2 F X" + using tfr_stp_all Q1_def Q2_def tfr\<^sub>s\<^sub>t\<^sub>p_list_all_alt_def[of S] by blast + + have S_fv_bvars_disj: "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" using \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \\ unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def by metis + hence ineqs_vars_not_bound: "\X F x. Inequality X F \ set S \ x \ ?Sineqsvars \ x \ set X" + using strand_fv_bvars_disjoint_unfold by blast + + have \_vars_S_bvars_disj: "(subst_domain \ \ range_vars \) \ set X = {}" + when "Inequality X F \ set S" for F X + using wf_constr_bvars_disj[OF \wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \\] + strand_fv_bvars_disjointD(1)[OF S_fv_bvars_disj that] + by blast + + obtain \::"('fun,'var) subst" + where \_fv_dom: "subst_domain \ = ?Sineqsvars" + and \_subterm_inj: "subterm_inj_on \ (subst_domain \)" + and \_fresh_pub_img: "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ {t. {} \\<^sub>c t} - ?Strms" + and \_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and \_wf_trm: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + using wt_bij_finite_subst_exists[OF finite_vars] + subst_inj_on_is_bij_betw subterm_inj_on_alt_def' + by moura + + have \_bij_dom_img: "bij_betw \ (subst_domain \) (subst_range \)" + by (metis \_subterm_inj subst_inj_on_is_bij_betw subterm_inj_on_alt_def) + + have "finite (subst_domain \)" by(metis \_fv_dom finite_vars(1)) + hence \_finite_img: "finite (subst_range \)" using \_bij_dom_img bij_betw_finite by blast + + have \_img_subterms: "\s \ subst_range \. \u \ subst_range \. (\v. v \ s \ v \ u) \ s = u" + by (metis \_subterm_inj subterm_inj_on_alt_def') + + have "subst_range \ \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" by auto + hence "subst_range \ \ public_ground_wf_terms - ?Strms" + and \_pgwt_img: + "subst_range \ \ public_ground_wf_terms" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ public_ground_wf_terms" + using \_fresh_pub_img pgwt_is_empty_synth by blast+ + + have \_img_ground: "ground (subst_range \)" + using \_pgwt_img pgwt_ground by auto + hence \_inj: "inj \" + using \_bij_dom_img subst_inj_is_bij_betw_dom_img_if_ground_img by auto + + have \_ineqs_fv_dom: "\X F. Inequality X F \ set S \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ subst_domain \" + using \_fv_dom by fastforce + + have \_dom_bvars_disj: "\X F. Inequality X F \ set S \ subst_domain \ \ set X = {}" + using ineqs_vars_not_bound \_fv_dom by fastforce + + have \'1: "\X F \. Inequality X F \ set S \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ subst_domain \'" + using \'(3) ineqs_vars_not_bound by fastforce + + have \'2: "\X F. Inequality X F \ set S \ subst_domain \' \ set X = {}" + using \'(3) ineqs_vars_not_bound by blast + + have doms_eq: "subst_domain \' = subst_domain \" using \'(3) \_fv_dom by simp + + have \_ineqs_neq: "ineq_model \ X F" when "Inequality X F \ set S" for X F + proof - + obtain a::"'fun" where a: "a \ \(funs_term ` subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \))" + using exists_fun_notin_funs_terms[OF subterms_union_finite[OF \_finite_img]] + by moura + hence a': "\T. Fun a T \ subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \)" + "\S. Fun a [] \ set (Fun a []#S)" "Fun a [] \ Var ` set X" + by (meson a UN_I term.set_intros(1), auto) + + define t where "t \ Fun a (Fun a []#map fst F)" + define t' where "t' \ Fun a (Fun a []#map snd F)" + + note F_in = that + + have t_fv: "fv t \ fv t' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" + unfolding t_def t'_def by force + + have t_subterms: "subterms t \ subterms t' \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ {t, t', Fun a []}" + unfolding t_def t'_def by force + + have "t \ \ \ \ \ t' \ \ \ \" when "?P \ X" for \ + proof - + have tfr_assms: "Q1 F X \ Q2 F X" using tfr_ineq F_in by metis + + have "Q1 F X \ \x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X. \c. \ x = Fun c []" + proof + fix x assume "Q1 F X" and x: "x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X" + then obtain a where "\ (Var x) = TAtom a" unfolding Q1_def by moura + hence a: "\ (\ x) = TAtom a" using \_wt unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp + + have "x \ subst_domain \" using \_ineqs_fv_dom x F_in by auto + then obtain f T where fT: "\ x = Fun f T" by (meson \_img_ground ground_img_obtain_fun) + hence "T = []" using \_wf_trm a TAtom_term_cases by fastforce + thus "\c. \ x = Fun c []" using fT by metis + qed + hence 1: "Q1 F X \ \x \ (fv t \ fv t') - set X. \c. \ x = Fun c []" + using t_fv by auto + + have 2: "\Q1 F X \ Q2 F X" by (metis tfr_assms) + + have 3: "subst_domain \ \ set X = {}" using \_dom_bvars_disj F_in by auto + + have 4: "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ (subterms t \ subterms t') = {}" + proof - + define M1 where "M1 \ {t, t', Fun a []}" + define M2 where "M2 \ ?Strms" + + have "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ M2" + using F_in unfolding M2_def by force + moreover have "subterms t \ subterms t' \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) \ M1" + using t_subterms unfolding M1_def by blast + ultimately have *: "subterms t \ subterms t' \ M2 \ M1" + by auto + + have "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ M1 = {}" + "subterms\<^sub>s\<^sub>e\<^sub>t (subst_range \) \ M2 = {}" + using a' \_fresh_pub_img + unfolding t_def t'_def M1_def M2_def + by blast+ + thus ?thesis using * by blast + qed + + have 5: "(fv t \ fv t') - subst_domain \ \ set X" + using \_ineqs_fv_dom[OF F_in] t_fv + by auto + + have 6: "\\. ?P \ X \ t \ \ \ \' \ t' \ \ \ \'" + by (metis t_def t'_def \'(1) F_in ineq_model_singleE ineq_model_single_iff) + + have 7: "fv t \ fv t' - set X \ subst_domain \'" using \'1 F_in t_fv by force + + have 8: "subst_domain \' \ set X = {}" using \'2 F_in by auto + + have 9: "Q1' t t' X" when "Q1 F X" + using that t_fv + unfolding Q1_def Q1'_def t_def t'_def + by blast + + have 10: "Q2' t t' X" when "Q2 F X" unfolding Q2'_def + proof (intro allI impI) + fix f T assume "Fun f T \ subterms t \ subterms t'" + moreover { + assume "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)" + hence "T = [] \ (\s\set T. s \ Var ` set X)" by (metis Q2_def that) + } moreover { + assume "Fun f T = t" hence "T = [] \ (\s\set T. s \ Var ` set X)" + unfolding t_def using a'(2,3) by simp + } moreover { + assume "Fun f T = t'" hence "T = [] \ (\s\set T. s \ Var ` set X)" + unfolding t'_def using a'(2,3) by simp + } moreover { + assume "Fun f T = Fun a []" hence "T = [] \ (\s\set T. s \ Var ` set X)" by simp + } ultimately show "T = [] \ (\s\set T. s \ Var ` set X)" using t_subterms by blast + qed + + note 11 = \_subterm_inj \_img_ground 3 4 5 + + note 12 = 6 7 8 \'(2) doms_eq + + show "t \ \ \ \ \ t' \ \ \ \" + using 1 2 9 10 that sat_ineq_subterm_inj_subst[OF 11 _ 12] + unfolding Q1'_def Q2'_def by metis + qed + thus ?thesis by (metis t_def t'_def ineq_model_singleI ineq_model_single_iff) + qed + + have \_ineqs_fv_dom': "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ subst_domain \" + when "Inequality X F \ set S" and "?P \ X" for F \ X + using \_ineqs_fv_dom[OF that(1)] + proof (induction F) + case (Cons g G) + obtain t t' where g: "g = (t,t')" by (metis surj_pair) + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (g#G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = fv (t \ \) \ fv (t' \ \) \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \)" + "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (g#G) = fv t \ fv t' \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" + by (simp_all add: subst_apply_pairs_def) + moreover have "fv (t \ \) = fv t - subst_domain \" "fv (t' \ \) = fv t' - subst_domain \" + using g that(2) by (simp_all add: subst_fv_unfold_ground_img range_vars_alt_def) + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (G \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ subst_domain \" using Cons by auto + ultimately show ?case using Cons.prems that(2) by auto + qed (simp add: subst_apply_pairs_def) + + have \_ineqs_ground: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) = {}" + when "Inequality X F \ set S" and "?P \ X" for F \ X + using \_ineqs_fv_dom'[OF that] + proof (induction F) + case (Cons g G) + obtain t t' where g: "g = (t,t')" by (metis surj_pair) + hence "fv (t \ \) \ subst_domain \" "fv (t' \ \) \ subst_domain \" + using Cons.prems by (auto simp add: subst_apply_pairs_def) + hence "fv (t \ \ \ \) = {}" "fv (t' \ \ \ \) = {}" + using subst_fv_dom_ground_if_ground_img[OF _ \_img_ground] by metis+ + thus ?case using g Cons by (auto simp add: subst_apply_pairs_def) + qed (simp add: subst_apply_pairs_def) + + from \_pgwt_img \_ineqs_neq have \_deduct: "M \\<^sub>c \ x" when "x \ subst_domain \" for x M + using that pgwt_deducible by fastforce + + { fix M::"('fun,'var) terms" + have "\M; S\\<^sub>c (\ \\<^sub>s \ \\<^sub>s \)" + using \wf\<^sub>s\<^sub>t {} S\ \simple S\ S_\_disj \_ineqs_neq \_ineqs_fv_dom' \_vars_S_bvars_disj + proof (induction S arbitrary: M rule: wf\<^sub>s\<^sub>t_simple_induct) + case (ConsSnd v S) + hence S_sat: "\M; S\\<^sub>c (\ \\<^sub>s \ \\<^sub>s \)" and "\ v = Var v" by auto + hence "\M. M \\<^sub>c Var v \ (\ \\<^sub>s \ \\<^sub>s \)" + using \_deduct \_deduct + by (metis ideduct_synth_subst_apply subst_apply_term.simps(1) + subst_subst_compose trm_subst_ident') + thus ?case using strand_sem_append(1)[OF S_sat] by (metis strand_sem_c.simps(1,2)) + next + case (ConsIneq X F S) + have dom_disj: "subst_domain \ \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = {}" + using ConsIneq.prems(1) subst_dom_vars_in_subst + by force + hence *: "F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \ = F" by blast + + have **: "ineq_model \ X F" by (meson ConsIneq.prems(2) in_set_conv_decomp) + + have "\x. x \ vars\<^sub>s\<^sub>t S \ x \ vars\<^sub>s\<^sub>t (S@[Inequality X F])" + "\x. x \ set S \ x \ set (S@[Inequality X F])" by auto + hence IH: "\M; S\\<^sub>c (\ \\<^sub>s \ \\<^sub>s \)" by (metis ConsIneq.IH ConsIneq.prems(1,2,3,4)) + + have "ineq_model (\ \\<^sub>s \) X F" + proof - + have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \) \ subst_domain \" when "?P \ X" for \ + using ConsIneq.prems(3)[OF _ that] by simp + hence "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ subst_domain \" + using fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_subst_subset ex_P + by (metis Diff_subset_conv Un_commute) + thus ?thesis by (metis ineq_model_ground_subst[OF _ \_img_ground **]) + qed + hence "ineq_model (\ \\<^sub>s \ \\<^sub>s \) X F" + using * ineq_model_subst' subst_compose_assoc ConsIneq.prems(4) + by (metis UnCI list.set_intros(1) set_append) + thus ?case using IH by (auto simp add: ineq_model_def) + qed auto + } + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\ \\<^sub>s \ \\<^sub>s \)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\ \\<^sub>s \ \\<^sub>s \))" + by (metis wt_subst_compose \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\ \wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\, + metis assms(4) \_wf_trm \_wf_trm wf_trm_subst subst_img_comp_subset') + ultimately show ?thesis + using interpretation_comp(1)[OF \interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\, of "\ \\<^sub>s \"] + subst_idem_support[OF \subst_idem \\, of "\ \\<^sub>s \"] subst_compose_assoc + unfolding constr_sem_c_def by metis +qed +end + + +subsubsection \Theorem: Type-flaw resistant constraints are well-typed satisfiable (composition-only)\ +text \ + There exists well-typed models of satisfiable type-flaw resistant constraints in the + semantics where the intruder is limited to composition only (i.e., he cannot perform + decomposition/analysis of deducible messages). +\ +theorem wt_attack_if_tfr_attack: + assumes "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "\ \\<^sub>c \S, \\" + and "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "tfr\<^sub>s\<^sub>t S" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + obtains \\<^sub>\ where "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" + and "\\<^sub>\ \\<^sub>c \S, \\" + and "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" +proof - + have tfr: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using assms(5,6) unfolding tfr\<^sub>s\<^sub>t_def by metis+ + obtain S' \' where *: "simple S'" "(S,\) \\<^sup>* (S',\')" "\{}; S'\\<^sub>c \" + using LI_completeness[OF assms(3,2)] unfolding constr_sem_c_def + by (meson term.order_refl) + have **: "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S' \'" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \'" "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S')" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \')" + using LI_preserves_welltypedness[OF *(2) assms(3,4,7) tfr] + LI_preserves_wellformedness[OF *(2) assms(3)] + LI_preserves_tfr[OF *(2) assms(3,4,7) tfr] + by metis+ + + define A where "A \ {x \ vars\<^sub>s\<^sub>t S'. \X F. Inequality X F \ set S' \ x \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \ x \ set X}" + define B where "B \ UNIV - A" + + let ?\ = "rm_vars B \" + + have gr\: "ground (subst_range \)" "ground (subst_range ?\)" + using assms(1) rm_vars_img_subset[of B \] by (auto simp add: subst_domain_def) + + { fix X F + assume "Inequality X F \ set S'" + hence *: "ineq_model \ X F" + using strand_sem_c_imp_ineq_model[OF *(3)] + by (auto simp del: subst_range.simps) + hence "ineq_model ?\ X F" + proof - + { fix \ + assume 1: "subst_domain \ = set X" "ground (subst_range \)" + and 2: "list_ex (\f. fst f \ \ \\<^sub>s \ \ snd f \ \ \\<^sub>s \) F" + have "list_ex (\f. fst f \ \ \\<^sub>s rm_vars B \ \ snd f \ \ \\<^sub>s rm_vars B \) F" using 2 + proof (induction F) + case (Cons g G) + obtain t t' where g: "g = (t,t')" by (metis surj_pair) + thus ?case + using Cons Unifier_ground_rm_vars[OF gr\(1), of "t \ \" B "t' \ \"] + by auto + qed simp + } thus ?thesis using * unfolding ineq_model_def by simp + qed + } moreover have "subst_domain \ = UNIV" using assms(1) by metis + hence "subst_domain ?\ = A" using rm_vars_dom[of B \] B_def by blast + ultimately obtain \\<^sub>\ where + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "\\<^sub>\ \\<^sub>c \S', \'\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + using wt_sat_if_simple[OF *(1) **(1,2,5,4) _ gr\(2) _ **(3)] A_def + by (auto simp del: subst_range.simps) + thus ?thesis using that LI_soundness[OF assms(3) *(2)] by metis +qed + +text \ + Contra-positive version: if a type-flaw resistant constraint does not have a well-typed model + then it is unsatisfiable +\ +corollary secure_if_wt_secure: + assumes "\(\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ (\\<^sub>\ \\<^sub>c \S, \\) \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\)" + and "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r S \" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "tfr\<^sub>s\<^sub>t S" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t S)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \)" + shows "\(\\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ (\ \\<^sub>c \S, \\))" +using wt_attack_if_tfr_attack[OF _ _ assms(2,3,4,5,6)] assms(1) by metis + +end + + +subsection \Lifting the Composition-Only Typing Result to the Full Intruder Model\ +context typed_model +begin + +subsubsection \Analysis Invariance\ +definition (in typed_model) Ana_invar_subst where + "Ana_invar_subst \ \ + (\f T K M \. Fun f T \ (subterms\<^sub>s\<^sub>e\<^sub>t \) \ + Ana (Fun f T) = (K, M) \ Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \))" + +lemma (in typed_model) Ana_invar_subst_subset: + assumes "Ana_invar_subst M" "N \ M" + shows "Ana_invar_subst N" +using assms unfolding Ana_invar_subst_def by blast + +lemma (in typed_model) Ana_invar_substD: + assumes "Ana_invar_subst \" + and "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t \" "Ana (Fun f T) = (K, M)" + shows "Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +using assms Ana_invar_subst_def by blast + +end + + +subsubsection \Preliminary Definitions\ +text \Strands extended with "decomposition steps"\ +datatype (funs\<^sub>e\<^sub>s\<^sub>t\<^sub>p: 'a, vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p: 'b) extstrand_step = + Step "('a,'b) strand_step" +| Decomp "('a,'b) term" + +context typed_model +begin + +context +begin +private fun trms\<^sub>e\<^sub>s\<^sub>t\<^sub>p where + "trms\<^sub>e\<^sub>s\<^sub>t\<^sub>p (Step x) = trms\<^sub>s\<^sub>t\<^sub>p x" +| "trms\<^sub>e\<^sub>s\<^sub>t\<^sub>p (Decomp t) = {t}" + +private abbreviation trms\<^sub>e\<^sub>s\<^sub>t where "trms\<^sub>e\<^sub>s\<^sub>t S \ \(trms\<^sub>e\<^sub>s\<^sub>t\<^sub>p ` set S)" + +private type_synonym ('a,'b) extstrand = "('a,'b) extstrand_step list" +private type_synonym ('a,'b) extstrands = "('a,'b) extstrand set" + +private definition decomp::"('fun,'var) term \ ('fun,'var) strand" where + "decomp t \ (case (Ana t) of (K,T) \ send\t\\<^sub>s\<^sub>t#map Send K@map Receive T)" + +private fun to_st where + "to_st [] = []" +| "to_st (Step x#S) = x#(to_st S)" +| "to_st (Decomp t#S) = (decomp t)@(to_st S)" + +private fun to_est where + "to_est [] = []" +| "to_est (x#S) = Step x#to_est S" + +private abbreviation "ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>s\<^sub>t (to_st A)" +private abbreviation "wf\<^sub>e\<^sub>s\<^sub>t V A \ wf\<^sub>s\<^sub>t V (to_st A)" +private abbreviation "assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>s\<^sub>t (to_st A)" +private abbreviation "vars\<^sub>e\<^sub>s\<^sub>t A \ vars\<^sub>s\<^sub>t (to_st A)" +private abbreviation "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t A \ wfrestrictedvars\<^sub>s\<^sub>t (to_st A)" +private abbreviation "bvars\<^sub>e\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>t (to_st A)" +private abbreviation "fv\<^sub>e\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>t (to_st A)" +private abbreviation "funs\<^sub>e\<^sub>s\<^sub>t A \ funs\<^sub>s\<^sub>t (to_st A)" + +private definition wf\<^sub>s\<^sub>t\<^sub>s'::"('fun,'var) strands \ ('fun,'var) extstrand \ bool" where + "wf\<^sub>s\<^sub>t\<^sub>s' \ \ \ (\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \) (dual\<^sub>s\<^sub>t S)) \ + (\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}) \ + (\S \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t \ = {}) \ + (\S \ \. fv\<^sub>s\<^sub>t (to_st \) \ bvars\<^sub>s\<^sub>t S = {})" + +private definition wf\<^sub>s\<^sub>t\<^sub>s::"('fun,'var) strands \ bool" where + "wf\<^sub>s\<^sub>t\<^sub>s \ \ (\S \ \. wf\<^sub>s\<^sub>t {} (dual\<^sub>s\<^sub>t S)) \ (\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {})" + +private inductive well_analyzed::"('fun,'var) extstrand \ bool" where + Nil[simp]: "well_analyzed []" +| Step: "well_analyzed A \ well_analyzed (A@[Step x])" +| Decomp: "\well_analyzed A; t \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) - (Var ` \)\ + \ well_analyzed (A@[Decomp t])" + +private fun subst_apply_extstrandstep (infix "\\<^sub>e\<^sub>s\<^sub>t\<^sub>p" 51) where + "subst_apply_extstrandstep (Step x) \ = Step (x \\<^sub>s\<^sub>t\<^sub>p \)" +| "subst_apply_extstrandstep (Decomp t) \ = Decomp (t \ \)" + +private lemma subst_apply_extstrandstep'_simps[simp]: + "(Step (send\t\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \ = Step (send\t \ \\\<^sub>s\<^sub>t)" + "(Step (receive\t\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \ = Step (receive\t \ \\\<^sub>s\<^sub>t)" + "(Step (\a: t \ t'\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \ = Step (\a: (t \ \) \ (t' \ \)\\<^sub>s\<^sub>t)" + "(Step (\X\\\: F\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \ = Step (\X\\\: (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)\\<^sub>s\<^sub>t)" +by simp_all + +private lemma vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p_subst_apply_simps[simp]: + "vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p ((Step (send\t\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p ((Step (receive\t\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \)" + "vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p ((Step (\a: t \ t'\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \) = fv (t \ \) \ fv (t' \ \)" + "vars\<^sub>e\<^sub>s\<^sub>t\<^sub>p ((Step (\X\\\: F\\<^sub>s\<^sub>t)) \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \) = set X \ fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \)" +by auto + +private definition subst_apply_extstrand (infix "\\<^sub>e\<^sub>s\<^sub>t" 51) where "S \\<^sub>e\<^sub>s\<^sub>t \ \ map (\x. x \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \) S" + +private abbreviation update\<^sub>s\<^sub>t::"('fun,'var) strands \ ('fun,'var) strand \ ('fun,'var) strands" +where + "update\<^sub>s\<^sub>t \ S \ (case S of Nil \ \ - {S} | Cons _ S' \ insert S' (\ - {S}))" + +private inductive_set decomps\<^sub>e\<^sub>s\<^sub>t:: + "('fun,'var) terms \ ('fun,'var) terms \ ('fun,'var) subst \ ('fun,'var) extstrands" +(* \: intruder knowledge + \: additional messages +*) +for \ and \ and \ where + Nil: "[] \ decomps\<^sub>e\<^sub>s\<^sub>t \ \ \" +| Decomp: "\\ \ decomps\<^sub>e\<^sub>s\<^sub>t \ \ \; Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (\ \ \); + Ana (Fun f T) = (K,M); M \ []; + (\ \ ik\<^sub>e\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c Fun f T \ \; + \k. k \ set K \ (\ \ ik\<^sub>e\<^sub>s\<^sub>t \) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \\ + \ \@[Decomp (Fun f T)] \ decomps\<^sub>e\<^sub>s\<^sub>t \ \ \" + +private fun decomp_rm\<^sub>e\<^sub>s\<^sub>t::"('fun,'var) extstrand \ ('fun,'var) extstrand" where + "decomp_rm\<^sub>e\<^sub>s\<^sub>t [] = []" +| "decomp_rm\<^sub>e\<^sub>s\<^sub>t (Decomp t#S) = decomp_rm\<^sub>e\<^sub>s\<^sub>t S" +| "decomp_rm\<^sub>e\<^sub>s\<^sub>t (Step x#S) = Step x#(decomp_rm\<^sub>e\<^sub>s\<^sub>t S)" + +private inductive sem\<^sub>e\<^sub>s\<^sub>t_d::"('fun,'var) terms \ ('fun,'var) subst \ ('fun,'var) extstrand \ bool" +where + Nil[simp]: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ []" +| Send: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ S \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \ \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (S@[Step (send\t\\<^sub>s\<^sub>t)])" +| Receive: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ S \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (S@[Step (receive\t\\<^sub>s\<^sub>t)])" +| Equality: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ S \ t \ \ = t' \ \ \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (S@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" +| Inequality: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ S + \ ineq_model \ X F + \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (S@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" +| Decompose: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ S \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \ \ Ana t = (K, M) + \ (\k. k \ set K \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \ k \ \) \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (S@[Decomp t])" + +private inductive sem\<^sub>e\<^sub>s\<^sub>t_c::"('fun,'var) terms \ ('fun,'var) subst \ ('fun,'var) extstrand \ bool" +where + Nil[simp]: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ []" +| Send: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ S \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \ \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (S@[Step (send\t\\<^sub>s\<^sub>t)])" +| Receive: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ S \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (S@[Step (receive\t\\<^sub>s\<^sub>t)])" +| Equality: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ S \ t \ \ = t' \ \ \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (S@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" +| Inequality: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ S + \ ineq_model \ X F + \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (S@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" +| Decompose: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ S \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \ \ Ana t = (K, M) + \ (\k. k \ set K \ (ik\<^sub>e\<^sub>s\<^sub>t S \ M\<^sub>0) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \) \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (S@[Decomp t])" + + +subsubsection \Preliminary Lemmata\ +private lemma wf\<^sub>s\<^sub>t\<^sub>s_wf\<^sub>s\<^sub>t\<^sub>s': + "wf\<^sub>s\<^sub>t\<^sub>s \ = wf\<^sub>s\<^sub>t\<^sub>s' \ []" +by (simp add: wf\<^sub>s\<^sub>t\<^sub>s_def wf\<^sub>s\<^sub>t\<^sub>s'_def) + +private lemma decomp_ik: + assumes "Ana t = (K,M)" + shows "ik\<^sub>s\<^sub>t (decomp t) = set M" +using ik_rcv_map[of _ M] ik_rcv_map'[of _ M] +by (auto simp add: decomp_def inv_def assms) + +private lemma decomp_assignment_rhs_empty: + assumes "Ana t = (K,M)" + shows "assignment_rhs\<^sub>s\<^sub>t (decomp t) = {}" +by (auto simp add: decomp_def inv_def assms) + +private lemma decomp_tfr\<^sub>s\<^sub>t\<^sub>p: + "list_all tfr\<^sub>s\<^sub>t\<^sub>p (decomp t)" +by (auto simp add: decomp_def list_all_def) + +private lemma trms\<^sub>e\<^sub>s\<^sub>t_ikI: + "t \ ik\<^sub>e\<^sub>s\<^sub>t A \ t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t A)" +proof (induction A rule: to_st.induct) + case (2 x S) thus ?case by (cases x) auto +next + case (3 t' A) + obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair) + show ?case using 3 decomp_ik[OF Ana] Ana_subterm[OF Ana] by auto +qed simp + +private lemma trms\<^sub>e\<^sub>s\<^sub>t_ik_assignment_rhsI: + "t \ ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \ t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t A)" +proof (induction A rule: to_st.induct) + case (2 x S) thus ?case + proof (cases x) + case (Equality ac t t') thus ?thesis using 2 by (cases ac) auto + qed auto +next + case (3 t' A) + obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair) + show ?case + using 3 decomp_ik[OF Ana] decomp_assignment_rhs_empty[OF Ana] Ana_subterm[OF Ana] + by auto +qed simp + +private lemma trms\<^sub>e\<^sub>s\<^sub>t_ik_subtermsI: + assumes "t \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A)" + shows "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t A)" +proof - + obtain t' where "t' \ ik\<^sub>e\<^sub>s\<^sub>t A" "t \ t'" using trms\<^sub>e\<^sub>s\<^sub>t_ikI assms by auto + thus ?thesis by (meson contra_subsetD in_subterms_subset_Union trms\<^sub>e\<^sub>s\<^sub>t_ikI) +qed + +private lemma trms\<^sub>e\<^sub>s\<^sub>tD: + assumes "t \ trms\<^sub>e\<^sub>s\<^sub>t A" + shows "t \ trms\<^sub>s\<^sub>t (to_st A)" +using assms +proof (induction A) + case (Cons a A) + obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair) + hence "t \ trms\<^sub>s\<^sub>t (decomp t)" unfolding decomp_def by force + thus ?case using Cons.IH Cons.prems by (cases a) auto +qed simp + +private lemma subst_apply_extstrand_nil[simp]: + "[] \\<^sub>e\<^sub>s\<^sub>t \ = []" +by (simp add: subst_apply_extstrand_def) + +private lemma subst_apply_extstrand_singleton[simp]: + "[Step (receive\t\\<^sub>s\<^sub>t)] \\<^sub>e\<^sub>s\<^sub>t \ = [Step (Receive (t \ \))]" + "[Step (send\t\\<^sub>s\<^sub>t)] \\<^sub>e\<^sub>s\<^sub>t \ = [Step (Send (t \ \))]" + "[Step (\a: t \ t'\\<^sub>s\<^sub>t)] \\<^sub>e\<^sub>s\<^sub>t \ = [Step (Equality a (t \ \) (t' \ \))]" + "[Decomp t] \\<^sub>e\<^sub>s\<^sub>t \ = [Decomp (t \ \)]" +unfolding subst_apply_extstrand_def by auto + +private lemma extstrand_subst_hom: + "(S@S') \\<^sub>e\<^sub>s\<^sub>t \ = (S \\<^sub>e\<^sub>s\<^sub>t \)@(S' \\<^sub>e\<^sub>s\<^sub>t \)" "(x#S) \\<^sub>e\<^sub>s\<^sub>t \ = (x \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \)#(S \\<^sub>e\<^sub>s\<^sub>t \)" +unfolding subst_apply_extstrand_def by auto + +private lemma decomp_vars: + "wfrestrictedvars\<^sub>s\<^sub>t (decomp t) = fv t" "vars\<^sub>s\<^sub>t (decomp t) = fv t" "bvars\<^sub>s\<^sub>t (decomp t) = {}" + "fv\<^sub>s\<^sub>t (decomp t) = fv t" +proof - + obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair) + hence "decomp t = send\t\\<^sub>s\<^sub>t#map Send K@map Receive M" + unfolding decomp_def by simp + moreover have "\(set (map fv K)) = fv\<^sub>s\<^sub>e\<^sub>t (set K)" "\(set (map fv M)) = fv\<^sub>s\<^sub>e\<^sub>t (set M)" by auto + moreover have "fv\<^sub>s\<^sub>e\<^sub>t (set K) \ fv t" "fv\<^sub>s\<^sub>e\<^sub>t (set M) \ fv t" + using Ana_subterm[OF Ana(1)] Ana_keys_fv[OF Ana(1)] + by (simp_all add: UN_least psubsetD subtermeq_vars_subset) + ultimately show + "wfrestrictedvars\<^sub>s\<^sub>t (decomp t) = fv t" "vars\<^sub>s\<^sub>t (decomp t) = fv t" "bvars\<^sub>s\<^sub>t (decomp t) = {}" + "fv\<^sub>s\<^sub>t (decomp t) = fv t" + by auto +qed + +private lemma bvars\<^sub>e\<^sub>s\<^sub>t_cons: "bvars\<^sub>e\<^sub>s\<^sub>t (x#X) = bvars\<^sub>e\<^sub>s\<^sub>t [x] \ bvars\<^sub>e\<^sub>s\<^sub>t X" +by (cases x) auto + +private lemma bvars\<^sub>e\<^sub>s\<^sub>t_append: "bvars\<^sub>e\<^sub>s\<^sub>t (A@B) = bvars\<^sub>e\<^sub>s\<^sub>t A \ bvars\<^sub>e\<^sub>s\<^sub>t B" +proof (induction A) + case (Cons x A) thus ?case using bvars\<^sub>e\<^sub>s\<^sub>t_cons[of x "A@B"] bvars\<^sub>e\<^sub>s\<^sub>t_cons[of x A] by force +qed simp + +private lemma fv\<^sub>e\<^sub>s\<^sub>t_cons: "fv\<^sub>e\<^sub>s\<^sub>t (x#X) = fv\<^sub>e\<^sub>s\<^sub>t [x] \ fv\<^sub>e\<^sub>s\<^sub>t X" +by (cases x) auto + +private lemma fv\<^sub>e\<^sub>s\<^sub>t_append: "fv\<^sub>e\<^sub>s\<^sub>t (A@B) = fv\<^sub>e\<^sub>s\<^sub>t A \ fv\<^sub>e\<^sub>s\<^sub>t B" +proof (induction A) + case (Cons x A) thus ?case using fv\<^sub>e\<^sub>s\<^sub>t_cons[of x "A@B"] fv\<^sub>e\<^sub>s\<^sub>t_cons[of x A] by auto +qed simp + +private lemma bvars_decomp: "bvars\<^sub>e\<^sub>s\<^sub>t (A@[Decomp t]) = bvars\<^sub>e\<^sub>s\<^sub>t A" "bvars\<^sub>e\<^sub>s\<^sub>t (Decomp t#A) = bvars\<^sub>e\<^sub>s\<^sub>t A" +using bvars\<^sub>e\<^sub>s\<^sub>t_append decomp_vars(3) by fastforce+ + +private lemma bvars_decomp_rm: "bvars\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) = bvars\<^sub>e\<^sub>s\<^sub>t A" +using bvars_decomp by (induct A rule: decomp_rm\<^sub>e\<^sub>s\<^sub>t.induct) simp_all+ + +private lemma fv_decomp_rm: "fv\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ fv\<^sub>e\<^sub>s\<^sub>t A" +by (induct A rule: decomp_rm\<^sub>e\<^sub>s\<^sub>t.induct) auto + +private lemma ik_assignment_rhs_decomp_fv: + assumes "t \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + shows "fv\<^sub>e\<^sub>s\<^sub>t (A@[Decomp t]) = fv\<^sub>e\<^sub>s\<^sub>t A" +proof - + have "fv\<^sub>e\<^sub>s\<^sub>t (A@[Decomp t]) = fv\<^sub>e\<^sub>s\<^sub>t A \ fv t" using fv\<^sub>e\<^sub>s\<^sub>t_append decomp_vars by simp + moreover have "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \ fv\<^sub>e\<^sub>s\<^sub>t A" by force + moreover have "fv t \ fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using fv_subset_subterms[OF assms(1)] by simp + ultimately show ?thesis by blast +qed + +private lemma wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_decomp_rm\<^sub>e\<^sub>s\<^sub>t_subset: + "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t A" +by (induct A rule: decomp_rm\<^sub>e\<^sub>s\<^sub>t.induct) auto+ + +private lemma wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_eq_wfrestrictedvars\<^sub>s\<^sub>t: + "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t A = wfrestrictedvars\<^sub>s\<^sub>t (to_st A)" +by simp + +private lemma decomp_set_unfold: + assumes "Ana t = (K, M)" + shows "set (decomp t) = {send\t\\<^sub>s\<^sub>t} \ (Send ` set K) \ (Receive ` set M)" +using assms unfolding decomp_def by auto + +private lemma ik\<^sub>e\<^sub>s\<^sub>t_finite: "finite (ik\<^sub>e\<^sub>s\<^sub>t A)" +by (rule finite_ik\<^sub>s\<^sub>t) + +private lemma assignment_rhs\<^sub>e\<^sub>s\<^sub>t_finite: "finite (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" +by (rule finite_assignment_rhs\<^sub>s\<^sub>t) + +private lemma to_est_append: "to_est (A@B) = to_est A@to_est B" +by (induct A rule: to_est.induct) auto + +private lemma to_st_to_est_inv: "to_st (to_est A) = A" +by (induct A rule: to_est.induct) auto + +private lemma to_st_append: "to_st (A@B) = (to_st A)@(to_st B)" +by (induct A rule: to_st.induct) auto + +private lemma to_st_cons: "to_st (a#B) = (to_st [a])@(to_st B)" +using to_st_append[of "[a]" B] by simp + +private lemma wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split: + "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t (x#S) = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t [x] \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t S" + "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t (S@S') = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t S \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t S'" +using to_st_cons[of x S] to_st_append[of S S'] by auto + +private lemma ik\<^sub>e\<^sub>s\<^sub>t_append: "ik\<^sub>e\<^sub>s\<^sub>t (A@B) = ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t B" +by (metis ik_append to_st_append) + +private lemma assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append: + "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@B) = assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t B" +by (metis assignment_rhs_append to_st_append) + +private lemma ik\<^sub>e\<^sub>s\<^sub>t_cons: "ik\<^sub>e\<^sub>s\<^sub>t (a#A) = ik\<^sub>e\<^sub>s\<^sub>t [a] \ ik\<^sub>e\<^sub>s\<^sub>t A" +by (metis ik_append to_st_cons) + +private lemma ik\<^sub>e\<^sub>s\<^sub>t_append_subst: + "ik\<^sub>e\<^sub>s\<^sub>t (A@B \\<^sub>e\<^sub>s\<^sub>t \) = ik\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (B \\<^sub>e\<^sub>s\<^sub>t \)" + "ik\<^sub>e\<^sub>s\<^sub>t (A@B) \\<^sub>s\<^sub>e\<^sub>t \ = (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t B \\<^sub>s\<^sub>e\<^sub>t \)" +by (metis ik\<^sub>e\<^sub>s\<^sub>t_append extstrand_subst_hom(1), simp add: image_Un to_st_append) + +private lemma assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append_subst: + "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@B \\<^sub>e\<^sub>s\<^sub>t \) = assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t (B \\<^sub>e\<^sub>s\<^sub>t \)" + "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@B) \\<^sub>s\<^sub>e\<^sub>t \ = (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t B \\<^sub>s\<^sub>e\<^sub>t \)" +by (metis assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append extstrand_subst_hom(1), use assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append in blast) + +private lemma ik\<^sub>e\<^sub>s\<^sub>t_cons_subst: + "ik\<^sub>e\<^sub>s\<^sub>t (a#A \\<^sub>e\<^sub>s\<^sub>t \) = ik\<^sub>e\<^sub>s\<^sub>t ([a \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \]) \ ik\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \)" + "ik\<^sub>e\<^sub>s\<^sub>t (a#A) \\<^sub>s\<^sub>e\<^sub>t \ = (ik\<^sub>e\<^sub>s\<^sub>t [a] \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \)" +by (metis ik\<^sub>e\<^sub>s\<^sub>t_cons extstrand_subst_hom(2), metis image_Un ik\<^sub>e\<^sub>s\<^sub>t_cons) + +private lemma decomp_rm\<^sub>e\<^sub>s\<^sub>t_append: "decomp_rm\<^sub>e\<^sub>s\<^sub>t (S@S') = (decomp_rm\<^sub>e\<^sub>s\<^sub>t S)@(decomp_rm\<^sub>e\<^sub>s\<^sub>t S')" +by (induct S rule: decomp_rm\<^sub>e\<^sub>s\<^sub>t.induct) auto + +private lemma decomp_rm\<^sub>e\<^sub>s\<^sub>t_single[simp]: + "decomp_rm\<^sub>e\<^sub>s\<^sub>t [Step (send\t\\<^sub>s\<^sub>t)] = [Step (send\t\\<^sub>s\<^sub>t)]" + "decomp_rm\<^sub>e\<^sub>s\<^sub>t [Step (receive\t\\<^sub>s\<^sub>t)] = [Step (receive\t\\<^sub>s\<^sub>t)]" + "decomp_rm\<^sub>e\<^sub>s\<^sub>t [Decomp t] = []" +by auto + +private lemma decomp_rm\<^sub>e\<^sub>s\<^sub>t_ik_subset: "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t S) \ ik\<^sub>e\<^sub>s\<^sub>t S" +proof (induction S rule: decomp_rm\<^sub>e\<^sub>s\<^sub>t.induct) + case (3 x S) thus ?case by (cases x) auto +qed auto + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_ik_subset: "D \ decomps\<^sub>e\<^sub>s\<^sub>t M N \ \ ik\<^sub>e\<^sub>s\<^sub>t D \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" +proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp D f T K M') + have "ik\<^sub>s\<^sub>t (decomp (Fun f T)) \ subterms (Fun f T)" + "ik\<^sub>s\<^sub>t (decomp (Fun f T)) = ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f T)]" + using decomp_ik[OF Decomp.hyps(3)] Ana_subterm[OF Decomp.hyps(3)] + by auto + hence "ik\<^sub>s\<^sub>t (to_st [Decomp (Fun f T)]) \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" + using in_subterms_subset_Union[OF Decomp.hyps(2)] + by blast + thus ?case using ik\<^sub>e\<^sub>s\<^sub>t_append[of D "[Decomp (Fun f T)]"] using Decomp.IH by auto +qed simp + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_decomp_rm\<^sub>e\<^sub>s\<^sub>t_empty: "D \ decomps\<^sub>e\<^sub>s\<^sub>t M N \ \ decomp_rm\<^sub>e\<^sub>s\<^sub>t D = []" +by (induct D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) (auto simp add: decomp_rm\<^sub>e\<^sub>s\<^sub>t_append) + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_append: + assumes "A \ decomps\<^sub>e\<^sub>s\<^sub>t S N \" "B \ decomps\<^sub>e\<^sub>s\<^sub>t S N \" + shows "A@B \ decomps\<^sub>e\<^sub>s\<^sub>t S N \" +using assms(2) +proof (induction B rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case Nil show ?case using assms(1) by simp +next + case (Decomp B f X K T) + hence "S \ ik\<^sub>e\<^sub>s\<^sub>t B \\<^sub>s\<^sub>e\<^sub>t \ \ S \ ik\<^sub>e\<^sub>s\<^sub>t (A@B) \\<^sub>s\<^sub>e\<^sub>t \" using ik\<^sub>e\<^sub>s\<^sub>t_append by auto + thus ?case + using decomps\<^sub>e\<^sub>s\<^sub>t.Decomp[OF Decomp.IH(1) Decomp.hyps(2,3,4)] + ideduct_synth_mono[OF Decomp.hyps(5)] + ideduct_synth_mono[OF Decomp.hyps(6)] + by auto +qed + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_subterms: + assumes "A' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" + shows "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A') \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" +using assms +proof (induction A' rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp D f X K T) + hence "Fun f X \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" by auto + hence "subterms\<^sub>s\<^sub>e\<^sub>t (set X) \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" + using in_subterms_subset_Union[of "Fun f X" "M \ N"] params_subterms_Union[of X f] + by blast + moreover have "ik\<^sub>s\<^sub>t (to_st [Decomp (Fun f X)]) = set T" using Decomp.hyps(3) decomp_ik by simp + hence "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>s\<^sub>t (to_st [Decomp (Fun f X)])) \ subterms\<^sub>s\<^sub>e\<^sub>t (set X)" + using Ana_fun_subterm[OF Decomp.hyps(3)] by auto + ultimately show ?case + using ik\<^sub>e\<^sub>s\<^sub>t_append[of D "[Decomp (Fun f X)]"] Decomp.IH + by auto +qed simp + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_assignment_rhs_empty: + assumes "A' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" + shows "assignment_rhs\<^sub>e\<^sub>s\<^sub>t A' = {}" +using assms +by (induction A' rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + (simp_all add: decomp_assignment_rhs_empty assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append) + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_finite_ik_append: + assumes "finite M" "M \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" + shows "\D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. ik\<^sub>e\<^sub>s\<^sub>t D = (\m \ M. ik\<^sub>e\<^sub>s\<^sub>t m)" +using assms +proof (induction M rule: finite_induct) + case empty + moreover have "[] \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" "ik\<^sub>s\<^sub>t (to_st []) = {}" using decomps\<^sub>e\<^sub>s\<^sub>t.Nil by auto + ultimately show ?case by blast +next + case (insert m M) + then obtain D where "D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" "ik\<^sub>e\<^sub>s\<^sub>t D = (\m\M. ik\<^sub>s\<^sub>t (to_st m))" by moura + moreover have "m \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" using insert.prems(1) by blast + ultimately show ?case using decomps\<^sub>e\<^sub>s\<^sub>t_append[of D A N \ m] ik\<^sub>e\<^sub>s\<^sub>t_append[of D m] by blast +qed + +private lemma decomp_snd_exists[simp]: "\D. decomp t = send\t\\<^sub>s\<^sub>t#D" +by (metis (mono_tags, lifting) decomp_def prod.case surj_pair) + +private lemma decomp_nonnil[simp]: "decomp t \ []" +using decomp_snd_exists[of t] by fastforce + +private lemma to_st_nil_inv[dest]: "to_st A = [] \ A = []" +by (induct A rule: to_st.induct) auto + +private lemma well_analyzedD: + assumes "well_analyzed A" "Decomp t \ set A" + shows "\f T. t = Fun f T" +using assms +proof (induction A rule: well_analyzed.induct) + case (Decomp A t') + hence "\f T. t' = Fun f T" by (cases t') auto + moreover have "Decomp t \ set A \ t = t'" using Decomp by auto + ultimately show ?case using Decomp.IH by auto +qed auto + +private lemma well_analyzed_inv: + assumes "well_analyzed (A@[Decomp t])" + shows "t \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) - (Var ` \)" +using assms well_analyzed.cases[of "A@[Decomp t]"] by fastforce + +private lemma well_analyzed_split_left_single: "well_analyzed (A@[a]) \ well_analyzed A" +by (induction "A@[a]" rule: well_analyzed.induct) auto + +private lemma well_analyzed_split_left: "well_analyzed (A@B) \ well_analyzed A" +proof (induction B rule: List.rev_induct) + case (snoc b B) thus ?case using well_analyzed_split_left_single[of "A@B" b] by simp +qed simp + +private lemma well_analyzed_append: + assumes "well_analyzed A" "well_analyzed B" + shows "well_analyzed (A@B)" +using assms(2,1) +proof (induction B rule: well_analyzed.induct) + case (Step B x) show ?case using well_analyzed.Step[OF Step.IH[OF Step.prems]] by simp +next + case (Decomp B t) thus ?case + using well_analyzed.Decomp[OF Decomp.IH[OF Decomp.prems]] ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append + by auto +qed simp_all + +private lemma well_analyzed_singleton: + "well_analyzed [Step (send\t\\<^sub>s\<^sub>t)]" "well_analyzed [Step (receive\t\\<^sub>s\<^sub>t)]" + "well_analyzed [Step (\a: t \ t'\\<^sub>s\<^sub>t)]" "well_analyzed [Step (\X\\\: F\\<^sub>s\<^sub>t)]" + "\well_analyzed [Decomp t]" +proof - + show "well_analyzed [Step (send\t\\<^sub>s\<^sub>t)]" "well_analyzed [Step (receive\t\\<^sub>s\<^sub>t)]" + "well_analyzed [Step (\a: t \ t'\\<^sub>s\<^sub>t)]" "well_analyzed [Step (\X\\\: F\\<^sub>s\<^sub>t)]" + using well_analyzed.Step[OF well_analyzed.Nil] + by simp_all + + show "\well_analyzed [Decomp t]" using well_analyzed.cases[of "[Decomp t]"] by auto +qed + +private lemma well_analyzed_decomp_rm\<^sub>e\<^sub>s\<^sub>t_fv: "well_analyzed A \ fv\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) = fv\<^sub>e\<^sub>s\<^sub>t A" +proof + assume "well_analyzed A" thus "fv\<^sub>e\<^sub>s\<^sub>t A \ fv\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A)" + proof (induction A rule: well_analyzed.induct) + case Decomp thus ?case using ik_assignment_rhs_decomp_fv decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by auto + next + case (Step A x) + have "fv\<^sub>e\<^sub>s\<^sub>t (A@[Step x]) = fv\<^sub>e\<^sub>s\<^sub>t A \ fv\<^sub>s\<^sub>t\<^sub>p x" + "fv\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t (A@[Step x])) = fv\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ fv\<^sub>s\<^sub>t\<^sub>p x" + using fv\<^sub>e\<^sub>s\<^sub>t_append decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by auto + thus ?case using Step by auto + qed simp +qed (rule fv_decomp_rm) + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_d_split_left: assumes "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (\@\')" shows "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ \" +using assms sem\<^sub>e\<^sub>s\<^sub>t_d.cases by (induction \' rule: List.rev_induct) fastforce+ + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ \ = \M\<^sub>0; to_st \\\<^sub>d' \" +proof + show "\M\<^sub>0; to_st \\\<^sub>d' \ \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ \" + proof (induction \ arbitrary: M\<^sub>0 rule: List.rev_induct) + case Nil show ?case using to_st_nil_inv by simp + next + case (snoc a \) + hence IH: "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ \" and *: "\ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0; to_st [a]\\<^sub>d' \" + using to_st_append by (auto simp add: sup.commute) + thus ?case using snoc + proof (cases a) + case (Step b) thus ?thesis + proof (cases b) + case (Send t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_d.Send[OF IH] * Step by auto + next + case (Receive t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_d.Receive[OF IH] Step by auto + next + case (Equality a t t') thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_d.Equality[OF IH] * Step by auto + next + case (Inequality X F) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_d.Inequality[OF IH] * Step by auto + qed + next + case (Decomp t) + obtain K M where Ana: "Ana t = (K,M)" by moura + have "to_st [a] = decomp t" using Decomp by auto + hence "to_st [a] = send\t\\<^sub>s\<^sub>t#map Send K@map Receive M" + using Ana unfolding decomp_def by auto + hence **: "ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" and "\ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0; map Send K\\<^sub>d' \" + using * by auto + hence "\k. k \ set K \ ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ k \ \" + using * + by (metis (full_types) strand_sem_d.simps(2) strand_sem_eq_defs(2) strand_sem_Send_split(2)) + thus ?thesis using Decomp sem\<^sub>e\<^sub>s\<^sub>t_d.Decompose[OF IH ** Ana] by metis + qed + qed + + show "sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ \ \ \M\<^sub>0; to_st \\\<^sub>d' \" + proof (induction rule: sem\<^sub>e\<^sub>s\<^sub>t_d.induct) + case Nil thus ?case by simp + next + case (Send M\<^sub>0 \ \ t) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[send\t\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (send\t\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Receive M\<^sub>0 \ \ t) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[receive\t\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (receive\t\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Equality M\<^sub>0 \ \ t t' a) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[\a: t \ t'\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (\a: t \ t'\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Inequality M\<^sub>0 \ \ X F) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[\X\\\: F\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (\X\\\: F\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Decompose M\<^sub>0 \ \ t K M) + have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); decomp t\\<^sub>d' \" + proof - + have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); [send\t\\<^sub>s\<^sub>t]\\<^sub>d' \" + using Decompose.hyps(2) by (auto simp add: sup.commute) + moreover have "\k. k \ set K \ M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \) \\<^sub>s\<^sub>e\<^sub>t \ \ k \ \" + using Decompose by (metis sup.commute) + hence "\k. k \ set K \ \M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); [Send k]\\<^sub>d' \" by auto + hence "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); map Send K\\<^sub>d' \" + using strand_sem_Send_map(2)[of K, of "M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \) \\<^sub>s\<^sub>e\<^sub>t \" \] strand_sem_eq_defs(2) + by auto + moreover have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); map Receive M\\<^sub>d' \" + by (metis strand_sem_Receive_map(2) strand_sem_eq_defs(2)) + ultimately have + "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); send\t\\<^sub>s\<^sub>t#map Send K@map Receive M\\<^sub>d' \" + by auto + thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto + qed + hence "\M\<^sub>0; to_st \@decomp t\\<^sub>d' \" + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "decomp t"] Decompose.IH + by simp + thus ?case using to_st_append[of \ "[Decomp t]"] by simp + qed +qed + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_c_eq_sem_st: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ \ = \M\<^sub>0; to_st \\\<^sub>c' \" +proof + show "\M\<^sub>0; to_st \\\<^sub>c' \ \ sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ \" + proof (induction \ arbitrary: M\<^sub>0 rule: List.rev_induct) + case Nil show ?case using to_st_nil_inv by simp + next + case (snoc a \) + hence IH: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ \" and *: "\ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0; to_st [a]\\<^sub>c' \" + using to_st_append + by (auto simp add: sup.commute) + thus ?case using snoc + proof (cases a) + case (Step b) thus ?thesis + proof (cases b) + case (Send t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_c.Send[OF IH] * Step by auto + next + case (Receive t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_c.Receive[OF IH] Step by auto + next + case (Equality t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_c.Equality[OF IH] * Step by auto + next + case (Inequality t) thus ?thesis using sem\<^sub>e\<^sub>s\<^sub>t_c.Inequality[OF IH] * Step by auto + qed + next + case (Decomp t) + obtain K M where Ana: "Ana t = (K,M)" by moura + have "to_st [a] = decomp t" using Decomp by auto + hence "to_st [a] = send\t\\<^sub>s\<^sub>t#map Send K@map Receive M" + using Ana unfolding decomp_def by auto + hence **: "ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" and "\ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0; map Send K\\<^sub>c' \" + using * by auto + hence "\k. k \ set K \ ik\<^sub>e\<^sub>s\<^sub>t \ \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" + using * strand_sem_Send_split(1) strand_sem_eq_defs(1) + by auto + thus ?thesis using Decomp sem\<^sub>e\<^sub>s\<^sub>t_c.Decompose[OF IH ** Ana] by metis + qed + qed + + show "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ \ \ \M\<^sub>0; to_st \\\<^sub>c' \" + proof (induction rule: sem\<^sub>e\<^sub>s\<^sub>t_c.induct) + case Nil thus ?case by simp + next + case (Send M\<^sub>0 \ \ t) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[send\t\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (send\t\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Receive M\<^sub>0 \ \ t) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[receive\t\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (receive\t\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Equality M\<^sub>0 \ \ t t' a) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[\a: t \ t'\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (\a: t \ t'\\<^sub>s\<^sub>t)]"] + by (simp add: sup.commute) + next + case (Inequality M\<^sub>0 \ \ X F) thus ?case + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "[\X\\\: F\\<^sub>s\<^sub>t]"] + to_st_append[of \ "[Step (\X\\\: F\\<^sub>s\<^sub>t)]"] + by (auto simp add: sup.commute) + next + case (Decompose M\<^sub>0 \ \ t K M) + have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); decomp t\\<^sub>c' \" + proof - + have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); [send\t\\<^sub>s\<^sub>t]\\<^sub>c' \" + using Decompose.hyps(2) by (auto simp add: sup.commute) + moreover have "\k. k \ set K \ M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" + using Decompose by (metis sup.commute) + hence "\k. k \ set K \ \M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); [Send k]\\<^sub>c' \" by auto + hence "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); map Send K\\<^sub>c' \" + using strand_sem_Send_map(1)[of K, of "M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \) \\<^sub>s\<^sub>e\<^sub>t \" \] + strand_sem_eq_defs(1) + by auto + moreover have "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); map Receive M\\<^sub>c' \" + by (metis strand_sem_Receive_map(1) strand_sem_eq_defs(1)) + ultimately have + "\M\<^sub>0 \ ik\<^sub>s\<^sub>t (to_st \); send\t\\<^sub>s\<^sub>t#map Send K@map Receive M\\<^sub>c' \" + by auto + thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto + qed + hence "\M\<^sub>0; to_st \@decomp t\\<^sub>c' \" + using strand_sem_append'[of M\<^sub>0 "to_st \" \ "decomp t"] Decompose.IH + by simp + thus ?case using to_st_append[of \ "[Decomp t]"] by simp + qed +qed + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct_aux: + assumes "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ A" "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + shows "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t" +using assms +proof (induction M\<^sub>0 \ A arbitrary: t rule: sem\<^sub>e\<^sub>s\<^sub>t_c.induct) + case (Send M\<^sub>0 \ A t') thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append ik\<^sub>e\<^sub>s\<^sub>t_append by auto +next + case (Receive M\<^sub>0 \ A t') + hence "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append ik\<^sub>e\<^sub>s\<^sub>t_append by auto + hence IH: "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t" using Receive.IH by auto + show ?case using ideduct_mono[OF IH] decomp_rm\<^sub>e\<^sub>s\<^sub>t_append ik\<^sub>e\<^sub>s\<^sub>t_append by auto +next + case (Equality M\<^sub>0 \ A t') thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append ik\<^sub>e\<^sub>s\<^sub>t_append by auto +next + case (Inequality M\<^sub>0 \ A t') thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append ik\<^sub>e\<^sub>s\<^sub>t_append by auto +next + case (Decompose M\<^sub>0 \ A t' K M t) + have *: "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t' \ \" using Decompose.hyps(2) + proof (induction rule: intruder_synth_induct) + case (AxiomC t'') + moreover { + assume "t'' \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t'' \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + hence ?case using Decompose.IH by auto + } + ultimately show ?case by force + qed simp + + { fix k assume "k \ set K" + hence "ik\<^sub>e\<^sub>s\<^sub>t A \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" using Decompose.hyps by auto + hence "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ k \ \" + proof (induction rule: intruder_synth_induct) + case (AxiomC t'') + moreover { + assume "t'' \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t'' \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + hence ?case using Decompose.IH by auto + } + ultimately show ?case by force + qed simp + } + hence **: "\k. k \ set (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ k" by auto + + show ?case + proof (cases "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \") + case True thus ?thesis using Decompose.IH Decompose.prems(2) decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by auto + next + case False + hence "t \ ik\<^sub>s\<^sub>t (decomp t') \\<^sub>s\<^sub>e\<^sub>t \" using Decompose.prems(1) ik\<^sub>e\<^sub>s\<^sub>t_append by auto + hence ***: "t \ set (M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" using Decompose.hyps(3) decomp_ik by auto + hence "M \ []" by auto + hence ****: "Ana (t' \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" using Ana_subst[OF Decompose.hyps(3)] by auto + + have "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t" by (rule intruder_deduct.Decompose[OF * **** ** ***]) + thus ?thesis using ideduct_mono decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by auto + qed +qed simp + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct: + assumes "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ A" "ik\<^sub>e\<^sub>s\<^sub>t A \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t" + shows "ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \ \ t" +using assms(2) +proof (induction t rule: intruder_synth_induct) + case (AxiomC t) + hence "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \ \ t \ M\<^sub>0 \\<^sub>s\<^sub>e\<^sub>t \" by auto + moreover { + assume "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + hence ?case using ideduct_mono[OF intruder_deduct.Axiom] by auto + } + moreover { + assume "t \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" "t \ ik\<^sub>e\<^sub>s\<^sub>t (decomp_rm\<^sub>e\<^sub>s\<^sub>t A) \\<^sub>s\<^sub>e\<^sub>t \" + hence ?case using sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct_aux[OF assms(1)] by auto + } + ultimately show ?case by auto +qed simp + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_d_decomp_rm\<^sub>e\<^sub>s\<^sub>t_if_sem\<^sub>e\<^sub>s\<^sub>t_c: "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ A \ sem\<^sub>e\<^sub>s\<^sub>t_d M\<^sub>0 \ (decomp_rm\<^sub>e\<^sub>s\<^sub>t A)" +proof (induction M\<^sub>0 \ A rule: sem\<^sub>e\<^sub>s\<^sub>t_c.induct) + case (Send M\<^sub>0 \ A t) + thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append sem\<^sub>e\<^sub>s\<^sub>t_d.Send[OF Send.IH] sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct by auto +next + case (Receive t) thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append sem\<^sub>e\<^sub>s\<^sub>t_d.Receive by auto +next + case (Equality M\<^sub>0 \ A t) + thus ?case + using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append sem\<^sub>e\<^sub>s\<^sub>t_d.Equality[OF Equality.IH] sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct + by auto +next + case (Inequality M\<^sub>0 \ A t) + thus ?case + using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append sem\<^sub>e\<^sub>s\<^sub>t_d.Inequality[OF Inequality.IH] sem\<^sub>e\<^sub>s\<^sub>t_c_decomp_rm\<^sub>e\<^sub>s\<^sub>t_deduct + by auto +next + case Decompose thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by auto +qed auto + +private lemma sem\<^sub>e\<^sub>s\<^sub>t_c_decomps\<^sub>e\<^sub>s\<^sub>t_append: + assumes "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ A" "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \) \" + shows "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (A@D)" +using assms(2,1) +proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp D f T K M) + hence *: "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (A @ D)" "ik\<^sub>e\<^sub>s\<^sub>t (A@D) \ {} \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c Fun f T \ \" + "\k. k \ set K \ ik\<^sub>e\<^sub>s\<^sub>t (A @ D) \ {} \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" + using ik\<^sub>e\<^sub>s\<^sub>t_append by auto + show ?case using sem\<^sub>e\<^sub>s\<^sub>t_c.Decompose[OF *(1,2) Decomp.hyps(3) *(3)] by simp +qed auto + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_preserves_wf: + assumes "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \" "wf\<^sub>e\<^sub>s\<^sub>t V A" + shows "wf\<^sub>e\<^sub>s\<^sub>t V (A@D)" +using assms +proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp D f T K M) + have "wfrestrictedvars\<^sub>s\<^sub>t (decomp (Fun f T)) \ fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using decomp_vars fv_subset_subterms[OF Decomp.hyps(2)] by fast + hence "wfrestrictedvars\<^sub>s\<^sub>t (decomp (Fun f T)) \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t A" + using ik\<^sub>s\<^sub>t_assignment_rhs\<^sub>s\<^sub>t_wfrestrictedvars_subset[of "to_st A"] by blast + hence "wfrestrictedvars\<^sub>s\<^sub>t (decomp (Fun f T)) \ wfrestrictedvars\<^sub>s\<^sub>t (to_st (A@D)) \ V" + using to_st_append[of A D] strand_vars_split(2)[of "to_st A" "to_st D"] + by (metis le_supI1) + thus ?case + using wf_append_suffix[OF Decomp.IH[OF Decomp.prems], of "decomp (Fun f T)"] + to_st_append[of "A@D" "[Decomp (Fun f T)]"] + by auto +qed auto + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_preserves_model_c: + assumes "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \" "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ A" + shows "sem\<^sub>e\<^sub>s\<^sub>t_c M\<^sub>0 \ (A@D)" +using assms +proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp D f T K M) show ?case + using sem\<^sub>e\<^sub>s\<^sub>t_c.Decompose[OF Decomp.IH[OF Decomp.prems] _ Decomp.hyps(3)] + Decomp.hyps(5,6) ideduct_synth_mono ik\<^sub>e\<^sub>s\<^sub>t_append + by (metis (mono_tags, lifting) List.append_assoc image_Un sup_ge1) +qed auto + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_exist_aux: + assumes "D \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "M \ ik\<^sub>e\<^sub>s\<^sub>t D \ t" "\(M \ (ik\<^sub>e\<^sub>s\<^sub>t D) \\<^sub>c t)" + obtains D' where + "D@D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "M \ ik\<^sub>e\<^sub>s\<^sub>t (D@D') \\<^sub>c t" "M \ ik\<^sub>e\<^sub>s\<^sub>t D \ M \ ik\<^sub>e\<^sub>s\<^sub>t (D@D')" +proof - + have "\D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \. M \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>c t" using assms(2) + proof (induction t rule: intruder_deduct_induct) + case (Compose X f) + from Compose.IH have "\D \ decomps\<^sub>e\<^sub>s\<^sub>t M N \. \x \ set X. M \ ik\<^sub>e\<^sub>s\<^sub>t D \\<^sub>c x" + proof (induction X) + case (Cons t X) + then obtain D' D'' where + D': "D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "M \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>c t" and + D'': "D'' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "\x \ set X. M \ ik\<^sub>e\<^sub>s\<^sub>t D'' \\<^sub>c x" + by moura + hence "M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c t" "\x \ set X. M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c x" + by (auto intro: ideduct_synth_mono simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + thus ?case using decomps\<^sub>e\<^sub>s\<^sub>t_append[OF D'(1) D''(1)] by (metis set_ConsD) + qed (auto intro: decomps\<^sub>e\<^sub>s\<^sub>t.Nil) + thus ?case using intruder_synth.ComposeC[OF Compose.hyps(1,2)] by metis + next + case (Decompose t K T t\<^sub>i) + have "\D \ decomps\<^sub>e\<^sub>s\<^sub>t M N \. \k \ set K. M \ ik\<^sub>e\<^sub>s\<^sub>t D \\<^sub>c k" using Decompose.IH + proof (induction K) + case (Cons t X) + then obtain D' D'' where + D': "D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "M \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>c t" and + D'': "D'' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "\x \ set X. M \ ik\<^sub>e\<^sub>s\<^sub>t D'' \\<^sub>c x" + using assms(1) by moura + hence "M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c t" "\x \ set X. M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c x" + by (auto intro: ideduct_synth_mono simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + thus ?case using decomps\<^sub>e\<^sub>s\<^sub>t_append[OF D'(1) D''(1)] by auto + qed auto + then obtain D' where D': "D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "\k. k \ set K \ M \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>c k" by metis + obtain D'' where D'': "D'' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "M \ ik\<^sub>e\<^sub>s\<^sub>t D'' \\<^sub>c t" by (metis Decompose.IH(1)) + obtain f X where fX: "t = Fun f X" "t\<^sub>i \ set X" + using Decompose.hyps(2,4) by (cases t) (auto dest: Ana_fun_subterm) + + from decomps\<^sub>e\<^sub>s\<^sub>t_append[OF D'(1) D''(1)] D'(2) D''(2) have *: + "D'@D'' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" "\k. k \ set K \ M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c k" + "M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>c t" + by (auto intro: ideduct_synth_mono simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + hence **: "\k. k \ set K \ M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" + using ideduct_synth_subst by auto + + have "t\<^sub>i \ ik\<^sub>s\<^sub>t (decomp t)" using Decompose.hyps(2,4) ik_rcv_map unfolding decomp_def by auto + with *(3) fX(1) Decompose.hyps(2) show ?case + proof (induction t rule: intruder_synth_induct) + case (AxiomC t) + hence t_in_subterms: "t \ subterms\<^sub>s\<^sub>e\<^sub>t (M \ N)" + using decomps\<^sub>e\<^sub>s\<^sub>t_ik_subset[OF *(1)] subset_subterms_Union + by auto + have "M \ ik\<^sub>e\<^sub>s\<^sub>t (D'@D'') \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" + using ideduct_synth_subst[OF intruder_synth.AxiomC[OF AxiomC.hyps(1)]] by metis + moreover have "T \ []" using decomp_ik[OF \Ana t = (K,T)\] \t\<^sub>i \ ik\<^sub>s\<^sub>t (decomp t)\ by auto + ultimately have "D'@D''@[Decomp (Fun f X)] \ decomps\<^sub>e\<^sub>s\<^sub>t M N \" + using AxiomC decomps\<^sub>e\<^sub>s\<^sub>t.Decomp[OF *(1) _ _ _ _ **] subset_subterms_Union t_in_subterms + by (simp add: subset_eq) + moreover have "decomp t = to_st [Decomp (Fun f X)]" using AxiomC.prems(1,2) by auto + ultimately show ?case + by (metis AxiomC.prems(3) UnCI intruder_synth.AxiomC ik\<^sub>e\<^sub>s\<^sub>t_append to_st_append) + qed (auto intro!: fX(2) *(1)) + qed (fastforce intro: intruder_synth.AxiomC assms(1)) + hence "\D' \ decomps\<^sub>e\<^sub>s\<^sub>t M N \. M \ ik\<^sub>e\<^sub>s\<^sub>t (D@D') \\<^sub>c t" + by (auto intro: ideduct_synth_mono simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + thus thesis using that[OF decomps\<^sub>e\<^sub>s\<^sub>t_append[OF assms(1)]] assms ik\<^sub>e\<^sub>s\<^sub>t_append by moura +qed + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_ik_max_exist: + assumes "finite A" "finite N" + shows "\D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. \D' \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. ik\<^sub>e\<^sub>s\<^sub>t D' \ ik\<^sub>e\<^sub>s\<^sub>t D" +proof - + let ?IK = "\M. \D \ M. ik\<^sub>e\<^sub>s\<^sub>t D" + have "?IK (decomps\<^sub>e\<^sub>s\<^sub>t A N \) \ (\t \ A \ N. subterms t)" by (auto dest!: decomps\<^sub>e\<^sub>s\<^sub>t_ik_subset) + hence "finite (?IK (decomps\<^sub>e\<^sub>s\<^sub>t A N \))" + using subterms_union_finite[OF assms(1)] subterms_union_finite[OF assms(2)] infinite_super + by auto + then obtain M where M: "finite M" "M \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" "?IK M = ?IK (decomps\<^sub>e\<^sub>s\<^sub>t A N \)" + using finite_subset_Union by moura + show ?thesis using decomps\<^sub>e\<^sub>s\<^sub>t_finite_ik_append[OF M(1,2)] M(3) by auto +qed + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_exist: + assumes "finite A" "finite N" + shows "\D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. \t. A \ t \ A \ ik\<^sub>e\<^sub>s\<^sub>t D \\<^sub>c t" +proof (rule ccontr) + assume neg: "\(\D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. \t. A \ t \ A \ ik\<^sub>e\<^sub>s\<^sub>t D \\<^sub>c t)" + + obtain D where D: "D \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" "\D' \ decomps\<^sub>e\<^sub>s\<^sub>t A N \. ik\<^sub>e\<^sub>s\<^sub>t D' \ ik\<^sub>e\<^sub>s\<^sub>t D" + using decomps\<^sub>e\<^sub>s\<^sub>t_ik_max_exist[OF assms] by moura + then obtain t where t: "A \ ik\<^sub>e\<^sub>s\<^sub>t D \ t" "\(A \ ik\<^sub>e\<^sub>s\<^sub>t D \\<^sub>c t)" + using neg by (fastforce intro: ideduct_mono) + + obtain D' where D': + "D@D' \ decomps\<^sub>e\<^sub>s\<^sub>t A N \" "A \ ik\<^sub>e\<^sub>s\<^sub>t (D@D') \\<^sub>c t" + "A \ ik\<^sub>e\<^sub>s\<^sub>t D \ A \ ik\<^sub>e\<^sub>s\<^sub>t (D@D')" + by (metis decomps\<^sub>e\<^sub>s\<^sub>t_exist_aux t D(1)) + hence "ik\<^sub>e\<^sub>s\<^sub>t D \ ik\<^sub>e\<^sub>s\<^sub>t (D@D')" using ik\<^sub>e\<^sub>s\<^sub>t_append by auto + moreover have "ik\<^sub>e\<^sub>s\<^sub>t (D@D') \ ik\<^sub>e\<^sub>s\<^sub>t D" using D(2) D'(1) by auto + ultimately show False by simp +qed + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_exist_subst: + assumes "ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" + and "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ A" "wf\<^sub>e\<^sub>s\<^sub>t {} A" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + and "Ana_invar_subst (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + and "well_analyzed A" + shows "\D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \. ik\<^sub>e\<^sub>s\<^sub>t (A@D) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" +proof - + have ik_eq: "ik\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \) = ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" using assms(5,6) + proof (induction A rule: List.rev_induct) + case (snoc a A) + hence "Ana_invar_subst (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using Ana_invar_subst_subset[OF snoc.prems(1)] ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append + unfolding Ana_invar_subst_def by simp + with snoc have IH: + "ik\<^sub>e\<^sub>s\<^sub>t (A@[a] \\<^sub>e\<^sub>s\<^sub>t \) = (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t ([a] \\<^sub>e\<^sub>s\<^sub>t \)" + "ik\<^sub>e\<^sub>s\<^sub>t (A@[a]) \\<^sub>s\<^sub>e\<^sub>t \ = (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t [a] \\<^sub>s\<^sub>e\<^sub>t \)" + using well_analyzed_split_left[OF snoc.prems(2)] + by (auto simp add: to_st_append ik\<^sub>e\<^sub>s\<^sub>t_append_subst) + + have "ik\<^sub>e\<^sub>s\<^sub>t [a \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \] = ik\<^sub>e\<^sub>s\<^sub>t [a] \\<^sub>s\<^sub>e\<^sub>t \" + proof (cases a) + case (Step b) thus ?thesis by (cases b) auto + next + case (Decomp t) + then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force + obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair) + moreover have "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t ((ik\<^sub>e\<^sub>s\<^sub>t (A@[a]) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@[a])))" + using t Decomp snoc.prems(2) + by (auto dest: well_analyzed_inv simp add: ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append) + hence "Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + using Ana_t snoc.prems(1) + unfolding Ana_invar_subst_def by force + ultimately show ?thesis using Decomp t by (auto simp add: decomp_ik) + qed + thus ?case using IH unfolding subst_apply_extstrand_def by simp + qed simp + moreover have assignment_rhs_eq: "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \) = assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" + using assms(5,6) + proof (induction A rule: List.rev_induct) + case (snoc a A) + hence "Ana_invar_subst (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using Ana_invar_subst_subset[OF snoc.prems(1)] ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append + unfolding Ana_invar_subst_def by simp + hence "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A \\<^sub>e\<^sub>s\<^sub>t \) = assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \" + using snoc.IH well_analyzed_split_left[OF snoc.prems(2)] + by simp + hence IH: + "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@[a] \\<^sub>e\<^sub>s\<^sub>t \) = (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t ([a] \\<^sub>e\<^sub>s\<^sub>t \)" + "assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@[a]) \\<^sub>s\<^sub>e\<^sub>t \ = (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t [a] \\<^sub>s\<^sub>e\<^sub>t \)" + by (metis assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append_subst(1), metis assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append_subst(2)) + + have "assignment_rhs\<^sub>e\<^sub>s\<^sub>t [a \\<^sub>e\<^sub>s\<^sub>t\<^sub>p \] = assignment_rhs\<^sub>e\<^sub>s\<^sub>t [a] \\<^sub>s\<^sub>e\<^sub>t \" + proof (cases a) + case (Step b) thus ?thesis by (cases b) auto + next + case (Decomp t) + then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force + obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair) + moreover have "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t ((ik\<^sub>e\<^sub>s\<^sub>t (A@[a]) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@[a])))" + using t Decomp snoc.prems(2) + by (auto dest: well_analyzed_inv simp add: ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append) + hence "Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" + using Ana_t snoc.prems(1) unfolding Ana_invar_subst_def by force + ultimately show ?thesis using Decomp t by (auto simp add: decomp_assignment_rhs_empty) + qed + thus ?case using IH unfolding subst_apply_extstrand_def by simp + qed simp + ultimately obtain D where D: + "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) Var" + "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D) \\<^sub>c t \ \" + using decomps\<^sub>e\<^sub>s\<^sub>t_exist[OF ik\<^sub>e\<^sub>s\<^sub>t_finite assignment_rhs\<^sub>e\<^sub>s\<^sub>t_finite, of "A \\<^sub>e\<^sub>s\<^sub>t \" "A \\<^sub>e\<^sub>s\<^sub>t \"] + ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append assms(1) + by force + + let ?P = "\D D'. \t. (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D) \\<^sub>c t \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t" + + have "\D' \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \. ?P D D'" using D(1) + proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case Nil + have "ik\<^sub>e\<^sub>s\<^sub>t [] = ik\<^sub>e\<^sub>s\<^sub>t [] \\<^sub>s\<^sub>e\<^sub>t \" by auto + thus ?case by (metis decomps\<^sub>e\<^sub>s\<^sub>t.Nil) + next + case (Decomp D f T K M) + obtain D' where D': "D' \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \" "?P D D'" + using Decomp.IH by auto + hence IH: "\k. k \ set K \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c k" + "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c Fun f T" + using Decomp.hyps(5,6) by auto + + have D'_ik: "ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \ \ subterms\<^sub>s\<^sub>e\<^sub>t ((ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)) \\<^sub>s\<^sub>e\<^sub>t \" + "ik\<^sub>e\<^sub>s\<^sub>t D' \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using decomps\<^sub>e\<^sub>s\<^sub>t_ik_subset[OF D'(1)] by (metis subst_all_mono, metis) + + show ?case using IH(2,1) Decomp.hyps(2,3,4) + proof (induction "Fun f T" arbitrary: f T K M rule: intruder_synth_induct) + case (AxiomC f T) + then obtain s where s: "s \ ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t D'" "Fun f T = s \ \" using AxiomC.prems by blast + hence fT_s_in: "Fun f T \ (subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)) \\<^sub>s\<^sub>e\<^sub>t \" + "s \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using AxiomC D'_ik subset_subterms_Union[of "ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A"] + subst_all_mono[OF subset_subterms_Union, of \] + by (metis (no_types) Un_iff image_eqI subset_Un_eq, metis (no_types) Un_iff subset_Un_eq) + obtain Ks Ms where Ana_s: "Ana s = (Ks,Ms)" by moura + + have AD'_props: "wf\<^sub>e\<^sub>s\<^sub>t {} (A@D')" "\{}; to_st (A@D')\\<^sub>c \" + using decomps\<^sub>e\<^sub>s\<^sub>t_preserves_model_c[OF D'(1) assms(2)] + decomps\<^sub>e\<^sub>s\<^sub>t_preserves_wf[OF D'(1) assms(3)] + sem\<^sub>e\<^sub>s\<^sub>t_c_eq_sem_st strand_sem_eq_defs(1) + by auto + + show ?case + proof (cases s) + case (Var x) + \ \In this case \\ x\ (is a subterm of something that) was derived from an + "earlier intruder knowledge" because \A\ is well-formed and has \\\ as a model. + So either the intruder composed \Fun f T\ himself (making \Decomp (Fun f T)\ + unnecessary) or \Fun f T\ is an instance of something else in the intruder + knowledge (in which case the "something" can be used in place of \Fun f T\)\ + hence "Var x \ ik\<^sub>e\<^sub>s\<^sub>t (A@D')" "\ x = Fun f T" using s ik\<^sub>e\<^sub>s\<^sub>t_append by auto + + show ?thesis + proof (cases "\m \ set M. ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c m") + case True + \ \All terms acquired by decomposing \Fun f T\ are already derivable. + Hence there is no need to consider decomposition of \Fun f T\ at all.\ + have *: "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (D@[Decomp (Fun f T)]) = (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t D \ set M" + using decomp_ik[OF \Ana (Fun f T) = (K,M)\] ik\<^sub>e\<^sub>s\<^sub>t_append[of D "[Decomp (Fun f T)]"] + by auto + + { fix t' assume "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t D \ set M \\<^sub>c t'" + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" + proof (induction t' rule: intruder_synth_induct) + case (AxiomC t') thus ?case + proof + assume "t' \ set M" + moreover have "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) = ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \" by auto + ultimately show ?case using True by auto + qed (metis D'(2) intruder_synth.AxiomC) + qed auto + } + thus ?thesis using D'(1) * by metis + next + case False + \ \Some term acquired by decomposition of \Fun f T\ cannot be derived in \\\<^sub>c\. + \Fun f T\ must therefore be an instance of something else in the intruder knowledge, + because of well-formedness.\ + then obtain t\<^sub>i where t\<^sub>i: "t\<^sub>i \ set T" "\ik\<^sub>e\<^sub>s\<^sub>t (A@D') \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t\<^sub>i" + using Ana_fun_subterm[OF \Ana (Fun f T) = (K,M)\] by (auto simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + obtain S where fS: + "Fun f S \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t (A@D')) \ + Fun f S \ subterms\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@D'))" + "\ x = Fun f S \ \" + using strand_sem_wf_ik_or_assignment_rhs_fun_subterm[ + OF AD'_props \Var x \ ik\<^sub>e\<^sub>s\<^sub>t (A@D')\ _ t\<^sub>i \interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\] + \\ x = Fun f T\ + by moura + hence fS_in: "Fun f S \ \ \ ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \" + "Fun f S \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A)" + using imageI[OF s(1), of "\x. x \ \"] Var + ik\<^sub>e\<^sub>s\<^sub>t_append[of A D'] assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append[of A D'] + decomps\<^sub>e\<^sub>s\<^sub>t_subterms[OF D'(1)] decomps\<^sub>e\<^sub>s\<^sub>t_assignment_rhs_empty[OF D'(1)] + by auto + obtain KS MS where Ana_fS: "Ana (Fun f S) = (KS, MS)" by moura + hence "K = KS \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \" "M = MS \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \" + using Ana_invar_substD[OF assms(5) fS_in(2)] + s(2) fS(2) \s = Var x\ \Ana (Fun f T) = (K,M)\ + by simp_all + hence "MS \ []" using \M \ []\ by simp + have "\k. k \ set KS \ ik\<^sub>e\<^sub>s\<^sub>t A \ ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c k \ \" + using AxiomC.prems(1) \K = KS \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \\ by (simp add: image_Un) + hence D'': "D'@[Decomp (Fun f S)] \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \" + using decomps\<^sub>e\<^sub>s\<^sub>t.Decomp[OF D'(1) fS_in(2) Ana_fS \MS \ []\] AxiomC.prems(1) + intruder_synth.AxiomC[OF fS_in(1)] + by simp + moreover { + fix t' assume "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (D@[Decomp (Fun f T)]) \\<^sub>c t'" + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t (D'@[Decomp (Fun f S)]) \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" + proof (induction t' rule: intruder_synth_induct) + case (AxiomC t') + hence "t' \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t D \ t' \ ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f T)]" + by (simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + thus ?case + proof + assume "t' \ ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f T)]" + hence "t' \ ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f S)] \\<^sub>s\<^sub>e\<^sub>t \" + using decomp_ik \Ana (Fun f T) = (K,M)\ \Ana (Fun f S) = (KS,MS)\ \M = MS \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \\ + by simp + thus ?case + using ideduct_synth_mono[ + OF intruder_synth.AxiomC[of t' "ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f S)] \\<^sub>s\<^sub>e\<^sub>t \"], + of "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t (D'@[Decomp (Fun f S)]) \\<^sub>s\<^sub>e\<^sub>t \)"] + by (auto simp add: ik\<^sub>e\<^sub>s\<^sub>t_append) + next + assume "t' \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t D" + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" + by (metis D'(2) intruder_synth.AxiomC) + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f S)] \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" + by (simp add: ideduct_synth_mono) + thus ?case + using ik\<^sub>e\<^sub>s\<^sub>t_append[of D' "[Decomp (Fun f S)]"] + image_Un[of "\x. x \ \" "ik\<^sub>e\<^sub>s\<^sub>t D'" "ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun f S)]"] + by (simp add: sup_aci(2)) + qed + qed auto + } + ultimately show ?thesis using D'' by auto + qed + next + case (Fun g S) \ \Hence \Decomp (Fun f T)\ can be substituted for \Decomp (Fun g S)\\ + hence KM: "K = Ks \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \" "M = Ms \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \" "set K = set Ks \\<^sub>s\<^sub>e\<^sub>t \" "set M = set Ms \\<^sub>s\<^sub>e\<^sub>t \" + using fT_s_in(2) \Ana (Fun f T) = (K,M)\ Ana_s s(2) + Ana_invar_substD[OF assms(5), of g S] + by auto + hence Ms_nonempty: "Ms \ []" using \M \ []\ by auto + { fix t' assume "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (D@[Decomp (Fun f T)]) \\<^sub>c t'" + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t (D'@[Decomp (Fun g S)]) \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" using AxiomC + proof (induction t' rule: intruder_synth_induct) + case (AxiomC t') + hence "t' \ ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \ \ t' \ ik\<^sub>e\<^sub>s\<^sub>t D \ t' \ set M" + by (simp add: decomp_ik ik\<^sub>e\<^sub>s\<^sub>t_append) + thus ?case + proof (elim disjE) + assume "t' \ ik\<^sub>e\<^sub>s\<^sub>t D" + hence *: "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" using D'(2) by simp + show ?case by (auto intro: ideduct_synth_mono[OF *] simp add: ik\<^sub>e\<^sub>s\<^sub>t_append_subst(2)) + next + assume "t' \ set M" + hence "t' \ ik\<^sub>e\<^sub>s\<^sub>t [Decomp (Fun g S)] \\<^sub>s\<^sub>e\<^sub>t \" + using KM(2) Fun decomp_ik[OF Ana_s] by auto + thus ?case by (simp add: image_Un ik\<^sub>e\<^sub>s\<^sub>t_append) + qed (simp add: ideduct_synth_mono[OF intruder_synth.AxiomC]) + qed auto + } + thus ?thesis + using s Fun Ana_s AxiomC.prems(1) KM(3) fT_s_in + decomps\<^sub>e\<^sub>s\<^sub>t.Decomp[OF D'(1) _ _ Ms_nonempty, of g S Ks] + by (metis AxiomC.hyps image_Un image_eqI intruder_synth.AxiomC) + qed + next + case (ComposeC T f) + have *: "\m. m \ set M \ (ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c m" + using Ana_fun_subterm[OF \Ana (Fun f T) = (K, M)\] ComposeC.hyps(3) + by auto + + have **: "ik\<^sub>e\<^sub>s\<^sub>t (D@[Decomp (Fun f T)]) = ik\<^sub>e\<^sub>s\<^sub>t D \ set M" + using decomp_ik[OF \Ana (Fun f T) = (K, M)\] ik\<^sub>e\<^sub>s\<^sub>t_append by auto + + { fix t' assume "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ ik\<^sub>e\<^sub>s\<^sub>t (D@[Decomp (Fun f T)]) \\<^sub>c t'" + hence "(ik\<^sub>e\<^sub>s\<^sub>t A \\<^sub>s\<^sub>e\<^sub>t \) \ (ik\<^sub>e\<^sub>s\<^sub>t D' \\<^sub>s\<^sub>e\<^sub>t \) \\<^sub>c t'" + by (induct rule: intruder_synth_induct) (auto simp add: D'(2) * **) + } + thus ?case using D'(1) by auto + qed + qed + thus ?thesis using D(2) assms(1) by (auto simp add: ik\<^sub>e\<^sub>s\<^sub>t_append_subst(2)) +qed + +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_nil: assumes "wf\<^sub>s\<^sub>t\<^sub>s' \ \" shows "wf\<^sub>s\<^sub>t\<^sub>s' (update\<^sub>s\<^sub>t \ []) \" +using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_snd: + assumes "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "send\t\\<^sub>s\<^sub>t#S \ \" + shows "wf\<^sub>s\<^sub>t\<^sub>s' (update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S)) (\@[Step (receive\t\\<^sub>s\<^sub>t)])" +unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def +proof (intro conjI) + let ?S = "send\t\\<^sub>s\<^sub>t#S" + let ?A = "\@[Step (receive\t\\<^sub>s\<^sub>t)]" + + have \: "\S'. S' \ update\<^sub>s\<^sub>t \ ?S \ S' = S \ S' \ \" by auto + + have 1: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \) (dual\<^sub>s\<^sub>t S)" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + moreover have 2: "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \ \ fv t" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split(2) by (auto simp add: Un_assoc) + ultimately have 3: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis wf_vars_mono) + + have 4: "\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by simp + + have "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" using 1 2 3 assms(2) by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis 3 \) + + have "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t S = {}" + using 4 assms(2) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by force+ + thus "\S \ update\<^sub>s\<^sub>t \ ?S. \S' \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" by (metis 4 \) + + have "\S' \ \. fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>s\<^sub>t S' = {}" "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t ?S = {}" + using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by metis+ + hence 5: "fv\<^sub>e\<^sub>s\<^sub>t ?A = fv\<^sub>e\<^sub>s\<^sub>t \ \ fv t" "bvars\<^sub>e\<^sub>s\<^sub>t ?A = bvars\<^sub>e\<^sub>s\<^sub>t \" "\S' \ \. fv t \ bvars\<^sub>s\<^sub>t S' = {}" + using to_st_append by fastforce+ + + have *: "\S \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" using assms(2) by metis + hence "fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by (metis * \) + + have **: "\S \ \. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t ?S = {}" using assms(2) by metis + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by fastforce + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by (metis ** \) +qed + +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_rcv: + assumes "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "receive\t\\<^sub>s\<^sub>t#S \ \" + shows "wf\<^sub>s\<^sub>t\<^sub>s' (update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S)) (\@[Step (send\t\\<^sub>s\<^sub>t)])" +unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def +proof (intro conjI) + let ?S = "receive\t\\<^sub>s\<^sub>t#S" + let ?A = "\@[Step (send\t\\<^sub>s\<^sub>t)]" + + have \: "\S'. S' \ update\<^sub>s\<^sub>t \ ?S \ S' = S \ S' \ \" by auto + + have 1: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \) (dual\<^sub>s\<^sub>t S)" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + moreover have 2: "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \ \ fv t" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split(2) by (auto simp add: Un_assoc) + ultimately have 3: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis wf_vars_mono) + + have 4: "\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by simp + + have "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" using 1 2 3 assms(2) by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis 3 \) + + have "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t S = {}" + using 4 assms(2) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by force+ + thus "\S \ update\<^sub>s\<^sub>t \ ?S. \S' \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" by (metis 4 \) + + have "\S' \ \. fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>s\<^sub>t S' = {}" "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t ?S = {}" + using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by metis+ + hence 5: "fv\<^sub>e\<^sub>s\<^sub>t ?A = fv\<^sub>e\<^sub>s\<^sub>t \ \ fv t" "bvars\<^sub>e\<^sub>s\<^sub>t ?A = bvars\<^sub>e\<^sub>s\<^sub>t \" "\S' \ \. fv t \ bvars\<^sub>s\<^sub>t S' = {}" + using to_st_append by fastforce+ + + have *: "\S \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" using assms(2) by metis + hence "fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by (metis * \) + + have **: "\S \ \. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t ?S = {}" using assms(2) by metis + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by fastforce + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by (metis ** \) +qed + +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_eq: + assumes "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "\a: t \ t'\\<^sub>s\<^sub>t#S \ \" + shows "wf\<^sub>s\<^sub>t\<^sub>s' (update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S)) (\@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" +unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def +proof (intro conjI) + let ?S = "\a: t \ t'\\<^sub>s\<^sub>t#S" + let ?A = "\@[Step (\a: t \ t'\\<^sub>s\<^sub>t)]" + + have \: "\S'. S' \ update\<^sub>s\<^sub>t \ ?S \ S' = S \ S' \ \" by auto + + have 1: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \) (dual\<^sub>s\<^sub>t S)" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + moreover have 2: + "a = Assign \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \ \ fv t \ fv t'" + "a = Check \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split(2) by (auto simp add: Un_assoc) + ultimately have 3: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" + by (cases a) (metis wf_vars_mono, metis) + + have 4: "\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by simp + + have "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" using 1 2 3 assms(2) by (cases a) auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis 3 \) + + have "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t S = {}" + using 4 assms(2) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by force+ + thus "\S \ update\<^sub>s\<^sub>t \ ?S. \S' \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" by (metis 4 \) + + have "\S' \ \. fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>s\<^sub>t S' = {}" "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t ?S = {}" + using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by metis+ + hence 5: "fv\<^sub>e\<^sub>s\<^sub>t ?A = fv\<^sub>e\<^sub>s\<^sub>t \ \ fv t \ fv t'" "bvars\<^sub>e\<^sub>s\<^sub>t ?A = bvars\<^sub>e\<^sub>s\<^sub>t \" + "\S' \ \. fv t \ bvars\<^sub>s\<^sub>t S' = {}" "\S' \ \. fv t' \ bvars\<^sub>s\<^sub>t S' = {}" + using to_st_append by fastforce+ + + have *: "\S \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" using assms(2) by metis + hence "fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by (metis * \) + + have **: "\S \ \. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" + using 5 assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t ?S = {}" using assms(2) by metis + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by fastforce + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by (metis ** \) +qed + +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_ineq: + assumes "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "\X\\\: F\\<^sub>s\<^sub>t#S \ \" + shows "wf\<^sub>s\<^sub>t\<^sub>s' (update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S)) (\@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" +unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def +proof (intro conjI) + let ?S = "\X\\\: F\\<^sub>s\<^sub>t#S" + let ?A = "\@[Step (\X\\\: F\\<^sub>s\<^sub>t)]" + + have \: "\S'. S' \ update\<^sub>s\<^sub>t \ ?S \ S' = S \ S' \ \" by auto + + have 1: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \) (dual\<^sub>s\<^sub>t S)" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + moreover have 2: "wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A = wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split(2) by (auto simp add: Un_assoc) + ultimately have 3: "\S \ \. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by metis + + have 4: "\S \ \. \S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by simp + + have "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" using 1 2 3 assms(2) by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t ?A) (dual\<^sub>s\<^sub>t S)" by (metis 3 \) + + have "fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" + "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t S = {}" + using 4 assms(2) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by force+ + thus "\S \ update\<^sub>s\<^sub>t \ ?S. \S' \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>s\<^sub>t S' = {}" by (metis 4 \) + + have "\S' \ \. fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>s\<^sub>t S' = {}" "\S' \ \. fv\<^sub>s\<^sub>t S' \ bvars\<^sub>s\<^sub>t ?S = {}" + using assms unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by metis+ + moreover have "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X \ fv\<^sub>s\<^sub>t (\X\\\: F\\<^sub>s\<^sub>t # S)" by auto + ultimately have 5: + "\S' \ \. (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X) \ bvars\<^sub>s\<^sub>t S' = {}" + "fv\<^sub>e\<^sub>s\<^sub>t ?A = fv\<^sub>e\<^sub>s\<^sub>t \ \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X)" "bvars\<^sub>e\<^sub>s\<^sub>t ?A = set X \ bvars\<^sub>e\<^sub>s\<^sub>t \" + "\S \ \. fv\<^sub>s\<^sub>t S \ set X = {}" + using to_st_append + by (blast, force, force, force) + + have *: "\S \ \. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" using 5(3,4) assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by blast + hence "fv\<^sub>s\<^sub>t ?S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" using assms(2) by metis + hence "fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t ?A = {}" by (metis * \) + + have **: "\S \ \. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" + using 5(1,2) assms(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fast + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t ?S = {}" using assms(2) by metis + hence "fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by auto + thus "\S \ update\<^sub>s\<^sub>t \ ?S. fv\<^sub>e\<^sub>s\<^sub>t ?A \ bvars\<^sub>s\<^sub>t S = {}" by (metis ** \) +qed + +private lemma trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq: + assumes "x#S \ \" + shows "\(trms\<^sub>s\<^sub>t ` update\<^sub>s\<^sub>t \ (x#S)) \ trms\<^sub>s\<^sub>t\<^sub>p x = \(trms\<^sub>s\<^sub>t ` \)" (is "?A = ?B") +proof + show "?B \ ?A" + proof + have "trms\<^sub>s\<^sub>t\<^sub>p x \ trms\<^sub>s\<^sub>t (x#S)" by auto + hence "\t'. t' \ ?B \ t' \ trms\<^sub>s\<^sub>t\<^sub>p x \ t' \ ?A" by simp + moreover { + fix t' assume t': "t' \ ?B" "t' \ trms\<^sub>s\<^sub>t\<^sub>p x" + then obtain S' where S': "t' \ trms\<^sub>s\<^sub>t S'" "S' \ \" by auto + hence "S' = x#S \ S' \ update\<^sub>s\<^sub>t \ (x#S)" by auto + moreover { + assume "S' = x#S" + hence "t' \ trms\<^sub>s\<^sub>t S" using S' t' by simp + hence "t' \ ?A" by auto + } + ultimately have "t' \ ?A" using t' S' by auto + } + ultimately show "\t'. t' \ ?B \ t' \ ?A" by metis + qed + + show "?A \ ?B" + proof + have "\t'. t' \ ?A \ t' \ trms\<^sub>s\<^sub>t\<^sub>p x \ trms\<^sub>s\<^sub>t\<^sub>p x \ ?B" + using assms by force+ + moreover { + fix t' assume t': "t' \ ?A" "t' \ trms\<^sub>s\<^sub>t\<^sub>p x" + then obtain S' where "t' \ trms\<^sub>s\<^sub>t S'" "S' \ update\<^sub>s\<^sub>t \ (x#S)" by auto + hence "S' = S \ S' \ \" by auto + moreover have "trms\<^sub>s\<^sub>t S \ ?B" using assms trms\<^sub>s\<^sub>t_cons[of x S] by blast + ultimately have "t' \ ?B" using t' by fastforce + } + ultimately show "\t'. t' \ ?A \ t' \ ?B" by blast + qed +qed + +private lemma trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_snd: + assumes "send\t\\<^sub>s\<^sub>t#S \ \" "\' = update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S)" "\' = \@[Step (receive\t\\<^sub>s\<^sub>t)]" + shows "(\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \) = (\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \')" +proof - + have "(trms\<^sub>e\<^sub>s\<^sub>t \') = (trms\<^sub>e\<^sub>s\<^sub>t \) \ {t}" "\(trms\<^sub>s\<^sub>t ` \') \ {t} = \(trms\<^sub>s\<^sub>t ` \)" + using to_st_append trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq[OF assms(1)] assms(2,3) by auto + thus ?thesis + by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral) +qed + +private lemma trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_rcv: + assumes "receive\t\\<^sub>s\<^sub>t#S \ \" "\' = update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S)" "\' = \@[Step (send\t\\<^sub>s\<^sub>t)]" + shows "(\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \) = (\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \')" +proof - + have "(trms\<^sub>e\<^sub>s\<^sub>t \') = (trms\<^sub>e\<^sub>s\<^sub>t \) \ {t}" "\(trms\<^sub>s\<^sub>t ` \') \ {t} = \(trms\<^sub>s\<^sub>t ` \)" + using to_st_append trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq[OF assms(1)] assms(2,3) by auto + thus ?thesis + by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral) +qed + +private lemma trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_eq: + assumes "\a: t \ t'\\<^sub>s\<^sub>t#S \ \" "\' = update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S)" "\' = \@[Step (\a: t \ t'\\<^sub>s\<^sub>t)]" + shows "(\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \) = (\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \')" +proof - + have "(trms\<^sub>e\<^sub>s\<^sub>t \') = (trms\<^sub>e\<^sub>s\<^sub>t \) \ {t,t'}" "\(trms\<^sub>s\<^sub>t ` \') \ {t,t'} = \(trms\<^sub>s\<^sub>t ` \)" + using to_st_append trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq[OF assms(1)] assms(2,3) by auto + thus ?thesis + by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral) +qed + +private lemma trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_ineq: + assumes "\X\\\: F\\<^sub>s\<^sub>t#S \ \" "\' = update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S)" "\' = \@[Step (\X\\\: F\\<^sub>s\<^sub>t)]" + shows "(\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \) = (\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \')" +proof - + have "(trms\<^sub>e\<^sub>s\<^sub>t \') = (trms\<^sub>e\<^sub>s\<^sub>t \) \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" "\(trms\<^sub>s\<^sub>t ` \') \ trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = \(trms\<^sub>s\<^sub>t ` \)" + using to_st_append trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq[OF assms(1)] assms(2,3) by auto + thus ?thesis by (simp add: Un_commute sup_left_commute) +qed + +private lemma ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset: + assumes "x#S \ \" + shows "\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` (update\<^sub>s\<^sub>t \ (x#S))) \ \(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)" (is ?A) + "\(assignment_rhs\<^sub>s\<^sub>t ` (update\<^sub>s\<^sub>t \ (x#S))) \ \(assignment_rhs\<^sub>s\<^sub>t ` \)" (is ?B) +proof - + { fix t assume "t \ \(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` (update\<^sub>s\<^sub>t \ (x#S)))" + then obtain S' where S': "S' \ update\<^sub>s\<^sub>t \ (x#S)" "t \ ik\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t S')" by auto + + have *: "ik\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t S) \ ik\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t (x#S))" + using ik_append[of "dual\<^sub>s\<^sub>t [x]" "dual\<^sub>s\<^sub>t S"] dual\<^sub>s\<^sub>t_append[of "[x]" S] + by auto + + hence "t \ \(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)" + proof (cases "S' = S") + case True thus ?thesis using * assms S' by auto + next + case False thus ?thesis using S' by auto + qed + } + moreover + { fix t assume "t \ \(assignment_rhs\<^sub>s\<^sub>t ` (update\<^sub>s\<^sub>t \ (x#S)))" + then obtain S' where S': "S' \ update\<^sub>s\<^sub>t \ (x#S)" "t \ assignment_rhs\<^sub>s\<^sub>t S'" by auto + + have "assignment_rhs\<^sub>s\<^sub>t S \ assignment_rhs\<^sub>s\<^sub>t (x#S)" + using assignment_rhs_append[of "[x]" S] by simp + hence "t \ \(assignment_rhs\<^sub>s\<^sub>t ` \)" + using assms S' by (cases "S' = S") auto + } + ultimately show ?A ?B by (metis subsetI)+ +qed + +private lemma ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_snd: + assumes "send\t\\<^sub>s\<^sub>t#S \ \" + "\' = update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S)" + "\' = \@[Step (receive\t\\<^sub>s\<^sub>t)]" + shows "(\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \') \ + (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" (is ?A) + "(\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \') \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" (is ?B) +proof - + { fix t' assume t'_in: "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \) \ {t}" using assms ik\<^sub>e\<^sub>s\<^sub>t_append by auto + moreover have "t \ \(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)" using assms(1) by force + ultimately have "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + moreover + { fix t' assume t'_in: "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using assms assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append by auto + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + ultimately show ?A ?B by (metis subsetI)+ +qed + +private lemma ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_rcv: + assumes "receive\t\\<^sub>s\<^sub>t#S \ \" + "\' = update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S)" + "\' = \@[Step (send\t\\<^sub>s\<^sub>t)]" + shows "(\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \') \ + (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" (is ?A) + "(\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \') \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" (is ?B) +proof - + { fix t' assume t'_in: "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" using assms ik\<^sub>e\<^sub>s\<^sub>t_append by auto + hence "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + moreover + { fix t' assume t'_in: "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using assms assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append by auto + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + ultimately show ?A ?B by (metis subsetI)+ +qed + +private lemma ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_eq: + assumes "\a: t \ t'\\<^sub>s\<^sub>t#S \ \" + "\' = update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S)" + "\' = \@[Step (\a: t \ t'\\<^sub>s\<^sub>t)]" + shows "(\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \') \ + (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" (is ?A) + "(\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \') \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" (is ?B) +proof - + have 1: "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" + when "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \')" + for t' + proof - + have "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" using that assms ik\<^sub>e\<^sub>s\<^sub>t_append by auto + thus ?thesis using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + qed + + have 2: "t'' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + when "t'' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \')" "a = Assign" + for t'' + proof - + have "t'' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \) \ {t'}" + using that assms assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append by auto + moreover have "t' \ \(assignment_rhs\<^sub>s\<^sub>t ` \)" using assms(1) that by force + ultimately show ?thesis using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) that by auto + qed + + have 3: "assignment_rhs\<^sub>e\<^sub>s\<^sub>t \' = assignment_rhs\<^sub>e\<^sub>s\<^sub>t \" (is ?C) + "(\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (\(assignment_rhs\<^sub>s\<^sub>t ` \))" (is ?D) + when "a = Check" + proof - + show ?C using that assms(2,3) by (simp add: assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append) + show ?D using assms(1,2,3) ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset(2) by auto + qed + + show ?A using 1 2 by (metis subsetI) + show ?B using 1 2 3 by (cases a) blast+ +qed + +private lemma ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_ineq: + assumes "\X\\\: F\\<^sub>s\<^sub>t#S \ \" + "\' = update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S)" + "\' = \@[Step (\X\\\: F\\<^sub>s\<^sub>t)]" + shows "(\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \') \ + (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" (is ?A) + "(\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \') \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" (is ?B) +proof - + { fix t' assume t'_in: "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \')) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" using assms ik\<^sub>e\<^sub>s\<^sub>t_append by auto + hence "t' \ (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \)) \ (ik\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + moreover + { fix t' assume t'_in: "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \')" + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \')) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using assms assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append by auto + hence "t' \ (\(assignment_rhs\<^sub>s\<^sub>t ` \)) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)" + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset[OF assms(1)] assms(2) by auto + } + ultimately show ?A ?B by (metis subsetI)+ +qed + + +subsubsection \Transition Systems Definitions\ +inductive pts_symbolic:: + "(('fun,'var) strands \ ('fun,'var) strand) \ + (('fun,'var) strands \ ('fun,'var) strand) \ bool" +(infix "\\<^sup>\" 50) where + Nil[simp]: "[] \ \ \ (\,\) \\<^sup>\ (update\<^sub>s\<^sub>t \ [],\)" +| Send[simp]: "send\t\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\ (update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S),\@[receive\t\\<^sub>s\<^sub>t])" +| Receive[simp]: "receive\t\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\ (update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S),\@[send\t\\<^sub>s\<^sub>t])" +| Equality[simp]: "\a: t \ t'\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\ (update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S),\@[\a: t \ t'\\<^sub>s\<^sub>t])" +| Inequality[simp]: "\X\\\: F\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\ (update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S),\@[\X\\\: F\\<^sub>s\<^sub>t])" + +private inductive pts_symbolic_c:: + "(('fun,'var) strands \ ('fun,'var) extstrand) \ + (('fun,'var) strands \ ('fun,'var) extstrand) \ bool" +(infix "\\<^sup>\\<^sub>c" 50) where + Nil[simp]: "[] \ \ \ (\,\) \\<^sup>\\<^sub>c (update\<^sub>s\<^sub>t \ [],\)" +| Send[simp]: "send\t\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\\<^sub>c (update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S),\@[Step (receive\t\\<^sub>s\<^sub>t)])" +| Receive[simp]: "receive\t\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\\<^sub>c (update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S),\@[Step (send\t\\<^sub>s\<^sub>t)])" +| Equality[simp]: "\a: t \ t'\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\\<^sub>c (update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S),\@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" +| Inequality[simp]: "\X\\\: F\\<^sub>s\<^sub>t#S \ \ \ (\,\) \\<^sup>\\<^sub>c (update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S),\@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" +| Decompose[simp]: "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \ \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \) + \ (\,\) \\<^sup>\\<^sub>c (\,\@[Decomp (Fun f T)])" + +abbreviation pts_symbolic_rtrancl (infix "\\<^sup>\\<^sup>*" 50) where "a \\<^sup>\\<^sup>* b \ pts_symbolic\<^sup>*\<^sup>* a b" +private abbreviation pts_symbolic_c_rtrancl (infix "\\<^sup>\\<^sub>c\<^sup>*" 50) where "a \\<^sup>\\<^sub>c\<^sup>* b \ pts_symbolic_c\<^sup>*\<^sup>* a b" + +lemma pts_symbolic_induct[consumes 1, case_names Nil Send Receive Equality Inequality]: + assumes "(\,\) \\<^sup>\ (\',\')" + and "\[] \ \; \' = update\<^sub>s\<^sub>t \ []; \' = \\ \ P" + and "\t S. \send\t\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S); \' = \@[receive\t\\<^sub>s\<^sub>t]\ \ P" + and "\t S. \receive\t\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S); \' = \@[send\t\\<^sub>s\<^sub>t]\ \ P" + and "\a t t' S. \\a: t \ t'\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S); \' = \@[\a: t \ t'\\<^sub>s\<^sub>t]\ \ P" + and "\X F S. \\X\\\: F\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S); \' = \@[\X\\\: F\\<^sub>s\<^sub>t]\ \ P" + shows "P" +apply (rule pts_symbolic.cases[OF assms(1)]) +using assms(2,3,4,5,6) by simp_all + +private lemma pts_symbolic_c_induct[consumes 1, case_names Nil Send Receive Equality Inequality Decompose]: + assumes "(\,\) \\<^sup>\\<^sub>c (\',\')" + and "\[] \ \; \' = update\<^sub>s\<^sub>t \ []; \' = \\ \ P" + and "\t S. \send\t\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (send\t\\<^sub>s\<^sub>t#S); \' = \@[Step (receive\t\\<^sub>s\<^sub>t)]\ \ P" + and "\t S. \receive\t\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (receive\t\\<^sub>s\<^sub>t#S); \' = \@[Step (send\t\\<^sub>s\<^sub>t)]\ \ P" + and "\a t t' S. \\a: t \ t'\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (\a: t \ t'\\<^sub>s\<^sub>t#S); \' = \@[Step (\a: t \ t'\\<^sub>s\<^sub>t)]\ \ P" + and "\X F S. \\X\\\: F\\<^sub>s\<^sub>t#S \ \; \' = update\<^sub>s\<^sub>t \ (\X\\\: F\\<^sub>s\<^sub>t#S); \' = \@[Step (\X\\\: F\\<^sub>s\<^sub>t)]\ \ P" + and "\f T. \Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \ \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \); \' = \; \' = \@[Decomp (Fun f T)]\ \ P" + shows "P" +apply (rule pts_symbolic_c.cases[OF assms(1)]) +using assms(2,3,4,5,6,7) by simp_all + +private lemma pts_symbolic_c_preserves_wf_prot: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "wf\<^sub>s\<^sub>t\<^sub>s' \ \" + shows "wf\<^sub>s\<^sub>t\<^sub>s' \' \'" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Decompose + hence "fv\<^sub>e\<^sub>s\<^sub>t \2 = fv\<^sub>e\<^sub>s\<^sub>t \1" "bvars\<^sub>e\<^sub>s\<^sub>t \2 = bvars\<^sub>e\<^sub>s\<^sub>t \1" + using bvars_decomp ik_assignment_rhs_decomp_fv by metis+ + thus ?case using Decompose unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def + by (metis wf_vars_mono wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_split(2)) + qed (metis wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_nil, metis wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_snd, + metis wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_rcv, metis wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_eq, + metis wf\<^sub>s\<^sub>t\<^sub>s'_update\<^sub>s\<^sub>t_ineq) +qed metis + +private lemma pts_symbolic_c_preserves_wf_is: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "wf\<^sub>s\<^sub>t V (to_st \)" + shows "wf\<^sub>s\<^sub>t V (to_st \')" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + hence "(\, \) \\<^sup>\\<^sub>c\<^sup>* (\2, \2)" by auto + hence *: "wf\<^sub>s\<^sub>t\<^sub>s' \1 \1" "wf\<^sub>s\<^sub>t\<^sub>s' \2 \2" + using pts_symbolic_c_preserves_wf_prot[OF _ step.prems(1)] step.hyps(1) + by auto + + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Nil thus ?case by auto + next + case (Send t S) + hence "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \1) (receive\t\\<^sub>s\<^sub>t#(dual\<^sub>s\<^sub>t S))" + using *(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fastforce + hence "fv t \ wfrestrictedvars\<^sub>s\<^sub>t (to_st \1) \ V" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_eq_wfrestrictedvars\<^sub>s\<^sub>t by auto + thus ?case using Send wf_rcv_append''' to_st_append by simp + next + case (Receive t) thus ?case using wf_snd_append to_st_append by simp + next + case (Equality a t t' S) + hence "wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \1) (\a: t \ t'\\<^sub>s\<^sub>t#(dual\<^sub>s\<^sub>t S))" + using *(1) unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by fastforce + hence "fv t' \ wfrestrictedvars\<^sub>s\<^sub>t (to_st \1) \ V" when "a = Assign" + using wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_eq_wfrestrictedvars\<^sub>s\<^sub>t that by auto + thus ?case using Equality wf_eq_append''' to_st_append by (cases a) auto + next + case (Inequality t t' S) thus ?case using wf_ineq_append'' to_st_append by simp + next + case (Decompose f T) + hence "fv (Fun f T) \ wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t \1" + by (metis fv_subterms_set fv_subset subset_trans + ik\<^sub>s\<^sub>t_assignment_rhs\<^sub>s\<^sub>t_wfrestrictedvars_subset) + hence "vars\<^sub>s\<^sub>t (decomp (Fun f T)) \ wfrestrictedvars\<^sub>s\<^sub>t (to_st \1) \ V" + using decomp_vars[of "Fun f T"] wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_eq_wfrestrictedvars\<^sub>s\<^sub>t[of \1] by auto + thus ?case + using to_st_append[of \1 "[Decomp (Fun f T)]"] + wf_append_suffix[OF Decompose.prems] Decompose.hyps(3) + by (metis append_Nil2 decomp_vars(1,2) to_st.simps(1,3)) + qed +qed metis + +private lemma pts_symbolic_c_preserves_tfr\<^sub>s\<^sub>e\<^sub>t: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" + and "tfr\<^sub>s\<^sub>e\<^sub>t ((\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \))" + and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s ((\(trms\<^sub>s\<^sub>t ` \)) \ (trms\<^sub>e\<^sub>s\<^sub>t \))" + shows "tfr\<^sub>s\<^sub>e\<^sub>t ((\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \')) \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s ((\(trms\<^sub>s\<^sub>t ` \')) \ (trms\<^sub>e\<^sub>s\<^sub>t \'))" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Nil + hence "\(trms\<^sub>s\<^sub>t ` \1) = \(trms\<^sub>s\<^sub>t ` \2)" by force + thus ?case using Nil by metis + next + case (Decompose f T) + obtain t where t: "t \ ik\<^sub>e\<^sub>s\<^sub>t \1 \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1" "Fun f T \ t" + using Decompose.hyps(1) by auto + have t_wf: "wf\<^sub>t\<^sub>r\<^sub>m t" + using Decompose.prems wf_trm_subterm[of _ t] + trms\<^sub>e\<^sub>s\<^sub>t_ik_assignment_rhsI[OF t(1)] + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def + by (metis UN_E Un_iff) + have "t \ subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t \1)" using trms\<^sub>e\<^sub>s\<^sub>t_ik_assignment_rhsI t by auto + hence "Fun f T \ SMP (trms\<^sub>e\<^sub>s\<^sub>t \1)" + by (metis (no_types) SMP.MP SMP.Subterm UN_E t(2)) + hence "{Fun f T} \ SMP (trms\<^sub>e\<^sub>s\<^sub>t \1)" using SMP.Subterm[of "Fun f T"] by auto + moreover have "trms\<^sub>e\<^sub>s\<^sub>t \2 = insert (Fun f T) (trms\<^sub>e\<^sub>s\<^sub>t \1)" + using Decompose.hyps(3) by auto + ultimately have *: "SMP (trms\<^sub>e\<^sub>s\<^sub>t \1) = SMP (trms\<^sub>e\<^sub>s\<^sub>t \2)" + using SMP_subset_union_eq[of "{Fun f T}"] + by (simp add: Un_commute) + hence "SMP ((\(trms\<^sub>s\<^sub>t ` \1)) \ (trms\<^sub>e\<^sub>s\<^sub>t \1)) = SMP ((\(trms\<^sub>s\<^sub>t ` \2)) \ (trms\<^sub>e\<^sub>s\<^sub>t \2))" + using Decompose.hyps(2) SMP_union by auto + moreover have "\t \ trms\<^sub>e\<^sub>s\<^sub>t \1. wf\<^sub>t\<^sub>r\<^sub>m t" "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)" + using Decompose.prems wf_trm_subterm t(2) t_wf unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by auto + hence "\t \ trms\<^sub>e\<^sub>s\<^sub>t \2. wf\<^sub>t\<^sub>r\<^sub>m t" by (metis * SMP.MP SMP_wf_trm) + hence "\t \ (\(trms\<^sub>s\<^sub>t ` \2)) \ (trms\<^sub>e\<^sub>s\<^sub>t \2). wf\<^sub>t\<^sub>r\<^sub>m t" + using Decompose.prems Decompose.hyps(2) unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by force + ultimately show ?thesis using Decompose.prems unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by presburger + qed (metis trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_snd, metis trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_rcv, + metis trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_eq, metis trms\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_eq_ineq) +qed metis + +private lemma pts_symbolic_c_preserves_tfr\<^sub>s\<^sub>t\<^sub>p: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "\S \ \ \ {to_st \}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + shows "\S \ \' \ {to_st \'}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Nil + have 1: "\S \ {to_st \2}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Nil by simp + have 2: "\2 = \1 - {[]}" "\S \ \1. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Nil by simp_all + have "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + proof + fix S assume "S \ \2" + hence "S \ \1" using 2(1) by simp + thus "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using 2(2) by simp + qed + thus ?case using 1 by auto + next + case (Send t S) + have 1: "\S \ {to_st \2}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Send by (simp add: to_st_append) + have 2: "\2 = insert S (\1 - {send\t\\<^sub>s\<^sub>t#S})" "\S \ \1. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Send by simp_all + have 3: "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + proof + fix S' assume "S' \ \2" + hence "S' \ \1 \ S' = S" using 2(1) by auto + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Send.hyps 2(2) by auto + ultimately show "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" using 2(2) by blast + qed + thus ?case using 1 by auto + next + case (Receive t S) + have 1: "\S \ {to_st \2}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Receive by (simp add: to_st_append) + have 2: "\2 = insert S (\1 - {receive\t\\<^sub>s\<^sub>t#S})" "\S \ \1. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using Receive by simp_all + have 3: "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + proof + fix S' assume "S' \ \2" + hence "S' \ \1 \ S' = S" using 2(1) by auto + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Receive.hyps 2(2) by auto + ultimately show "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" using 2(2) by blast + qed + show ?case using 1 3 by auto + next + case (Equality a t t' S) + have 1: "to_st \2 = to_st \1@[\a: t \ t'\\<^sub>s\<^sub>t]" "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \1)" + using Equality by (simp_all add: to_st_append) + have 2: "list_all tfr\<^sub>s\<^sub>t\<^sub>p [\a: t \ t'\\<^sub>s\<^sub>t]" using Equality by fastforce + have 3: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \2)" + using tfr_stp_all_append[of "to_st \1" "[\a: t \ t'\\<^sub>s\<^sub>t]"] 1 2 by metis + hence 4: "\S \ {to_st \2}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Equality by simp + have 5: "\2 = insert S (\1 - {\a: t \ t'\\<^sub>s\<^sub>t#S})" "\S \ \1. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using Equality by simp_all + have 6: "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + proof + fix S' assume "S' \ \2" + hence "S' \ \1 \ S' = S" using 5(1) by auto + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Equality.hyps 5(2) by auto + ultimately show "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" using 5(2) by blast + qed + thus ?case using 4 by auto + next + case (Inequality X F S) + have 1: "to_st \2 = to_st \1@[\X\\\: F\\<^sub>s\<^sub>t]" "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \1)" + using Inequality by (simp_all add: to_st_append) + have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (\X\\\: F\\<^sub>s\<^sub>t#S)" using Inequality(1,4) by blast + hence 2: "list_all tfr\<^sub>s\<^sub>t\<^sub>p [\X\\\: F\\<^sub>s\<^sub>t]" by simp + have 3: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \2)" + using tfr_stp_all_append[of "to_st \1" "[\X\\\: F\\<^sub>s\<^sub>t]"] 1 2 by metis + hence 4: "\S \ {to_st \2}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Inequality by simp + have 5: "\2 = insert S (\1 - {\X\\\: F\\<^sub>s\<^sub>t#S})" "\S \ \1. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using Inequality by simp_all + have 6: "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + proof + fix S' assume "S' \ \2" + hence "S' \ \1 \ S' = S" using 5(1) by auto + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p S" using Inequality.hyps 5(2) by auto + ultimately show "list_all tfr\<^sub>s\<^sub>t\<^sub>p S'" using 5(2) by blast + qed + thus ?case using 4 by auto + next + case (Decompose f T) + hence 1: "\S \ \2. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" by blast + have 2: "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \1)" "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st [Decomp (Fun f T)])" + using Decompose.prems decomp_tfr\<^sub>s\<^sub>t\<^sub>p by auto + hence "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \1@to_st [Decomp (Fun f T)])" by auto + hence "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \2)" + using Decompose.hyps(3) to_st_append[of \1 "[Decomp (Fun f T)]"] + by auto + thus ?case using 1 by blast + qed +qed + +private lemma pts_symbolic_c_preserves_well_analyzed: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "well_analyzed \" + shows "well_analyzed \'" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Receive thus ?case by (metis well_analyzed_singleton(1) well_analyzed_append) + next + case Send thus ?case by (metis well_analyzed_singleton(2) well_analyzed_append) + next + case Equality thus ?case by (metis well_analyzed_singleton(3) well_analyzed_append) + next + case Inequality thus ?case by (metis well_analyzed_singleton(4) well_analyzed_append) + next + case (Decompose f T) + hence "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1 \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1) - (Var`\)" by auto + thus ?case by (metis well_analyzed.Decomp Decompose.prems Decompose.hyps(3)) + qed simp +qed metis + +private lemma pts_symbolic_c_preserves_Ana_invar_subst: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" + and "Ana_invar_subst ( + (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \) \ (ik\<^sub>e\<^sub>s\<^sub>t \)) \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \)))" + shows "Ana_invar_subst ( + (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \') \ (ik\<^sub>e\<^sub>s\<^sub>t \')) \ + (\(assignment_rhs\<^sub>s\<^sub>t ` \') \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \')))" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + from step.hyps(2) step.IH[OF step.prems] show ?case + proof (induction rule: pts_symbolic_c_induct) + case Nil + hence "\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \1) = \(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \2)" + "\(assignment_rhs\<^sub>s\<^sub>t ` \1) = \(assignment_rhs\<^sub>s\<^sub>t ` \2)" + by force+ + thus ?case using Nil by metis + next + case Send show ?case + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_snd[OF Send.hyps] + Ana_invar_subst_subset[OF Send.prems] + by (metis Un_mono) + next + case Receive show ?case + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_rcv[OF Receive.hyps] + Ana_invar_subst_subset[OF Receive.prems] + by (metis Un_mono) + next + case Equality show ?case + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_eq[OF Equality.hyps] + Ana_invar_subst_subset[OF Equality.prems] + by (metis Un_mono) + next + case Inequality show ?case + using ik\<^sub>s\<^sub>t_update\<^sub>s\<^sub>t_subset_ineq[OF Inequality.hyps] + Ana_invar_subst_subset[OF Inequality.prems] + by (metis Un_mono) + next + case (Decompose f T) + let ?X = "\(assignment_rhs\<^sub>s\<^sub>t`\2) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \2" + let ?Y = "\(assignment_rhs\<^sub>s\<^sub>t`\1) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1" + obtain K M where Ana: "Ana (Fun f T) = (K,M)" by moura + hence *: "ik\<^sub>e\<^sub>s\<^sub>t \2 = ik\<^sub>e\<^sub>s\<^sub>t \1 \ set M" "assignment_rhs\<^sub>e\<^sub>s\<^sub>t \2 = assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1" + using ik\<^sub>e\<^sub>s\<^sub>t_append assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append decomp_ik + decomp_assignment_rhs_empty Decompose.hyps(3) + by auto + { fix g S assume "Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t`\2) \ ik\<^sub>e\<^sub>s\<^sub>t \2 \ ?X)" + hence "Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \1) \ ik\<^sub>e\<^sub>s\<^sub>t \1 \ set M \ ?X)" + using * Decompose.hyps(2) by auto + hence "Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \1)) + \ Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1) + \ Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (set M) + \ Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (\(assignment_rhs\<^sub>s\<^sub>t`\1)) + \ Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1)" + using Decompose * Ana_fun_subterm[OF Ana] by auto + moreover have "Fun f T \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1 \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1)" + using trms\<^sub>e\<^sub>s\<^sub>t_ik_subtermsI Decompose.hyps(1) by auto + hence "subterms (Fun f T) \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1 \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1)" + by (metis in_subterms_subset_Union) + hence "subterms\<^sub>s\<^sub>e\<^sub>t (set M) \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1 \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1)" + by (meson Un_upper2 Ana_subterm[OF Ana] subterms_subset_set psubsetE subset_trans) + ultimately have "Fun g S \ subterms\<^sub>s\<^sub>e\<^sub>t (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t ` \1) \ ik\<^sub>e\<^sub>s\<^sub>t \1 \ ?Y)" + by auto + } + thus ?case using Decompose unfolding Ana_invar_subst_def by metis + qed +qed + +private lemma pts_symbolic_c_preserves_constr_disj_vars: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "wf\<^sub>s\<^sub>t\<^sub>s' \ \" "fv\<^sub>e\<^sub>s\<^sub>t \ \ bvars\<^sub>e\<^sub>s\<^sub>t \ = {}" + shows "fv\<^sub>e\<^sub>s\<^sub>t \' \ bvars\<^sub>e\<^sub>s\<^sub>t \' = {}" +using assms +proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) + have *: "\S. S \ \1 \ fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t \1 = {}" "\S. S \ \1 \ fv\<^sub>e\<^sub>s\<^sub>t \1 \ bvars\<^sub>s\<^sub>t S = {}" + using pts_symbolic_c_preserves_wf_prot[OF step.hyps(1) step.prems(1)] + unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def by auto + from step.hyps(2) step.IH[OF step.prems] + show ?case + proof (induction rule: pts_symbolic_c_induct) + case Nil thus ?case by auto + next + case (Send t S) + hence "fv\<^sub>e\<^sub>s\<^sub>t \2 = fv\<^sub>e\<^sub>s\<^sub>t \1 \ fv t" "bvars\<^sub>e\<^sub>s\<^sub>t \2 = bvars\<^sub>e\<^sub>s\<^sub>t \1" + "fv\<^sub>s\<^sub>t (send\t\\<^sub>s\<^sub>t#S) = fv t \ fv\<^sub>s\<^sub>t S" + using fv\<^sub>e\<^sub>s\<^sub>t_append bvars\<^sub>e\<^sub>s\<^sub>t_append by simp+ + thus ?case using *(1)[OF Send(1)] Send(4) by auto + next + case (Receive t S) + hence "fv\<^sub>e\<^sub>s\<^sub>t \2 = fv\<^sub>e\<^sub>s\<^sub>t \1 \ fv t" "bvars\<^sub>e\<^sub>s\<^sub>t \2 = bvars\<^sub>e\<^sub>s\<^sub>t \1" + "fv\<^sub>s\<^sub>t (receive\t\\<^sub>s\<^sub>t#S) = fv t \ fv\<^sub>s\<^sub>t S" + using fv\<^sub>e\<^sub>s\<^sub>t_append bvars\<^sub>e\<^sub>s\<^sub>t_append by simp+ + thus ?case using *(1)[OF Receive(1)] Receive(4) by auto + next + case (Equality a t t' S) + hence "fv\<^sub>e\<^sub>s\<^sub>t \2 = fv\<^sub>e\<^sub>s\<^sub>t \1 \ fv t \ fv t'" "bvars\<^sub>e\<^sub>s\<^sub>t \2 = bvars\<^sub>e\<^sub>s\<^sub>t \1" + "fv\<^sub>s\<^sub>t (\a: t \ t'\\<^sub>s\<^sub>t#S) = fv t \ fv t' \ fv\<^sub>s\<^sub>t S" + using fv\<^sub>e\<^sub>s\<^sub>t_append bvars\<^sub>e\<^sub>s\<^sub>t_append by fastforce+ + thus ?case using *(1)[OF Equality(1)] Equality(4) by auto + next + case (Inequality X F S) + hence "fv\<^sub>e\<^sub>s\<^sub>t \2 = fv\<^sub>e\<^sub>s\<^sub>t \1 \ (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X)" "bvars\<^sub>e\<^sub>s\<^sub>t \2 = bvars\<^sub>e\<^sub>s\<^sub>t \1 \ set X" + "fv\<^sub>s\<^sub>t (\X\\\: F\\<^sub>s\<^sub>t#S) = (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set X) \ fv\<^sub>s\<^sub>t S" + using fv\<^sub>e\<^sub>s\<^sub>t_append bvars\<^sub>e\<^sub>s\<^sub>t_append strand_vars_split(3)[of "[\X\\\: F\\<^sub>s\<^sub>t]" S] + by auto+ + moreover have "fv\<^sub>e\<^sub>s\<^sub>t \1 \ set X = {}" using *(2)[OF Inequality(1)] by auto + ultimately show ?case using *(1)[OF Inequality(1)] Inequality(4) by auto + next + case (Decompose f T) + thus ?case + using Decompose(3,4) bvars_decomp ik_assignment_rhs_decomp_fv[OF Decompose(1)] by auto + qed +qed + + +subsubsection \Theorem: The Typing Result Lifted to the Transition System Level\ +private lemma wf\<^sub>s\<^sub>t\<^sub>s'_decomp_rm: + assumes "well_analyzed A" "wf\<^sub>s\<^sub>t\<^sub>s' S (decomp_rm\<^sub>e\<^sub>s\<^sub>t A)" shows "wf\<^sub>s\<^sub>t\<^sub>s' S A" +unfolding wf\<^sub>s\<^sub>t\<^sub>s'_def +proof (intro conjI) + show "\S\S. wf\<^sub>s\<^sub>t (wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t A) (dual\<^sub>s\<^sub>t S)" + by (metis (no_types) assms(2) wf\<^sub>s\<^sub>t\<^sub>s'_def wfrestrictedvars\<^sub>e\<^sub>s\<^sub>t_decomp_rm\<^sub>e\<^sub>s\<^sub>t_subset + wf_vars_mono le_iff_sup) + + show "\Sa\S. \S'\S. fv\<^sub>s\<^sub>t Sa \ bvars\<^sub>s\<^sub>t S' = {}" by (metis assms(2) wf\<^sub>s\<^sub>t\<^sub>s'_def) + + show "\S\S. fv\<^sub>s\<^sub>t S \ bvars\<^sub>e\<^sub>s\<^sub>t A = {}" by (metis assms(2) wf\<^sub>s\<^sub>t\<^sub>s'_def bvars_decomp_rm) + + show "\S\S. fv\<^sub>e\<^sub>s\<^sub>t A \ bvars\<^sub>s\<^sub>t S = {}" by (metis assms wf\<^sub>s\<^sub>t\<^sub>s'_def well_analyzed_decomp_rm\<^sub>e\<^sub>s\<^sub>t_fv) +qed + +private lemma decomps\<^sub>e\<^sub>s\<^sub>t_pts_symbolic_c: + assumes "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \" + shows "(S,A) \\<^sup>\\<^sub>c\<^sup>* (S,A@D)" +using assms(1) +proof (induction D rule: decomps\<^sub>e\<^sub>s\<^sub>t.induct) + case (Decomp B f X K T) + have "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t A \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t A) \ + subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t (A@B) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@B))" + using ik\<^sub>e\<^sub>s\<^sub>t_append[of A B] assignment_rhs\<^sub>e\<^sub>s\<^sub>t_append[of A B] + by auto + hence "Fun f X \ subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t (A@B) \ assignment_rhs\<^sub>e\<^sub>s\<^sub>t (A@B))" using Decomp.hyps by auto + hence "(S,A@B) \\<^sup>\\<^sub>c (S,A@B@[Decomp (Fun f X)])" + using pts_symbolic_c.Decompose[of f X "A@B"] + by simp + thus ?case + using Decomp.IH rtrancl_into_rtrancl + rtranclp_rtrancl_eq[of pts_symbolic_c "(S,A)" "(S,A@B)"] + by auto +qed simp + +private lemma pts_symbolic_to_pts_symbolic_c: + assumes "(\,to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)) \\<^sup>\\<^sup>* (\',\')" "sem\<^sub>e\<^sub>s\<^sub>t_d {} \ (to_est \')" "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ \\<^sub>d" + and wf: "wf\<^sub>s\<^sub>t\<^sub>s' \ (decomp_rm\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)" "wf\<^sub>e\<^sub>s\<^sub>t {} \\<^sub>d" + and tar: "Ana_invar_subst ((\(ik\<^sub>s\<^sub>t` dual\<^sub>s\<^sub>t` \) \ (ik\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)) + \ (\(assignment_rhs\<^sub>s\<^sub>t` \) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)))" + and wa: "well_analyzed \\<^sub>d" + and \: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\\\<^sub>d'. \' = to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \\<^sub>d') \ (\,\\<^sub>d) \\<^sup>\\<^sub>c\<^sup>* (\',\\<^sub>d') \ sem\<^sub>e\<^sub>s\<^sub>t_c {} \ \\<^sub>d'" +using assms(1,2) +proof (induction rule: rtranclp_induct2) + case refl thus ?case using assms by auto +next + case (step \1 \1 \2 \2) + have "sem\<^sub>e\<^sub>s\<^sub>t_d {} \ (to_est \1)" using step.hyps(2) step.prems + by (induct rule: pts_symbolic_induct, metis, (metis sem\<^sub>e\<^sub>s\<^sub>t_d_split_left to_est_append)+) + then obtain \1d where + \1d: "\1 = to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1d)" "(\, \\<^sub>d) \\<^sup>\\<^sub>c\<^sup>* (\1, \1d)" "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ \1d" + using step.IH by moura + + show ?case using step.hyps(2) + proof (induction rule: pts_symbolic_induct) + case Nil + hence "(\, \\<^sub>d) \\<^sup>\\<^sub>c\<^sup>* (\2, \1d)" using \1d pts_symbolic_c.Nil[OF Nil.hyps(1), of \1d] by simp + thus ?case using \1d Nil by auto + next + case (Send t S) + hence "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (\1d@[Step (receive\t\\<^sub>s\<^sub>t)])" using sem\<^sub>e\<^sub>s\<^sub>t_c.Receive[OF \1d(3)] by simp + moreover have "(\1, \1d) \\<^sup>\\<^sub>c (\2, \1d@[Step (receive\t\\<^sub>s\<^sub>t)])" + using Send.hyps(2) pts_symbolic_c.Send[OF Send.hyps(1), of \1d] by simp + moreover have "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t (\1d@[Step (receive\t\\<^sub>s\<^sub>t)])) = \2" + using Send.hyps(3) decomp_rm\<^sub>e\<^sub>s\<^sub>t_append \1d(1) by (simp add: to_st_append) + ultimately show ?case using \1d(2) by auto + next + case (Equality a t t' S) + hence "t \ \ = t' \ \" + using step.prems sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st[of "{}" \ "to_est \2"] + to_st_append to_est_append to_st_to_est_inv + by auto + hence "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (\1d@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" using sem\<^sub>e\<^sub>s\<^sub>t_c.Equality[OF \1d(3)] by simp + moreover have "(\1, \1d) \\<^sup>\\<^sub>c (\2, \1d@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])" + using Equality.hyps(2) pts_symbolic_c.Equality[OF Equality.hyps(1), of \1d] by simp + moreover have "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t (\1d@[Step (\a: t \ t'\\<^sub>s\<^sub>t)])) = \2" + using Equality.hyps(3) decomp_rm\<^sub>e\<^sub>s\<^sub>t_append \1d(1) by (simp add: to_st_append) + ultimately show ?case using \1d(2) by auto + next + case (Inequality X F S) + hence "ineq_model \ X F" + using step.prems sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st[of "{}" \ "to_est \2"] + to_st_append to_est_append to_st_to_est_inv + by auto + hence "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (\1d@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" using sem\<^sub>e\<^sub>s\<^sub>t_c.Inequality[OF \1d(3)] by simp + moreover have "(\1, \1d) \\<^sup>\\<^sub>c (\2, \1d@[Step (\X\\\: F\\<^sub>s\<^sub>t)])" + using Inequality.hyps(2) pts_symbolic_c.Inequality[OF Inequality.hyps(1), of \1d] by simp + moreover have "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t (\1d@[Step (\X\\\: F\\<^sub>s\<^sub>t)])) = \2" + using Inequality.hyps(3) decomp_rm\<^sub>e\<^sub>s\<^sub>t_append \1d(1) by (simp add: to_st_append) + ultimately show ?case using \1d(2) by auto + next + case (Receive t S) + hence "ik\<^sub>s\<^sub>t \1 \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" + using step.prems sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st[of "{}" \ "to_est \2"] + strand_sem_split(4)[of "{}" \1 "[send\t\\<^sub>s\<^sub>t]" \] + to_st_append to_est_append to_st_to_est_inv + by auto + moreover have "ik\<^sub>s\<^sub>t \1 \\<^sub>s\<^sub>e\<^sub>t \ \ ik\<^sub>e\<^sub>s\<^sub>t \1d \\<^sub>s\<^sub>e\<^sub>t \" using \1d(1) decomp_rm\<^sub>e\<^sub>s\<^sub>t_ik_subset by auto + ultimately have *: "ik\<^sub>e\<^sub>s\<^sub>t \1d \\<^sub>s\<^sub>e\<^sub>t \ \ t \ \" using ideduct_mono by auto + + have "wf\<^sub>s\<^sub>t\<^sub>s' \ \\<^sub>d" by (rule wf\<^sub>s\<^sub>t\<^sub>s'_decomp_rm[OF wa assms(4)]) + hence **: "wf\<^sub>e\<^sub>s\<^sub>t {} \1d" by (rule pts_symbolic_c_preserves_wf_is[OF \1d(2) _ assms(5)]) + + have "Ana_invar_subst (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t`\1) \ (ik\<^sub>e\<^sub>s\<^sub>t \1d) \ + (\(assignment_rhs\<^sub>s\<^sub>t`\1) \ (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1d)))" + using tar \1d(2) pts_symbolic_c_preserves_Ana_invar_subst by metis + hence "Ana_invar_subst (ik\<^sub>e\<^sub>s\<^sub>t \1d)" "Ana_invar_subst (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1d)" + using Ana_invar_subst_subset by blast+ + moreover have "well_analyzed \1d" + using pts_symbolic_c_preserves_well_analyzed[OF \1d(2) wa] by metis + ultimately obtain D where D: + "D \ decomps\<^sub>e\<^sub>s\<^sub>t (ik\<^sub>e\<^sub>s\<^sub>t \1d) (assignment_rhs\<^sub>e\<^sub>s\<^sub>t \1d) \" + "ik\<^sub>e\<^sub>s\<^sub>t (\1d@D) \\<^sub>s\<^sub>e\<^sub>t \ \\<^sub>c t \ \" + using decomps\<^sub>e\<^sub>s\<^sub>t_exist_subst[OF * \1d(3) ** assms(8)] unfolding Ana_invar_subst_def by auto + + have "(\, \\<^sub>d) \\<^sup>\\<^sub>c\<^sup>* (\1, \1d@D)" using \1d(2) decomps\<^sub>e\<^sub>s\<^sub>t_pts_symbolic_c[OF D(1), of \1] by auto + hence "(\, \\<^sub>d) \\<^sup>\\<^sub>c\<^sup>* (\2, \1d@D@[Step (send\t\\<^sub>s\<^sub>t)])" + using Receive(2) pts_symbolic_c.Receive[OF Receive.hyps(1), of "\1d@D"] by auto + moreover have "\2 = to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t (\1d@D@[Step (send\t\\<^sub>s\<^sub>t)]))" + using Receive.hyps(3) \1d(1) decomps\<^sub>e\<^sub>s\<^sub>t_decomp_rm\<^sub>e\<^sub>s\<^sub>t_empty[OF D(1)] + decomp_rm\<^sub>e\<^sub>s\<^sub>t_append to_st_append + by auto + moreover have "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ (\1d@D@[Step (send\t\\<^sub>s\<^sub>t)])" + using D(2) sem\<^sub>e\<^sub>s\<^sub>t_c.Send[OF sem\<^sub>e\<^sub>s\<^sub>t_c_decomps\<^sub>e\<^sub>s\<^sub>t_append[OF \1d(3) D(1)]] by simp + ultimately show ?case by auto + qed +qed + +private lemma pts_symbolic_c_to_pts_symbolic: + assumes "(\,\) \\<^sup>\\<^sub>c\<^sup>* (\',\')" "sem\<^sub>e\<^sub>s\<^sub>t_c {} \ \'" + shows "(\,to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \)) \\<^sup>\\<^sup>* (\',to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \'))" + "sem\<^sub>e\<^sub>s\<^sub>t_d {} \ (decomp_rm\<^sub>e\<^sub>s\<^sub>t \')" +proof - + show "(\,to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \)) \\<^sup>\\<^sup>* (\',to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \'))" using assms(1) + proof (induction rule: rtranclp_induct2) + case (step \1 \1 \2 \2) show ?case using step.hyps(2,1) step.IH + proof (induction rule: pts_symbolic_c_induct) + case Nil thus ?case + using pts_symbolic.Nil[OF Nil.hyps(1), of "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1)"] by simp + next + case (Send t S) thus ?case + using pts_symbolic.Send[OF Send.hyps(1), of "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1)"] + by (simp add: decomp_rm\<^sub>e\<^sub>s\<^sub>t_append to_st_append) + next + case (Receive t S) thus ?case + using pts_symbolic.Receive[OF Receive.hyps(1), of "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1)"] + by (simp add: decomp_rm\<^sub>e\<^sub>s\<^sub>t_append to_st_append) + next + case (Equality a t t' S) thus ?case + using pts_symbolic.Equality[OF Equality.hyps(1), of "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1)"] + by (simp add: decomp_rm\<^sub>e\<^sub>s\<^sub>t_append to_st_append) + next + case (Inequality t t' S) thus ?case + using pts_symbolic.Inequality[OF Inequality.hyps(1), of "to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \1)"] + by (simp add: decomp_rm\<^sub>e\<^sub>s\<^sub>t_append to_st_append) + next + case (Decompose t) thus ?case using decomp_rm\<^sub>e\<^sub>s\<^sub>t_append by simp + qed + qed simp +qed (rule sem\<^sub>e\<^sub>s\<^sub>t_d_decomp_rm\<^sub>e\<^sub>s\<^sub>t_if_sem\<^sub>e\<^sub>s\<^sub>t_c[OF assms(2)]) + +private lemma pts_symbolic_to_pts_symbolic_c_from_initial: + assumes "(\\<^sub>0,[]) \\<^sup>\\<^sup>* (\,\)" "\ \ \\\" "wf\<^sub>s\<^sub>t\<^sub>s' \\<^sub>0 []" + and "Ana_invar_subst (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \\<^sub>0) \ \(assignment_rhs\<^sub>s\<^sub>t ` \\<^sub>0))" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" + shows "\\\<^sub>d. \ = to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \\<^sub>d) \ (\\<^sub>0,[]) \\<^sup>\\<^sub>c\<^sup>* (\,\\<^sub>d) \ (\ \\<^sub>c \to_st \\<^sub>d\)" +using assms pts_symbolic_to_pts_symbolic_c[of \\<^sub>0 "[]" \ \ \] + sem\<^sub>e\<^sub>s\<^sub>t_c_eq_sem_st[of "{}" \] sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st[of "{}" \] + to_st_to_est_inv[of \] strand_sem_eq_defs +by (auto simp add: constr_sem_c_def constr_sem_d_def simp del: subst_range.simps) + +private lemma pts_symbolic_c_to_pts_symbolic_from_initial: + assumes "(\\<^sub>0,[]) \\<^sup>\\<^sub>c\<^sup>* (\,\)" "\ \\<^sub>c \to_st \\" + shows "(\\<^sub>0,[]) \\<^sup>\\<^sup>* (\,to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \))" "\ \ \to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \)\" +using assms pts_symbolic_c_to_pts_symbolic[of \\<^sub>0 "[]" \ \ \] + sem\<^sub>e\<^sub>s\<^sub>t_c_eq_sem_st[of "{}" \] sem\<^sub>e\<^sub>s\<^sub>t_d_eq_sem_st[of "{}" \] strand_sem_eq_defs +by (auto simp add: constr_sem_c_def constr_sem_d_def) + +private lemma to_st_trms_wf: + assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>e\<^sub>s\<^sub>t A)" + shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t (to_st A))" +using assms +proof (induction A) + case (Cons x A) + hence IH: "\t \ trms\<^sub>s\<^sub>t (to_st A). wf\<^sub>t\<^sub>r\<^sub>m t" by auto + with Cons show ?case + proof (cases x) + case (Decomp t) + hence "wf\<^sub>t\<^sub>r\<^sub>m t" using Cons.prems by auto + obtain K T where Ana_t: "Ana t = (K,T)" by moura + hence "trms\<^sub>s\<^sub>t (decomp t) \ {t} \ set K \ set T" using decomp_set_unfold[OF Ana_t] by force + moreover have "\t \ set T. wf\<^sub>t\<^sub>r\<^sub>m t" using Ana_subterm[OF Ana_t] \wf\<^sub>t\<^sub>r\<^sub>m t\ wf_trm_subterm by auto + ultimately have "\t \ trms\<^sub>s\<^sub>t (decomp t). wf\<^sub>t\<^sub>r\<^sub>m t" using Ana_keys_wf'[OF Ana_t] \wf\<^sub>t\<^sub>r\<^sub>m t\ by auto + thus ?thesis using IH Decomp by auto + qed auto +qed simp + +private lemma to_st_trms_SMP_subset: "trms\<^sub>s\<^sub>t (to_st A) \ SMP (trms\<^sub>e\<^sub>s\<^sub>t A)" +proof + fix t assume "t \ trms\<^sub>s\<^sub>t (to_st A)" thus "t \ SMP (trms\<^sub>e\<^sub>s\<^sub>t A)" + proof (induction A) + case (Cons x A) + hence *: "t \ trms\<^sub>s\<^sub>t (to_st [x]) \ trms\<^sub>s\<^sub>t (to_st A)" using to_st_append[of "[x]" A] by auto + have **: "trms\<^sub>s\<^sub>t (to_st A) \ trms\<^sub>s\<^sub>t (to_st (x#A))" "trms\<^sub>e\<^sub>s\<^sub>t A \ trms\<^sub>e\<^sub>s\<^sub>t (x#A)" + using to_st_append[of "[x]" A] by auto + show ?case + proof (cases "t \ trms\<^sub>s\<^sub>t (to_st A)") + case True thus ?thesis using Cons.IH SMP_mono[OF **(2)] by auto + next + case False + hence ***: "t \ trms\<^sub>s\<^sub>t (to_st [x])" using * by auto + thus ?thesis + proof (cases x) + case (Decomp t') + hence ****: "t \ trms\<^sub>s\<^sub>t (decomp t')" "t' \ trms\<^sub>e\<^sub>s\<^sub>t (x#A)" using *** by auto + obtain K T where Ana_t': "Ana t' = (K,T)" by moura + hence "t \ {t'} \ set K \ set T" using decomp_set_unfold[OF Ana_t'] ****(1) by force + moreover + { assume "t = t'" hence ?thesis using SMP.MP[OF ****(2)] by simp } + moreover + { assume "t \ set K" hence ?thesis using SMP.Ana[OF SMP.MP[OF ****(2)] Ana_t'] by auto } + moreover + { assume "t \ set T" "t \ t'" + hence "t \ t'" using Ana_subterm[OF Ana_t'] by blast + hence ?thesis using SMP.Subterm[OF SMP.MP[OF ****(2)]] by auto + } + ultimately show ?thesis using Decomp by auto + qed auto + qed + qed simp +qed + +private lemma to_st_trms_tfr\<^sub>s\<^sub>e\<^sub>t: + assumes "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t A)" + shows "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t (to_st A))" +proof - + have *: "trms\<^sub>s\<^sub>t (to_st A) \ SMP (trms\<^sub>e\<^sub>s\<^sub>t A)" + using to_st_trms_wf to_st_trms_SMP_subset assms unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by auto + have "trms\<^sub>s\<^sub>t (to_st A) = trms\<^sub>s\<^sub>t (to_st A) \ trms\<^sub>e\<^sub>s\<^sub>t A" by (blast dest!: trms\<^sub>e\<^sub>s\<^sub>tD) + hence "SMP (trms\<^sub>e\<^sub>s\<^sub>t A) = SMP (trms\<^sub>s\<^sub>t (to_st A))" using SMP_subset_union_eq[OF *] by auto + thus ?thesis using * assms unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by presburger +qed + +theorem wt_attack_if_tfr_attack_pts: + assumes "wf\<^sub>s\<^sub>t\<^sub>s \\<^sub>0" "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>s\<^sub>t ` \\<^sub>0))" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>s\<^sub>t ` \\<^sub>0))" "\S \ \\<^sub>0. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + and "Ana_invar_subst (\(ik\<^sub>s\<^sub>t ` dual\<^sub>s\<^sub>t ` \\<^sub>0) \ \(assignment_rhs\<^sub>s\<^sub>t ` \\<^sub>0))" + and "(\\<^sub>0,[]) \\<^sup>\\<^sup>* (\,\)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\ \ \\, Var\" + shows "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ (\\<^sub>\ \ \\, Var\) \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" +proof - + have "(\(trms\<^sub>s\<^sub>t ` \\<^sub>0)) \ (trms\<^sub>e\<^sub>s\<^sub>t []) = \(trms\<^sub>s\<^sub>t ` \\<^sub>0)" "to_st [] = []" "list_all tfr\<^sub>s\<^sub>t\<^sub>p []" + using assms by simp_all + hence *: "tfr\<^sub>s\<^sub>e\<^sub>t ((\(trms\<^sub>s\<^sub>t ` \\<^sub>0)) \ (trms\<^sub>e\<^sub>s\<^sub>t []))" + "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s ((\(trms\<^sub>s\<^sub>t ` \\<^sub>0)) \ (trms\<^sub>e\<^sub>s\<^sub>t []))" + "wf\<^sub>s\<^sub>t\<^sub>s' \\<^sub>0 []" "\S \ \\<^sub>0 \ {to_st []}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using assms wf\<^sub>s\<^sub>t\<^sub>s_wf\<^sub>s\<^sub>t\<^sub>s' by (metis, metis, metis, simp) + + obtain \\<^sub>d where \\<^sub>d: "\ = to_st (decomp_rm\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)" "(\\<^sub>0,[]) \\<^sup>\\<^sub>c\<^sup>* (\,\\<^sub>d)" "\ \\<^sub>c \to_st \\<^sub>d\" + using pts_symbolic_to_pts_symbolic_c_from_initial assms *(3) by metis + hence "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>s\<^sub>t ` \) \ (trms\<^sub>e\<^sub>s\<^sub>t \\<^sub>d))" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>s\<^sub>t ` \) \ (trms\<^sub>e\<^sub>s\<^sub>t \\<^sub>d))" + using pts_symbolic_c_preserves_tfr\<^sub>s\<^sub>e\<^sub>t[OF _ *(1,2)] by blast+ + hence "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>e\<^sub>s\<^sub>t \\<^sub>d)" + unfolding tfr\<^sub>s\<^sub>e\<^sub>t_def by (metis DiffE DiffI SMP_union UnCI, metis UnCI) + hence "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t (to_st \\<^sub>d))" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t (to_st \\<^sub>d))" + by (metis to_st_trms_tfr\<^sub>s\<^sub>e\<^sub>t, metis to_st_trms_wf) + moreover have "wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r (to_st \\<^sub>d) Var" + proof - + have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" "subst_domain Var \ vars\<^sub>e\<^sub>s\<^sub>t \\<^sub>d = {}" + "range_vars Var \ bvars\<^sub>e\<^sub>s\<^sub>t \\<^sub>d = {}" + by (simp_all add: range_vars_alt_def) + moreover have "wf\<^sub>e\<^sub>s\<^sub>t {} \\<^sub>d" + using pts_symbolic_c_preserves_wf_is[OF \\<^sub>d(2) *(3), of "{}"] + by auto + moreover have "fv\<^sub>s\<^sub>t (to_st \\<^sub>d) \ bvars\<^sub>e\<^sub>s\<^sub>t \\<^sub>d = {}" + using pts_symbolic_c_preserves_constr_disj_vars[OF \\<^sub>d(2)] assms(1) wf\<^sub>s\<^sub>t\<^sub>s_wf\<^sub>s\<^sub>t\<^sub>s' + by fastforce + ultimately show ?thesis unfolding wf\<^sub>c\<^sub>o\<^sub>n\<^sub>s\<^sub>t\<^sub>r_def wf\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by simp + qed + moreover have "list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \\<^sub>d)" + using pts_symbolic_c_preserves_tfr\<^sub>s\<^sub>t\<^sub>p[OF \\<^sub>d(2) *(4)] by blast + moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" by simp_all + ultimately obtain \\<^sub>\ where \\<^sub>\: + "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "\\<^sub>\ \\<^sub>c \to_st \\<^sub>d, Var\" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" + using wt_attack_if_tfr_attack[OF assms(7) \\<^sub>d(3)] + \tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>t (to_st \\<^sub>d))\ \list_all tfr\<^sub>s\<^sub>t\<^sub>p (to_st \\<^sub>d)\ + unfolding tfr\<^sub>s\<^sub>t_def by metis + hence "\\<^sub>\ \ \\, Var\" using pts_symbolic_c_to_pts_symbolic_from_initial \\<^sub>d by metis + thus ?thesis using \\<^sub>\(1,3,4) by metis +qed + + +subsubsection \Corollary: The Typing Result on the Level of Constraints\ +text \There exists well-typed models of satisfiable type-flaw resistant constraints\ +corollary wt_attack_if_tfr_attack_d: + assumes "wf\<^sub>s\<^sub>t {} \" "fv\<^sub>s\<^sub>t \ \ bvars\<^sub>s\<^sub>t \ = {}" "tfr\<^sub>s\<^sub>t \" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>s\<^sub>t \)" + and "Ana_invar_subst (ik\<^sub>s\<^sub>t \ \ assignment_rhs\<^sub>s\<^sub>t \)" + and "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \" "\ \ \\\" + shows "\\\<^sub>\. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ (\\<^sub>\ \ \\\) \ wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \\<^sub>\ \ wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \\<^sub>\)" +proof - + { fix S A have "({S},A) \\<^sup>\\<^sup>* ({},A@dual\<^sub>s\<^sub>t S)" + proof (induction S arbitrary: A) + case Nil thus ?case using pts_symbolic.Nil[of "{[]}"] by auto + next + case (Cons x S) + hence "({S}, A@dual\<^sub>s\<^sub>t [x]) \\<^sup>\\<^sup>* ({}, A@dual\<^sub>s\<^sub>t (x#S))" + by (metis dual\<^sub>s\<^sub>t_append List.append_assoc List.append_Nil List.append_Cons) + moreover have "({x#S}, A) \\<^sup>\ ({S}, A@dual\<^sub>s\<^sub>t [x])" + using pts_symbolic.Send[of _ S "{x#S}"] pts_symbolic.Receive[of _ S "{x#S}"] + pts_symbolic.Equality[of _ _ _ S "{x#S}"] pts_symbolic.Inequality[of _ _ S "{x#S}"] + by (cases x) auto + ultimately show ?case by simp + qed + } + hence 0: "({dual\<^sub>s\<^sub>t \},[]) \\<^sup>\\<^sup>* ({},\)" using dual\<^sub>s\<^sub>t_self_inverse by (metis List.append_Nil) + + have "fv\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t \) \ bvars\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t \) = {}" using assms(2) dual\<^sub>s\<^sub>t_fv dual\<^sub>s\<^sub>t_bvars by metis+ + hence 1: "wf\<^sub>s\<^sub>t\<^sub>s {dual\<^sub>s\<^sub>t \}" using assms(1,2) dual\<^sub>s\<^sub>t_self_inverse[of \] unfolding wf\<^sub>s\<^sub>t\<^sub>s_def by auto + + have "\(trms\<^sub>s\<^sub>t ` {\}) = trms\<^sub>s\<^sub>t \" "\(trms\<^sub>s\<^sub>t ` {dual\<^sub>s\<^sub>t \}) = trms\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t \)" by auto + hence "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>s\<^sub>t ` {\}))" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>s\<^sub>t ` {\}))" + "(\(trms\<^sub>s\<^sub>t ` {\})) = \(trms\<^sub>s\<^sub>t ` {dual\<^sub>s\<^sub>t \})" + using assms(3,4) unfolding tfr\<^sub>s\<^sub>t_def + by (metis, metis, metis dual\<^sub>s\<^sub>t_trms_eq) + hence 2: "tfr\<^sub>s\<^sub>e\<^sub>t (\(trms\<^sub>s\<^sub>t ` {dual\<^sub>s\<^sub>t \}))" and 3: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (\(trms\<^sub>s\<^sub>t ` {dual\<^sub>s\<^sub>t \}))" by metis+ + + have 4: "\S \ {dual\<^sub>s\<^sub>t \}. list_all tfr\<^sub>s\<^sub>t\<^sub>p S" + using dual\<^sub>s\<^sub>t_tfr\<^sub>s\<^sub>t\<^sub>p assms(3) unfolding tfr\<^sub>s\<^sub>t_def by blast + + have "assignment_rhs\<^sub>s\<^sub>t \ = assignment_rhs\<^sub>s\<^sub>t (dual\<^sub>s\<^sub>t \)" + by (induct \ rule: assignment_rhs\<^sub>s\<^sub>t.induct) auto + hence 5: "Ana_invar_subst (\(ik\<^sub>s\<^sub>t`dual\<^sub>s\<^sub>t`{dual\<^sub>s\<^sub>t \}) \ \(assignment_rhs\<^sub>s\<^sub>t`{dual\<^sub>s\<^sub>t \}))" + using assms(5) dual\<^sub>s\<^sub>t_self_inverse[of \] by auto + + show ?thesis by (rule wt_attack_if_tfr_attack_pts[OF 1 2 3 4 5 0 assms(6,7)]) +qed + +end + +end + +end + diff --git a/Stateful_Protocol_Composition_and_Typing/document/root.bib b/Stateful_Protocol_Composition_and_Typing/document/root.bib new file mode 100644 index 0000000..6363b85 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/document/root.bib @@ -0,0 +1,47 @@ + +@InProceedings{ hess.ea:formalizing:2017, + author = {Andreas V. Hess and Sebastian M{\"{o}}dersheim}, + title = {{Formalizing and Proving a Typing Result for Security Protocols in Isabelle/HOL}}, + booktitle = {30th {IEEE} Computer Security Foundations Symposium, {CSF} 2017, Santa Barbara, CA, USA, August + 21-25, 2017}, + pages = {451--463}, + publisher = {{IEEE} Computer Society}, + year = 2017, + doi = {10.1109/CSF.2017.27} +} + +@InProceedings{ hess.ea:typing:2018, + author = {Andreas V. Hess and Sebastian M{\"{o}}dersheim}, + title = {{A Typing Result for Stateful Protocols}}, + booktitle = {31st {IEEE} Computer Security Foundations Symposium, {CSF} 2018, Oxford, United Kingdom, July 9-12, + 2018}, + pages = {374--388}, + publisher = {{IEEE} Computer Society}, + year = 2018, + doi = {10.1109/CSF.2018.00034} +} + +@InProceedings{ hess.ea:stateful:2018, + author = {Andreas V. Hess and Sebastian M{\"{o}}dersheim and Achim D. Brucker}, + editor = {Javier L{\'{o}}pez and Jianying Zhou and Miguel Soriano}, + title = {{Stateful Protocol Composition}}, + booktitle = {Computer Security - 23rd European Symposium on Research in Computer Security, {ESORICS} 2018, + Barcelona, Spain, September 3-7, 2018, Proceedings, Part {I}}, + series = {Lecture Notes in Computer Science}, + volume = 11098, + pages = {427--446}, + publisher = {Springer}, + year = 2018, + doi = {10.1007/978-3-319-99073-6_21} +} + +@PhDThesis{ hess:typing:2018, + author = {Andreas Viktor Hess}, + title = {Typing and Compositionality for Stateful Security Protocols}, + year = {2019}, + url = {https://orbit.dtu.dk/en/publications/typing-and-compositionality-for-stateful-security-protocols}, + language = {English}, + series = {TU Compute PHD-2018}, + publisher = {DTU Compute} +} + diff --git a/Stateful_Protocol_Composition_and_Typing/document/root.tex b/Stateful_Protocol_Composition_and_Typing/document/root.tex new file mode 100644 index 0000000..f545a90 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/document/root.tex @@ -0,0 +1,151 @@ +\documentclass[10pt,DIV16,a4paper,abstract=true,twoside=semi,openright] +{scrreprt} +\usepackage[USenglish]{babel} +\usepackage[numbers, sort&compress]{natbib} +\usepackage{isabelle,isabellesym} +\usepackage{booktabs} +\usepackage{paralist} +\usepackage{graphicx} +\usepackage{amssymb} +\usepackage{xspace} +\usepackage{xcolor} +\usepackage{hyperref} + +\sloppy +\pagestyle{headings} +\isabellestyle{default} +\setcounter{tocdepth}{1} +\newcommand{\ie}{i.\,e.\xspace} +\newcommand{\eg}{e.\,g.\xspace} +\newcommand{\thy}{\isabellecontext} +\renewcommand{\isamarkupsection}[1]{% + \begingroup% + \def\isacharunderscore{\textunderscore}% + \section{#1 (\thy)}% + \def\isacharunderscore{-}% + \expandafter\label{sec:\isabellecontext}% + \endgroup% +} + +\title{Stateful Protocol Composition and Typing} +\author{% + \href{https://www.dtu.dk/english/service/phonebook/person?id=64207}{Andreas~V.~Hess}\footnotemark[1] + \and + \href{https://people.compute.dtu.dk/samo/}{Sebastian~M{\"o}dersheim}\footnotemark[1] + \and + \href{http://www.brucker.ch/}{Achim~D.~Brucker}\footnotemark[2] +} +\publishers{% + \footnotemark[1]~DTU Compute, Technical University of Denmark, Lyngby, Denmark\texorpdfstring{\\}{, } + \texttt{\{avhe, samo\}@dtu.dk}\\[2em] + % + \footnotemark[2]~ + Department of Computer Science, University of Exeter, Exeter, UK\texorpdfstring{\\}{, } + \texttt{a.brucker@exeter.ac.uk} + % +} + +\begin{document} + \maketitle + \begin{abstract} + \begin{quote} + We provide in this AFP entry several relative soundness results for security protocols. + In particular, we prove typing and compositionality results for stateful protocols (i.e., protocols with mutable state that may span several sessions), and that focuses on reachability properties. + Such results are useful to simplify protocol verification by reducing it to a simpler problem: Typing results give conditions under which it is safe to verify a protocol in a typed model where only ``well-typed'' attacks can occur whereas compositionality results allow us to verify a composed protocol by only verifying the component protocols in isolation. + The conditions on the protocols under which the results hold are furthermore syntactic in nature allowing for full automation. + The foundation presented here is used in another entry to provide fully automated and formalized security proofs of stateful protocols. + + \bigskip + \noindent{\textbf{Keywords:}} + Security protocols, stateful protocols, relative soundness results, proof assistants, Isabelle/HOL, compositionality + \end{quote} + \end{abstract} + + +\tableofcontents +\cleardoublepage + +\chapter{Introduction} +The rest of this document is automatically generated from the formalization in Isabelle/HOL, i.e., all content is checked by Isabelle. +The formalization presented in this entry is described in more detail in several publications: +\begin{itemize} +\item The typing result (\autoref{sec:Typing{-}Result} ``Typing\_Result'') for stateless protocols, the TLS formalization (\autoref{sec:Example{-}TLS} ``Example\_TLS''), and the theories depending on those (see \autoref{fig:session-graph}) are described in~\cite{hess.ea:formalizing:2017} and~\cite[chapter 3]{hess:typing:2018}. +\item The typing result for stateful protocols (\autoref{sec:Stateful{-}Typing} ``Stateful\_Typing'') and the keyserver example (\autoref{sec:Example{-}Keyserver} ``Example\_Keyserver'') are described in~\cite{hess.ea:typing:2018} and~\cite[chapter 4]{hess:typing:2018}. +\item The results on parallel composition for stateless protocols (\autoref{sec:Parallel{-}Compositionality} ``Parallel\_Compositionality'') and stateful protocols (\autoref{sec:Stateful{-}Compositionality} ``Stateful\_Compositionality'') are described in~\cite{hess.ea:stateful:2018} and~\cite[chapter 5]{hess:typing:2018}. +\end{itemize} +Overall, the structure of this document follows the theory dependencies (see \autoref{fig:session-graph}): we start with introducing the technical preliminaries of our formalization (\autoref{cha:preliminaries}). +Next, we introduce the typing results in \autoref{cha:typing} and \autoref{cha:stateful-typing}. +We introduce our compositionality results in \autoref{cha:composition} and \autoref{cha:stateful-composition}. +Finally, we present two example protocols \autoref{cha:examples}. + +\paragraph{Acknowledgments} +This work was supported by the Sapere-Aude project ``Composec: Secure Composition of Distributed Systems'', grant 4184-00334B of the Danish Council for Independent Research. + +\clearpage + +\begin{figure} + \centering + \includegraphics[height=\textheight]{session_graph} + \caption{The Dependency Graph of the Isabelle Theories.\label{fig:session-graph}} +\end{figure} + +\clearpage + +% \input{session} + +\chapter{Preliminaries and Intruder Model} +\label{cha:preliminaries} +In this chapter, we introduce the formal preliminaries, including the intruder model and related lemmata. +\input{Miscellaneous.tex} +\input{Messages.tex} +\input{More_Unification.tex} +\input{Intruder_Deduction.tex} + +\chapter{The Typing Result for Non-Stateful Protocols} +\label{cha:typing} +In this chapter, we formalize and prove a typing result for ``stateless'' security protocols. +This work is described in more detail in~\cite{hess.ea:formalizing:2017} and~\cite[chapter 3]{hess:typing:2018}. +\input{Strands_and_Constraints.tex} +\input{Lazy_Intruder.tex} +\input{Typed_Model.tex} +\input{Typing_Result.tex} + +\chapter{The Typing Result for Stateful Protocols} +\label{cha:stateful-typing} +In this chapter, we lift the typing result to stateful protocols. +For more details, we refer the reader to~\cite{hess.ea:typing:2018} and~\cite[chapter 4]{hess:typing:2018}. +\input{Stateful_Strands.tex} +\input{Stateful_Typing.tex} + +\chapter{The Parallel Composition Result for Non-Stateful Protocols} +\label{cha:composition} +In this chapter, we formalize and prove a compositionality result for security protocols. +This work is an extension of the work described in~\cite{hess.ea:stateful:2018} and~\cite[chapter 5]{hess:typing:2018}. +\input{Labeled_Strands.tex} +\input{Parallel_Compositionality.tex} + +\chapter{The Stateful Protocol Composition Result} +\label{cha:stateful-composition} +In this chapter, we extend the compositionality result to stateful security protocols. +This work is an extension of the work described in~\cite{hess.ea:stateful:2018} and~\cite[chapter 5]{hess:typing:2018}. +\input{Labeled_Stateful_Strands.tex} +\input{Stateful_Compositionality.tex} + +\chapter{Examples} +\label{cha:examples} +In this chapter, we present two examples illustrating our results: +In \autoref{sec:Example{-}TLS} we show that the TLS example from~\cite{hess.ea:formalizing:2017} is type-flaw resistant. +In \autoref{sec:Example{-}Keyserver} we show that the keyserver examples from~\cite{hess.ea:typing:2018,hess.ea:stateful:2018} are also type-flaw resistant and that the steps of the composed keyserver protocol from~\cite{hess.ea:stateful:2018} satisfy our conditions for protocol composition. +\input{Example_TLS.tex} +\input{Example_Keyserver.tex} + +{\small + \bibliographystyle{abbrvnat} + \bibliography{root} +} +\end{document} + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: t +%%% End: diff --git a/Stateful_Protocol_Composition_and_Typing/examples/Example_Keyserver.thy b/Stateful_Protocol_Composition_and_Typing/examples/Example_Keyserver.thy new file mode 100644 index 0000000..0cfb404 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/examples/Example_Keyserver.thy @@ -0,0 +1,404 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Example_Keyserver.thy + Author: Andreas Viktor Hess, DTU +*) + + +section \The Keyserver Example\ +theory Example_Keyserver +imports "../Stateful_Compositionality" +begin + +declare [[code_timing]] + +subsection \Setup\ +subsubsection \Datatypes and functions setup\ +datatype ex_lbl = Label1 ("\") | Label2 ("\") + +datatype ex_atom = + Agent | Value | Attack | PrivFunSec +| Bot + +datatype ex_fun = + ring | valid | revoked | events | beginauth nat | endauth nat | pubkeys | seen +| invkey | tuple | tuple' | attack nat +| sign | crypt | update | pw +| encodingsecret | pubkey nat +| pubconst ex_atom nat + +type_synonym ex_type = "(ex_fun, ex_atom) term_type" +type_synonym ex_var = "ex_type \ nat" + +lemma ex_atom_UNIV: + "(UNIV::ex_atom set) = {Agent, Value, Attack, PrivFunSec, Bot}" +by (auto intro: ex_atom.exhaust) + +instance ex_atom::finite +by intro_classes (metis ex_atom_UNIV finite.emptyI finite.insertI) + +lemma ex_lbl_UNIV: + "(UNIV::ex_lbl set) = {Label1, Label2}" +by (auto intro: ex_lbl.exhaust) + +type_synonym ex_term = "(ex_fun, ex_var) term" +type_synonym ex_terms = "(ex_fun, ex_var) terms" + +primrec arity::"ex_fun \ nat" where + "arity ring = 2" +| "arity valid = 3" +| "arity revoked = 3" +| "arity events = 1" +| "arity (beginauth _) = 3" +| "arity (endauth _) = 3" +| "arity pubkeys = 2" +| "arity seen = 2" +| "arity invkey = 2" +| "arity tuple = 2" +| "arity tuple' = 2" +| "arity (attack _) = 0" +| "arity sign = 2" +| "arity crypt = 2" +| "arity update = 4" +| "arity pw = 2" +| "arity (pubkey _) = 0" +| "arity encodingsecret = 0" +| "arity (pubconst _ _) = 0" + +fun public::"ex_fun \ bool" where + "public (pubkey _) = False" +| "public encodingsecret = False" +| "public _ = True" + +fun Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t::"ex_term list \ (ex_term list \ ex_term list)" where + "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t [k,m] = ([Fun invkey [Fun encodingsecret [], k]], [m])" +| "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t _ = ([], [])" + +fun Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n::"ex_term list \ (ex_term list \ ex_term list)" where + "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n [k,m] = ([], [m])" +| "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n _ = ([], [])" + +fun Ana::"ex_term \ (ex_term list \ ex_term list)" where + "Ana (Fun tuple T) = ([], T)" +| "Ana (Fun tuple' T) = ([], T)" +| "Ana (Fun sign T) = Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n T" +| "Ana (Fun crypt T) = Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t T" +| "Ana _ = ([], [])" + + +subsubsection \Keyserver example: Locale interpretation\ +lemma assm1: + "Ana t = (K,M) \ fv\<^sub>s\<^sub>e\<^sub>t (set K) \ fv t" + "Ana t = (K,M) \ (\g S'. Fun g S' \ t \ length S' = arity g) + \ k \ set K \ Fun f T' \ k \ length T' = arity f" + "Ana t = (K,M) \ K \ [] \ M \ [] \ Ana (t \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +by (rule Ana.cases[of "t"], auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)+ + +lemma assm2: "Ana (Fun f T) = (K, M) \ set M \ set T" +by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims) + +lemma assm6: "0 < arity f \ public f" by (cases f) simp_all + +global_interpretation im: intruder_model arity public Ana + defines wf\<^sub>t\<^sub>r\<^sub>m = "im.wf\<^sub>t\<^sub>r\<^sub>m" +by unfold_locales (metis assm1(1), metis assm1(2),rule Ana.simps, metis assm2, metis assm1(3)) + +type_synonym ex_strand_step = "(ex_fun,ex_var) strand_step" +type_synonym ex_strand = "(ex_fun,ex_var) strand" + + +subsubsection \Typing function\ +definition \\<^sub>v::"ex_var \ ex_type" where + "\\<^sub>v v = (if (\t \ subterms (fst v). case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True) + then fst v else TAtom Bot)" + +fun \::"ex_term \ ex_type" where + "\ (Var v) = \\<^sub>v v" +| "\ (Fun (attack _) _) = TAtom Attack" +| "\ (Fun (pubkey _) _) = TAtom Value" +| "\ (Fun encodingsecret _) = TAtom PrivFunSec" +| "\ (Fun (pubconst \ _) _) = TAtom \" +| "\ (Fun f T) = TComp f (map \ T)" + + +subsubsection \Locale interpretation: typed model\ +lemma assm7: "arity c = 0 \ \a. \X. \ (Fun c X) = TAtom a" by (cases c) simp_all + +lemma assm8: "0 < arity f \ \ (Fun f X) = TComp f (map \ X)" by (cases f) simp_all + +lemma assm9: "infinite {c. \ (Fun c []) = TAtom a \ public c}" +proof - + let ?T = "(range (pubconst a))::ex_fun set" + have *: + "\x y::nat. x \ UNIV \ y \ UNIV \ (pubconst a x = pubconst a y) = (x = y)" + "\x::nat. x \ UNIV \ pubconst a x \ ?T" + "\y::ex_fun. y \ ?T \ \x \ UNIV. y = pubconst a x" + by auto + have "?T \ {c. \ (Fun c []) = TAtom a \ public c}" by auto + moreover have "\f::nat \ ex_fun. bij_betw f UNIV ?T" + using bij_betwI'[OF *] by blast + hence "infinite ?T" by (metis nat_not_finite bij_betw_finite) + ultimately show ?thesis using infinite_super by blast +qed + +lemma assm10: "TComp f T \ \ t \ arity f > 0" +proof (induction rule: \.induct) + case (1 x) + hence *: "TComp f T \ \\<^sub>v x" by simp + hence "\\<^sub>v x \ TAtom Bot" unfolding \\<^sub>v_def by force + hence "\t \ subterms (fst x). case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True" + unfolding \\<^sub>v_def by argo + thus ?case using * unfolding \\<^sub>v_def by fastforce +qed auto + +lemma assm11: "im.wf\<^sub>t\<^sub>r\<^sub>m (\ (Var x))" +proof - + have "im.wf\<^sub>t\<^sub>r\<^sub>m (\\<^sub>v x)" unfolding \\<^sub>v_def im.wf\<^sub>t\<^sub>r\<^sub>m_def by auto + thus ?thesis by simp +qed + +lemma assm12: "\ (Var (\, n)) = \ (Var (\, m))" +apply (cases "\t \ subterms \. case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True") +by (auto simp add: \\<^sub>v_def) + +lemma Ana_const: "arity c = 0 \ Ana (Fun c T) = ([], [])" +by (cases c) simp_all + +lemma Ana_subst': "Ana (Fun f T) = (K,M) \ Ana (Fun f T \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \,M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +by (cases f) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims) + +global_interpretation tm: typed_model' arity public Ana \ +by (unfold_locales, unfold wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric]) + (metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6, + metis assm12, metis Ana_const, metis Ana_subst') + + +subsubsection \Locale interpretation: labeled stateful typed model\ +global_interpretation stm: labeled_stateful_typed_model' arity public Ana \ tuple \ \ +by standard (rule arity.simps, metis Ana_subst', metis assm12, metis Ana_const, simp) + +type_synonym ex_stateful_strand_step = "(ex_fun,ex_var) stateful_strand_step" +type_synonym ex_stateful_strand = "(ex_fun,ex_var) stateful_strand" + +type_synonym ex_labeled_stateful_strand_step = + "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand_step" + +type_synonym ex_labeled_stateful_strand = + "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand" + + +subsection \Theorem: Type-flaw resistance of the keyserver example from the CSF18 paper\ +abbreviation "PK n \ Var (TAtom Value,n)" +abbreviation "A n \ Var (TAtom Agent,n)" +abbreviation "X n \ (TAtom Agent,n)" + +abbreviation "ringset t \ Fun ring [Fun encodingsecret [], t]" +abbreviation "validset t t' \ Fun valid [Fun encodingsecret [], t, t']" +abbreviation "revokedset t t' \ Fun revoked [Fun encodingsecret [], t, t']" +abbreviation "eventsset \ Fun events [Fun encodingsecret []]" + +(* Note: We will use S\<^sub>k\<^sub>s as a constraint, but it actually represents all steps that might occur + in the protocol *) +abbreviation S\<^sub>k\<^sub>s::"(ex_fun,ex_var) stateful_strand_step list" where + "S\<^sub>k\<^sub>s \ [ + insert\Fun (attack 0) [], eventsset\, + delete\PK 0, validset (A 0) (A 0)\, + \(TAtom Agent,0)\PK 0 not in revokedset (A 0) (A 0)\, + \(TAtom Agent,0)\PK 0 not in validset (A 0) (A 0)\, + insert\PK 0, validset (A 0) (A 0)\, + insert\PK 0, ringset (A 0)\, + insert\PK 0, revokedset (A 0) (A 0)\, + select\PK 0, validset (A 0) (A 0)\, + select\PK 0, ringset (A 0)\, + receive\Fun invkey [Fun encodingsecret [], PK 0]\, + receive\Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]\, + send\Fun invkey [Fun encodingsecret [], PK 0]\, + send\Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]\ +]" + +theorem "stm.tfr\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s" +proof - + let ?M = "concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s)))" + have "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \ tuple ?M S\<^sub>k\<^sub>s" by eval + thus ?thesis by (rule stm.tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t) +qed + + +subsection \Theorem: Type-flaw resistance of the keyserver examples from the ESORICS18 paper\ +abbreviation "signmsg t t' \ Fun sign [t, t']" +abbreviation "cryptmsg t t' \ Fun crypt [t, t']" +abbreviation "invkeymsg t \ Fun invkey [Fun encodingsecret [], t]" +abbreviation "updatemsg a b c d \ Fun update [a,b,c,d]" +abbreviation "pwmsg t t' \ Fun pw [t, t']" + +abbreviation "beginauthset n t t' \ Fun (beginauth n) [Fun encodingsecret [], t, t']" +abbreviation "endauthset n t t' \ Fun (endauth n) [Fun encodingsecret [], t, t']" +abbreviation "pubkeysset t \ Fun pubkeys [Fun encodingsecret [], t]" +abbreviation "seenset t \ Fun seen [Fun encodingsecret [], t]" + +declare [[coercion "Var::ex_var \ ex_term"]] +declare [[coercion_enabled]] + +(* Note: S'\<^sub>k\<^sub>s contains the (slightly over-approximated) steps that can occur in the + reachable constraints of \

\<^sub>k\<^sub>s,\<^sub>1 and \

\<^sub>k\<^sub>s,\<^sub>2 modulo variable renaming *) +definition S'\<^sub>k\<^sub>s::"ex_labeled_stateful_strand_step list" where + "S'\<^sub>k\<^sub>s \ [ +\<^cancel>\constraint steps from the first protocol (duplicate steps are ignored)\ + + \<^cancel>\rule R^1_1\ + \\, send\invkeymsg (PK 0)\\, + \\, \PK 0 in validset (A 0) (A 1)\\, + \\, receive\Fun (attack 0) []\\, + + \<^cancel>\rule R^2_1\ + \\, send\signmsg (invkeymsg (PK 0)) (Fun tuple' [A 0, PK 0])\\, + \\, \PK 0 in validset (A 0) (A 1)\\, + \\, \X 0, X 1\PK 0 not in validset (Var (X 0)) (Var (X 1))\\, + \\, \X 0, X 1\PK 0 not in revokedset (Var (X 0)) (Var (X 1))\\, + \\, \PK 0 not in beginauthset 0 (A 0) (A 1)\\, + + \<^cancel>\rule R^3_1\ + \\, \PK 0 in beginauthset 0 (A 0) (A 1)\\, + \\, \PK 0 in endauthset 0 (A 0) (A 1)\\, + + \<^cancel>\rule R^4_1\ + \\, receive\PK 0\\, + \\, receive\invkeymsg (PK 0)\\, + + \<^cancel>\rule R^5_1\ + \\, insert\PK 0, ringset (A 0)\\, + \\, insert\PK 0, validset (A 0) (A 1)\\, + \\, insert\PK 0, beginauthset 0 (A 0) (A 1)\\, + \\, insert\PK 0, endauthset 0 (A 0) (A 1)\\, + + \<^cancel>\rule R^6_1\ + \\, select\PK 0, ringset (A 0)\\, + \\, delete\PK 0, ringset (A 0)\\, + + \<^cancel>\rule R^7_1\ + \\, \PK 0 not in endauthset 0 (A 0) (A 1)\\, + \\, delete\PK 0, validset (A 0) (A 1)\\, + \\, insert\PK 0, revokedset (A 0) (A 1)\\, + + \<^cancel>\rule R^8_1\ + \<^cancel>\nothing new\ + + \<^cancel>\rule R^9_1\ + \\, send\PK 0\\, + + \<^cancel>\rule R^10_1\ + \\, send\Fun (attack 0) []\\, + +\<^cancel>\constraint steps from the second protocol (duplicate steps are ignored)\ + \<^cancel>\rule R^2_1\ + \\, send\invkeymsg (PK 0)\\, + \\, \PK 0 in validset (A 0) (A 1)\\, + \\, receive\Fun (attack 1) []\\, + + \<^cancel>\rule R^2_2\ + \\, send\cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))\\, + \\, select\PK 0, pubkeysset (A 0)\\, + \\, \X 0\PK 0 not in pubkeysset (Var (X 0))\\, + \\, \X 0\PK 0 not in seenset (Var (X 0))\\, + + \<^cancel>\rule R^3_2\ + \\, \PK 0 in beginauthset 1 (A 0) (A 1)\\, + \\, \PK 0 in endauthset 1 (A 0) (A 1)\\, + + \<^cancel>\rule R^4_2\ + \\, receive\PK 0\\, + \\, receive\invkeymsg (PK 0)\\, + + \<^cancel>\rule R^5_2\ + \\, select\PK 0, pubkeysset (A 0)\\, + \\, insert\PK 0, beginauthset 1 (A 0) (A 1)\\, + \\, receive\cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))\\, + + \<^cancel>\rule R^6_2\ + \\, \PK 0 not in endauthset 1 (A 0) (A 1)\\, + \\, insert\PK 0, validset (A 0) (A 1)\\, + \\, insert\PK 0, endauthset 1 (A 0) (A 1)\\, + \\, insert\PK 0, seenset (A 0)\\, + + \<^cancel>\rule R^7_2\ + \\, receive\pwmsg (A 0) (A 1)\\, + + \<^cancel>\rule R^8_2\ + \<^cancel>\nothing new\ + + \<^cancel>\rule R^9_2\ + \\, insert\PK 0, pubkeysset (A 0)\\, + + \<^cancel>\rule R^10_2\ + \\, send\Fun (attack 1) []\\ +]" + +theorem "stm.tfr\<^sub>s\<^sub>s\<^sub>t (unlabel S'\<^sub>k\<^sub>s)" +proof - + let ?S = "unlabel S'\<^sub>k\<^sub>s" + let ?M = "concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t ?S@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t ?S)))" + have "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \ tuple ?M ?S" by eval + thus ?thesis by (rule stm.tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t) +qed + + +subsection \Theorem: The steps of the keyserver protocols from the ESORICS18 paper satisfy the conditions for parallel composition\ +theorem + fixes S f + defines "S \ [PK 0, invkeymsg (PK 0), Fun encodingsecret []]@concat ( + map (\s. [s, Fun tuple [PK 0, s]]) + [validset (A 0) (A 1), beginauthset 0 (A 0) (A 1), endauthset 0 (A 0) (A 1), + beginauthset 1 (A 0) (A 1), endauthset 1 (A 0) (A 1)])@ + [A 0]" + and "f \ \M. {t \ \ | t \. t \ M \ tm.wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \ \ im.wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \) \ fv (t \ \) = {}}" + and "Sec \ (f (set S)) - {m. im.intruder_synth {} m}" + shows "stm.par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t S'\<^sub>k\<^sub>s Sec" +proof - + let ?N = "\P. concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t P@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t P)))" + let ?M = "\l. ?N (proj_unl l S'\<^sub>k\<^sub>s)" + have "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \ tuple S'\<^sub>k\<^sub>s ?M S" + unfolding S_def by eval + thus ?thesis + using stm.par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_if_comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t[of S'\<^sub>k\<^sub>s ?M S] + unfolding Sec_def f_def wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric] by blast +qed + +end diff --git a/Stateful_Protocol_Composition_and_Typing/examples/Example_TLS.thy b/Stateful_Protocol_Composition_and_Typing/examples/Example_TLS.thy new file mode 100644 index 0000000..75054f9 --- /dev/null +++ b/Stateful_Protocol_Composition_and_Typing/examples/Example_TLS.thy @@ -0,0 +1,305 @@ +(* +(C) Copyright Andreas Viktor Hess, DTU, 2015-2020 + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(* Title: Example_TLS.thy + Author: Andreas Viktor Hess, DTU +*) + +section \Proving Type-Flaw Resistance of the TLS Handshake Protocol\ +theory Example_TLS +imports "../Typed_Model" +begin + +declare [[code_timing]] + +subsection \TLS example: Datatypes and functions setup\ +datatype ex_atom = PrivKey | SymKey | PubConst | Agent | Nonce | Bot + +datatype ex_fun = + clientHello | clientKeyExchange | clientFinished +| serverHello | serverCert | serverHelloDone +| finished | changeCipher | x509 | prfun | master | pmsForm +| sign | hash | crypt | pub | concat | privkey nat +| pubconst ex_atom nat + +type_synonym ex_type = "(ex_fun, ex_atom) term_type" +type_synonym ex_var = "ex_type \ nat" + +instance ex_atom::finite +proof + let ?S = "UNIV::ex_atom set" + have "?S = {PrivKey, SymKey, PubConst, Agent, Nonce, Bot}" by (auto intro: ex_atom.exhaust) + thus "finite ?S" by (metis finite.emptyI finite.insertI) +qed + +type_synonym ex_term = "(ex_fun, ex_var) term" +type_synonym ex_terms = "(ex_fun, ex_var) terms" + +primrec arity::"ex_fun \ nat" where + "arity changeCipher = 0" +| "arity clientFinished = 4" +| "arity clientHello = 5" +| "arity clientKeyExchange = 1" +| "arity concat = 5" +| "arity crypt = 2" +| "arity finished = 1" +| "arity hash = 1" +| "arity master = 3" +| "arity pmsForm = 1" +| "arity prfun = 1" +| "arity (privkey _) = 0" +| "arity pub = 1" +| "arity (pubconst _ _) = 0" +| "arity serverCert = 1" +| "arity serverHello = 5" +| "arity serverHelloDone = 0" +| "arity sign = 2" +| "arity x509 = 2" + +fun public::"ex_fun \ bool" where + "public (privkey _) = False" +| "public _ = True" + +fun Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t::"ex_term list \ (ex_term list \ ex_term list)" where + "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t [Fun pub [k],m] = ([k], [m])" +| "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t _ = ([], [])" + +fun Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n::"ex_term list \ (ex_term list \ ex_term list)" where + "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n [k,m] = ([], [m])" +| "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n _ = ([], [])" + +fun Ana::"ex_term \ (ex_term list \ ex_term list)" where + "Ana (Fun crypt T) = Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t T" +| "Ana (Fun finished T) = ([], T)" +| "Ana (Fun master T) = ([], T)" +| "Ana (Fun pmsForm T) = ([], T)" +| "Ana (Fun serverCert T) = ([], T)" +| "Ana (Fun serverHello T) = ([], T)" +| "Ana (Fun sign T) = Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n T" +| "Ana (Fun x509 T) = ([], T)" +| "Ana _ = ([], [])" + + +subsection \TLS example: Locale interpretation\ +lemma assm1: + "Ana t = (K,M) \ fv\<^sub>s\<^sub>e\<^sub>t (set K) \ fv t" + "Ana t = (K,M) \ (\g S'. Fun g S' \ t \ length S' = arity g) + \ k \ set K \ Fun f T' \ k \ length T' = arity f" + "Ana t = (K,M) \ K \ [] \ M \ [] \ Ana (t \ \) = (K \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \, M \\<^sub>l\<^sub>i\<^sub>s\<^sub>t \)" +by (rule Ana.cases[of "t"], auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)+ + +lemma assm2: "Ana (Fun f T) = (K, M) \ set M \ set T" +by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims) + +lemma assm6: "0 < arity f \ public f" by (cases f) simp_all + +global_interpretation im: intruder_model arity public Ana + defines wf\<^sub>t\<^sub>r\<^sub>m = "im.wf\<^sub>t\<^sub>r\<^sub>m" + and wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s = "im.wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s" +by unfold_locales (metis assm1(1), metis assm1(2), rule Ana.simps, metis assm2, metis assm1(3)) + + +subsection \TLS Example: Typing function\ +definition \\<^sub>v::"ex_var \ ex_type" where + "\\<^sub>v v = (if (\t \ subterms (fst v). case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True) + then fst v else TAtom Bot)" + +fun \::"ex_term \ ex_type" where + "\ (Var v) = \\<^sub>v v" +| "\ (Fun (privkey _) _) = TAtom PrivKey" +| "\ (Fun changeCipher _) = TAtom PubConst" +| "\ (Fun serverHelloDone _) = TAtom PubConst" +| "\ (Fun (pubconst \ _) _) = TAtom \" +| "\ (Fun f T) = TComp f (map \ T)" + + +subsection \TLS Example: Locale interpretation (typed model)\ +lemma assm7: "arity c = 0 \ \a. \X. \ (Fun c X) = TAtom a" by (cases c) simp_all + +lemma assm8: "0 < arity f \ \ (Fun f X) = TComp f (map \ X)" by (cases f) simp_all + +lemma assm9: "infinite {c. \ (Fun c []) = TAtom a \ public c}" +proof - + let ?T = "(range (pubconst a))::ex_fun set" + have *: + "\x y::nat. x \ UNIV \ y \ UNIV \ (pubconst a x = pubconst a y) = (x = y)" + "\x::nat. x \ UNIV \ pubconst a x \ ?T" + "\y::ex_fun. y \ ?T \ \x \ UNIV. y = pubconst a x" + by auto + have "?T \ {c. \ (Fun c []) = TAtom a \ public c}" by auto + moreover have "\f::nat \ ex_fun. bij_betw f UNIV ?T" + using bij_betwI'[OF *] by blast + hence "infinite ?T" by (metis nat_not_finite bij_betw_finite) + ultimately show ?thesis using infinite_super by blast +qed + +lemma assm10: "TComp f T \ \ t \ arity f > 0" +proof (induction rule: \.induct) + case (1 x) + hence *: "TComp f T \ \\<^sub>v x" by simp + hence "\\<^sub>v x \ TAtom Bot" unfolding \\<^sub>v_def by force + hence "\t \ subterms (fst x). case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True" + unfolding \\<^sub>v_def by argo + thus ?case using * unfolding \\<^sub>v_def by fastforce +qed auto + +lemma assm11: "im.wf\<^sub>t\<^sub>r\<^sub>m (\ (Var x))" +proof - + have "im.wf\<^sub>t\<^sub>r\<^sub>m (\\<^sub>v x)" unfolding \\<^sub>v_def im.wf\<^sub>t\<^sub>r\<^sub>m_def by auto + thus ?thesis by simp +qed + +lemma assm12: "\ (Var (\, n)) = \ (Var (\, m))" + apply (cases "\t \ subterms \. case t of + (TComp f T) \ arity f > 0 \ arity f = length T + | _ \ True") + by (auto simp add: \\<^sub>v_def) + +lemma Ana_const: "arity c = 0 \ Ana (Fun c T) = ([],[])" +by (cases c) simp_all + +lemma Ana_keys_subterm: "Ana t = (K,T) \ k \ set K \ k \ t" +proof (induct t rule: Ana.induct) + case (1 U) + then obtain m where "U = [Fun pub [k], m]" "K = [k]" "T = [m]" + by (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims) + thus ?case using Fun_subterm_inside_params[of k crypt U] by auto +qed (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims) + +global_interpretation tm: typed_model' arity public Ana \ +by (unfold_locales, unfold wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric], + metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6, + metis assm12, metis Ana_const, metis Ana_keys_subterm) + +subsection \TLS example: Proving type-flaw resistance\ +abbreviation \\<^sub>v_clientHello where + "\\<^sub>v_clientHello \ + TComp clientHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]" + +abbreviation \\<^sub>v_serverHello where + "\\<^sub>v_serverHello \ + TComp serverHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]" + +abbreviation \\<^sub>v_pub where + "\\<^sub>v_pub \ TComp pub [TAtom PrivKey]" + +abbreviation \\<^sub>v_x509 where + "\\<^sub>v_x509 \ TComp x509 [TAtom Agent, \\<^sub>v_pub]" + +abbreviation \\<^sub>v_sign where + "\\<^sub>v_sign \ TComp sign [TAtom PrivKey, \\<^sub>v_x509]" + +abbreviation \\<^sub>v_serverCert where + "\\<^sub>v_serverCert \ TComp serverCert [\\<^sub>v_sign]" + +abbreviation \\<^sub>v_pmsForm where + "\\<^sub>v_pmsForm \ TComp pmsForm [TAtom SymKey]" + +abbreviation \\<^sub>v_crypt where + "\\<^sub>v_crypt \ TComp crypt [\\<^sub>v_pub, \\<^sub>v_pmsForm]" + +abbreviation \\<^sub>v_clientKeyExchange where + "\\<^sub>v_clientKeyExchange \ + TComp clientKeyExchange [\\<^sub>v_crypt]" + +abbreviation \\<^sub>v_HSMsgs where + "\\<^sub>v_HSMsgs \ TComp concat [ + \\<^sub>v_clientHello, + \\<^sub>v_serverHello, + \\<^sub>v_serverCert, + TAtom PubConst, + \\<^sub>v_clientKeyExchange]" + +(* Variables from TLS *) +abbreviation "T\<^sub>1 n \ Var (TAtom Nonce,n)" +abbreviation "T\<^sub>2 n \ Var (TAtom Nonce,n)" +abbreviation "R\<^sub>A n \ Var (TAtom Nonce,n)" +abbreviation "R\<^sub>B n \ Var (TAtom Nonce,n)" +abbreviation "S n \ Var (TAtom Nonce,n)" +abbreviation "Cipher n \ Var (TAtom Nonce,n)" +abbreviation "Comp n \ Var (TAtom Nonce,n)" +abbreviation "B n \ Var (TAtom Agent,n)" +abbreviation "Pr\<^sub>c\<^sub>a n \ Var (TAtom PrivKey,n)" +abbreviation "PMS n \ Var (TAtom SymKey,n)" +abbreviation "P\<^sub>B n \ Var (TComp pub [TAtom PrivKey],n)" +abbreviation "HSMsgs n \ Var (\\<^sub>v_HSMsgs,n)" + +subsubsection \Defining the over-approximation set\ +abbreviation clientHello\<^sub>t\<^sub>r\<^sub>m where + "clientHello\<^sub>t\<^sub>r\<^sub>m \ Fun clientHello [T\<^sub>1 0, R\<^sub>A 1, S 2, Cipher 3, Comp 4]" + +abbreviation serverHello\<^sub>t\<^sub>r\<^sub>m where + "serverHello\<^sub>t\<^sub>r\<^sub>m \ Fun serverHello [T\<^sub>2 0, R\<^sub>B 1, S 2, Cipher 3, Comp 4]" + +abbreviation serverCert\<^sub>t\<^sub>r\<^sub>m where + "serverCert\<^sub>t\<^sub>r\<^sub>m \ Fun serverCert [Fun sign [Pr\<^sub>c\<^sub>a 0, Fun x509 [B 1, P\<^sub>B 2]]]" + +abbreviation serverHelloDone\<^sub>t\<^sub>r\<^sub>m where + "serverHelloDone\<^sub>t\<^sub>r\<^sub>m \ Fun serverHelloDone []" + +abbreviation clientKeyExchange\<^sub>t\<^sub>r\<^sub>m where + "clientKeyExchange\<^sub>t\<^sub>r\<^sub>m \ Fun clientKeyExchange [Fun crypt [P\<^sub>B 0, Fun pmsForm [PMS 1]]]" + +abbreviation changeCipher\<^sub>t\<^sub>r\<^sub>m where + "changeCipher\<^sub>t\<^sub>r\<^sub>m \ Fun changeCipher []" + +abbreviation finished\<^sub>t\<^sub>r\<^sub>m where + "finished\<^sub>t\<^sub>r\<^sub>m \ Fun finished [Fun prfun [ + Fun clientFinished [ + Fun prfun [Fun master [PMS 0, R\<^sub>A 1, R\<^sub>B 2]], + R\<^sub>A 3, R\<^sub>B 4, Fun hash [HSMsgs 5] + ] + ]]" + +definition M\<^sub>T\<^sub>L\<^sub>S::"ex_term list" where + "M\<^sub>T\<^sub>L\<^sub>S \ [ + clientHello\<^sub>t\<^sub>r\<^sub>m, + serverHello\<^sub>t\<^sub>r\<^sub>m, + serverCert\<^sub>t\<^sub>r\<^sub>m, + serverHelloDone\<^sub>t\<^sub>r\<^sub>m, + clientKeyExchange\<^sub>t\<^sub>r\<^sub>m, + changeCipher\<^sub>t\<^sub>r\<^sub>m, + finished\<^sub>t\<^sub>r\<^sub>m +]" + + +subsection \Theorem: The TLS handshake protocol is type-flaw resistant\ +theorem "tm.tfr\<^sub>s\<^sub>e\<^sub>t (set M\<^sub>T\<^sub>L\<^sub>S)" +by (rule tm.tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t') eval + +end