(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Hoare.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* Auxiliary Definitions/Lemmas to Facilitate Hoare Logic *}
theory HoareCon imports Main begin

(*
syntax

"_hoarep_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,
   'f set,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_,_/\<turnstile> (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoarep_emptyCtx"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_/\<turnstile>\<^bsub>'/_\<^esub> (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoarep_emptyCtx_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_/\<turnstile> (_/ (_)/ _,/_))" [61,1000,20,1000,1000]60)

"_hoarep_noAbr"::
"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_,_/\<turnstile>\<^bsub>'/_\<^esub> (_/ (_)/ _))" [61,60,60,1000,20,1000]60)

"_hoarep_noAbr_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_,_/\<turnstile> (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoarep_emptyCtx_noAbr"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_/\<turnstile>\<^bsub>'/_\<^esub> (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoarep_emptyCtx_noAbr_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_/\<turnstile> (_/ (_)/ _))" [61,1000,20,1000]60)

"_hoaret_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,
    's assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_,_/\<turnstile>\<^sub>t (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoaret_emptyCtx"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_/\<turnstile>\<^sub>t\<^bsub>'/_\<^esub> (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoaret_emptyCtx_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_/\<turnstile>\<^sub>t (_/ (_)/ _,/_))" [61,1000,20,1000,1000]60)

"_hoaret_noAbr"::
"[('s,'p,'f) body,'f set, ('s,'p) quadruple set,
    's assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_,_/\<turnstile>\<^sub>t\<^bsub>'/_\<^esub> (_/ (_)/ _))" [61,60,60,1000,20,1000]60)

"_hoaret_noAbr_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_,_/\<turnstile>\<^sub>t (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoaret_emptyCtx_noAbr"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_/\<turnstile>\<^sub>t\<^bsub>'/_\<^esub> (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoaret_emptyCtx_noAbr_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn] => bool"
    ("(3_/\<turnstile>\<^sub>t (_/ (_)/ _))" [61,1000,20,1000]60)

syntax (ascii)

"_hoarep_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,
     's assn,('s,'p,'f) com, 's assn,'s assn] \<Rightarrow> bool"
   ("(3_,_/|- (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoarep_emptyCtx"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
   ("(3_/|-'/_ (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoarep_emptyCtx_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
   ("(3_/|-(_/ (_)/ _,/_))" [61,1000,20,1000,1000]60)

"_hoarep_noAbr"::
"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
   's assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_,_/|-'/_ (_/ (_)/ _))" [61,60,60,1000,20,1000]60)

"_hoarep_noAbr_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_,_/|-(_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoarep_emptyCtx_noAbr"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_/|-'/_ (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoarep_emptyCtx_noAbr_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_/|-(_/ (_)/ _))" [61,1000,20,1000]60)

"_hoaret_emptyFault"::
"[('s,'p,'f) body,('s,'p) quadruple set,
     's assn,('s,'p,'f) com, 's assn,'s assn] => bool"
   ("(3_,_/|-t (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoaret_emptyCtx"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
   ("(3_/|-t'/_ (_/ (_)/ _,/_))" [61,60,1000,20,1000,1000]60)

"_hoaret_emptyCtx_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn,'s assn] => bool"
   ("(3_/|-t(_/ (_)/ _,/_))" [61,1000,20,1000,1000]60)

"_hoaret_noAbr"::
"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
   's assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_,_/|-t'/_ (_/ (_)/ _))" [61,60,60,1000,20,1000]60)

"_hoaret_noAbr_emptyFaults"::
"[('s,'p,'f) body,('s,'p) quadruple set,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_,_/|-t(_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoaret_emptyCtx_noAbr"::
"[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_/|-t'/_ (_/ (_)/ _))" [61,60,1000,20,1000]60)

"_hoaret_emptyCtx_noAbr_emptyFaults"::
"[('s,'p,'f) body,'s assn,('s,'p,'f) com, 's assn] => bool"
   ("(3_/|-t(_/ (_)/ _))" [61,1000,20,1000]60)
*)
(*
translations

 "\<Gamma>\<turnstile> P c Q,A"  == "\<Gamma>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
 "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"  == "\<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

 "\<Gamma>,\<Theta>\<turnstile> P c Q"  == "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q"
 "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q"  == "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,{}"
 "\<Gamma>,\<Theta>\<turnstile> P c Q,A" == "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"

 "\<Gamma>\<turnstile> P c Q"    ==  "\<Gamma>\<turnstile>\<^bsub>/{}\<^esub> P c Q"
 "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q"  == "\<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> P c Q"
 "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q"  <=  "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q,{}"
 "\<Gamma>\<turnstile> P c Q"    <=  "\<Gamma>\<turnstile> P c Q,{}"

 "\<Gamma>\<turnstile>\<^sub>t P c Q,A"   == "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q,A"
 "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"  == "\<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

 "\<Gamma>,\<Theta>\<turnstile>\<^sub>t P c Q"   == "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q"
 "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q" == "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,{}"
 "\<Gamma>,\<Theta>\<turnstile>\<^sub>t P c Q,A"   == "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q,A"

 "\<Gamma>\<turnstile>\<^sub>t P c Q"    == "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/{}\<^esub> P c Q"
 "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q"  == "\<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q"
 "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q"  <=  "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,{}"
 "\<Gamma>\<turnstile>\<^sub>t P c Q"    <=  "\<Gamma>\<turnstile>\<^sub>t P c Q,{}"

term "\<Gamma>\<turnstile> P c Q"
term "\<Gamma>\<turnstile> P c Q,A"

term "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q"
term "\<Gamma>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

term "\<Gamma>,\<Theta>\<turnstile> P c Q"
term "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q"

term "\<Gamma>,\<Theta>\<turnstile> P c Q,A"
term "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

term "\<Gamma>\<turnstile>\<^sub>t P c Q"
term "\<Gamma>\<turnstile>\<^sub>t P c Q,A"

term "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q"
term "\<Gamma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

term "\<Gamma>,\<Theta>\<turnstile> P c Q"
term "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q"

term "\<Gamma>,\<Theta>\<turnstile> P c Q,A"
term "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
*)

primrec assoc:: "('a \<times>'b) list \<Rightarrow> 'a \<Rightarrow> 'b "
where
"assoc [] x = undefined" |
"assoc (p#ps) x = (if fst p = x then (snd p) else assoc ps x)"

lemma conjE_simp: "(P \<and> Q \<Longrightarrow> PROP R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> PROP R)"
  by rule simp_all

lemma CollectInt_iff: "{s. P s} \<inter> {s. Q s} = {s. P s \<and> Q s}"
  by auto

lemma Compl_Collect:"-(Collect b) = {x. \<not>(b x)}"
  by fastforce

lemma Collect_False: "{s. False} = {}"
  by simp

lemma Collect_True: "{s. True} = UNIV"
  by simp

lemma triv_All_eq: "\<forall>x. P \<equiv> P"
  by simp

lemma triv_Ex_eq: "\<exists>x. P \<equiv> P"
  by simp

lemma Ex_True: "\<exists>b. b"
   by blast

lemma Ex_False: "\<exists>b. \<not>b"
  by blast

definition mex::"('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "mex P = Ex P"

definition meq::"'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "meq s Z = (s = Z)"

lemma subset_unI1: "A \<subseteq> B \<Longrightarrow> A \<subseteq> B \<union> C"
  by blast

lemma subset_unI2: "A \<subseteq> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by blast

lemma split_paired_UN: "(\<Union>p. (P p)) = (\<Union>a b. (P (a,b)))"
  by auto

lemma in_insert_hd: "f \<in> insert f X"
  by simp

lemma lookup_Some_in_dom: "\<Gamma> p = Some bdy \<Longrightarrow> p \<in> dom \<Gamma>"
  by auto

lemma unit_object: "(\<forall>u::unit. P u) = P ()"
  by auto

lemma unit_ex: "(\<exists>u::unit. P u) = P ()"
  by auto

lemma unit_meta: "(\<And>(u::unit). PROP P u) \<equiv> PROP P ()"
  by auto

lemma unit_UN: "(\<Union>z::unit. P z) = P ()"
  by auto

lemma subset_singleton_insert1: "y = x \<Longrightarrow> {y} \<subseteq> insert x A"
  by auto

lemma subset_singleton_insert2: "{y} \<subseteq> A \<Longrightarrow> {y} \<subseteq> insert x A"
  by auto

lemma in_Specs_simp: "(\<forall>x\<in>\<Union>Z. {(P Z, p, Q Z, A Z)}. Prop x) =
       (\<forall>Z. Prop (P Z,p,Q Z,A Z))"
  by auto

lemma in_set_Un_simp: "(\<forall>x\<in>A \<union> B. P x) = ((\<forall>x \<in> A. P x) \<and> (\<forall>x \<in> B. P x))"
  by auto

lemma split_all_conj: "(\<forall>x. P x \<and> Q x) = ((\<forall>x. P x) \<and> (\<forall>x. Q x))"
  by blast

lemma image_Un_single_simp: "f ` (\<Union>Z. {P Z}) = (\<Union>Z. {f (P Z)}) "
  by auto

lemma measure_lex_prod_def':
  "f <*mlex*> r \<equiv> ({(x,y). (x,y) \<in> measure f \<or> f x=f y \<and> (x,y) \<in>  r})"
  by (auto simp add: mlex_prod_def inv_image_def)

lemma in_measure_iff: "(x,y) \<in> measure f = (f x < f y)"
  by (simp add: measure_def inv_image_def)

lemma in_lex_iff:
  "((a,b),(x,y)) \<in> r <*lex*> s = ((a,x) \<in> r \<or> (a=x \<and> (b,y)\<in>s))"
  by (simp add: lex_prod_def)

lemma in_mlex_iff:
  "(x,y) \<in> f <*mlex*> r = (f x < f y \<or> (f x=f y \<and> (x,y) \<in> r))"
  by (simp add: measure_lex_prod_def' in_measure_iff)

lemma in_inv_image_iff: "(x,y) \<in> inv_image r f = ((f x, f y) \<in> r)"
  by (simp add: inv_image_def)

text {* This is actually the same as @{thm [source] wf_mlex}. However, this basic
proof took me so long that I'm not willing to delete it.
*}
lemma wf_measure_lex_prod [simp,intro]:
  assumes wf_r: "wf r"
  shows "wf (f <*mlex*> r)"
proof (rule ccontr)
  assume " \<not> wf (f <*mlex*> r)"
  then
  obtain g where "\<forall>i. (g (Suc i), g i) \<in> f <*mlex*> r"
    by (auto simp add: wf_iff_no_infinite_down_chain)
  hence g: "\<forall>i. (g (Suc i), g i) \<in> measure f \<or>
    f (g (Suc i)) = f (g i) \<and> (g (Suc i), g i) \<in> r"
    by (simp add: measure_lex_prod_def')
  hence le_g: "\<forall>i. f (g (Suc i)) \<le> f (g i)"
    by (auto simp add: in_measure_iff order_le_less)
  have "wf (measure f)"
    by simp
  hence " \<forall>Q. (\<exists>x. x \<in> Q) \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> measure f \<longrightarrow> y \<notin> Q)"
    by (simp add: wf_eq_minimal)
  from this [rule_format, of "g ` UNIV"]
  have "\<exists>z. z \<in> range g \<and> (\<forall>y. (y, z) \<in> measure f \<longrightarrow> y \<notin> range g)"
    by auto
  then obtain z where
    z: "z \<in> range g" and
    min_z: "\<forall>y. f y < f z \<longrightarrow> y \<notin> range g"
    by (auto simp add: in_measure_iff)
  from z obtain k where
    k: "z = g k"
    by auto
  have "\<forall>i. k \<le> i \<longrightarrow> f (g i) = f (g k)"
  proof (intro allI impI)
    fix i
    assume "k \<le> i" then show "f (g i) = f (g k)"
    proof (induct i)
      case 0
      have "k \<le> 0" by fact hence "k = 0" by simp
      thus "f (g 0) = f (g k)"
        by simp
    next
      case (Suc n)
      have k_Suc_n: "k \<le> Suc n" by fact
      then show "f (g (Suc n)) = f (g k)"
      proof (cases "k = Suc n")
        case True
        thus ?thesis by simp
      next
        case False
        with k_Suc_n
        have "k \<le> n"
          by simp
        with Suc.hyps
        have n_k: "f (g n) = f (g k)" by simp
        from le_g have le: "f (g (Suc n)) \<le> f (g n)"
          by simp
        show ?thesis
        proof (cases "f (g (Suc n)) = f (g n)")
          case True with n_k show ?thesis by simp
        next
          case False
          with le have "f (g (Suc n)) < f (g n)"
            by simp
          with n_k k have "f (g (Suc n)) < f z"
            by simp
          with min_z have "g (Suc n) \<notin> range g"
            by blast
          hence False by simp
          thus ?thesis
            by simp
        qed
      qed
    qed
  qed
  with k [symmetric] have "\<forall>i. k \<le> i \<longrightarrow> f (g i) = f z"
    by simp
  hence "\<forall>i. k \<le> i \<longrightarrow> f (g (Suc i)) = f (g i)"
    by simp
  with g have "\<forall>i. k \<le> i \<longrightarrow> (g (Suc i),(g i)) \<in> r"
    by (auto simp add: in_measure_iff order_less_le )
  hence "\<forall>i. (g (Suc (i+k)),(g (i+k))) \<in> r"
    by simp
  then
  have "\<exists>f. \<forall>i. (f (Suc i), f i) \<in> r"
    by - (rule exI [where x="\<lambda>i. g (i+k)"],simp)
  with wf_r show False
    by (simp add: wf_iff_no_infinite_down_chain)
qed

lemmas all_imp_to_ex = all_simps (5)
(*"!!P Q. (ALL x. P x --> Q) = ((EX x. P x) --> Q)"

 Avoid introduction of existential quantification of states on negative
 position.
*)


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Language_Composition
imports Strongly_Secure_Skip_Assign
begin

context Strongly_Secure_Programs
begin

theorem Compositionality_Seq:
  assumes relatedpart1: "[c1] \<approx>\<^bsub>d\<^esub> [c1']"
  assumes relatedpart2: "[c2] \<approx>\<^bsub>d\<^esub> [c2']"
  shows "[c1;c2] \<approx>\<^bsub>d\<^esub> [c1';c2']"
proof -
  define R0 where "R0 = {(S1,S2). \<exists>c1 c1' c2 c2' W W'.
    S1 = (c1;c2)#W \<and> S2 = (c1';c2')#W' \<and>
    [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> W \<approx>\<^bsub>d\<^esub> W'}"

  from relatedpart1 relatedpart2 trivialpair_in_USdB
  have inR0: "([c1;c2],[c1';c2']) \<in> R0"
    by (simp add: R0_def)

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
        from USdBsym
        show "sym R0"
          by (simp add: sym_def R0_def, fastforce)
      next
        fix S1 S2
        assume inR0: "(S1,S2) \<in> R0"
        with USdBeqlen show "length S1 = length S2"
          by (auto simp add: R0_def)
      next
        fix S1 S2 RS m1 m2 m1' i
        assume inR0: "(S1,S2) \<in> R0"
        assume irange: "i < length S1"
        assume S1step: "\<langle>S1!i,m1\<rangle> \<rightarrow> \<langle>RS,m2\<rangle>"
        assume dequal: "m1 =\<^bsub>d\<^esub> m1'"
        from inR0 obtain c1 c1' c2 c2' V V'
          where R0def': "S1 = (c1;c2)#V \<and> S2 = (c1';c2')#V' \<and>
          [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> V \<approx>\<^bsub>d\<^esub> V'"
          by (simp add: R0_def, force)

        with irange have case_distinction1:
          "i = 0 \<or> (V \<noteq> [] \<and> i \<noteq> 0)"
          by auto
        moreover
        have case1: "i = 0 \<Longrightarrow>
          \<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
             ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
          proof -
            assume i0: "i = 0"

              \<comment> \<open>get the two different sub-cases:\<close>
            with R0def' S1step obtain c3 W where case_distinction:
              "RS = [c2] \<and> \<langle>c1,m1\<rangle> \<rightarrow> \<langle>[],m2\<rangle>
              \<or> RS = (c3;c2)#W \<and> \<langle>c1,m1\<rangle> \<rightarrow> \<langle>c3#W,m2\<rangle>"
              by (simp, metis MWLfSteps_det_cases(3))
            moreover
              \<comment> \<open>Case 1: first command terminates\<close>
            {
              assume RSassump: "RS = [c2]"
              assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow> \<langle>[],m2\<rangle>"

              from USdBeqlen[of "[]"] StepAssump R0def'
                USdB_Strong_d_Bisimulation dequal
                strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i"
                "[c1]" "[c1']" "m1" "[]" "m2" "m1'"] i0
              obtain W' m2' where c1c1'reason:
                "\<langle>c1',m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> W' = []
                \<and> [] \<approx>\<^bsub>d\<^esub> W' \<and> m2 =\<^bsub>d\<^esub> m2'"
                by fastforce

              with c1c1'reason have conclpart:
                "\<langle>c1';c2',m1'\<rangle> \<rightarrow> \<langle>[c2'],m2'\<rangle> \<and> m2 =\<^bsub>d\<^esub> m2'"
                by (simp add: MWLfSteps_det.seq1)

              with RSassump R0def' i0 have case1_concl:
                "\<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                 ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
                by (simp, rule_tac x="[c2']" in exI, auto)
            }
            moreover
              \<comment> \<open>Case 2: first command does not terminate\<close>
            {
              assume RSassump: "RS = (c3;c2)#W"
              assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow> \<langle>c3#W,m2\<rangle>"

              from StepAssump R0def' USdB_Strong_d_Bisimulation dequal
                strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i" "[c1]" "[c1']" "m1"
                "c3#W" "m2" "m1'"] i0
              obtain V'' m2' where c1c1'reason:
                "\<langle>c1',m1'\<rangle> \<rightarrow> \<langle>V'',m2'\<rangle>
                \<and> (c3#W) \<approx>\<^bsub>d\<^esub> V'' \<and> m2 =\<^bsub>d\<^esub> m2'"
                by fastforce

              with USdBeqlen[of "c3#W" "V''"] obtain c3' W'
                where V''reason:
                "V'' = c3'#W' \<and> length W = length W'"
                by (cases V'', force, force)

              with c1c1'reason have conclpart1:
                "\<langle>c1';c2',m1'\<rangle> \<rightarrow> \<langle>(c3';c2')#W',m2'\<rangle> \<and> m2 =\<^bsub>d\<^esub> m2'"
                by (simp add: MWLfSteps_det.seq2)

              from V''reason c1c1'reason
                USdB_decomp_head_tail[of "c3" "W"]
                USdB_Strong_d_Bisimulation
              have c3aWinUSDB:
                "[c3] \<approx>\<^bsub>d\<^esub> [c3'] \<and> W \<approx>\<^bsub>d\<^esub> W'"
                by blast

              with R0def' have conclpart2:
                "((c3;c2)#W,(c3';c2')#W') \<in> R0"
                by (auto simp add: R0_def)

              with i0 RSassump R0def' V''reason conclpart1
              have case2_concl:
                "\<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
                by (rule_tac x="(c3';c2')#W'" in exI, auto)
            }
            ultimately
            show "\<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
               ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
              by blast
          qed
          moreover
          have case2: "\<lbrakk> V \<noteq> []; i \<noteq> 0 \<rbrakk>
            \<Longrightarrow> \<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
               ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
            proof -
              assume Vnonempt: "V \<noteq> []"
              assume inot0: "i \<noteq> 0"

              with Vnonempt irange R0def' have i1range:
                "(i-Suc 0) < length V"
                by simp

              from inot0 R0def' have S1ieq: "S1!i = V!(i-Suc 0)"
                by auto

              from inot0 R0def' have "S2!i = V'!(i-Suc 0)"
                by auto

              with S1ieq R0def' S1step i1range dequal
                USdB_Strong_d_Bisimulation
                strongdB_aux[of "d" "USdB d"
                "i-Suc 0" "V" "V'" "m1" "RS" "m2" "m1'"]
              show "\<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
                by force
            qed
          ultimately show "\<exists>RS' m2'. \<langle>S2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
           ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
            by auto
        qed

  hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
    by (rule Up_To_Technique)

  with inR0 show ?thesis
    by auto

qed

theorem Compositionality_Fork:
  fixes V::"('exp,'id) MWLfCom list"
  assumes relatedmain: "[c] \<approx>\<^bsub>d\<^esub> [c']"
  assumes relatedthreads: "V \<approx>\<^bsub>d\<^esub> V'"
  shows "[fork c V] \<approx>\<^bsub>d\<^esub> [fork c' V']"
proof -
  define R0 where "R0 = {(F1,F2). \<exists>c1 c1' W W'.
    F1 = [fork c1 W] \<and> F2 = [fork c1' W']
    \<and> [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> W \<approx>\<^bsub>d\<^esub> W'}"
  from relatedmain relatedthreads
  have inR0: "([fork c V],[fork c' V']) \<in> R0"
    by (simp add: R0_def)

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      from USdBsym show "sym R0"
        by (simp add: R0_def sym_def, auto)
    next
      fix F1 F2
      assume inR0: "(F1,F2) \<in> R0"
      with R0_def USdBeqlen show "length F1 = length F2"
        by auto
    next
      fix F1 F2 c1V m1 m2 m1' i
      assume inR0: "(F1,F2) \<in> R0"
      assume irange: "i < length F1"
      assume F1step: "\<langle>F1!i,m1\<rangle> \<rightarrow> \<langle>c1V,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR0 obtain c1 c1' V V'
        where R0def': "F1 = [fork c1 V] \<and> F2 = [fork c1' V'] \<and>
        [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> V \<approx>\<^bsub>d\<^esub> V'"
        by (simp add: R0_def, force)

      from irange R0def' F1step
      have rew: "c1V = c1#V \<and> m2 = m1"
        by (simp, metis MWLf_semantics.MWLfSteps_det_cases(6))

      from irange R0def' MWLfSteps_det.fork have F2step:
        "\<langle>F2!i,m1'\<rangle> \<rightarrow> \<langle>c1'#V',m1'\<rangle>"
        by force

      from R0def' USdB_comp_head_tail have conclpart:
         "((c1#V,c1'#V') \<in> R0 \<or> (c1#V) \<approx>\<^bsub>d\<^esub> (c1'#V'))"
        by auto

      with irange rew inR0 F1step dequal R0def' F2step
      show "\<exists>c1V' m2'. \<langle>F2!i,m1'\<rangle> \<rightarrow> \<langle>c1V',m2'\<rangle> \<and>
        ((c1V,c1V') \<in> R0 \<or> c1V \<approx>\<^bsub>d\<^esub> c1V') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by fastforce
    qed

  hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
    by (rule Up_To_Technique)

  with inR0 show ?thesis
    by auto

qed

theorem Compositionality_If:
  assumes dind_or_branchesrelated:
  "b \<equiv>\<^bsub>d\<^esub> b' \<or> [c1] \<approx>\<^bsub>d\<^esub> [c2] \<or> [c1'] \<approx>\<^bsub>d\<^esub> [c2']"
  assumes branch1related: "[c1] \<approx>\<^bsub>d\<^esub> [c1']"
  assumes branch2related: "[c2] \<approx>\<^bsub>d\<^esub> [c2']"
  shows "[if b then c1 else c2 fi] \<approx>\<^bsub>d\<^esub> [if b' then c1' else c2' fi]"
proof -
  define R1 where "R1 = {(I1,I2). \<exists>c1 c1' c2 c2' b b'.
    I1 = [if b then c1 else c2 fi] \<and> I2 = [if b' then c1' else c2' fi] \<and>
    [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  define R2 where "R2 = {(I1,I2). \<exists>c1 c1' c2 c2' b b'.
    I1 = [if b then c1 else c2 fi] \<and> I2 = [if b' then c1' else c2' fi] \<and>
    [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and>
    ([c1] \<approx>\<^bsub>d\<^esub> [c2] \<or> [c1'] \<approx>\<^bsub>d\<^esub> [c2'])}"

  define R0 where "R0 = R1 \<union> R2"

  from dind_or_branchesrelated branch1related branch2related
  have inR0: "([if b then c1 else c2 fi],[if b' then c1' else c2' fi]) \<in> R0"
    by (simp add: R0_def R1_def R2_def)

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
        from USdBsym d_indistinguishable_sym
        have symR1: "sym R1"
          by (simp add: sym_def R1_def, fastforce)
        from USdBsym
        have symR2: "sym R2"
          by (simp add: sym_def R2_def, fastforce)

        from symR1 symR2 show "sym R0"
          by (simp add: sym_def R0_def)
      next
        fix I1 I2
        assume inR0: "(I1,I2) \<in> R0"
        thus "length I1 = length I2"
          by (simp add: R0_def R1_def R2_def, auto)
      next
        fix I1 I2 RS m1 m1' m2 i
        assume inR0: "(I1,I2) \<in> R0"
        assume irange: "i < length I1"
        assume I1step: "\<langle>I1!i,m1\<rangle> \<rightarrow> \<langle>RS,m2\<rangle>"
        assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

        have inR1case: "(I1,I2) \<in> R1
          \<Longrightarrow> \<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
             ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
          proof -
            assume inR1: "(I1,I2) \<in> R1"

            then obtain c1 c1' c2 c2' b b' where R1def':
              "I1 = [if b then c1 else c2 fi]
              \<and> I2 = [if b' then c1' else c2' fi] \<and>
              [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by (simp add: R1_def, force)
            moreover
            \<comment> \<open>get the two different cases True and False from semantics:\<close>
            from irange R1def' I1step have case_distinction:
              "RS = [c1] \<and> BMap (E b m1) = True \<or>
              RS = [c2] \<and> BMap (E b m1) = False"
              by (simp, metis MWLf_semantics.MWLfSteps_det_cases(4))
            moreover
              \<comment> \<open>Case 1: b evaluates to True\<close>
            {
              assume bevalT: "BMap (E b m1) = True"
              assume RSassump: "RS = [c1]"
              from irange bevalT I1step R1def' RSassump have memeq:
                "m2 = m1"
                by (simp, metis MWLf_semantics.MWLfSteps_det_cases(4))

              from bevalT R1def' dequal have b'evalT:
                "BMap (E b' m1') = True"
                by (simp add: d_indistinguishable_def)

              hence I2step_case1:
                "\<langle>if b' then c1' else c2' fi,m1'\<rangle> \<rightarrow> \<langle>[c1'],m1'\<rangle>"
                by (simp add: MWLfSteps_det.iftrue)

              with irange dequal RSassump memeq R1def'
              have case1_concl:
                "\<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
                by auto
            }
            moreover
              \<comment> \<open>Case 2: b evaluates to False\<close>
            {
              assume bevalF: "BMap (E b m1) = False"
              assume RSassump: "RS = [c2]"
              from irange bevalF I1step R1def' RSassump have memeq:
                "m1 = m2"
                by (simp, metis MWLf_semantics.MWLfSteps_det_cases(4))

              from bevalF R1def' dequal have b'evalF:
                "BMap (E b' m1') = False"
                by (simp add: d_indistinguishable_def)

              hence I2step_case1:
                "\<langle>if b' then c1' else c2' fi,m1'\<rangle> \<rightarrow> \<langle>[c2'],m1'\<rangle>"
                by (simp add: MWLfSteps_det.iffalse)

              with irange dequal RSassump memeq R1def'
              have case1_concl:
                "\<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
                by auto
            }
            ultimately show
              "\<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
               ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
              by auto
          qed

        have inR2case: "(I1,I2) \<in> R2
          \<Longrightarrow> \<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
             ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
          proof -
            assume inR2: "(I1,I2) \<in> R2"
            then obtain c1 c1' c2 c2' b b' where R2def':
              "I1 = [if b then c1 else c2 fi]
              \<and> I2 = [if b' then c1' else c2' fi] \<and>
              [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and>
              ([c1] \<approx>\<^bsub>d \<^esub>[c2] \<or> [c1'] \<approx>\<^bsub>d\<^esub> [c2'])"
              by (simp add: R2_def, force)
            moreover
              \<comment> \<open>get the two different cases for the result from semantics:\<close>
            from irange R2def' I1step have case_distinction_left:
              "(RS = [c1] \<or> RS = [c2]) \<and> m2 = m1"
              by (simp, metis MWLf_semantics.MWLfSteps_det_cases(4))
            moreover
            from irange R2def' dequal obtain RS' where I2step:
              "\<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m1'\<rangle>
              \<and> (RS' = [c1'] \<or> RS' = [c2']) \<and> m1 =\<^bsub>d\<^esub> m1'"
              by (simp, metis MWLfSteps_det.iffalse MWLfSteps_det.iftrue)
            moreover
            from USdBtrans have "\<lbrakk> [c1] \<approx>\<^bsub>d\<^esub> [c2]; [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<rbrakk>
              \<Longrightarrow> [c1] \<approx>\<^bsub>d\<^esub> [c2']"
              by (unfold trans_def, blast)
            moreover
            from USdBtrans have "\<lbrakk> [c1] \<approx>\<^bsub>d\<^esub> [c1']; [c1'] \<approx>\<^bsub>d\<^esub> [c2'] \<rbrakk>
              \<Longrightarrow> [c1] \<approx>\<^bsub>d\<^esub> [c2']"
              by (unfold trans_def, blast)
            moreover
            from USdBsym have "[c1] \<approx>\<^bsub>d\<^esub> [c2] \<Longrightarrow> [c2] \<approx>\<^bsub>d\<^esub> [c1]"
              by (simp add: sym_def)
            moreover
            from USdBtrans have "\<lbrakk> [c2] \<approx>\<^bsub>d\<^esub> [c1]; [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<rbrakk>
              \<Longrightarrow> [c2] \<approx>\<^bsub>d\<^esub> [c1']"
              by (unfold trans_def, blast)
            moreover
            from USdBsym have "[c1'] \<approx>\<^bsub>d\<^esub> [c2'] \<Longrightarrow> [c2'] \<approx>\<^bsub>d\<^esub> [c1']"
              by (simp add: sym_def)
            moreover
            from USdBtrans have "\<lbrakk> [c2] \<approx>\<^bsub>d\<^esub> [c2']; [c2'] \<approx>\<^bsub>d\<^esub> [c1'] \<rbrakk>
              \<Longrightarrow> [c2] \<approx>\<^bsub>d\<^esub> [c1']"
              by (unfold trans_def, blast)
            ultimately show
             "\<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
              ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
              by auto
          qed

        from inR0 inR1case inR2case show
          "\<exists>RS' m2'. \<langle>I2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
          ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
          by (auto simp add: R0_def)
        qed

  hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
    by (rule Up_To_Technique)

  with inR0 show ?thesis
    by auto

qed

theorem Compositionality_While:
  assumes dind: "b \<equiv>\<^bsub>d\<^esub> b'"
  assumes bodyrelated: "[c] \<approx>\<^bsub>d\<^esub> [c']"
  shows "[while b do c od] \<approx>\<^bsub>d\<^esub> [while b' do c' od]"
proof -
  define R1 where "R1 = {(S1,S2). \<exists>c1 c1' c2 c2' b b' W W'.
    S1 = (c1;(while b do c2 od))#W \<and>
    S2 = (c1';(while b' do c2' od))#W' \<and>
    [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> W \<approx>\<^bsub>d\<^esub> W' \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  define R2 where "R2 = {(W1,W2). \<exists>c1 c1' b b'.
    W1 = [while b do c1 od] \<and> W2 = [while b' do c1' od] \<and>
    [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  define R0 where "R0 = R1 \<union> R2"

  from dind bodyrelated
  have inR0: "([while b do c od],[while b' do c' od]) \<in> R0"
    by (simp add: R0_def R1_def R2_def)

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
        from USdBsym d_indistinguishable_sym have symR1: "sym R1"
          by (simp add: sym_def R1_def, fastforce)
        from USdBsym d_indistinguishable_sym have symR2: "sym R2"
          by (simp add: sym_def R2_def, fastforce)
        from symR1 symR2 show "sym R0"
          by (simp add: sym_def R0_def)
      next
        fix W1 W2
        assume inR0: "(W1,W2) \<in> R0"
        with USdBeqlen show "length W1 = length W2"
          by (simp add: R0_def R1_def R2_def, force)
      next
        fix W1 W2 i m1 m1' RS m2
        assume inR0: "(W1,W2) \<in> R0"
        assume irange: "i < length W1"
        assume W1step: "\<langle>W1!i,m1\<rangle> \<rightarrow> \<langle>RS,m2\<rangle>"
        assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

        from inR0 show "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
          ((RS,RS') \<in> R0 \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
          proof (simp add: R0_def, auto)
            assume inR1: "(W1,W2) \<in> R1"

            then obtain c1 c1' c2 c2' b b' V V'
              where R1def': "W1 = (c1;(while b do c2 od))#V
              \<and> W2 = (c1';(while b' do c2' od))#V' \<and>
              [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> [c2] \<approx>\<^bsub>d\<^esub> [c2'] \<and> V \<approx>\<^bsub>d\<^esub> V' \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by (simp add: R1_def, force)

            with irange have case_distinction1: "i = 0 \<or>
              (V \<noteq> [] \<and> i \<noteq> 0)"
              by auto
            moreover
            have case1: "i = 0 \<Longrightarrow>
              \<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
              ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
              \<and> m2 =\<^bsub>d\<^esub> m2'"
              proof -
                assume i0: "i = 0"
                  \<comment> \<open>get the two different sub-cases:\<close>
                with R1def' W1step obtain c3 W where case_distinction:
                  "RS = [while b do c2 od] \<and> \<langle>c1,m1\<rangle> \<rightarrow> \<langle>[],m2\<rangle>
                  \<or> RS = (c3;(while b do c2 od))#W \<and> \<langle>c1,m1\<rangle> \<rightarrow> \<langle>c3#W,m2\<rangle>"
                  by (simp, metis MWLfSteps_det_cases(3))
                moreover
                  \<comment> \<open>Case 1: first command terminates\<close>
                {
                  assume RSassump: "RS = [while b do c2 od]"
                  assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow> \<langle>[],m2\<rangle>"

                  from USdBeqlen[of "[]"] StepAssump R1def'
                    USdB_Strong_d_Bisimulation dequal
                    strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i"
                    "[c1]" "[c1']" "m1" "[]" "m2" "m1'"] i0
                  obtain W' m2' where c1c1'reason:
                    "\<langle>c1',m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> W' = []
                    \<and> [] \<approx>\<^bsub>d\<^esub> W' \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by fastforce

                  with c1c1'reason have conclpart1:
                    "\<langle>c1';(while b' do c2' od),m1'\<rangle>
                    \<rightarrow> \<langle>[while b' do c2' od],m2'\<rangle> \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by (simp add: MWLfSteps_det.seq1)

                  from R1def' have conclpart2:
                    "([while b do c2 od],[while b' do c2' od]) \<in> R2"
                    by (simp add: R2_def)

                  with conclpart1 RSassump i0 R1def'
                  have case1_concl:
                    "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                    ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                    \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by auto
                }
                moreover
                  \<comment> \<open>Case 2: first command does not terminate\<close>
                {
                  assume RSassump: "RS = (c3;(while b do c2 od))#W"
                  assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow> \<langle>c3#W,m2\<rangle>"

                  from StepAssump R1def' USdB_Strong_d_Bisimulation dequal
                    strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i"
                    "[c1]" "[c1']" "m1" "c3#W" "m2" "m1'"] i0
                  obtain V'' m2' where c1c1'reason:
                    "\<langle>c1',m1'\<rangle> \<rightarrow> \<langle>V'',m2'\<rangle>
                    \<and> (c3#W) \<approx>\<^bsub>d\<^esub> V'' \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by fastforce

                  with USdBeqlen[of "c3#W" "V''"] obtain c3' W'
                    where V''reason: "V'' = c3'#W'"
                    by (cases V'', force, force)

                  with c1c1'reason have conclpart1:
                    "\<langle>c1';(while b' do c2' od),m1'\<rangle> \<rightarrow>
                    \<langle>(c3';(while b' do c2' od))#W',m2'\<rangle>
                    \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by (simp add: MWLfSteps_det.seq2)

                  from V''reason
                    c1c1'reason USdB_decomp_head_tail[of "c3" "W"]
                    USdB_Strong_d_Bisimulation
                  have c3aWinUSDB:
                    "[c3] \<approx>\<^bsub>d\<^esub> [c3'] \<and> W \<approx>\<^bsub>d\<^esub> W'"
                    by blast

                  with R1def' have conclpart2:
                    "((c3;(while b do c2 od))#W,
                       (c3';(while b' do c2' od))#W') \<in> R1"
                    by (simp add: R1_def)

                  with i0 RSassump R1def' V''reason conclpart1
                  have case2_concl:
                    "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                    ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                    \<and> m2 =\<^bsub>d\<^esub> m2'"
                    by auto
                }
                ultimately
                show "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                  ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                  \<and> m2 =\<^bsub>d\<^esub> m2'"
                  by blast
              qed
              moreover
              have case2: "\<lbrakk> V \<noteq> []; i \<noteq> 0 \<rbrakk>
                \<Longrightarrow> \<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                \<and> m2 =\<^bsub>d\<^esub> m2'"
              proof -
                assume Vnonempt: "V \<noteq> []"
                assume inot0: "i \<noteq> 0"

                with Vnonempt irange R1def' have i1range:
                  "(i-Suc 0) < length V"
                  by simp

                from inot0 R1def' have W1ieq: "W1!i = V!(i-Suc 0)"
                  by auto

                from inot0 R1def' have "W2!i = V'!(i-Suc 0)"
                  by auto

                with W1ieq R1def' W1step i1range dequal
                  USdB_Strong_d_Bisimulation
                  strongdB_aux[of "d" "USdB d"
                  "i-Suc 0" "V" "V'" "m1" "RS" "m2" "m1'"]
                show "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                  ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                  \<and> m2 =\<^bsub>d\<^esub> m2'"
                  by force
              qed
              ultimately show "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                \<and> m2 =\<^bsub>d\<^esub> m2'"
                by auto
            next
              assume inR2: "(W1,W2) \<in> R2"

              then obtain c1 c1' b b' where R2def':
                "W1 = [while b do c1 od] \<and> W2 = [while b' do c1' od] \<and>
                [c1] \<approx>\<^bsub>d\<^esub> [c1'] \<and> b \<equiv>\<^bsub>d\<^esub> b'"
                by (auto simp add: R2_def)
                \<comment> \<open>get the two different cases:\<close>
              moreover
              from irange R2def' W1step have case_distinction:
                "RS = [c1;(while b do c1 od)] \<and> BMap (E b m1) = True \<or>
                RS = [] \<and> BMap (E b m1) = False"
                by (simp,metis MWLf_semantics.MWLfSteps_det_cases(5))
              moreover
                \<comment> \<open>Case 1: b evaluates to True\<close>
              {
                assume bevalT: "BMap (E b m1)"
                assume RSassump: "RS = [c1;(while b do c1 od)]"
                from irange bevalT W1step R2def' RSassump have memeq:
                  "m2 = m1"
                  by (simp,metis MWLf_semantics.MWLfSteps_det_cases(5))

                from bevalT R2def' dequal have b'evalT: "BMap (E b' m1')"
                  by (simp add: d_indistinguishable_def)

                hence W2step_case1:
                  "\<langle>while b' do c1' od,m1'\<rangle>
                    \<rightarrow> \<langle>[c1';(while b' do c1' od)],m1'\<rangle>"
                  by (simp add: MWLfSteps_det.whiletrue)

                from trivialpair_in_USdB R2def' have inWR2:
                  "([c1;(while b do c1 od)],
                     [c1';(while b' do c1' od)]) \<in> R1"
                  by (auto simp add: R1_def)

                with irange dequal RSassump memeq W2step_case1 R2def'
                have case1_concl:
                  "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                  ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                  \<and> m2 =\<^bsub>d\<^esub> m2'"
                  by auto
              }
              moreover
                \<comment> \<open>Case 2: b evaluates to False\<close>
              {
                assume bevalF: "BMap (E b m1) = False"
                assume RSassump: "RS = []"
                from irange bevalF W1step R2def' RSassump have memeq:
                  "m2 = m1"
                  by (simp,metis MWLf_semantics.MWLfSteps_det_cases(5))

                from bevalF R2def' dequal have b'equalF:
                  "BMap (E b' m1') = False"
                  by (simp add: d_indistinguishable_def)

                hence W2step_case2:
                  "\<langle>while b' do c1' od,m1'\<rangle> \<rightarrow> \<langle>[],m1'\<rangle>"
                  by (simp add: MWLfSteps_det.whilefalse)

                with trivialpair_in_USdB irange dequal RSassump
                  memeq R2def'
                have case1_concl:
                  "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                  ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                  \<and> m2 =\<^bsub>d\<^esub> m2'"
                  by force
              }
              ultimately
              show "\<exists>RS' m2'. \<langle>W2!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
                ((RS,RS') \<in> R1 \<or> (RS,RS') \<in> R2 \<or> RS \<approx>\<^bsub>d\<^esub> RS')
                \<and> m2 =\<^bsub>d\<^esub> m2'"
                by auto
            qed
          qed

  hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
    by (rule Up_To_Technique)

  with inR0 show ?thesis
    by auto

qed

end

end


theory Common_Primitive_Matcher_Generic
imports "../Semantics_Ternary/Semantics_Ternary"
        Common_Primitive_Syntax
        "../Semantics_Ternary/Unknown_Match_Tacs"
begin

subsection\<open>A Generic primitive matcher: Agnostic of IP Addresses\<close>

text\<open>Generalized Definition agnostic of IP Addresses fro IPv4 and IPv6\<close>

(*generic assumptions for a common matcher without information about IPs.
  used to add ipv6 integration without duplicating all proofs *)
locale primitive_matcher_generic =
  fixes \<beta> :: "('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
  assumes IIface: "\<forall> p i. \<beta> (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))"
      and OIface: "\<forall> p i. \<beta> (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))"
        and Prot: "\<forall> p proto. \<beta> (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))"
   and Src_Ports: "\<forall> p proto ps. \<beta> (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_sport p \<in> ports_to_set ps)"
   and Dst_Ports: "\<forall> p proto ps. \<beta> (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_dport p \<in> ports_to_set ps)"
   \<comment> \<open>-m multiport --ports matches source or destination port\<close>
   and MultiportsPorts: "\<forall> p proto ps. \<beta> (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> (p_sport p \<in> ports_to_set ps \<or> p_dport p \<in> ports_to_set ps))"
    and L4_Flags: "\<forall> p flags. \<beta> (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))"
    and CT_State: "\<forall> p S. \<beta> (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))"
        and Extra: "\<forall> p str. \<beta> (Extra str) p = TernaryUnknown"
begin
  lemma Iface_single:
    "matches (\<beta>, \<alpha>) (Match (IIface X)) a p \<longleftrightarrow> match_iface X (p_iiface p)"
    "matches (\<beta>, \<alpha>) (Match (OIface X)) a p \<longleftrightarrow> match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  text\<open>Since matching on the iface cannot be @{const TernaryUnknown}*, we can pull out negations.\<close>
  lemma Iface_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (IIface X))) a p \<longleftrightarrow> \<not> match_iface X (p_iiface p)"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (OIface X))) a p \<longleftrightarrow> \<not> match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface matches_case_ternaryvalue_tuple bool_to_ternary_simps
          split: ternaryvalue.split)

  lemma Prot_single:
    "matches (\<beta>, \<alpha>) (Match (Prot X)) a p \<longleftrightarrow> match_proto X (p_proto p)"
     by(simp add: Prot match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
  lemma Prot_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Prot X))) a p \<longleftrightarrow> \<not> match_proto X (p_proto p)"
     by(simp add: Prot matches_case_ternaryvalue_tuple bool_to_ternary_simps split: ternaryvalue.split)

  lemma Ports_single:
    "matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto ps))) a p \<longleftrightarrow> proto = p_proto p \<and> p_sport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto ps))) a p \<longleftrightarrow> proto = p_proto p \<and> p_dport p \<in> ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  lemma Ports_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p \<longleftrightarrow> proto \<noteq> p_proto p \<or> p_sport p \<notin> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p \<longleftrightarrow> proto \<noteq> p_proto p \<or> p_dport p \<notin> ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports matches_case_ternaryvalue_tuple bool_to_ternary_simps
               split: ternaryvalue.split)

  text\<open>Ports are dependent matches. They always match on the protocol too\<close>
  lemma Ports_single_rewrite_Prot:
    "matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto ps))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Prot (Proto proto))) a p \<and> p_sport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchNot (Match (Prot (Proto proto)))) a p \<or> p_sport p \<notin> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto ps))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Prot (Proto proto))) a p \<and> p_dport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchNot (Match (Prot (Proto proto)))) a p \<or> p_dport p \<notin> ports_to_set ps"
  by(auto simp add: Ports_single_not Ports_single Prot_single_not Prot_single)

  lemma multiports_disjuction:
        "(\<exists>rg\<in>set spts. matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto [rg]))) a p) \<longleftrightarrow> matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto spts))) a p"
        "(\<exists>rg\<in>set dpts. matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto [rg]))) a p) \<longleftrightarrow> matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto dpts))) a p"
    by(auto simp add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps ports_to_set
                   split: ternaryvalue.split)

  lemma MultiportPorts_single_rewrite:
    "matches (\<beta>, \<alpha>) (Match (MultiportPorts ports)) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Src_Ports ports)) a p \<or> matches (\<beta>, \<alpha>) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    apply(simp add: Ports_single)
    by(simp add: MultiportsPorts match_raw_ternary bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_rewrite_MatchOr:
    "matches (\<beta>, \<alpha>) (Match (MultiportPorts ports)) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchOr (Match (Src_Ports ports)) (Match (Dst_Ports ports))) a p"
    apply(cases ports)
    by(simp add: MatchOr MultiportPorts_single_rewrite)

  lemma MultiportPorts_single_not_rewrite_MatchAnd:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (MultiportPorts ports))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchAnd (MatchNot (Match (Src_Ports ports))) (MatchNot (Match (Dst_Ports ports)))) a p"
    apply(cases ports)
    apply(simp add: Ports_single_not bunch_of_lemmata_about_matches)
    by(simp add: MultiportsPorts matches_case_ternaryvalue_tuple bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_not_rewrite:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (MultiportPorts ports))) a p \<longleftrightarrow>
      \<not> matches (\<beta>, \<alpha>) (Match (Src_Ports ports)) a p \<and> \<not> matches (\<beta>, \<alpha>) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    by(simp add: MultiportPorts_single_not_rewrite_MatchAnd bunch_of_lemmata_about_matches
                 Ports_single_not Ports_single)

  lemma Extra_single:
    "matches (\<beta>, \<alpha>) (Match (Extra str)) a p \<longleftrightarrow> \<alpha> a p"
     by(simp add: Extra match_raw_ternary)
  lemma Extra_single_not:  \<comment> \<open>ternary logic, @{text "\<not> unknown = unknown"}\<close>
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Extra str))) a p \<longleftrightarrow> \<alpha> a p"
     by(simp add: Extra matches_case_ternaryvalue_tuple)
end

subsection\<open>Basic optimisations\<close>

  (*this is currently not used.*)
  text\<open>Compress many @{const Extra} expressions to one expression.\<close>
  fun compress_extra :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "compress_extra (Match x) = Match x" |
    "compress_extra (MatchNot (Match (Extra e))) = Match (Extra (''NOT (''@e@'')''))" |
    "compress_extra (MatchNot m) = (MatchNot (compress_extra m))" |
    (*"compress_extra (MatchAnd (Match (Extra e1)) (Match (Extra e2))) = compress_extra (Match (Extra (e1@'' ''@e2)))" |*)
    (*"compress_extra (MatchAnd (Match (Extra e1)) MatchAny) = Match (Extra e1)" |*)
    "compress_extra (MatchAnd (Match (Extra e1)) m2) = (case compress_extra m2 of Match (Extra e2) \<Rightarrow> Match (Extra (e1@'' ''@e2)) | MatchAny \<Rightarrow> Match (Extra e1) | m2' \<Rightarrow> MatchAnd (Match (Extra e1)) m2')" |
    "compress_extra (MatchAnd m1 m2) = MatchAnd (compress_extra m1) (compress_extra m2)" |
    (*"compress_extra (MatchAnd m1 m2) = (case (compress_extra m1, compress_extra m2) of
          (Match (Extra e1), Match (Extra e2)) \<Rightarrow> Match (Extra (e1@'' ''@e2))
        | (Match (Extra e1), MatchAny) \<Rightarrow> Match (Extra e1)
        | (MatchAny, Match (Extra e2)) \<Rightarrow> Match (Extra e2)
        | (m1', m2') \<Rightarrow> MatchAnd m1' m2')" |*)
    "compress_extra MatchAny = MatchAny"

  thm compress_extra.simps

  value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (Match (Extra ''bar'')))"
  value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (MatchNot (Match (Extra ''bar''))))"
  value [nbe] "compress_extra (MatchAnd (Match (Extra ''-m'')) (MatchAnd (Match (Extra ''addrtype'')) (MatchAnd (Match (Extra ''--dst-type'')) (MatchAnd (Match (Extra ''BROADCAST'')) MatchAny))))"

  lemma compress_extra_correct_matchexpr:
    fixes \<beta>::"('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic \<beta>"
    shows "matches (\<beta>, \<alpha>) m = matches (\<beta>, \<alpha>) (compress_extra m)"
    proof(simp add: fun_eq_iff, clarify, rename_tac a p)
      fix a and p :: "('i, 'a) tagged_packet_scheme"
      from generic have "\<beta> (Extra e) p = TernaryUnknown" for e by(simp add: primitive_matcher_generic.Extra)
      hence "ternary_ternary_eval (map_match_tac \<beta> p m) = ternary_ternary_eval (map_match_tac \<beta> p (compress_extra m))"
        proof(induction m rule: compress_extra.induct)
        case 4 thus ?case
          by(simp_all split: match_expr.split match_expr.split_asm common_primitive.split)
        qed (simp_all)
      thus "matches (\<beta>, \<alpha>) m a p = matches (\<beta>, \<alpha>) (compress_extra m) a p"
        by(rule matches_iff_apply_f)
      qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory AbstractArrays
imports
  "../lib/TypHeapLib"
  "../lib/$L4V_ARCH/WordSetup"
begin

(*
 * Return a list of addresses that contain an element for an array at location
 * "p" of length "n".
 *)
primrec
  array_addrs :: "('a::mem_type) ptr \<Rightarrow> nat \<Rightarrow> 'a ptr list"
where
  "array_addrs _ 0 = []"
| "array_addrs p (Suc n) = p # (array_addrs (p +\<^sub>p 1) n)"

declare array_addrs.simps(2) [simp del]

(* The first element is in the array if the array has non-zero length. *)
lemma hd_in_array_addrs [simp]:
  "(x \<in> set (array_addrs x n)) = (n > 0)"
  by (case_tac n, auto simp: array_addrs.simps(2))

lemma array_addrs_1 [simp]:
  "array_addrs p (Suc 0) = [p]"
  "array_addrs p 1 = [p]"
  by (auto simp: array_addrs.simps(2))

(* All array elements are aligned if the array itself is aligned. *)
lemma array_addrs_ptr_aligned:
     "\<lbrakk> x \<in> set (array_addrs p n); ptr_aligned p \<rbrakk> \<Longrightarrow> ptr_aligned x"
  apply (induct n arbitrary: x p)
   apply clarsimp
  apply (clarsimp simp: array_addrs.simps(2))
  apply (erule disjE)
   apply clarsimp
  apply atomize
  apply (drule_tac x=x in spec)
  apply (drule_tac x="p +\<^sub>p 1" in spec)
  apply (clarsimp simp: ptr_aligned_plus)
  done

(* Split off the last element in an array. *)
lemma set_array_addrs_unfold_last:
  shows "set (array_addrs a (Suc n)) = set (array_addrs a n) \<union> {(a :: ('a::mem_type) ptr) +\<^sub>p int n}"
    (is "?LHS a n = ?RHS a n")
proof (induct n arbitrary: a)
  fix a
  show "?LHS a 0 = ?RHS a 0"
    by clarsimp
next
  fix a n
  assume induct: "\<And>a. ?LHS a n = ?RHS a n"
  show "?LHS a (Suc n) = ?RHS a (Suc n)"
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (subst induct [where a="a +\<^sub>p 1"])
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (clarsimp simp: CTypesDefs.ptr_add_def field_simps insert_commute)
  done
qed

(* Alternative representation of the set of array elements. *)
lemma set_array_addrs:
  "set (array_addrs (p :: ('a::mem_type) ptr) n)
           = {x. \<exists>k. x = p +\<^sub>p int k \<and> k < n }"
  apply (induct n arbitrary: p)
   apply (clarsimp simp: not_less)
  apply (subst set_array_addrs_unfold_last)
  apply atomize
  apply (drule_tac x=p in spec)
  apply (erule ssubst)
  apply (rule set_eqI)
  apply (rule iffI)
   apply clarsimp
   apply (erule disjE)
    apply clarsimp
    apply force
   apply force
  apply clarsimp
  apply (drule_tac x=k in spec)
  apply (clarsimp simp: not_less)
  apply (subgoal_tac "k = n")
   apply clarsimp
  apply clarsimp
  done

end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Instantiation of words (the isabelle type) whose size in bits is a
    multiple of 8 to the mem_type class.
*)

theory WordTypes
imports MemTypes WordsARM
begin

lemma arm_same_addr_spaces [simp]:
  "addr_space_size = memory_size"
  by (simp add: addr_space_size memory_size)

instantiation "word" :: (word_len_8_16_32) mem_type
begin

definition
  "to_bytes_word \<equiv> machine_w2b"
definition
  "from_bytes_word \<equiv> machine_b2w"
definition
  size_of_word :: "'a word itself \<Rightarrow> nat" where
  "size_of_word x \<equiv> size (undefined::'a word) div 8"
definition
  align_of_word :: "'a word itself \<Rightarrow> nat" where
  "align_of_word \<equiv> size_of"
definition
  type_tag_word :: "'a word itself \<Rightarrow> type_tag" where
  "type_tag_word x \<equiv> ''word'' @ replicate (size_of x) (CHR ''1'')"
  (*XXX: picked up the sizing hack from Harvey, don't feel like playing with strings*)

lemma len_dvd: "\<lbrakk> len_of TYPE('a) = y ; x dvd y \<rbrakk> \<Longrightarrow> x dvd len_of TYPE('a)"
  by (erule dvdE, simp)

lemma dvd8: "8 dvd len_of TYPE('a)"
  by (insert word_len_8_16_32, auto intro: len_dvd)

lemma div8_same: "(7 + len_of TYPE('a)) div 8 = len_of TYPE('a) div 8"
proof -
  from dvd8 show ?thesis by - (erule dvdE, simp)
qed

lemma some_bytes: "0 < len_of TYPE('a) div 8"
proof -
  have "0 < len_of TYPE('a)" by simp
  with dvd8 show ?thesis by - (erule dvdE, simp)
qed

lemma max_length:
  "len_of TYPE('a) div 8 < memory_size"
  using word_len_8_16_32 [where 'a='a]
  by (auto simp: memory_size)

lemma size_dvd_memory:
  "len_of TYPE('a) div 8 dvd memory_size"
  using word_len_8_16_32 [where 'a='a]
  by (auto simp: memory_size)

lemma w2b_b2w_id:
  "\<lbrakk> length bs = (len_of TYPE('a)) div 8 \<rbrakk>
   \<Longrightarrow>  machine_w2b ((machine_b2w bs)::'a word) = bs"
  using word_len_8_16_32 [where 'a='a]
  by (auto simp: machine_b2w_def machine_w2b_def
                 word_rsplit_rcat_size word_size)

lemma restorable_word:
  "length bs = size_of TYPE('a word)
   \<Longrightarrow> to_bytes ((from_bytes bs)::('a word)) = bs"
  using word_len_8_16_32 [where 'a='a]
  by (auto simp: to_bytes_word_def from_bytes_word_def w2b_b2w_id
                 size_of_word_def word_size)

instance
  using restorable_word
  by (intro_classes)
     (auto simp: to_bytes_word_def from_bytes_word_def size_of_word_def
                    align_of_word_def
                    machine_b2w_def machine_w2b_def
                    word_rcat_rsplit length_word_rsplit_exp_size' word_size
                    div8_same some_bytes max_length size_dvd_memory)
end

text \<open>Size simplifications\<close>

lemma size_of_8 [simp]: "size_of TYPE(8 word) = 1"
  by (auto simp: size_of_word_def word_size)

lemma size_of_16 [simp]: "size_of TYPE(16 word) = 2"
  by (auto simp: size_of_word_def word_size)

lemma size_of_32 [simp]: "size_of TYPE(32 word) = 4"
  by (auto simp: size_of_word_def word_size)

declare align_of_word_def [simp]

text \<open>Simple tests checking little-endianess\<close>

lemma "to_bytes (0xAA :: byte) = [0xAA]"
  by (simp add: to_bytes_word_def machine_w2b_def)

lemma "to_bytes (0xEEAA :: 16 word) = [0xAA,0xEE]"
  by (simp add: to_bytes_word_def machine_w2b_def)

lemma "to_bytes (0xFFDDEEAA :: 32 word) = [0xAA,0xEE,0xDD,0xFF]"
  by (simp add: to_bytes_word_def machine_w2b_def)

end


section \<open>\isaheader{Generic Map Algorithms}\<close>
theory Gen_Map
imports "../Intf/Intf_Map" "../../Iterator/Iterator"
begin
  lemma map_to_set_distinct_conv:
    assumes "distinct tsl'" and "map_to_set m' = set tsl'"
    shows "distinct (map fst tsl')"
    apply (rule ccontr)
    apply (drule not_distinct_decomp)
    using assms
    apply (clarsimp elim!: map_eq_appendE)
    by (metis (opaque_lifting, no_types) insert_iff map_to_set_inj)

  (* TODO: Make foldli explicit, such that it is seen by
  iterator-optimizations! cf Gen_Set for how to do this! *)
  lemma foldli_add: "det_fold_map X
    (\<lambda>_. True) (\<lambda>(k,v) m. op_map_update k v m) m ((++) m)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      apply (induct l arbitrary: m)
      apply (auto simp: map_of_distinct_upd[symmetric])
      done
  qed

  definition gen_add
    :: "('s2 \<Rightarrow> _) \<Rightarrow> ('k \<Rightarrow> 'v \<Rightarrow> 's1 \<Rightarrow> 's1) \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> 's1"
    where
    "gen_add it upd A B \<equiv> it B (\<lambda>_. True) (\<lambda>(k,v) m. upd k v m) A"

  lemma gen_add[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes UPD: "GEN_OP ins op_map_update (Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>Rs1\<rightarrow>\<langle>Rk,Rv\<rangle>Rs1)"
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs2 tsl)"
    shows "(gen_add (foldli o tsl) ins,(++))
      \<in> (\<langle>Rk,Rv\<rangle>Rs1) \<rightarrow> (\<langle>Rk,Rv\<rangle>Rs2) \<rightarrow> (\<langle>Rk,Rv\<rangle>Rs1)"
    apply (intro fun_relI)
    unfolding gen_add_def comp_def
    apply (rule det_fold_map[OF foldli_add IT[unfolded autoref_tag_defs]])
    apply (parametricity add: UPD[unfolded autoref_tag_defs])+
    done

  lemma foldli_restrict: "det_fold_map X (\<lambda>_. True)
    (\<lambda>(k,v) m. if P (k,v) then op_map_update k v m else m) Map.empty
      (op_map_restrict P )" (is "det_fold_map _ _ ?f _ _")
  proof -
    {
      fix l m
      have "distinct (map fst l) \<Longrightarrow>
        foldli l (\<lambda>_. True) ?f m = m ++ op_map_restrict P (map_of l)"
      proof (induction l arbitrary: m)
        case Nil thus ?case by simp
      next
        case (Cons kv l)
        obtain k v where [simp]: "kv = (k,v)" by fastforce
        from Cons.prems have
          DL: "distinct (map fst l)" and KNI: "k \<notin> set (map fst l)"
          by auto

        show ?case proof (cases "P (k,v)")
          case [simp]: True
          have "foldli (kv#l) (\<lambda>_. True) ?f m = foldli l (\<lambda>_. True) ?f (m(k\<mapsto>v))"
            by simp
          also from Cons.IH[OF DL] have
            "\<dots> = m(k\<mapsto>v) ++ op_map_restrict P (map_of l)" .
          also have "\<dots> = m ++ op_map_restrict P (map_of (kv#l))"
            using KNI
            by (auto
              split: option.splits
              intro!: ext
              simp: Map.restrict_map_def Map.map_add_def
              simp: map_of_eq_None_iff[symmetric])
          finally show ?thesis .
        next
          case [simp]: False
          have "foldli (kv#l) (\<lambda>_. True) ?f m = foldli l (\<lambda>_. True) ?f m"
            by simp
          also from Cons.IH[OF DL] have
            "\<dots> = m ++ op_map_restrict P (map_of l)" .
          also have "\<dots> = m ++ op_map_restrict P (map_of (kv#l))"
            using KNI
            by (auto
              intro!: ext
              simp: Map.restrict_map_def Map.map_add_def
              simp: map_of_eq_None_iff[symmetric]
            )
          finally show ?thesis .
        qed
      qed
    }
    from this[of _ Map.empty] show ?thesis
      by (auto intro!: det_fold_mapI)
  qed

  definition gen_restrict :: "('s1 \<Rightarrow> _) \<Rightarrow> _"
    where "gen_restrict it upd emp P m
    \<equiv> it m (\<lambda>_. True) (\<lambda>(k,v) m. if P (k,v) then upd k v m else m) emp"

  lemma gen_restrict[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs1 tsl)"
    assumes INS:
      "GEN_OP upd op_map_update (Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>Rs2\<rightarrow>\<langle>Rk,Rv\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP emp Map.empty (\<langle>Rk,Rv\<rangle>Rs2)"
    shows "(gen_restrict (foldli o tsl) upd emp,op_map_restrict)
    \<in> (\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> Id) \<rightarrow> (\<langle>Rk,Rv\<rangle>Rs1) \<rightarrow> (\<langle>Rk,Rv\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_restrict_def comp_def
    apply (rule det_fold_map[OF foldli_restrict IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma fold_map_of:
    "fold (\<lambda>(k,v) s. op_map_update k v s) (rev l) Map.empty = map_of l"
  proof -
    {
      fix m
      have "fold (\<lambda>(k,v) s. s(k\<mapsto>v)) (rev l) m = m ++ map_of l"
        apply (induct l arbitrary: m)
        apply auto
        done
    } thus ?thesis by simp
  qed

  definition gen_map_of :: "'m \<Rightarrow> ('k\<Rightarrow>'v\<Rightarrow>'m\<Rightarrow>'m) \<Rightarrow> _" where
    "gen_map_of emp upd l \<equiv> fold (\<lambda>(k,v) s. upd k v s) (rev l) emp"

  lemma gen_map_of[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes UPD: "GEN_OP upd op_map_update (Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>Rm\<rightarrow>\<langle>Rk,Rv\<rangle>Rm)"
    assumes EMPTY: "GEN_OP emp Map.empty (\<langle>Rk,Rv\<rangle>Rm)"
    shows "(gen_map_of emp upd,map_of) \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>Rm"
    using assms
    apply (intro fun_relI)
    unfolding gen_map_of_def[abs_def]
    unfolding autoref_tag_defs
    apply (subst fold_map_of[symmetric])
    apply parametricity
    done

  lemma foldli_ball_aux:
    "distinct (map fst l) \<Longrightarrow> foldli l (\<lambda>x. x) (\<lambda>x _. P x) b
    \<longleftrightarrow> b \<and> op_map_ball (map_of l) P"
    apply (induct l arbitrary: b)
    apply simp
    apply (force simp: map_to_set_map_of image_def)
    done

  lemma foldli_ball:
    "det_fold_map X (\<lambda>x. x) (\<lambda>x _. P x) True (\<lambda>m. op_map_ball m P)"
    apply rule
    using foldli_ball_aux[where b=True] by auto

  definition gen_ball :: "('m \<Rightarrow> _) \<Rightarrow> _" where
    "gen_ball it m P \<equiv> it m (\<lambda>x. x) (\<lambda>x _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_ball (foldli o tsl),op_map_ball)
    \<in> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> (\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_ball_def comp_def
    apply (rule det_fold_map[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux:
    "distinct (map fst l) \<Longrightarrow> foldli l (\<lambda>x. \<not>x) (\<lambda>x _. P x) b
    \<longleftrightarrow> b \<or> op_map_bex (map_of l) P"
    apply (induct l arbitrary: b)
    apply simp
    apply (force simp: map_to_set_map_of image_def)
    done

  lemma foldli_bex:
    "det_fold_map X (\<lambda>x. \<not>x) (\<lambda>x _. P x) False (\<lambda>m. op_map_bex m P)"
    apply rule
    using foldli_bex_aux[where b=False] by auto

  definition gen_bex :: "('m \<Rightarrow> _) \<Rightarrow> _" where
    "gen_bex it m P \<equiv> it m (\<lambda>x. \<not>x) (\<lambda>x _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_bex (foldli o tsl),op_map_bex)
    \<in> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> (\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_bex_def comp_def
    apply (rule det_fold_map[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_isEmpty: "op_map_isEmpty m = op_map_ball m (\<lambda>_. False)"
    apply (auto intro!: ext)
    by (metis map_to_set_simps(7) option.exhaust)

  definition "gen_isEmpty ball m \<equiv> ball m (\<lambda>_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes BALL:
      "GEN_OP ball op_map_ball (\<langle>Rk,Rv\<rangle>Rm\<rightarrow>(\<langle>Rk,Rv\<rangle>prod_rel\<rightarrow>Id) \<rightarrow> Id)"
    shows "(gen_isEmpty ball,op_map_isEmpty)
    \<in> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity+
    done

  lemma foldli_size_aux: "distinct (map fst l)
    \<Longrightarrow> foldli l (\<lambda>_. True) (\<lambda>_ n. Suc n) n = n + op_map_size (map_of l)"
    apply (induct l arbitrary: n)
    apply (auto simp: dom_map_of_conv_image_fst)
    done

  lemma foldli_size: "det_fold_map X (\<lambda>_. True) (\<lambda>_ n. Suc n) 0 op_map_size"
    apply rule
    using foldli_size_aux[where n=0] by simp

  definition gen_size :: "('m \<Rightarrow> _) \<Rightarrow> _"
    where "gen_size it m \<equiv> it m (\<lambda>_. True) (\<lambda>_ n. Suc n) 0"

  lemma gen_size[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_size (foldli o tsl),op_map_size) \<in> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_size_def comp_def
    apply (rule det_fold_map[OF foldli_size IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_size_abort_aux:
    "\<lbrakk>n0\<le>m; distinct (map fst l)\<rbrakk> \<Longrightarrow>
      foldli l (\<lambda>n. n<m) (\<lambda>_ n. Suc n) n0 = min m (n0 + card (dom (map_of l)))"
    apply (induct l arbitrary: n0)
    apply (auto simp: dom_map_of_conv_image_fst)
    done

  lemma foldli_size_abort:
    "det_fold_map X (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0 (op_map_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort :: "('s \<Rightarrow> _) \<Rightarrow> _" where
    "gen_size_abort it m s \<equiv> it s (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_size_abort (foldli o tsl),op_map_size_abort)
      \<in> Id \<rightarrow> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def comp_def
    apply (rule det_fold_map[OF foldli_size_abort
      IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma size_abort_isSng: "op_map_isSng s \<longleftrightarrow> op_map_size_abort 2 s = 1"
    by (auto simp: dom_eq_singleton_conv min_def dest!: card_eq_SucD)

  definition gen_isSng :: "(nat \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> _" where
    "gen_isSng sizea s \<equiv> sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_map_size_abort (Id \<rightarrow> (\<langle>Rk,Rv\<rangle>Rm) \<rightarrow> Id)"
    shows "(gen_isSng sizea,op_map_isSng)
    \<in> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done

  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l\<noteq>[]"
    obtains k v where "(k,v)\<in>set l"
    and "(foldli l (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None)
      = Some (k,v)"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s \<equiv>
      (the (it s (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None))"

context begin interpretation autoref_syn .

  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm it)"
    assumes NE: "SIDE_PRECOND (m'\<noteq>Map.empty)"
    assumes SREF: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    shows "(RETURN (gen_pick (\<lambda>x. foldli (it x)) m),
      (OP op_map_pick ::: \<langle>Rk,Rv\<rangle>Rm\<rightarrow>\<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)$m')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel"
  proof -
    thm is_map_to_list_def is_map_to_sorted_listE

    obtain tsl' where
      [param]: "(it m,tsl') \<in> \<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel"
      and IT': "RETURN tsl' \<le> it_to_sorted_list (\<lambda>_ _. True) (map_to_set m')"
      using IT[unfolded autoref_tag_defs is_map_to_list_def] SREF
      by (auto intro: is_map_to_sorted_listE)

    from IT' NE have "tsl'\<noteq>[]" and [simp]: "m'=map_of tsl'"
      and DIS': "distinct (map fst tsl')"
      unfolding it_to_sorted_list_def
      apply simp_all
      apply (metis empty_set map_to_set_empty_iff(1))
      apply (metis map_of_map_to_set map_to_set_distinct_conv)
      apply (metis map_to_set_distinct_conv)
      done

    then obtain k v where "m' k = Some v" and
      "(foldli tsl' (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None)
        = Some (k,v)"
      (is "?fld = _")
      by (cases rule: foldli_pick) auto
    moreover
    have "(RETURN (gen_pick (\<lambda>x. foldli (it x)) m), RETURN (the ?fld))
      \<in> \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel"
      unfolding gen_pick_def
      apply (parametricity add: the_paramR)
      using \<open>?fld = Some (k,v)\<close>
      by simp
    ultimately show ?thesis
      unfolding autoref_tag_defs
      apply -
      apply (drule nres_relD)
      apply (rule nres_relI)
      apply (erule ref_two_step)
      by simp
  qed
end

  definition "gen_map_pick_remove pick del m \<equiv> do {
    (k,v)\<leftarrow>pick m;
    let m = del k m;
    RETURN ((k,v),m)
    }"

context begin interpretation autoref_syn .
  lemma gen_map_pick_remove
    [unfolded gen_map_pick_remove_def, autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes PICK: "SIDE_GEN_OP (
      (pick m,
      (OP op_map_pick ::: \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)$m') \<in>
      \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
    assumes DEL: "GEN_OP del op_map_delete (Rk \<rightarrow> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
    assumes [param]: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    shows "(gen_map_pick_remove pick del m,
      (OP op_map_pick_remove
        ::: \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel)$m')
      \<in> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel"
  proof -
    note [param] =
      PICK[unfolded autoref_tag_defs]
      DEL[unfolded autoref_tag_defs]

    have "(gen_map_pick_remove pick del m,
      do {
        (k,v)\<leftarrow>op_map_pick m';
        let m' = op_map_delete k m';
        RETURN ((k,v),m')
      }) \<in> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel" (is "(_,?h):_")
      unfolding gen_map_pick_remove_def[abs_def]
      apply parametricity
      done
    also have "?h = op_map_pick_remove m'"
      by (auto simp add: pw_eq_iff refine_pw_simps)
    finally show ?thesis by simp
  qed
end

end