(*  Title:      HOL/UNITY/ProgressSets.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Progress Sets.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section\<open>Progress Sets\<close>

theory ProgressSets imports Transformers begin

subsection \<open>Complete Lattices and the Operator \<^term>\<open>cl\<close>\<close>

definition lattice :: "'a set set => bool" where
   \<comment> \<open>Meier calls them closure sets, but they are just complete lattices\<close>
   "lattice L ==
         (\<forall>M. M \<subseteq> L --> \<Inter>M \<in> L) & (\<forall>M. M \<subseteq> L --> \<Union>M \<in> L)"

definition cl :: "['a set set, 'a set] => 'a set" where
   \<comment> \<open>short for ``closure''\<close>
   "cl L r == \<Inter>{x. x\<in>L & r \<subseteq> x}"

lemma UNIV_in_lattice: "lattice L ==> UNIV \<in> L"
by (force simp add: lattice_def)

lemma empty_in_lattice: "lattice L ==> {} \<in> L"
by (force simp add: lattice_def)

lemma Union_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Union>M \<in> L"
by (simp add: lattice_def)

lemma Inter_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Inter>M \<in> L"
by (simp add: lattice_def)

lemma UN_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Union>i\<in>I. r i) \<in> L"
apply (blast intro: Union_in_lattice)
done

lemma INT_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Inter>i\<in>I. r i)  \<in> L"
apply (blast intro: Inter_in_lattice)
done

lemma Un_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<union>y \<in> L"
  using Union_in_lattice [of "{x, y}" L] by simp

lemma Int_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<inter>y \<in> L"
  using Inter_in_lattice [of "{x, y}" L] by simp

lemma lattice_stable: "lattice {X. F \<in> stable X}"
by (simp add: lattice_def stable_def constrains_def, blast)

text\<open>The next three results state that \<^term>\<open>cl L r\<close> is the minimal
 element of \<^term>\<open>L\<close> that includes \<^term>\<open>r\<close>.\<close>
lemma cl_in_lattice: "lattice L ==> cl L r \<in> L"
  by (simp add: lattice_def cl_def)

lemma cl_least: "[|c\<in>L; r\<subseteq>c|] ==> cl L r \<subseteq> c"
by (force simp add: cl_def)

text\<open>The next three lemmas constitute assertion (4.61)\<close>
lemma cl_mono: "r \<subseteq> r' ==> cl L r \<subseteq> cl L r'"
by (simp add: cl_def, blast)

lemma subset_cl: "r \<subseteq> cl L r"
by (simp add: cl_def le_Inf_iff)

text\<open>A reformulation of @{thm subset_cl}\<close>
lemma clI: "x \<in> r ==> x \<in> cl L r"
by (simp add: cl_def, blast)

text\<open>A reformulation of @{thm cl_least}\<close>
lemma clD: "[|c \<in> cl L r; B \<in> L; r \<subseteq> B|] ==> c \<in> B"
by (force simp add: cl_def)

lemma cl_UN_subset: "(\<Union>i\<in>I. cl L (r i)) \<subseteq> cl L (\<Union>i\<in>I. r i)"
by (simp add: cl_def, blast)

lemma cl_Un: "lattice L ==> cl L (r\<union>s) = cl L r \<union> cl L s"
apply (rule equalityI)
 prefer 2
  apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: Un_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_UN: "lattice L ==> cl L (\<Union>i\<in>I. r i) = (\<Union>i\<in>I. cl L (r i))"
apply (rule equalityI)
 prefer 2 apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: UN_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_Int_subset: "cl L (r\<inter>s) \<subseteq> cl L r \<inter> cl L s"
by (simp add: cl_def, blast)

lemma cl_idem [simp]: "cl L (cl L r) = cl L r"
by (simp add: cl_def, blast)

lemma cl_ident: "r\<in>L ==> cl L r = r"
by (force simp add: cl_def)

lemma cl_empty [simp]: "lattice L ==> cl L {} = {}"
by (simp add: cl_ident empty_in_lattice)

lemma cl_UNIV [simp]: "lattice L ==> cl L UNIV = UNIV"
by (simp add: cl_ident UNIV_in_lattice)

text\<open>Assertion (4.62)\<close>
lemma cl_ident_iff: "lattice L ==> (cl L r = r) = (r\<in>L)"
apply (rule iffI)
 apply (erule subst)
 apply (erule cl_in_lattice)
apply (erule cl_ident)
done

lemma cl_subset_in_lattice: "[|cl L r \<subseteq> r; lattice L|] ==> r\<in>L"
by (simp add: cl_ident_iff [symmetric] equalityI subset_cl)

subsection \<open>Progress Sets and the Main Lemma\<close>
text\<open>A progress set satisfies certain closure conditions and is a
simple way of including the set \<^term>\<open>wens_set F B\<close>.\<close>

definition closed :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "closed F T B L == \<forall>M. \<forall>act \<in> Acts F. B\<subseteq>M & T\<inter>M \<in> L -->
                              T \<inter> (B \<union> wp act M) \<in> L"

definition progress_set :: "['a program, 'a set, 'a set] => 'a set set set" where
   "progress_set F T B ==
      {L. lattice L & B \<in> L & T \<in> L & closed F T B L}"

lemma closedD:
   "[|closed F T B L; act \<in> Acts F; B\<subseteq>M; T\<inter>M \<in> L|]
    ==> T \<inter> (B \<union> wp act M) \<in> L"
by (simp add: closed_def)

text\<open>Note: the formalization below replaces Meier's \<^term>\<open>q\<close> by \<^term>\<open>B\<close>
and \<^term>\<open>m\<close> by \<^term>\<open>X\<close>.\<close>

text\<open>Part of the proof of the claim at the bottom of page 97.  It's
proved separately because the argument requires a generalization over
all \<^term>\<open>act \<in> Acts F\<close>.\<close>
lemma lattice_awp_lemma:
  assumes TXC:  "T\<inter>X \<in> C" \<comment> \<open>induction hypothesis in theorem below\<close>
      and BsubX:  "B \<subseteq> X"   \<comment> \<open>holds in inductive step\<close>
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r))) \<in> C"
apply (simp del: INT_simps add: awp_def INT_extend_simps)
apply (rule INT_in_lattice [OF latt])
apply (erule closedD [OF clos])
apply (simp add: subset_trans [OF BsubX Un_upper1])
apply (subgoal_tac "T \<inter> (X \<union> cl C (T\<inter>r)) = (T\<inter>X) \<union> cl C (T\<inter>r)")
 prefer 2 apply (blast intro: TC clD)
apply (erule ssubst)
apply (blast intro: Un_in_lattice latt cl_in_lattice TXC)
done

text\<open>Remainder of the proof of the claim at the bottom of page 97.\<close>
lemma lattice_lemma:
  assumes TXC:  "T\<inter>X \<in> C" \<comment> \<open>induction hypothesis in theorem below\<close>
      and BsubX:  "B \<subseteq> X"   \<comment> \<open>holds in inductive step\<close>
      and act:  "act \<in> Acts F"
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X) \<in> C"
apply (subgoal_tac "T \<inter> (B \<union> wp act X) \<in> C")
 prefer 2 apply (simp add: closedD [OF clos] act BsubX TXC)
apply (drule Int_in_lattice
              [OF _ lattice_awp_lemma [OF TXC BsubX latt TC BC clos, of r]
                    latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X) \<inter> (T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r)))) =
          T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)))")
 prefer 2 apply blast
apply simp
apply (drule Un_in_lattice [OF _ TXC latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r))) \<union> T\<inter>X =
          T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X)")
 apply simp
apply (blast intro: BsubX [THEN subsetD])
done

text\<open>Induction step for the main lemma\<close>
lemma progress_induction_step:
  assumes TXC:  "T\<inter>X \<in> C" \<comment> \<open>induction hypothesis in theorem below\<close>
      and act:  "act \<in> Acts F"
      and Xwens: "X \<in> wens_set F B"
      and latt: "lattice C"
      and  TC:  "T \<in> C"
      and  BC:  "B \<in> C"
      and clos: "closed F T B C"
      and Fstable: "F \<in> stable T"
  shows "T \<inter> wens F act X \<in> C"
proof -
  from Xwens have BsubX: "B \<subseteq> X"
    by (rule wens_set_imp_subset)
  let ?r = "wens F act X"
  have "?r \<subseteq> (wp act X \<inter> awp F (X\<union>?r)) \<union> X"
    by (simp add: wens_unfold [symmetric])
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X\<union>?r)) \<union> X)"
    by blast
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (T \<inter> (X\<union>?r))) \<union> X)"
    by (simp add: awp_Int_eq Fstable stable_imp_awp_ident, blast)
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (blast intro: awp_mono [THEN [2] rev_subsetD] subset_cl [THEN subsetD])
  then have "cl C (T\<inter>?r) \<subseteq>
             cl C (T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X))"
    by (rule cl_mono)
  then have "cl C (T\<inter>?r) \<subseteq>
             T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (simp add: cl_ident lattice_lemma [OF TXC BsubX act latt TC BC clos])
  then have "cl C (T\<inter>?r) \<subseteq> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X"
    by blast
  then have "cl C (T\<inter>?r) \<subseteq> ?r"
    by (blast intro!: subset_wens)
  then have cl_subset: "cl C (T\<inter>?r) \<subseteq> T\<inter>?r"
    by (simp add: cl_ident TC
                  subset_trans [OF cl_mono [OF Int_lower1]])
  show ?thesis
    by (rule cl_subset_in_lattice [OF cl_subset latt])
qed

text\<open>Proved on page 96 of Meier's thesis.  The special case when
   \<^term>\<open>T=UNIV\<close> states that every progress set for the program \<^term>\<open>F\<close>
   and set \<^term>\<open>B\<close> includes the set \<^term>\<open>wens_set F B\<close>.\<close>
lemma progress_set_lemma:
     "[|C \<in> progress_set F T B; r \<in> wens_set F B; F \<in> stable T|] ==> T\<inter>r \<in> C"
apply (simp add: progress_set_def, clarify)
apply (erule wens_set.induct)
  txt\<open>Base\<close>
  apply (simp add: Int_in_lattice)
 txt\<open>The difficult \<^term>\<open>wens\<close> case\<close>
 apply (simp add: progress_induction_step)
txt\<open>Disjunctive case\<close>
apply (subgoal_tac "(\<Union>U\<in>W. T \<inter> U) \<in> C")
 apply simp
apply (blast intro: UN_in_lattice)
done

subsection \<open>The Progress Set Union Theorem\<close>

lemma closed_mono:
  assumes BB':  "B \<subseteq> B'"
      and TBwp: "T \<inter> (B \<union> wp act M) \<in> C"
      and B'C:  "B' \<in> C"
      and TC:   "T \<in> C"
      and latt: "lattice C"
  shows "T \<inter> (B' \<union> wp act M) \<in> C"
proof -
  from TBwp have "(T\<inter>B) \<union> (T \<inter> wp act M) \<in> C"
    by (simp add: Int_Un_distrib)
  then have TBBC: "(T\<inter>B') \<union> ((T\<inter>B) \<union> (T \<inter> wp act M)) \<in> C"
    by (blast intro: Int_in_lattice Un_in_lattice TC B'C latt)
  show ?thesis
    by (rule eqelem_imp_iff [THEN iffD1, OF _ TBBC],
        blast intro: BB' [THEN subsetD])
qed

lemma progress_set_mono:
    assumes BB':  "B \<subseteq> B'"
    shows
     "[| B' \<in> C;  C \<in> progress_set F T B|]
      ==> C \<in> progress_set F T B'"
by (simp add: progress_set_def closed_def closed_mono [OF BB']
                 subset_trans [OF BB'])

theorem progress_set_Union:
  assumes leadsTo: "F \<in> A leadsTo B'"
      and prog: "C \<in> progress_set F T B"
      and Fstable: "F \<in> stable T"
      and BB':  "B \<subseteq> B'"
      and B'C:  "B' \<in> C"
      and Gco: "!!X. X\<in>C ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B'"
apply (insert prog Fstable)
apply (rule leadsTo_Join [OF leadsTo])
  apply (force simp add: progress_set_def awp_iff_stable [symmetric])
apply (simp add: awp_iff_constrains)
apply (drule progress_set_mono [OF BB' B'C])
apply (blast intro: progress_set_lemma Gco constrains_weaken_L
                    BB' [THEN subsetD])
done

subsection \<open>Some Progress Sets\<close>

lemma UNIV_in_progress_set: "UNIV \<in> progress_set F T B"
by (simp add: progress_set_def lattice_def closed_def)

subsubsection \<open>Lattices and Relations\<close>
text\<open>From Meier's thesis, section 4.5.3\<close>

definition relcl :: "'a set set => ('a * 'a) set" where
    \<comment> \<open>Derived relation from a lattice\<close>
    "relcl L == {(x,y). y \<in> cl L {x}}"

definition latticeof :: "('a * 'a) set => 'a set set" where
    \<comment> \<open>Derived lattice from a relation: the set of upwards-closed sets\<close>
    "latticeof r == {X. \<forall>s t. s \<in> X & (s,t) \<in> r --> t \<in> X}"

lemma relcl_refl: "(a,a) \<in> relcl L"
by (simp add: relcl_def subset_cl [THEN subsetD])

lemma relcl_trans:
     "[| (a,b) \<in> relcl L; (b,c) \<in> relcl L; lattice L |] ==> (a,c) \<in> relcl L"
apply (simp add: relcl_def)
apply (blast intro: clD cl_in_lattice)
done

lemma refl_relcl: "lattice L ==> refl (relcl L)"
by (simp add: refl_onI relcl_def subset_cl [THEN subsetD])

lemma trans_relcl: "lattice L ==> trans (relcl L)"
by (blast intro: relcl_trans transI)

lemma lattice_latticeof: "lattice (latticeof r)"
by (auto simp add: lattice_def latticeof_def)

lemma lattice_singletonI:
     "[|lattice L; !!s. s \<in> X ==> {s} \<in> L|] ==> X \<in> L"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (simp only: UN_in_lattice)
done

text\<open>Equation (4.71) of Meier's thesis.  He gives no proof.\<close>
lemma cl_latticeof:
     "[|refl r; trans r|]
      ==> cl (latticeof r) X = {t. \<exists>s. s\<in>X & (s,t) \<in> r}"
apply (rule equalityI)
 apply (rule cl_least)
  apply (simp (no_asm_use) add: latticeof_def trans_def, blast)
 apply (simp add: latticeof_def refl_on_def, blast)
apply (simp add: latticeof_def, clarify)
apply (unfold cl_def, blast)
done

text\<open>Related to (4.71).\<close>
lemma cl_eq_Collect_relcl:
     "lattice L ==> cl L X = {t. \<exists>s. s\<in>X & (s,t) \<in> relcl L}"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (force simp only: relcl_def cl_UN)
done

text\<open>Meier's theorem of section 4.5.3\<close>
theorem latticeof_relcl_eq: "lattice L ==> latticeof (relcl L) = L"
apply (rule equalityI)
 prefer 2 apply (force simp add: latticeof_def relcl_def cl_def, clarify)
apply (rename_tac X)
apply (rule cl_subset_in_lattice)
 prefer 2 apply assumption
apply (drule cl_ident_iff [OF lattice_latticeof, THEN iffD2])
apply (drule equalityD1)
apply (rule subset_trans)
 prefer 2 apply assumption
apply (thin_tac "_ \<subseteq> X")
apply (cut_tac A=X in UN_singleton)
apply (erule subst)
apply (simp only: cl_UN lattice_latticeof
                  cl_latticeof [OF refl_relcl trans_relcl])
apply (simp add: relcl_def)
done

theorem relcl_latticeof_eq:
     "[|refl r; trans r|] ==> relcl (latticeof r) = r"
by (simp add: relcl_def cl_latticeof)

subsubsection \<open>Decoupling Theorems\<close>

definition decoupled :: "['a program, 'a program] => bool" where
   "decoupled F G ==
        \<forall>act \<in> Acts F. \<forall>B. G \<in> stable B --> G \<in> stable (wp act B)"

text\<open>Rao's Decoupling Theorem\<close>
lemma stableco: "F \<in> stable A ==> F \<in> A-B co A"
by (simp add: stable_def constrains_def, blast)

theorem decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and Gstable: "G \<in> stable B"
      and dec:     "decoupled F G"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp add: progress_set_def lattice_stable Gstable closed_def
                  stable_Un [OF Gstable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: Gstable stableco)
  thus ?thesis by simp
qed

text\<open>Rao's Weak Decoupling Theorem\<close>
theorem weak_decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and stable: "F\<squnion>G \<in> stable B"
      and dec:     "decoupled F (F\<squnion>G)"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. F\<squnion>G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp del: Join_stable
             add: progress_set_def lattice_stable stable closed_def
                  stable_Un [OF stable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all del: Join_stable add: stable,
        simp add: stableco)
  thus ?thesis by simp
qed

text\<open>The ``Decoupling via \<^term>\<open>G'\<close> Union Theorem''\<close>
theorem decoupling_via_aux:
  assumes leadsTo: "F \<in> A leadsTo B"
      and prog: "{X. G' \<in> stable X} \<in> progress_set F UNIV B"
      and GG':  "G \<le> G'"
               \<comment> \<open>Beware!  This is the converse of the refinement relation!\<close>
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  from prog have stable: "G' \<in> stable B"
    by (simp add: progress_set_def)
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: stable stableco component_stable [OF GG'])
  thus ?thesis by simp
qed

subsection\<open>Composition Theorems Based on Monotonicity and Commutativity\<close>

subsubsection\<open>Commutativity of \<^term>\<open>cl L\<close> and assignment.\<close>
definition commutes :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "commutes F T B L ==
       \<forall>M. \<forall>act \<in> Acts F. B \<subseteq> M -->
           cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T\<inter>M)))"

text\<open>From Meier's thesis, section 4.5.6\<close>
lemma commutativity1_lemma:
  assumes commutes: "commutes F T B L"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
  shows "closed F T B L"
apply (simp add: closed_def, clarify)
apply (rule ProgressSets.cl_subset_in_lattice [OF _ lattice])
apply (simp add: Int_Un_distrib cl_Un [OF lattice]
                 cl_ident Int_in_lattice [OF TL BL lattice] Un_upper1)
apply (subgoal_tac "cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))")
 prefer 2
 apply (cut_tac commutes, simp add: commutes_def)
apply (erule subset_trans)
apply (simp add: cl_ident)
apply (blast intro: rev_subsetD [OF _ wp_mono])
done

text\<open>Version packaged with @{thm progress_set_Union}\<close>
lemma commutativity1:
  assumes leadsTo: "F \<in> A leadsTo B"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
      and commutes: "commutes F T B L"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
by (rule progress_set_Union [OF leadsTo _ Fstable subset_refl BL Gco],
    simp add: progress_set_def commutativity1_lemma commutes lattice BL TL)

text\<open>Possibly move to Relation.thy, after \<^term>\<open>single_valued\<close>\<close>
definition funof :: "[('a*'b)set, 'a] => 'b" where
   "funof r == (\<lambda>x. THE y. (x,y) \<in> r)"

lemma funof_eq: "[|single_valued r; (x,y) \<in> r|] ==> funof r x = y"
by (simp add: funof_def single_valued_def, blast)

lemma funof_Pair_in:
     "[|single_valued r; x \<in> Domain r|] ==> (x, funof r x) \<in> r"
by (force simp add: funof_eq)

lemma funof_in:
     "[|r``{x} \<subseteq> A; single_valued r; x \<in> Domain r|] ==> funof r x \<in> A"
by (force simp add: funof_eq)

lemma funof_imp_wp: "[|funof act t \<in> A; single_valued act|] ==> t \<in> wp act A"
by (force simp add: in_wp_iff funof_eq)

subsubsection\<open>Commutativity of Functions and Relation\<close>
text\<open>Thesis, page 109\<close>

(*FIXME: this proof is still an ungodly mess*)
text\<open>From Meier's thesis, section 4.5.6\<close>
lemma commutativity2_lemma:
  assumes dcommutes:
      "\<And>act s t. act \<in> Acts F \<Longrightarrow> s \<in> T \<Longrightarrow> (s, t) \<in> relcl L \<Longrightarrow>
        s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
    and determ: "!!act. act \<in> Acts F ==> single_valued act"
    and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
    and lattice:  "lattice L"
    and BL: "B \<in> L"
    and TL: "T \<in> L"
    and Fstable: "F \<in> stable T"
  shows  "commutes F T B L"
proof -
  { fix M and act and t
    assume 1: "B \<subseteq> M" "act \<in> Acts F" "t \<in> cl L (T \<inter> wp act M)"
    then have "\<exists>s. (s,t) \<in> relcl L \<and> s \<in> T \<inter> wp act M"
      by (force simp add: cl_eq_Collect_relcl [OF lattice])
    then obtain s where 2: "(s, t) \<in> relcl L" "s \<in> T" "s \<in> wp act M"
      by blast
    then have 3: "\<forall>u\<in>L. s \<in> u --> t \<in> u"
      apply (intro ballI impI)
      apply (subst cl_ident [symmetric], assumption)
      apply (simp add: relcl_def)
      apply (blast intro: cl_mono [THEN [2] rev_subsetD])
      done
    with 1 2 Fstable have 4: "funof act s \<in> T\<inter>M"
      by (force intro!: funof_in
        simp add: wp_def stable_def constrains_def determ total)
    with 1 2 3 have 5: "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      by (intro dcommutes) assumption+
    with 1 2 3 4 have "t \<in> B | funof act t \<in> cl L (T\<inter>M)"
      by (simp add: relcl_def) (blast intro: BL cl_mono [THEN [2] rev_subsetD])
    with 1 2 3 4 5 have "t \<in> B | t \<in> wp act (cl L (T\<inter>M))"
      by (blast intro: funof_imp_wp determ)
    with 2 3 have "t \<in> T \<and> (t \<in> B \<or> t \<in> wp act (cl L (T \<inter> M)))"
      by (blast intro: TL cl_mono [THEN [2] rev_subsetD])
    then have"t \<in> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))"
      by simp
  }
  then show "commutes F T B L" unfolding commutes_def by clarify
qed

text\<open>Version packaged with @{thm progress_set_Union}\<close>
lemma commutativity2:
  assumes leadsTo: "F \<in> A leadsTo B"
      and dcommutes:
        "\<forall>act \<in> Acts F.
         \<forall>s \<in> T. \<forall>t. (s,t) \<in> relcl L -->
                      s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      and determ: "!!act. act \<in> Acts F ==> single_valued act"
      and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule commutativity1 [OF leadsTo lattice])
apply (simp_all add: Gco commutativity2_lemma dcommutes determ total
                     lattice BL TL Fstable)
done

subsection \<open>Monotonicity\<close>
text\<open>From Meier's thesis, section 4.5.7, page 110\<close>
(*to be continued?*)

end


(* Author: Tobias Nipkow, with contributions by Thomas Sewell *)

section "Arrays via Braun Trees"

theory Array_Braun
imports
  Array_Specs
  Braun_Tree
begin

subsection "Array"

fun lookup1 :: "'a tree \<Rightarrow> nat \<Rightarrow> 'a" where
"lookup1 (Node l x r) n = (if n=1 then x else lookup1 (if even n then l else r) (n div 2))"

fun update1 :: "nat \<Rightarrow> 'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"update1 n x Leaf = Node Leaf x Leaf" |
"update1 n x (Node l a r) =
  (if n=1 then Node l x r else
   if even n then Node (update1 (n div 2) x l) a r
            else Node l a (update1 (n div 2) x r))"

fun adds :: "'a list \<Rightarrow> nat \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"adds [] n t = t" |
"adds (x#xs) n t = adds xs (n+1) (update1 (n+1) x t)"

fun list :: "'a tree \<Rightarrow> 'a list" where
"list Leaf = []" |
"list (Node l x r) = x # splice (list l) (list r)"

subsubsection "Functional Correctness"

lemma size_list: "size(list t) = size t"
by(induction t)(auto)

lemma minus1_div2: "(n - Suc 0) div 2 = (if odd n then n div 2 else n div 2 - 1)"
by auto arith

lemma nth_splice: "\<lbrakk> n < size xs + size ys;  size ys \<le> size xs;  size xs \<le> size ys + 1 \<rbrakk>
  \<Longrightarrow> splice xs ys ! n = (if even n then xs else ys) ! (n div 2)"
apply(induction xs ys arbitrary: n rule: splice.induct)
apply (auto simp: nth_Cons' minus1_div2)
done

lemma div2_in_bounds:
  "\<lbrakk> braun (Node l x r); n \<in> {1..size(Node l x r)}; n > 1 \<rbrakk> \<Longrightarrow>
   (odd n \<longrightarrow> n div 2 \<in> {1..size r}) \<and> (even n \<longrightarrow> n div 2 \<in> {1..size l})"
by auto arith

declare upt_Suc[simp del]

paragraph \<open>\<^const>\<open>lookup1\<close>\<close>

lemma nth_list_lookup1: "\<lbrakk>braun t; i < size t\<rbrakk> \<Longrightarrow> list t ! i = lookup1 t (i+1)"
proof(induction t arbitrary: i)
  case Leaf thus ?case by simp
next
  case Node
  thus ?case using div2_in_bounds[OF Node.prems(1), of "i+1"]
    by (auto simp: nth_splice minus1_div2 size_list)
qed

lemma list_eq_map_lookup1: "braun t \<Longrightarrow> list t = map (lookup1 t) [1..<size t + 1]"
by(auto simp add: list_eq_iff_nth_eq size_list nth_list_lookup1)

paragraph \<open>\<^const>\<open>update1\<close>\<close>

lemma size_update1: "\<lbrakk> braun t;  n \<in> {1.. size t} \<rbrakk> \<Longrightarrow> size(update1 n x t) = size t"
proof(induction t arbitrary: n)
  case Leaf thus ?case by simp
next
  case Node thus ?case using div2_in_bounds[OF Node.prems] by simp
qed

lemma braun_update1: "\<lbrakk>braun t;  n \<in> {1.. size t} \<rbrakk> \<Longrightarrow> braun(update1 n x t)"
proof(induction t arbitrary: n)
  case Leaf thus ?case by simp
next
  case Node thus ?case
    using div2_in_bounds[OF Node.prems] by (simp add: size_update1)
qed

lemma lookup1_update1: "\<lbrakk> braun t;  n \<in> {1.. size t} \<rbrakk> \<Longrightarrow>
  lookup1 (update1 n x t) m = (if n=m then x else lookup1 t m)"
proof(induction t arbitrary: m n)
  case Leaf
  then show ?case by simp
next
  have aux: "\<lbrakk> odd n; odd m \<rbrakk> \<Longrightarrow> n div 2 = (m::nat) div 2 \<longleftrightarrow> m=n" for m n
    using odd_two_times_div_two_succ by fastforce
  case Node
  thus ?case using div2_in_bounds[OF Node.prems] by (auto simp: aux)
qed

lemma list_update1: "\<lbrakk> braun t;  n \<in> {1.. size t} \<rbrakk> \<Longrightarrow> list(update1 n x t) = (list t)[n-1 := x]"
by(auto simp add: list_eq_map_lookup1 list_eq_iff_nth_eq lookup1_update1 size_update1 braun_update1)

text \<open>A second proof of @{thm list_update1}:\<close>

lemma diff1_eq_iff: "n > 0 \<Longrightarrow> n - Suc 0 = m \<longleftrightarrow> n = m+1"
by arith

lemma list_update_splice:
  "\<lbrakk> n < size xs + size ys;  size ys \<le> size xs;  size xs \<le> size ys + 1 \<rbrakk> \<Longrightarrow>
  (splice xs ys) [n := x] =
  (if even n then splice (xs[n div 2 := x]) ys else splice xs (ys[n div 2 := x]))"
by(induction xs ys arbitrary: n rule: splice.induct) (auto split: nat.split)

lemma list_update2: "\<lbrakk> braun t;  n \<in> {1.. size t} \<rbrakk> \<Longrightarrow> list(update1 n x t) = (list t)[n-1 := x]"
proof(induction t arbitrary: n)
  case Leaf thus ?case by simp
next
  case (Node l a r) thus ?case using div2_in_bounds[OF Node.prems]
    by(auto simp: list_update_splice diff1_eq_iff size_list split: nat.split)
qed

paragraph \<open>\<^const>\<open>adds\<close>\<close>

lemma splice_last: shows
  "size ys \<le> size xs \<Longrightarrow> splice (xs @ [x]) ys = splice xs ys @ [x]"
and "size ys+1 \<ge> size xs \<Longrightarrow> splice xs (ys @ [y]) = splice xs ys @ [y]"
by(induction xs ys arbitrary: x y rule: splice.induct) (auto)

lemma list_add_hi: "braun t \<Longrightarrow> list(update1 (Suc(size t)) x t) = list t @ [x]"
by(induction t)(auto simp: splice_last size_list)

lemma size_add_hi: "braun t \<Longrightarrow> m = size t \<Longrightarrow> size(update1 (Suc m) x t) = size t + 1"
by(induction t arbitrary: m)(auto)

lemma braun_add_hi: "braun t \<Longrightarrow> braun(update1 (Suc(size t)) x t)"
by(induction t)(auto simp: size_add_hi)

lemma size_braun_adds:
  "\<lbrakk> braun t; size t = n \<rbrakk> \<Longrightarrow> size(adds xs n t) = size t + length xs \<and> braun (adds xs n t)"
by(induction xs arbitrary: t n)(auto simp: braun_add_hi size_add_hi)

lemma list_adds: "\<lbrakk> braun t; size t = n \<rbrakk> \<Longrightarrow> list(adds xs n t) = list t @ xs"
by(induction xs arbitrary: t n)(auto simp: size_braun_adds list_add_hi size_add_hi braun_add_hi)

subsubsection "Array Implementation"

interpretation A: Array
where lookup = "\<lambda>(t,l) n. lookup1 t (n+1)"
and update = "\<lambda>n x (t,l). (update1 (n+1) x t, l)"
and len = "\<lambda>(t,l). l"
and array = "\<lambda>xs. (adds xs 0 Leaf, length xs)"
and invar = "\<lambda>(t,l). braun t \<and> l = size t"
and list = "\<lambda>(t,l). list t"
proof (standard, goal_cases)
  case 1 thus ?case by (simp add: nth_list_lookup1 split: prod.splits)
next
  case 2 thus ?case by (simp add: list_update1 split: prod.splits)
next
  case 3 thus ?case by (simp add: size_list split: prod.splits)
next
  case 4 thus ?case by (simp add: list_adds)
next
  case 5 thus ?case by (simp add: braun_update1 size_update1 split: prod.splits)
next
  case 6 thus ?case by (simp add: size_braun_adds split: prod.splits)
qed

subsection "Flexible Array"

fun add_lo where
"add_lo x Leaf = Node Leaf x Leaf" |
"add_lo x (Node l a r) = Node (add_lo a r) x l"

fun merge where
"merge Leaf r = r" |
"merge (Node l a r) rr = Node rr a (merge l r)"

fun del_lo where
"del_lo Leaf = Leaf" |
"del_lo (Node l a r) = merge l r"

fun del_hi :: "nat \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"del_hi n Leaf = Leaf" |
"del_hi n (Node l x r) =
  (if n = 1 then Leaf
   else if even n
       then Node (del_hi (n div 2) l) x r
       else Node l x (del_hi (n div 2) r))"

subsubsection "Functional Correctness"

paragraph \<open>\<^const>\<open>add_lo\<close>\<close>

lemma list_add_lo: "braun t \<Longrightarrow> list (add_lo a t) = a # list t"
by(induction t arbitrary: a) auto

lemma braun_add_lo: "braun t \<Longrightarrow> braun(add_lo x t)"
by(induction t arbitrary: x) (auto simp add: list_add_lo simp flip: size_list)

paragraph \<open>\<^const>\<open>del_lo\<close>\<close>

lemma list_merge: "braun (Node l x r) \<Longrightarrow> list(merge l r) = splice (list l) (list r)"
by (induction l r rule: merge.induct) auto

lemma braun_merge: "braun (Node l x r) \<Longrightarrow> braun(merge l r)"
by (induction l r rule: merge.induct)(auto simp add: list_merge simp flip: size_list)

lemma list_del_lo: "braun t \<Longrightarrow> list(del_lo t) = tl (list t)"
by (cases t) (simp_all add: list_merge)

lemma braun_del_lo: "braun t \<Longrightarrow> braun(del_lo t)"
by (cases t) (simp_all add: braun_merge)

paragraph \<open>\<^const>\<open>del_hi\<close>\<close>

lemma list_Nil_iff: "list t = [] \<longleftrightarrow> t = Leaf"
by(cases t) simp_all

lemma butlast_splice: "butlast (splice xs ys) =
  (if size xs > size ys then splice (butlast xs) ys else splice xs (butlast ys))"
by(induction xs ys rule: splice.induct) (auto)

lemma list_del_hi: "braun t \<Longrightarrow> size t = st \<Longrightarrow> list(del_hi st t) = butlast(list t)"
apply(induction t arbitrary: st)
by(auto simp: list_Nil_iff size_list butlast_splice)

lemma braun_del_hi: "braun t \<Longrightarrow> size t = st \<Longrightarrow> braun(del_hi st t)"
apply(induction t arbitrary: st)
by(auto simp: list_del_hi simp flip: size_list)

subsubsection "Flexible Array Implementation"

interpretation AF: Array_Flex
where lookup = "\<lambda>(t,l) n. lookup1 t (n+1)"
and update = "\<lambda>n x (t,l). (update1 (n+1) x t, l)"
and len = "\<lambda>(t,l). l"
and array = "\<lambda>xs. (adds xs 0 Leaf, length xs)"
and invar = "\<lambda>(t,l). braun t \<and> l = size t"
and list = "\<lambda>(t,l). list t"
and add_lo = "\<lambda>x (t,l). (add_lo x t, l+1)"
and del_lo = "\<lambda>(t,l). (del_lo t, l-1)"
and add_hi = "\<lambda>x (t,l). (update1 (Suc l) x t, l+1)"
and del_hi = "\<lambda>(t,l). (del_hi l t, l-1)"
proof (standard, goal_cases)
  case 1 thus ?case by (simp add: list_add_lo split: prod.splits)
next
  case 2 thus ?case by (simp add: list_del_lo split: prod.splits)
next
  case 3 thus ?case by (simp add: list_add_hi braun_add_hi split: prod.splits)
next
  case 4 thus ?case by (simp add: list_del_hi split: prod.splits)
next
  case 5 thus ?case by (simp add: braun_add_lo list_add_lo flip: size_list split: prod.splits)
next
  case 6 thus ?case by (simp add: braun_del_lo list_del_lo flip: size_list split: prod.splits)
next
  case 7 thus ?case by (simp add: size_add_hi braun_add_hi split: prod.splits)
next
  case 8 thus ?case by (simp add: braun_del_hi list_del_hi flip: size_list split: prod.splits)
qed

subsection "Faster"

subsubsection \<open>Size\<close>

fun diff :: "'a tree \<Rightarrow> nat \<Rightarrow> nat" where
"diff Leaf _ = 0" |
"diff (Node l x r) n = (if n=0 then 1 else if even n then diff r (n div 2 - 1) else diff l (n div 2))"

fun size_fast :: "'a tree \<Rightarrow> nat" where
"size_fast Leaf = 0" |
"size_fast (Node l x r) = (let n = size_fast r in 1 + 2*n + diff l n)"

declare Let_def[simp]

lemma diff: "braun t \<Longrightarrow> size t : {n, n + 1} \<Longrightarrow> diff t n = size t - n"
by(induction t arbitrary: n) auto

lemma size_fast: "braun t \<Longrightarrow> size_fast t = size t"
by(induction t) (auto simp add: diff)

subsubsection \<open>Initialization with 1 element\<close>

fun braun_of_naive :: "'a \<Rightarrow> nat \<Rightarrow> 'a tree" where
"braun_of_naive x n = (if n=0 then Leaf
  else let m = (n-1) div 2
       in if odd n then Node (braun_of_naive x m) x (braun_of_naive x m)
       else Node (braun_of_naive x (m + 1)) x (braun_of_naive x m))"

fun braun2_of :: "'a \<Rightarrow> nat \<Rightarrow> 'a tree * 'a tree" where
"braun2_of x n = (if n = 0 then (Leaf, Node Leaf x Leaf)
  else let (s,t) = braun2_of x ((n-1) div 2)
       in if odd n then (Node s x s, Node t x s) else (Node t x s, Node t x t))"

definition braun_of :: "'a \<Rightarrow> nat \<Rightarrow> 'a tree" where
"braun_of x n = fst (braun2_of x n)"

declare braun2_of.simps [simp del]

lemma braun2_of_size_braun: "braun2_of x n = (s,t) \<Longrightarrow> size s = n \<and> size t = n+1 \<and> braun s \<and> braun t"
proof(induction x n arbitrary: s t rule: braun2_of.induct)
  case (1 x n)
  then show ?case
    by (auto simp: braun2_of.simps[of x n] split: prod.splits if_splits) presburger+
qed

lemma braun2_of_replicate:
  "braun2_of x n = (s,t) \<Longrightarrow> list s = replicate n x \<and> list t = replicate (n+1) x"
proof(induction x n arbitrary: s t rule: braun2_of.induct)
  case (1 x n)
  have "x # replicate m x = replicate (m+1) x" for m by simp
  with 1 show ?case
    apply (auto simp: braun2_of.simps[of x n] replicate.simps(2)[of 0 x]
        simp del: replicate.simps(2) split: prod.splits if_splits)
    by presburger+
qed

corollary braun_braun_of: "braun(braun_of x n)"
unfolding braun_of_def by (metis eq_fst_iff braun2_of_size_braun)

corollary list_braun_of: "list(braun_of x n) = replicate n x"
unfolding braun_of_def by (metis eq_fst_iff braun2_of_replicate)

subsubsection "Proof Infrastructure"

text \<open>Originally due to Thomas Sewell.\<close>

paragraph \<open>\<open>take_nths\<close>\<close>

fun take_nths :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"take_nths i k [] = []" |
"take_nths i k (x # xs) = (if i = 0 then x # take_nths (2^k - 1) k xs
  else take_nths (i - 1) k xs)"

text \<open>This is the more concise definition but seems to complicate the proofs:\<close>

lemma take_nths_eq_nths: "take_nths i k xs = nths xs (\<Union>n. {n*2^k + i})"
proof(induction xs arbitrary: i)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof cases
    assume [simp]: "i = 0"
    have "(\<Union>n. {(n+1) * 2 ^ k - 1}) = {m. \<exists>n. Suc m = n * 2 ^ k}"
      apply (auto simp del: mult_Suc)
      by (metis diff_Suc_Suc diff_zero mult_eq_0_iff not0_implies_Suc)
    thus ?thesis by (simp add: Cons.IH ac_simps nths_Cons)
  next
    assume [arith]: "i \<noteq> 0"
    have "(\<Union>n. {n * 2 ^ k + i - 1}) = {m. \<exists>n. Suc m = n * 2 ^ k + i}"
      apply auto
      by (metis diff_Suc_Suc diff_zero)
    thus ?thesis by (simp add: Cons.IH nths_Cons)
  qed
qed

lemma take_nths_drop:
  "take_nths i k (drop j xs) = take_nths (i + j) k xs"
by (induct xs arbitrary: i j; simp add: drop_Cons split: nat.split)

lemma take_nths_00:
  "take_nths 0 0 xs = xs"
by (induct xs; simp)

lemma splice_take_nths:
  "splice (take_nths 0 (Suc 0) xs) (take_nths (Suc 0) (Suc 0) xs) = xs"
by (induct xs; simp)

lemma take_nths_take_nths:
  "take_nths i m (take_nths j n xs) = take_nths ((i * 2^n) + j) (m + n) xs"
by (induct xs arbitrary: i j; simp add: algebra_simps power_add)

lemma take_nths_empty:
  "(take_nths i k xs = []) = (length xs \<le> i)"
by (induction xs arbitrary: i k) auto

lemma hd_take_nths:
  "i < length xs \<Longrightarrow> hd(take_nths i k xs) = xs ! i"
by (induction xs arbitrary: i k) auto

lemma take_nths_01_splice:
  "\<lbrakk> length xs = length ys \<or> length xs = length ys + 1 \<rbrakk> \<Longrightarrow>
   take_nths 0 (Suc 0) (splice xs ys) = xs \<and>
   take_nths (Suc 0) (Suc 0) (splice xs ys) = ys"
by (induct xs arbitrary: ys; case_tac ys; simp)

lemma length_take_nths_00:
  "length (take_nths 0 (Suc 0) xs) = length (take_nths (Suc 0) (Suc 0) xs) \<or>
   length (take_nths 0 (Suc 0) xs) = length (take_nths (Suc 0) (Suc 0) xs) + 1"
by (induct xs) auto

paragraph \<open>\<open>braun_list\<close>\<close>

fun braun_list :: "'a tree \<Rightarrow> 'a list \<Rightarrow> bool" where
"braun_list Leaf xs = (xs = [])" |
"braun_list (Node l x r) xs = (xs \<noteq> [] \<and> x = hd xs \<and>
    braun_list l (take_nths 1 1 xs) \<and>
    braun_list r (take_nths 2 1 xs))"

lemma braun_list_eq:
  "braun_list t xs = (braun t \<and> xs = list t)"
proof (induct t arbitrary: xs)
  case Leaf
  show ?case by simp
next
  case Node
  show ?case
    using length_take_nths_00[of xs] splice_take_nths[of xs]
    by (auto simp: neq_Nil_conv Node.hyps size_list[symmetric] take_nths_01_splice)
qed

subsubsection \<open>Converting a list of elements into a Braun tree\<close>

fun nodes :: "'a tree list \<Rightarrow> 'a list \<Rightarrow> 'a tree list \<Rightarrow> 'a tree list" where
"nodes (l#ls) (x#xs) (r#rs) = Node l x r # nodes ls xs rs" |
"nodes (l#ls) (x#xs) [] = Node l x Leaf # nodes ls xs []" |
"nodes [] (x#xs) (r#rs) = Node Leaf x r # nodes [] xs rs" |
"nodes [] (x#xs) [] = Node Leaf x Leaf # nodes [] xs []" |
"nodes ls [] rs = []"

fun brauns :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a tree list" where
"brauns k xs = (if xs = [] then [] else
   let ys = take (2^k) xs;
       zs = drop (2^k) xs;
       ts = brauns (k+1) zs
   in nodes ts ys (drop (2^k) ts))"

declare brauns.simps[simp del]

definition brauns1 :: "'a list \<Rightarrow> 'a tree" where
"brauns1 xs = (if xs = [] then Leaf else brauns 0 xs ! 0)"

fun T_brauns :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
"T_brauns k xs = (if xs = [] then 0 else
   let ys = take (2^k) xs;
       zs = drop (2^k) xs;
       ts = brauns (k+1) zs
   in 4 * min (2^k) (length xs) + T_brauns (k+1) zs)"

paragraph "Functional correctness"

text \<open>The proof is originally due to Thomas Sewell.\<close>

lemma length_nodes:
  "length (nodes ls xs rs) = length xs"
by (induct ls xs rs rule: nodes.induct; simp)

lemma nth_nodes:
  "i < length xs \<Longrightarrow> nodes ls xs rs ! i =
  Node (if i < length ls then ls ! i else Leaf) (xs ! i)
    (if i < length rs then rs ! i else Leaf)"
by (induct ls xs rs arbitrary: i rule: nodes.induct;
    simp add: nth_Cons split: nat.split)

theorem length_brauns:
  "length (brauns k xs) = min (length xs) (2 ^ k)"
proof (induct xs arbitrary: k rule: measure_induct_rule[where f=length])
  case (less xs) thus ?case by (simp add: brauns.simps[of k xs] length_nodes)
qed

theorem brauns_correct:
  "i < min (length xs) (2 ^ k) \<Longrightarrow> braun_list (brauns k xs ! i) (take_nths i k xs)"
proof (induct xs arbitrary: i k rule: measure_induct_rule[where f=length])
  case (less xs)
  have "xs \<noteq> []" using less.prems by auto
  let ?zs = "drop (2^k) xs"
  let ?ts = "brauns (Suc k) ?zs"
  from less.hyps[of ?zs _ "Suc k"]
  have IH: "\<lbrakk> j = i + 2 ^ k;  i < min (length ?zs) (2 ^ (k+1)) \<rbrakk> \<Longrightarrow>
    braun_list (?ts ! i) (take_nths j (Suc k) xs)" for i j
    using \<open>xs \<noteq> []\<close> by (simp add: take_nths_drop)
  show ?case
    using less.prems
    by (auto simp: brauns.simps[of k xs] nth_nodes take_nths_take_nths
                   IH take_nths_empty hd_take_nths length_brauns)
qed

corollary brauns1_correct:
  "braun (brauns1 xs) \<and> list (brauns1 xs) = xs"
using brauns_correct[of 0 xs 0]
by (simp add: brauns1_def braun_list_eq take_nths_00)

paragraph "Running Time Analysis"

theorem T_brauns:
  "T_brauns k xs = 4 * length xs"
proof (induction xs arbitrary: k rule: measure_induct_rule[where f = length])
  case (less xs)
  show ?case
  proof cases
    assume "xs = []"
    thus ?thesis by(simp)
  next
    assume "xs \<noteq> []"
    let ?zs = "drop (2^k) xs"
    have "T_brauns k xs = T_brauns (k+1) ?zs + 4 * min (2^k) (length xs)"
     using \<open>xs \<noteq> []\<close> by(simp)
    also have "\<dots> = 4 * length ?zs + 4 * min (2^k) (length xs)"
      using less[of ?zs "k+1"] \<open>xs \<noteq> []\<close>
      by (simp)
    also have "\<dots> = 4 * length xs"
      by(simp)
    finally show ?case .
  qed
qed

subsubsection \<open>Converting a Braun Tree into a List of Elements\<close>

text \<open>The code and the proof are originally due to Thomas Sewell (except running time).\<close>

function list_fast_rec :: "'a tree list \<Rightarrow> 'a list" where
"list_fast_rec ts = (let us = filter (\<lambda>t. t \<noteq> Leaf) ts in
  if us = [] then [] else
  map value us @ list_fast_rec (map left us @ map right us))"
by (pat_completeness, auto)

lemma list_fast_rec_term1: "ts \<noteq> [] \<Longrightarrow> Leaf \<notin> set ts \<Longrightarrow>
  sum_list (map (size o left) ts) + sum_list (map (size o right) ts) < sum_list (map size ts)"
  apply (clarsimp simp: sum_list_addf[symmetric] sum_list_map_filter')
  apply (rule sum_list_strict_mono; clarsimp?)
  apply (case_tac x; simp)
  done

lemma list_fast_rec_term: "us \<noteq> [] \<Longrightarrow> us = filter (\<lambda>t. t \<noteq> \<langle>\<rangle>) ts \<Longrightarrow>
  sum_list (map (size o left) us) + sum_list (map (size o right) us) < sum_list (map size ts)"
  apply (rule order_less_le_trans, rule list_fast_rec_term1, simp_all)
  apply (rule sum_list_filter_le_nat)
  done

termination
  apply (relation "measure (sum_list o map size)")
   apply simp
  apply (simp add: list_fast_rec_term)
  done

declare list_fast_rec.simps[simp del]

definition list_fast :: "'a tree \<Rightarrow> 'a list" where
"list_fast t = list_fast_rec [t]"

function T_list_fast_rec :: "'a tree list \<Rightarrow> nat" where
"T_list_fast_rec ts = (let us = filter (\<lambda>t. t \<noteq> Leaf) ts
  in length ts + (if us = [] then 0 else
  5 * length us + T_list_fast_rec (map left us @ map right us)))"
by (pat_completeness, auto)

termination
  apply (relation "measure (sum_list o map size)")
   apply simp
  apply (simp add: list_fast_rec_term)
  done

declare T_list_fast_rec.simps[simp del]

paragraph "Functional Correctness"

lemma list_fast_rec_all_Leaf:
  "\<forall>t \<in> set ts. t = Leaf \<Longrightarrow> list_fast_rec ts = []"
by (simp add: filter_empty_conv list_fast_rec.simps)

lemma take_nths_eq_single:
  "length xs - i < 2^n \<Longrightarrow> take_nths i n xs = take 1 (drop i xs)"
by (induction xs arbitrary: i n; simp add: drop_Cons')

lemma braun_list_Nil:
  "braun_list t [] = (t = Leaf)"
by (cases t; simp)

lemma braun_list_not_Nil: "xs \<noteq> [] \<Longrightarrow>
  braun_list t xs =
 (\<exists>l x r. t = Node l x r \<and> x = hd xs \<and>
    braun_list l (take_nths 1 1 xs) \<and>
    braun_list r (take_nths 2 1 xs))"
by(cases t; simp)

theorem list_fast_rec_correct:
  "\<lbrakk> length ts = 2 ^ k; \<forall>i < 2 ^ k. braun_list (ts ! i) (take_nths i k xs) \<rbrakk>
    \<Longrightarrow> list_fast_rec ts = xs"
proof (induct xs arbitrary: k ts rule: measure_induct_rule[where f=length])
  case (less xs)
  show ?case
  proof (cases "length xs < 2 ^ k")
    case True
    from less.prems True have filter:
      "\<exists>n. ts = map (\<lambda>x. Node Leaf x Leaf) xs @ replicate n Leaf"
      apply (rule_tac x="length ts - length xs" in exI)
      apply (clarsimp simp: list_eq_iff_nth_eq)
      apply(auto simp: nth_append braun_list_not_Nil take_nths_eq_single braun_list_Nil hd_drop_conv_nth)
      done
    thus ?thesis
      by (clarsimp simp: list_fast_rec.simps[of ts] o_def list_fast_rec_all_Leaf)
  next
    case False
    with less.prems(2) have *:
      "\<forall>i < 2 ^ k. ts ! i \<noteq> Leaf
         \<and> value (ts ! i) = xs ! i
         \<and> braun_list (left (ts ! i)) (take_nths (i + 2 ^ k) (Suc k) xs)
         \<and> (\<forall>ys. ys = take_nths (i + 2 * 2 ^ k) (Suc k) xs
                 \<longrightarrow> braun_list (right (ts ! i)) ys)"
      by (auto simp: take_nths_empty hd_take_nths braun_list_not_Nil take_nths_take_nths
                     algebra_simps)
    have 1: "map value ts = take (2 ^ k) xs"
      using less.prems(1) False by (simp add: list_eq_iff_nth_eq *)
    have 2: "list_fast_rec (map left ts @ map right ts) = drop (2 ^ k) xs"
      using less.prems(1) False
      by (auto intro!: Nat.diff_less less.hyps[where k= "Suc k"]
               simp: nth_append * take_nths_drop algebra_simps)
    from less.prems(1) False show ?thesis
      by (auto simp: list_fast_rec.simps[of ts] 1 2 * all_set_conv_all_nth)
  qed
qed

corollary list_fast_correct:
  "braun t \<Longrightarrow> list_fast t = list t"
by (simp add: list_fast_def take_nths_00 braun_list_eq list_fast_rec_correct[where k=0])

paragraph "Running Time Analysis"

lemma sum_tree_list_children: "\<forall>t \<in> set ts. t \<noteq> Leaf \<Longrightarrow>
  (\<Sum>t\<leftarrow>ts. k * size t) = (\<Sum>t \<leftarrow> map left ts @ map right ts. k * size t) + k * length ts"
by(induction ts)(auto simp add: neq_Leaf_iff algebra_simps)

theorem T_list_fast_rec_ub:
  "T_list_fast_rec ts \<le> sum_list (map (\<lambda>t. 7*size t + 1) ts)"
proof (induction ts rule: measure_induct_rule[where f="sum_list o map size"])
  case (less ts)
  let ?us = "filter (\<lambda>t. t \<noteq> Leaf) ts"
  show ?case
  proof cases
    assume "?us = []"
    thus ?thesis using T_list_fast_rec.simps[of ts]
      by(simp add: sum_list_Suc)
    next
    assume "?us \<noteq> []"
    let ?children = "map left ?us @ map right ?us"
    have "T_list_fast_rec ts = T_list_fast_rec ?children + 5 * length ?us + length ts"
     using \<open>?us \<noteq> []\<close> T_list_fast_rec.simps[of ts] by(simp)
    also have "\<dots> \<le> (\<Sum>t\<leftarrow>?children. 7 * size t + 1) + 5 * length ?us + length ts"
      using less[of "?children"] list_fast_rec_term[of "?us"] \<open>?us \<noteq> []\<close>
      by (simp)
    also have "\<dots> = (\<Sum>t\<leftarrow>?children. 7*size t) + 7 * length ?us + length ts"
      by(simp add: sum_list_Suc o_def)
    also have "\<dots> = (\<Sum>t\<leftarrow>?us. 7*size t) + length ts"
      by(simp add: sum_tree_list_children)
    also have "\<dots> \<le> (\<Sum>t\<leftarrow>ts. 7*size t) + length ts"
      by(simp add: sum_list_filter_le_nat)
    also have "\<dots> = (\<Sum>t\<leftarrow>ts. 7 * size t + 1)"
      by(simp add: sum_list_Suc)
    finally show ?case .
  qed
qed

end


(*  Title:      HOL/Induct/QuoNestedDataType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2004  University of Cambridge
*)

section{*Quotienting a Free Algebra Involving Nested Recursion*}

theory QuoNestedDataType imports Main begin

subsection{*Defining the Free Algebra*}

text{*Messages with encryption and decryption as free constructors.*}
datatype
     freeExp = VAR  nat
             | PLUS  freeExp freeExp
             | FNCALL  nat "freeExp list"

datatype_compat freeExp

text{*The equivalence relation, which makes PLUS associative.*}

text{*The first rule is the desired equation. The next three rules
make the equations applicable to subterms. The last two rules are symmetry
and transitivity.*}
inductive_set
  exprel :: "(freeExp * freeExp) set"
  and exp_rel :: "[freeExp, freeExp] => bool"  (infixl "\<sim>" 50)
  where
    "X \<sim> Y == (X,Y) \<in> exprel"
  | ASSOC: "PLUS X (PLUS Y Z) \<sim> PLUS (PLUS X Y) Z"
  | VAR: "VAR N \<sim> VAR N"
  | PLUS: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> PLUS X Y \<sim> PLUS X' Y'"
  | FNCALL: "(Xs,Xs') \<in> listrel exprel \<Longrightarrow> FNCALL F Xs \<sim> FNCALL F Xs'"
  | SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
  | TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"
  monos listrel_mono

text{*Proving that it is an equivalence relation*}

lemma exprel_refl: "X \<sim> X"
  and list_exprel_refl: "(Xs,Xs) \<in> listrel(exprel)"
  by (induct X and Xs rule: compat_freeExp.induct compat_freeExp_list.induct)
    (blast intro: exprel.intros listrel.intros)+

theorem equiv_exprel: "equiv UNIV exprel"
proof -
  have "refl exprel" by (simp add: refl_on_def exprel_refl)
  moreover have "sym exprel" by (simp add: sym_def, blast intro: exprel.SYM)
  moreover have "trans exprel" by (simp add: trans_def, blast intro: exprel.TRANS)
  ultimately show ?thesis by (simp add: equiv_def)
qed

theorem equiv_list_exprel: "equiv UNIV (listrel exprel)"
  using equiv_listrel [OF equiv_exprel] by simp

lemma FNCALL_Nil: "FNCALL F [] \<sim> FNCALL F []"
apply (rule exprel.intros)
apply (rule listrel.intros)
done

lemma FNCALL_Cons:
     "\<lbrakk>X \<sim> X'; (Xs,Xs') \<in> listrel(exprel)\<rbrakk>
      \<Longrightarrow> FNCALL F (X#Xs) \<sim> FNCALL F (X'#Xs')"
by (blast intro: exprel.intros listrel.intros)

subsection{*Some Functions on the Free Algebra*}

subsubsection{*The Set of Variables*}

text{*A function to return the set of variables present in a message.  It will
be lifted to the initial algrebra, to serve as an example of that process.
Note that the "free" refers to the free datatype rather than to the concept
of a free variable.*}
primrec freevars :: "freeExp \<Rightarrow> nat set"
  and freevars_list :: "freeExp list \<Rightarrow> nat set" where
  "freevars (VAR N) = {N}"
| "freevars (PLUS X Y) = freevars X \<union> freevars Y"
| "freevars (FNCALL F Xs) = freevars_list Xs"

| "freevars_list [] = {}"
| "freevars_list (X # Xs) = freevars X \<union> freevars_list Xs"

text{*This theorem lets us prove that the vars function respects the
equivalence relation.  It also helps us prove that Variable
  (the abstract constructor) is injective*}
theorem exprel_imp_eq_freevars: "U \<sim> V \<Longrightarrow> freevars U = freevars V"
apply (induct set: exprel)
apply (erule_tac [4] listrel.induct)
apply (simp_all add: Un_assoc)
done

subsubsection{*Functions for Freeness*}

text{*A discriminator function to distinguish vars, sums and function calls*}
primrec freediscrim :: "freeExp \<Rightarrow> int" where
  "freediscrim (VAR N) = 0"
| "freediscrim (PLUS X Y) = 1"
| "freediscrim (FNCALL F Xs) = 2"

theorem exprel_imp_eq_freediscrim:
     "U \<sim> V \<Longrightarrow> freediscrim U = freediscrim V"
  by (induct set: exprel) auto

text{*This function, which returns the function name, is used to
prove part of the injectivity property for FnCall.*}
primrec freefun :: "freeExp \<Rightarrow> nat" where
  "freefun (VAR N) = 0"
| "freefun (PLUS X Y) = 0"
| "freefun (FNCALL F Xs) = F"

theorem exprel_imp_eq_freefun:
     "U \<sim> V \<Longrightarrow> freefun U = freefun V"
  by (induct set: exprel) (simp_all add: listrel.intros)

text{*This function, which returns the list of function arguments, is used to
prove part of the injectivity property for FnCall.*}
primrec freeargs :: "freeExp \<Rightarrow> freeExp list" where
  "freeargs (VAR N) = []"
| "freeargs (PLUS X Y) = []"
| "freeargs (FNCALL F Xs) = Xs"

theorem exprel_imp_eqv_freeargs:
  assumes "U \<sim> V"
  shows "(freeargs U, freeargs V) \<in> listrel exprel"
proof -
  from equiv_list_exprel have sym: "sym (listrel exprel)" by (rule equivE)
  from equiv_list_exprel have trans: "trans (listrel exprel)" by (rule equivE)
  from assms show ?thesis
    apply induct
    apply (erule_tac [4] listrel.induct)
    apply (simp_all add: listrel.intros)
    apply (blast intro: symD [OF sym])
    apply (blast intro: transD [OF trans])
    done
qed

subsection{*The Initial Algebra: A Quotiented Message Type*}

definition "Exp = UNIV//exprel"

typedef exp = Exp
  morphisms Rep_Exp Abs_Exp
  unfolding Exp_def by (auto simp add: quotient_def)

text{*The abstract message constructors*}

definition
  Var :: "nat \<Rightarrow> exp" where
  "Var N = Abs_Exp(exprel``{VAR N})"

definition
  Plus :: "[exp,exp] \<Rightarrow> exp" where
   "Plus X Y =
       Abs_Exp (\<Union>U \<in> Rep_Exp X. \<Union>V \<in> Rep_Exp Y. exprel``{PLUS U V})"

definition
  FnCall :: "[nat, exp list] \<Rightarrow> exp" where
   "FnCall F Xs =
       Abs_Exp (\<Union>Us \<in> listset (map Rep_Exp Xs). exprel `` {FNCALL F Us})"

text{*Reduces equality of equivalence classes to the @{term exprel} relation:
  @{term "(exprel `` {x} = exprel `` {y}) = ((x,y) \<in> exprel)"} *}
lemmas equiv_exprel_iff = eq_equiv_class_iff [OF equiv_exprel UNIV_I UNIV_I]

declare equiv_exprel_iff [simp]

text{*All equivalence classes belong to set of representatives*}

lemma inj_on_Abs_Exp: "inj_on Abs_Exp Exp"
apply (rule inj_on_inverseI)
apply (erule Abs_Exp_inverse)
done

text{*Reduces equality on abstractions to equality on representatives*}
declare inj_on_Abs_Exp [THEN inj_on_iff, simp]

declare Abs_Exp_inverse [simp]

text{*Case analysis on the representation of a exp as an equivalence class.*}
lemma eq_Abs_Exp [case_names Abs_Exp, cases type: exp]:
     "(!!U. z = Abs_Exp(exprel``{U}) ==> P) ==> P"
apply (rule Rep_Exp [of z, unfolded Exp_def, THEN quotientE])
apply (drule arg_cong [where f=Abs_Exp])
apply (auto simp add: Rep_Exp_inverse intro: exprel_refl)
done

subsection{*Every list of abstract expressions can be expressed in terms of a
  list of concrete expressions*}

definition
  Abs_ExpList :: "freeExp list => exp list" where
  "Abs_ExpList Xs = map (%U. Abs_Exp(exprel``{U})) Xs"

lemma Abs_ExpList_Nil [simp]: "Abs_ExpList [] == []"
by (simp add: Abs_ExpList_def)

lemma Abs_ExpList_Cons [simp]:
     "Abs_ExpList (X#Xs) == Abs_Exp (exprel``{X}) # Abs_ExpList Xs"
by (simp add: Abs_ExpList_def)

lemma ExpList_rep: "\<exists>Us. z = Abs_ExpList Us"
apply (induct z)
apply (rename_tac [2] a b)
apply (rule_tac [2] z=a in eq_Abs_Exp)
apply (auto simp add: Abs_ExpList_def Cons_eq_map_conv intro: exprel_refl)
done

lemma eq_Abs_ExpList [case_names Abs_ExpList]:
     "(!!Us. z = Abs_ExpList Us ==> P) ==> P"
by (rule exE [OF ExpList_rep], blast)

subsubsection{*Characteristic Equations for the Abstract Constructors*}

lemma Plus: "Plus (Abs_Exp(exprel``{U})) (Abs_Exp(exprel``{V})) =
             Abs_Exp (exprel``{PLUS U V})"
proof -
  have "(\<lambda>U V. exprel `` {PLUS U V}) respects2 exprel"
    by (auto simp add: congruent2_def exprel.PLUS)
  thus ?thesis
    by (simp add: Plus_def UN_equiv_class2 [OF equiv_exprel equiv_exprel])
qed

text{*It is not clear what to do with FnCall: it's argument is an abstraction
of an @{typ "exp list"}. Is it just Nil or Cons? What seems to work best is to
regard an @{typ "exp list"} as a @{term "listrel exprel"} equivalence class*}

text{*This theorem is easily proved but never used. There's no obvious way
even to state the analogous result, @{text FnCall_Cons}.*}
lemma FnCall_Nil: "FnCall F [] = Abs_Exp (exprel``{FNCALL F []})"
  by (simp add: FnCall_def)

lemma FnCall_respects:
     "(\<lambda>Us. exprel `` {FNCALL F Us}) respects (listrel exprel)"
  by (auto simp add: congruent_def exprel.FNCALL)

lemma FnCall_sing:
     "FnCall F [Abs_Exp(exprel``{U})] = Abs_Exp (exprel``{FNCALL F [U]})"
proof -
  have "(\<lambda>U. exprel `` {FNCALL F [U]}) respects exprel"
    by (auto simp add: congruent_def FNCALL_Cons listrel.intros)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_exprel])
qed

lemma listset_Rep_Exp_Abs_Exp:
     "listset (map Rep_Exp (Abs_ExpList Us)) = listrel exprel `` {Us}"
  by (induct Us) (simp_all add: listrel_Cons Abs_ExpList_def)

lemma FnCall:
     "FnCall F (Abs_ExpList Us) = Abs_Exp (exprel``{FNCALL F Us})"
proof -
  have "(\<lambda>Us. exprel `` {FNCALL F Us}) respects (listrel exprel)"
    by (auto simp add: congruent_def exprel.FNCALL)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_list_exprel]
                  listset_Rep_Exp_Abs_Exp)
qed

text{*Establishing this equation is the point of the whole exercise*}

subsection{*The Abstract Function to Return the Set of Variables*}

definition
  vars :: "exp \<Rightarrow> nat set" where
  "vars X = (\<Union>U \<in> Rep_Exp X. freevars U)"

lemma vars_respects: "freevars respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freevars)

text{*The extension of the function @{term vars} to lists*}
primrec vars_list :: "exp list \<Rightarrow> nat set" where
  "vars_list []    = {}"
| "vars_list(E#Es) = vars E \<union> vars_list Es"

text{*Now prove the three equations for @{term vars}*}

lemma vars_Variable [simp]: "vars (Var N) = {N}"
by (simp add: vars_def Var_def
              UN_equiv_class [OF equiv_exprel vars_respects])

lemma vars_Plus [simp]: "vars (Plus X Y) = vars X \<union> vars Y"
apply (cases X, cases Y)
apply (simp add: vars_def Plus
                 UN_equiv_class [OF equiv_exprel vars_respects])
done

lemma vars_FnCall [simp]: "vars (FnCall F Xs) = vars_list Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall)
apply (induct_tac Us)
apply (simp_all add: vars_def UN_equiv_class [OF equiv_exprel vars_respects])
done

lemma vars_FnCall_Nil: "vars (FnCall F Nil) = {}"
by simp

lemma vars_FnCall_Cons: "vars (FnCall F (X#Xs)) = vars X \<union> vars_list Xs"
by simp

subsection{*Injectivity Properties of Some Constructors*}

lemma VAR_imp_eq: "VAR m \<sim> VAR n \<Longrightarrow> m = n"
by (drule exprel_imp_eq_freevars, simp)

text{*Can also be proved using the function @{term vars}*}
lemma Var_Var_eq [iff]: "(Var m = Var n) = (m = n)"
by (auto simp add: Var_def exprel_refl dest: VAR_imp_eq)

lemma VAR_neqv_PLUS: "VAR m \<sim> PLUS X Y \<Longrightarrow> False"
by (drule exprel_imp_eq_freediscrim, simp)

theorem Var_neq_Plus [iff]: "Var N \<noteq> Plus X Y"
apply (cases X, cases Y)
apply (simp add: Var_def Plus)
apply (blast dest: VAR_neqv_PLUS)
done

theorem Var_neq_FnCall [iff]: "Var N \<noteq> FnCall F Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (auto simp add: FnCall Var_def)
apply (drule exprel_imp_eq_freediscrim, simp)
done

subsection{*Injectivity of @{term FnCall}*}

definition
  "fun" :: "exp \<Rightarrow> nat" where
  "fun X = the_elem (\<Union>U \<in> Rep_Exp X. {freefun U})"

lemma fun_respects: "(%U. {freefun U}) respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freefun)

lemma fun_FnCall [simp]: "fun (FnCall F Xs) = F"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall fun_def UN_equiv_class [OF equiv_exprel fun_respects])
done

definition
  args :: "exp \<Rightarrow> exp list" where
  "args X = the_elem (\<Union>U \<in> Rep_Exp X. {Abs_ExpList (freeargs U)})"

text{*This result can probably be generalized to arbitrary equivalence
relations, but with little benefit here.*}
lemma Abs_ExpList_eq:
     "(y, z) \<in> listrel exprel \<Longrightarrow> Abs_ExpList (y) = Abs_ExpList (z)"
  by (induct set: listrel) simp_all

lemma args_respects: "(%U. {Abs_ExpList (freeargs U)}) respects exprel"
by (auto simp add: congruent_def Abs_ExpList_eq exprel_imp_eqv_freeargs)

lemma args_FnCall [simp]: "args (FnCall F Xs) = Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall args_def UN_equiv_class [OF equiv_exprel args_respects])
done

lemma FnCall_FnCall_eq [iff]:
     "(FnCall F Xs = FnCall F' Xs') = (F=F' & Xs=Xs')"
proof
  assume "FnCall F Xs = FnCall F' Xs'"
  hence "fun (FnCall F Xs) = fun (FnCall F' Xs')"
    and "args (FnCall F Xs) = args (FnCall F' Xs')" by auto
  thus "F=F' & Xs=Xs'" by simp
next
  assume "F=F' & Xs=Xs'" thus "FnCall F Xs = FnCall F' Xs'" by simp
qed

subsection{*The Abstract Discriminator*}
text{*However, as @{text FnCall_Var_neq_Var} illustrates, we don't need this
function in order to prove discrimination theorems.*}

definition
  discrim :: "exp \<Rightarrow> int" where
  "discrim X = the_elem (\<Union>U \<in> Rep_Exp X. {freediscrim U})"

lemma discrim_respects: "(\<lambda>U. {freediscrim U}) respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freediscrim)

text{*Now prove the four equations for @{term discrim}*}

lemma discrim_Var [simp]: "discrim (Var N) = 0"
by (simp add: discrim_def Var_def
              UN_equiv_class [OF equiv_exprel discrim_respects])

lemma discrim_Plus [simp]: "discrim (Plus X Y) = 1"
apply (cases X, cases Y)
apply (simp add: discrim_def Plus
                 UN_equiv_class [OF equiv_exprel discrim_respects])
done

lemma discrim_FnCall [simp]: "discrim (FnCall F Xs) = 2"
apply (rule_tac z=Xs in eq_Abs_ExpList)
apply (simp add: discrim_def FnCall
                 UN_equiv_class [OF equiv_exprel discrim_respects])
done

text{*The structural induction rule for the abstract type*}
theorem exp_inducts:
  assumes V:    "\<And>nat. P1 (Var nat)"
      and P:    "\<And>exp1 exp2. \<lbrakk>P1 exp1; P1 exp2\<rbrakk> \<Longrightarrow> P1 (Plus exp1 exp2)"
      and F:    "\<And>nat list. P2 list \<Longrightarrow> P1 (FnCall nat list)"
      and Nil:  "P2 []"
      and Cons: "\<And>exp list. \<lbrakk>P1 exp; P2 list\<rbrakk> \<Longrightarrow> P2 (exp # list)"
  shows "P1 exp" and "P2 list"
proof -
  obtain U where exp: "exp = (Abs_Exp (exprel `` {U}))" by (cases exp)
  obtain Us where list: "list = Abs_ExpList Us" by (rule eq_Abs_ExpList)
  have "P1 (Abs_Exp (exprel `` {U}))" and "P2 (Abs_ExpList Us)"
  proof (induct U and Us rule: compat_freeExp.induct compat_freeExp_list.induct)
    case (VAR nat)
    with V show ?case by (simp add: Var_def)
  next
    case (PLUS X Y)
    with P [of "Abs_Exp (exprel `` {X})" "Abs_Exp (exprel `` {Y})"]
    show ?case by (simp add: Plus)
  next
    case (FNCALL nat list)
    with F [of "Abs_ExpList list"]
    show ?case by (simp add: FnCall)
  next
    case Nil_freeExp
    with Nil show ?case by simp
  next
    case Cons_freeExp
    with Cons show ?case by simp
  qed
  with exp and list show "P1 exp" and "P2 list" by (simp_all only:)
qed

end


section \<open>cpo fixpoint\<close>

theory CPOFix
imports Prelude
begin

default_sort type

(* genaral fixpoint over cpo, x is \<sqsubseteq> f x*)

definition fixg::"('a::cpo) \<Rightarrow> ('a \<rightarrow> 'a) \<rightarrow> 'a" where
"fixg = (\<lambda> x. \<Lambda> F. if x \<sqsubseteq> F\<cdot>x then \<Squnion>i. iterate i\<cdot>F\<cdot>x else x)"

lemma iter_fixg_mono2: assumes "x \<sqsubseteq> y" and "F1 \<sqsubseteq> F2"
  shows "\<forall>i . (iterate i\<cdot>F1\<cdot>x) \<sqsubseteq> (iterate i\<cdot>F2\<cdot>y)"
  by (simp add: assms(1) assms(2) monofun_cfun)

lemma iter_fixg_chain: assumes "x \<sqsubseteq> F\<cdot>x"
  shows "chain (\<lambda>i. iterate i\<cdot>F\<cdot>x)"
    apply (rule chainI)
  by (metis assms cont_pref_eq1I iterate_Suc2)

lemma lub_iter_fixg_mono_req: assumes "F1 \<sqsubseteq> F2" and "x \<sqsubseteq> F1\<cdot>x" and "x\<sqsubseteq>F2\<cdot>x"
  shows "(\<Squnion>i. iterate i\<cdot>F1\<cdot>x) \<sqsubseteq> (\<Squnion>i. iterate i\<cdot>F2\<cdot>x)"
proof -
  have "\<forall>i. (iterate i\<cdot>F1\<cdot>x) \<sqsubseteq> (iterate i\<cdot>F2\<cdot>x)"
    by (simp add: iter_fixg_mono2 assms(1) assms(2))
   then show ?thesis
    by (simp add: lub_mono assms iter_fixg_mono2 iter_fixg_chain)
qed

(*cont (\<lambda> F. fixg x F)*)

lemma fixg_pre:"x \<sqsubseteq> (if x \<sqsubseteq> F\<cdot>x then \<Squnion>i. iterate i\<cdot>F\<cdot>x else x)"
proof(cases "x\<sqsubseteq>F\<cdot>x")
  case True
  then show ?thesis
  proof -
    have "\<And>n. iterate n\<cdot>F\<cdot>x \<sqsubseteq> (\<Squnion>n. iterate n\<cdot>F\<cdot>x)"
      using True is_ub_thelub iter_fixg_chain by blast
    then have "x \<sqsubseteq> (\<Squnion>n. iterate n\<cdot>F\<cdot>x)"
      by (metis iterate_0)
    then show ?thesis
      using True by presburger
  qed
next
  case False
  then show ?thesis
    by simp
qed

lemma fixg_mono[simp]:"monofun (\<lambda>F. if x \<sqsubseteq> F\<cdot>x then \<Squnion>i. iterate i\<cdot>F\<cdot>x else x)"
proof(rule monofunI)
   fix xa::"'a \<rightarrow> 'a" and y::"'a \<rightarrow> 'a"
  assume a1:"xa \<sqsubseteq> y"
  show "(if x \<sqsubseteq> xa\<cdot>x then \<Squnion>i. iterate i\<cdot>xa\<cdot>x else x) \<sqsubseteq> (if x \<sqsubseteq> y\<cdot>x then \<Squnion>i. iterate i\<cdot>y\<cdot>x else x)"
  proof(cases "x \<sqsubseteq> xa \<cdot>x")
    case True
    then have "x \<sqsubseteq> y\<cdot>x"
      using a1 cfun_below_iff rev_below_trans by blast
    then show ?thesis
      by (simp add: True a1 lub_iter_fixg_mono_req)
  next
    case False
    then show ?thesis
      by(simp add: fixg_pre)
  qed
qed

lemma fixg_cont[simp]:assumes "\<And> y z. x\<sqsubseteq>z \<and> y\<sqsubseteq>z \<longrightarrow> x\<sqsubseteq>y" shows "cont (\<lambda>F. if x \<sqsubseteq> F\<cdot>x then \<Squnion>i. iterate i\<cdot>F\<cdot>x else x)"
proof(rule Cont.contI2, simp)
fix Y:: "nat \<Rightarrow> ('a \<rightarrow> 'a)"
  assume a1:"chain Y"
  assume a2:"chain (\<lambda>i. if x \<sqsubseteq> Y i\<cdot>x then \<Squnion>ia. iterate ia\<cdot>(Y i)\<cdot>x else x)"
  show "(if x \<sqsubseteq> (\<Squnion>i. Y i)\<cdot>x then \<Squnion>i. iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x else x) \<sqsubseteq> (\<Squnion>i. if x \<sqsubseteq> Y i\<cdot>x then \<Squnion>ia. iterate ia\<cdot>(Y i)\<cdot>x else x)"
  proof(cases "x \<sqsubseteq> (\<Squnion>i. Y i)\<cdot>x")
    case True
    then show ?thesis
    proof(cases "\<exists>i. x \<sqsubseteq> (Y i)\<cdot>x")
      case True
      then have h1:"\<forall>i. x \<sqsubseteq> Y i \<cdot>x"
        by (meson a1 assms cfun_below_iff is_ub_thelub rev_below_trans)
      then have h2:"(\<Squnion>i. if x \<sqsubseteq> Y i\<cdot>x then \<Squnion>ia. iterate ia\<cdot>(Y i)\<cdot>x else x) = (\<Squnion>i.\<Squnion>ia. iterate ia\<cdot>(Y i)\<cdot>x)"
        by simp
      have h3:"(if x \<sqsubseteq> (\<Squnion>i. Y i)\<cdot>x then \<Squnion>i. iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x else x) = (\<Squnion>i. iterate i\<cdot>(\<Squnion>ia. Y ia)\<cdot>x)"
        by (meson True a1 below_trans cfun_below_iff is_ub_thelub)
      have h4:"(\<Squnion>i. iterate i\<cdot>(\<Squnion>ia. Y ia)\<cdot>x) = (\<Squnion>i.\<Squnion>ia. iterate i\<cdot>( Y ia)\<cdot>x)"
        by(simp add: a1 contlub_cfun_fun contlub_cfun_arg)
      show ?thesis
      proof-
        show "(if x \<sqsubseteq> (\<Squnion>i. Y i)\<cdot>x then \<Squnion>i. iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x else x) \<sqsubseteq> (\<Squnion>i. if x \<sqsubseteq> Y i\<cdot>x then \<Squnion>ia. iterate ia\<cdot>(Y i)\<cdot>x else x)"
          by(simp_all add: h2 h3  h4 diag_lub a1 h1 iter_fixg_chain)
      qed
    next
      case False
      have h1:"(\<Squnion>i. Y i)\<cdot>x = x"
      proof-
        have "x \<sqsubseteq> (\<Squnion>i. Y i)\<cdot>x"
          by(simp add: True)
        have "\<forall>i. Y i\<cdot>x \<sqsubseteq> x"
          using False True a1 assms cfun_below_iff is_ub_thelub by blast
        then show "(\<Squnion>i. Y i)\<cdot>x = x"
          by (metis True a1 below_antisym ch2ch_Rep_cfunL contlub_cfun_fun lub_below_iff)
      qed
      have "\<forall>i. iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x = x"
      proof(auto)
        fix i::nat
        show "iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x = x"
        proof(induction i)
          case 0
          then show ?case
            by simp
        next
          case (Suc i)
          then show ?case
            by (simp add: h1)
        qed
      qed
      then have "(\<Squnion>i. iterate i\<cdot>(\<Squnion>i. Y i)\<cdot>x) = x"
        by auto
      then show ?thesis
        using False by auto
    qed
  next
    case False
    then show ?thesis
      using a2 below_lub fixg_pre by fastforce
  qed
qed

lemma fixg_apply: assumes "\<And> y z. x\<sqsubseteq>z \<and> y\<sqsubseteq>z \<longrightarrow> x\<sqsubseteq>y"
  shows "fixg x\<cdot>F = (if x \<sqsubseteq> F\<cdot>x then \<Squnion>i. iterate i\<cdot>F\<cdot>x else x)"
  by (simp add: assms fixg_def)

(*fixg gives the least fixpoint, if x \<sqsubseteq> F\<cdot>x*)

lemma fixg_fix:assumes" x \<sqsubseteq> F\<cdot>x " and "\<And>y z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> y"
  shows "fixg x\<cdot> F = F\<cdot>(fixg x\<cdot>F)"
  apply (simp add: fixg_def assms)
  apply (subst lub_range_shift [of _ 1, symmetric])
  apply(rule chainI)
  apply(subst iterate_Suc2)
  apply(rule Cfun.monofun_cfun_arg, simp add: assms)
  apply (subst contlub_cfun_arg)
  apply(rule chainI)
  apply(subst iterate_Suc2)
  apply(rule Cfun.monofun_cfun_arg, simp add: assms)
  by simp

lemma fixg_least_below:assumes" x \<sqsubseteq> F\<cdot>x " and "\<And>y z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> y" and "x \<sqsubseteq> y"
  shows "F\<cdot>y \<sqsubseteq> y \<Longrightarrow> (fixg x\<cdot> F) \<sqsubseteq> y"
  apply (simp add: fixg_def assms)
  apply (rule lub_below)
  apply(rule chainI)
  apply(subst iterate_Suc2)
  apply(rule Cfun.monofun_cfun_arg, simp add: assms)
  apply (induct_tac i)
  apply (simp add: assms)
  apply (simp add: assms(1))
  apply (erule rev_below_trans)
  by (erule monofun_cfun_arg)

lemma fixg_least_fix:assumes"F\<cdot>y = y" and "x \<sqsubseteq> y" and "x \<sqsubseteq> F\<cdot>x" and "\<And>y z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> y"
  shows "fixg x\<cdot> F \<sqsubseteq> y"
  by(subst fixg_least_below, simp_all add: assms)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_ISortPermutes
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (isort xs) xs"
  oops

end


(*  Title:      Views.thy
    Author:     Sven Linker, University of Liverpool

Defines a type for views on traffic. Consists of closed real valued interval
denoting "extension" (length on the road visible", the visible interval of lanes,
and the owner of the view.

Contains chopping relations on extension and lanes and switching to
different owners.
*)

section\<open>Views on Traffic\<close>
text\<open>
In this section, we define a notion of locality for each car. These
local parts of a road are called \emph{views} and define the part of
the model currently under consideration by a car. In particular, a
view consists of
\begin{itemize}
\item the \emph{extension}, a real-valued interval denoting the distance perceived,
\item the \emph{lanes}, a discrete interval, denoting which lanes are perceived,
\item the \emph{owner}, the car associated with this view.
\end{itemize}
\<close>

theory Views
  imports NatInt RealInt Cars
begin

type_synonym lanes = nat_int
type_synonym extension = real_int

record view =
  ext::extension
  lan ::lanes
  own ::cars

text \<open>
The orders on discrete and continuous intervals induce an order on views.
For two views \(v\) and \(v^\prime\) with \(v \leq v^\prime\), we call \(v\)
a \emph{subview} of \(v^\prime\).\<close>

instantiation  view_ext:: (order) order
begin
definition "less_eq_view_ext (V:: 'a view_ext)  (V':: 'a view_ext)  \<equiv>
     (ext V \<le> ext V') \<and> (lan V \<sqsubseteq>  lan V') \<and> own V = own V'
   \<and> more V \<le> more V'"
definition "less_view_ext (V :: 'a view_ext) (V':: 'a view_ext)  \<equiv>
     (ext V \<le> ext V') \<and> (lan V \<sqsubseteq>  lan V') \<and> own V' = own V
    \<and> more V \<le> more V' \<and>
     \<not>((ext V' \<le> ext V) \<and> (lan V' \<sqsubseteq>  lan V) \<and> own V' = own V
      \<and> more V' \<le> more V)"
instance
proof
  fix v v' v''::  "'a view_ext"
  show "v \<le> v"
    using less_eq_view_ext_def less_eq_nat_int.rep_eq by auto
  show " (v < v') = (v \<le> v' \<and> \<not> v' \<le> v)"
    using less_eq_view_ext_def less_view_ext_def by auto
  show "v \<le> v' \<Longrightarrow> v' \<le> v'' \<Longrightarrow> v \<le> v''"
    using less_eq_view_ext_def less_eq_nat_int.rep_eq order_trans by auto
  show "v \<le> v' \<Longrightarrow> v' \<le> v \<Longrightarrow> v = v'"
    using less_eq_view_ext_def by auto
qed
end

locale view
begin

notation nat_int.maximum ("maximum")
notation nat_int.minimum ("minimum")
notation nat_int.consec ("consec")

text\<open>We lift the chopping relations from discrete and continuous intervals
to views, and introduce new notation for these relations.\<close>

definition       hchop :: "view \<Rightarrow> view \<Rightarrow>  view \<Rightarrow> bool" ("_=_\<parallel>_")
  where "(v=u\<parallel>w) == real_int.R_Chop(ext v)(ext u)(ext w) \<and>
                    lan v=lan u \<and>
                    lan v=lan w \<and>
                    own v = own u \<and>
                    own v = own w \<and>
                    more v = more w \<and>
                    more v = more u  "
definition   vchop :: "view \<Rightarrow> view \<Rightarrow>  view \<Rightarrow> bool" ("_=_--_")
  where "(v=u--w) == nat_int.N_Chop(lan v)(lan u)( lan w) \<and>
                     ext v = ext u \<and>
                     ext v = ext w \<and>
                     own v = own u \<and>
                     own  v = own w \<and>
                     more v = more w \<and>
                     more v = more u "

text\<open>We can also switch the perspective of a view to the car \(c\). That is,
we substitute \(c\) for the original owner of the view.\<close>

definition switch :: "view \<Rightarrow> cars \<Rightarrow> view \<Rightarrow> bool" ("_ = _ > _")
  where   "  (v=c>w) == ext v = ext w \<and>
                        lan v = lan w \<and>
                        own w = c \<and>
                        more v = more w"

text\<open>Most of the lemmas in this theory are direct transfers of the corresponding
lemmas on discrete and continuous intervals, which implies rather simple proofs.
The only exception is
the connection between subviews and the chopping operations. This proof is rather lengthy,
since we need to distinguish several cases, and within each case, we need to
 explicitly construct six different views for the chopping relations.\<close>

lemma h_chop_middle1:"(v=u\<parallel>w) \<longrightarrow> left (ext v) \<le> right (ext u)"
  by (metis hchop_def real_int.rchop_def real_int.left_leq_right)

lemma h_chop_middle2:"(v=u\<parallel>w) \<longrightarrow> right (ext v) \<ge> left (ext w)"
  using real_int.left_leq_right real_int.rchop_def view.hchop_def by auto

lemma horizontal_chop1: " \<exists> u w. (v=u\<parallel>w)"
proof -
  have real_chop:"\<exists>x1 x2.  R_Chop(ext v, x1,x2)"
    using real_int.chop_singleton_left by force
  obtain x1 and x2 where x1_x2_def:" R_Chop(ext v, x1,x2)"
    using real_chop by force
  obtain V1 and V2
    where v1:"V1 = \<lparr> ext = x1, lan = lan v, own = own v\<rparr>"
    and v2:"V2 = \<lparr> ext = x2,lan= lan v, own = own v\<rparr> "  by blast
  from v1 and v2 have "v=V1\<parallel>V2"
    using hchop_def x1_x2_def by (simp)
  thus ?thesis by blast
qed

lemma horizontal_chop_empty_right :"\<forall>v. \<exists> u. (v=v\<parallel>u)"
  using hchop_def real_int.chop_singleton_right
  by (metis (no_types, hide_lams) select_convs)

lemma horizontal_chop_empty_left :"\<forall>v. \<exists>u. (v=u\<parallel>v)"
  using hchop_def real_int.chop_singleton_left
  by (metis (no_types, hide_lams) select_convs)

lemma horizontal_chop_non_empty:
  "\<parallel>ext v\<parallel> > 0 \<longrightarrow> (\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> > 0 \<and> \<parallel>ext w\<parallel>>0)"
proof
  assume "\<parallel>ext v\<parallel> > 0"
  then obtain l1 and l2
    where chop:" R_Chop(ext v, l1,l2) \<and> \<parallel>l1\<parallel> > 0 \<and> \<parallel>l2\<parallel> > 0"
    using real_int.chop_dense by force
  obtain V1 where v1_def:"V1 = \<lparr> ext = l1, lan = lan v, own = own v \<rparr>"
    by simp
  obtain V2 where v2_def:"V2 = \<lparr> ext = l2, lan = lan v, own = own v \<rparr>"
    by simp
  then have  "(v=V1\<parallel>V2) \<and> \<parallel>ext V1\<parallel> > 0 \<and> \<parallel>ext V2\<parallel>>0"
   using  chop hchop_def v1_def by (simp)
  then show " (\<exists>V1 V2. (v=V1\<parallel>V2) \<and> \<parallel>ext V1\<parallel> > 0 \<and> \<parallel>ext V2\<parallel>>0)"
    by blast
qed

lemma horizontal_chop_split_add:
  "x \<ge> 0 \<and> y \<ge> 0 \<longrightarrow> \<parallel>ext v\<parallel> = x+y \<longrightarrow> (\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y)"
proof (rule impI)+
  assume geq_0:"x \<ge> 0 \<and> y \<ge> 0" and len_v:"\<parallel>ext v\<parallel> = x+y"
  obtain u
    where v1_def:
      "u = \<lparr> ext = Abs_real_int (left (ext v), left (ext v) + x), lan = lan v, own = (own v) \<rparr>"
    by simp
  have v1_in_type:"(left (ext v), left (ext v) + x) \<in> {r::(real*real) . fst r \<le> snd r}"
    by (simp add: geq_0)
  obtain w
    where v2_def:
      "w = \<lparr> ext = Abs_real_int (left (ext v)+x, left (ext v) + (x+y)),
             lan = (lan v), own = (own v) \<rparr>" by simp
  have v2_in_type:
    "(left (ext v)+x, left (ext v) + (x+y)) \<in> {r::(real*real) . fst r \<le> snd r}"
    by (simp add: geq_0)
  from v1_def and geq_0 have len_v1:"\<parallel>ext u\<parallel> = x" using v1_in_type
    by (simp add: Abs_real_int_inverse  real_int.length_def)
  from v2_def and geq_0 have len_v2:"\<parallel>ext w\<parallel>= y" using v2_in_type
    by (simp add: Abs_real_int_inverse  real_int.length_def)
  from v1_def and v2_def have "(v=u\<parallel>w)"
    using Abs_real_int_inverse fst_conv hchop_def len_v prod.collapse real_int.rchop_def
      real_int.length_def snd_conv v1_in_type v2_in_type by auto
  with len_v1 and len_v2 have "(v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y" by simp
  thus "(\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y)" by blast
qed

lemma horizontal_chop_assoc1:
  "(v=v1\<parallel>v2) \<and> (v2=v3\<parallel>v4) \<longrightarrow> (\<exists>v'. (v=v'\<parallel>v4) \<and> (v'=v1\<parallel>v3))"
proof
  assume assm:"(v=v1\<parallel>v2) \<and> (v2=v3\<parallel>v4)"
  obtain v'
    where v'_def:
      "v' =\<lparr> ext = Abs_real_int(left (ext v1), right (ext v3)),
             lan = (lan v), own = (own v) \<rparr>"
    by simp
  hence 1:"v=v'\<parallel>v4"
    using assm real_int.chop_assoc1 hchop_def by auto
  have 2:"v'=v1\<parallel>v3" using v'_def assm real_int.chop_assoc1 hchop_def by auto
  from 1 and 2 have "(v=v'\<parallel>v4) \<and>  (v'=v1\<parallel>v3)" by best
  thus "(\<exists>v'. (v=v'\<parallel>v4)  \<and> (v'=v1\<parallel>v3))" ..
qed

lemma horizontal_chop_assoc2:
  "(v=v1\<parallel>v2) \<and> (v1=v3\<parallel>v4) \<longrightarrow> (\<exists>v'. (v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2))"
proof
  assume assm:"(v=v1\<parallel>v2) \<and> (v1=v3\<parallel>v4)"
  obtain v'
    where v'_def:
      "v'=\<lparr> ext = Abs_real_int(left (ext v4),right (ext v2)),
            lan = (lan v), own = (own v) \<rparr>"
    by simp
  hence 1:"v=v3\<parallel>v'"
    using assm fst_conv real_int.chop_assoc2 snd_conv hchop_def by auto
  have 2: "v'=v4\<parallel>v2"
    using assm real_int.chop_assoc2 v'_def hchop_def by auto
  from 1 and 2 have "(v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2)" by best
  thus "(\<exists>v'. (v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2))" ..
qed

lemma horizontal_chop_width_stable:"(v=u\<parallel>w)\<longrightarrow>|lan v|=|lan u|\<and>|lan v|=|lan w|"
  using hchop_def by auto

lemma horizontal_chop_own_trans:"(v=u\<parallel>w) \<longrightarrow> own u = own w"
  using hchop_def by auto

lemma vertical_chop1:"\<forall>v. \<exists> u w. (v=u--w)"
  using vchop_def  nat_int.chop_always_possible
  by (metis (no_types, hide_lams) select_convs)

lemma vertical_chop_empty_down:"\<forall>v.\<exists> u.(v=v--u)"
  using vchop_def nat_int.chop_empty_right
  by (metis (no_types, hide_lams) select_convs)

lemma vertical_chop_empty_up:"\<forall>v.\<exists>u.(v=u--v)"
  using vchop_def nat_int.chop_empty_left
  by (metis (no_types, hide_lams) select_convs)

lemma vertical_chop_assoc1:
  "(v=v1--v2) \<and> (v2=v3--v4) \<longrightarrow> (\<exists>v'. (v=v'--v4) \<and> (v'=v1--v3))"
proof
  assume assm:"(v=v1--v2) \<and> (v2=v3--v4)"
  obtain v'
    where v'_def:"v' =\<lparr> ext = ext v, lan=(lan v1) \<squnion> (lan v3), own = (own v) \<rparr>"
    by simp
  then have 1:"v=v'--v4"
    using assm nat_int.chop_assoc1 vchop_def by auto
  have 2:"v'=v1--v3"
    using v'_def assm nat_int.chop_assoc1 vchop_def by auto
  from 1 and 2 have "(v=v'--v4) \<and>  (v'=v1--v3)" by best
  then show "(\<exists>v'. (v=v'--v4)  \<and> (v'=v1--v3))" ..
qed

lemma vertical_chop_assoc2:
  "(v=v1--v2) \<and> (v1=v3--v4) \<longrightarrow> (\<exists>v'. (v=v3--v') \<and> (v'=v4--v2))"
proof
  assume assm:"(v=v1--v2) \<and> (v1=v3--v4)"
  obtain v'
    where v'_def:"v'=\<lparr> ext = ext v, lan =(lan v4) \<squnion> (lan v2), own = (own v) \<rparr>"
    by simp
  then have 1:"v=v3--v'"
    using assm fst_conv nat_int.chop_assoc2 snd_conv vchop_def by auto
  have 2: "v'=v4--v2"
    using assm nat_int.chop_assoc2 v'_def vchop_def by auto
  from 1 and 2 have "(v=v3--v') \<and> (v'=v4--v2)" by best
  then show "(\<exists>v'. (v=v3--v') \<and> (v'=v4--v2))" ..
qed

lemma vertical_chop_singleton:
  "(v=u--w) \<and> |lan v| = 1 \<longrightarrow> ( |lan u| = 0 \<or> |lan w| = 0)"
  using nat_int.chop_single vchop_def Rep_nat_int_inverse
  by fastforce

lemma vertical_chop_add1:"(v=u--w) \<longrightarrow> |lan v| = |lan u| + |lan w|"
  using nat_int.chop_add1 vchop_def by fastforce

lemma vertical_chop_add2:
  "|lan v| = x+y \<longrightarrow> (\<exists> u w.  (v=u--w) \<and> |lan u| = x \<and> |lan w| = y)"
proof
  assume assm:"|lan v| = x+y"
  hence add:"\<exists>i j. N_Chop(lan v, i,j) \<and> |i| = x \<and> |j| = y"
    using chop_add2 by blast
  obtain i and j where l1_l2_def:"N_Chop(lan v, i,j) \<and> |i| = x \<and> |j| = y"
    using add by blast
  obtain u and w where "u=\<lparr>ext =  ext v, lan = i, own = (own v) \<rparr>"
    and "w = \<lparr> ext = ext v, lan = j, own = (own v) \<rparr> " by blast
  hence "(v=u--w) \<and> |lan u|=x \<and> |lan w|=y"
    using l1_l2_def view.vchop_def
    by (simp)
  thus "(\<exists> u w.  (v=u--w) \<and> |lan u| = x \<and> |lan w| = y)" by blast
qed

lemma vertical_chop_length_stable:
  "(v=u--w) \<longrightarrow> \<parallel>ext v\<parallel> = \<parallel>ext u\<parallel> \<and> \<parallel>ext v\<parallel> = \<parallel>ext w\<parallel>"
  using vchop_def by auto

lemma vertical_chop_own_trans:"(v=u--w) \<longrightarrow> own u = own w"
  using vchop_def by auto

lemma vertical_chop_width_mon:
  "(v=v1--v2) \<and> (v2=v3--v4) \<and> |lan v3| = x \<longrightarrow> |lan v| \<ge> x"
  by (metis le_add1 trans_le_add2 vertical_chop_add1)

lemma horizontal_chop_leq1:"(v=u\<parallel>w) \<longrightarrow> u \<le> v"
  using real_int.chop_leq1 hchop_def less_eq_view_ext_def order_refl by fastforce

lemma horizontal_chop_leq2:"(v=u\<parallel>w) \<longrightarrow> w \<le> v"
  using real_int.chop_leq2 hchop_def less_eq_view_ext_def order_refl by fastforce

lemma vertical_chop_leq1:"(v=u--w) \<longrightarrow> u \<le> v"
  using nat_int.chop_subset1 vchop_def less_eq_view_ext_def order_refl by fastforce

lemma vertical_chop_leq2:"(v=u--w) \<longrightarrow> w \<le> v"
  using nat_int.chop_subset2 vchop_def less_eq_view_ext_def order_refl by fastforce

lemma somewhere_leq:
  "v \<le> v' \<longleftrightarrow> (\<exists>v1 v2 v3 vl vr vu vd.
                (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu))"
proof
  assume "v \<le> v'"
  hence assm_exp:"(ext v \<le> ext v') \<and> (lan v \<sqsubseteq> lan v') \<and> (own v = own v')"
    using less_eq_view_ext_def by auto
  obtain vl v1 v2 vr
    where
      vl:"vl=\<lparr>ext=Abs_real_int(left(ext v'),left(ext v)), lan=lan v', own=own v'\<rparr>"
    and
      v1:"v1=\<lparr>ext=Abs_real_int(left(ext v),right(ext v')), lan=lan v', own=own v'\<rparr>"
    and
      v2:"v2=\<lparr>ext=Abs_real_int(left(ext v),right(ext v)), lan=lan v', own=own v'\<rparr>"
    and
      vr:"vr=\<lparr>ext=Abs_real_int(right(ext v),right(ext v')), lan=lan v', own=own v'\<rparr>"
    by blast
  have vl_in_type:"(left (ext v'), left (ext v)) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv
      fst_conv mem_Collect_eq by simp
  have v1_in_type:"(left (ext v), right (ext v')) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv fst_conv
      mem_Collect_eq order_trans by fastforce
  have v2_in_type:"(left (ext v), right (ext v)) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv fst_conv
      mem_Collect_eq order_trans by fastforce
  have vr_in_type:"(right (ext v), right (ext v')) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv fst_conv
      mem_Collect_eq order_trans by fastforce
  then have hchops:"(v'=vl\<parallel>v1)\<and> (v1=v2\<parallel>vr)"
    using vl v1 v2 vr less_eq_real_int_def hchop_def real_int.rchop_def
     vl_in_type  v1_in_type  v2_in_type vr_in_type Abs_real_int_inverse by auto
  have lanes_v2:"lan v2 = lan v'" using v2 by auto
  have own_v2:"own v2 = own v'" using v2 by auto
  have ext_v2:"ext v2 =ext v"
    using v2 v2_in_type Abs_real_int_inverse  by (simp add: Rep_real_int_inverse)
  show
    "\<exists>v1 v2 v3 vl vr vu vd. (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu)"
  proof (cases "lan v' = lan v")
    case True
    obtain vd v3 vu
      where vd:"vd = \<lparr> ext = ext v2, lan = \<emptyset>, own = own v'\<rparr>"
      and v3:"v3 = \<lparr> ext = ext v2, lan = lan v', own = own v' \<rparr>"
      and vu:"vu = \<lparr> ext = ext v2, lan = \<emptyset>, own = own v' \<rparr>" by blast
    hence "(v2=vd--v3) \<and> (v3=v--vu)"
      using vd v3 vu True vchop_def nat_int.nchop_def nat_int.un_empty_absorb1
        nat_int.un_empty_absorb2 nat_int.inter_empty1 nat_int.inter_empty2 lanes_v2
        own_v2 ext_v2 assm_exp by auto
    then show ?thesis using hchops by blast
  next
    case False
    then have v'_neq_empty:"lan v' \<noteq> \<emptyset>"
      by (metis assm_exp nat_int.card_empty_zero nat_int.card_non_empty_geq_one
          nat_int.card_subset_le le_0_eq)
    show ?thesis
    proof (cases "lan v \<noteq> \<emptyset>")
      case False
      obtain vd v3 vu where vd:"vd = \<lparr> ext = ext v2, lan = \<emptyset>, own = own v'\<rparr>"
        and v3:"v3 = \<lparr> ext = ext v2, lan = lan v', own = own v' \<rparr>"
        and vu:"vu = \<lparr> ext = ext v2, lan = lan v', own = own v' \<rparr>" by blast
      then have "(v2=vd--v3) \<and> (v3=v--vu)"
        using vd v3 vu False vchop_def nat_int.nchop_def
          nat_int.un_empty_absorb1 nat_int.un_empty_absorb2
          nat_int.inter_empty1 nat_int.inter_empty2 lanes_v2 own_v2 ext_v2 assm_exp
        by auto
      then show ?thesis
        using hchops by blast
    next
      case True
      show ?thesis
      proof (cases "(minimum (lan v)) = minimum(lan v')")
        assume min:"minimum ( lan v) = minimum (lan v')"
        hence max:"maximum (lan v) <maximum (lan v')"
          by (metis Rep_nat_int_inverse assm_exp atLeastatMost_subset_iff leI le_antisym
              nat_int.leq_max_sup nat_int.leq_min_inf nat_int.maximum_def nat_int.minimum_def
              nat_int.rep_non_empty_means_seq less_eq_nat_int.rep_eq False True
              v'_neq_empty)
        obtain vd v3 vu
          where vd:"vd = \<lparr> ext = ext v2, lan = \<emptyset>, own = own v'\<rparr>"
          and v3:"v3 = \<lparr> ext = ext v2, lan = lan v', own = own v' \<rparr>"
          and vu:"vu = \<lparr> ext = ext v2, lan =
            Abs_nat_int({maximum(lan v)+1..maximum(lan v')}), own = own v' \<rparr>"
          by blast
        have vu_in_type:
          "{maximum(lan v)+1 ..maximum(lan v')} \<in> {S.(\<exists> (m::nat) n.{m..n }=S)}"
          using max by auto
        have consec:"consec (lan v) (lan vu)" using max
          by (simp add:  Suc_leI   nat_int.consec_def nat_int.leq_min_inf'
              nat_int.leq_nat_non_empty True  vu)
        have disjoint:" lan v \<sqinter>  lan vu = \<emptyset>"
          by (simp add: consec nat_int.consec_inter_empty)
        have union:"lan v' = lan v \<squnion> lan vu"
          by (metis Suc_eq_plus1 Suc_leI consec leq_max_sup' max min
              nat_int.consec_un_equality nat_int.consec_un_max nat_int.consec_un_min
              select_convs(2) v'_neq_empty vu)
        then have "(v2=vd--v3) \<and> (v3=v--vu)"
          using vd v3 vu vchop_def nat_int.nchop_def nat_int.un_empty_absorb1
            nat_int.un_empty_absorb2 nat_int.inter_empty1 nat_int.inter_empty2
            lanes_v2 own_v2 ext_v2 assm_exp vu_in_type  Abs_nat_int_inverse
            consec union disjoint select_convs
          by force
        then show ?thesis using hchops by blast
      next
        assume "(minimum (lan v)) \<noteq> minimum (lan v')"
        then have  min:"minimum ( lan v) > minimum (lan v')"
          by (metis Min_le True assm_exp finite_atLeastAtMost le_neq_implies_less
              less_eq_nat_int.rep_eq nat_int.el.rep_eq nat_int.minimum_def
              nat_int.minimum_in rep_non_empty_means_seq subsetCE v'_neq_empty)
        show ?thesis
        proof (cases "(maximum (lan v)) = maximum (lan v')")
          assume max:"maximum(lan v) = maximum (lan v')"
          obtain vd v3 vu
            where
              vd:"vd =
              \<lparr> ext = ext v2,
                lan = Abs_nat_int ({minimum(lan v')..minimum(lan v)-1}),
                own = own v'\<rparr>"
            and
            v3:"v3 = \<lparr> ext = ext v2, lan = lan v, own = own v' \<rparr>"
            and
            vu:"vu = \<lparr> ext = ext v2, lan = \<emptyset> , own = own v' \<rparr>" by blast
          have consec:"consec (lan vd) (lan v)"
            using True leq_max_sup' leq_nat_non_empty min
              nat_int.consec_def vd by auto
          have "maximum (lan vd \<squnion> lan v) = maximum (lan v)"
            using consec consec_un_max by auto
          then have max':"maximum (lan vd \<squnion> lan v) = maximum (lan v')"
            by (simp add: max)
          have "minimum (lan vd \<squnion> lan v) = minimum (lan vd)"
            using consec consec_un_min by auto
          then have min':"minimum (lan vd \<squnion> lan v) = minimum (lan v')"
            by (metis atLeastatMost_empty_iff vd bot_nat_int.abs_eq consec
                nat_int.consec_def nat_int.leq_min_inf' select_convs(2))
          have union:" lan v' = lan vd \<squnion> lan v"
            using consec max' min' nat_int.consec_un_equality v'_neq_empty
            by fastforce
          then have "(v2=vd--v3) \<and> (v3=v--vu)"
            using assm_exp consec ext_v2 lanes_v2 nat_int.nchop_def nat_int.un_empty_absorb1
              own_v2 v3 vd view.vchop_def vu by force
          then show ?thesis
            using hchops by blast
        next
          assume "(maximum (lan v)) \<noteq> maximum (lan v')"
          then have max:"maximum (lan v) < maximum (lan v')"
            by (metis assm_exp atLeastatMost_subset_iff nat_int.leq_max_sup
                nat_int.maximum_def nat_int.rep_non_empty_means_seq less_eq_nat_int.rep_eq
                True order.not_eq_order_implies_strict v'_neq_empty)
          obtain vd v3 vu
            where vd:
              "vd = \<lparr> ext = ext v2,
                      lan = Abs_nat_int ({minimum(lan v')..minimum(lan v)-1}),
                      own = own v'\<rparr>"
            and v3:
            "v3 = \<lparr> ext = ext v2, lan = lan v \<squnion> lan vu, own = own v' \<rparr>"
            and vu:
            "vu = \<lparr> ext = ext v2,
                    lan = Abs_nat_int ({maximum(lan v)+1..maximum(lan v')}),
                    own = own v' \<rparr>" by blast
          have consec:"consec (lan v) (lan vu)"
            using True leq_nat_non_empty max nat_int.consec_def nat_int.leq_min_inf'
              vu
            by auto
          have union:"lan v3 = lan v \<squnion> lan vu"
            by (simp add: v3 min max consec)
          then have chop1:" (v3=v--vu)"
            using assm_exp consec ext_v2 nat_int.nchop_def v3 view.vchop_def
              vu
            by auto
          have min_eq:"minimum (lan v3) = minimum (lan v)"
            using chop1 consec nat_int.chop_min vchop_def by blast
          have neq3:"lan v3 \<noteq> \<emptyset>"
            by (metis bot.extremum_uniqueI consec nat_int.consec_def nat_int.un_subset2
                union)
          have consec2:"consec (lan vd) (lan v3)"
            using min consec union min_eq Suc_leI nat_int.consec_def nat_int.leq_max_sup'
              nat_int.leq_min_inf' nat_int.leq_nat_non_empty neq3 v3 vd
            by (auto)
          have "minimum (lan vd \<squnion> lan v3) = minimum (lan vd)"
            using consec2 consec_un_min by auto
          then have min':"minimum (lan vd \<squnion> lan v3) = minimum (lan v')"
            by (metis vd atLeastatMost_empty_iff2 bot_nat_int.abs_eq consec2 leq_min_inf'
                nat_int.consec_def select_convs(2))
          have "maximum (lan vd \<squnion>lan v3) = maximum (lan v3)"
            using consec2 consec_un_max by auto
          then have "maximum (lan vd \<squnion>lan v3) = maximum (lan vu)"
            using consec consec_un_max union by auto
          then have max':"maximum (lan vd \<squnion>lan v3) = maximum (lan v')"
            by (metis Suc_eq_plus1 Suc_leI max nat_int.leq_max_sup'
                select_convs(2) vu)
          have union2:" lan v' = lan vd \<squnion> lan v3"
            using min max consec2 neq3 min' max' nat_int.consec_un_equality v'_neq_empty
            by force
          have "(v2=vd--v3) \<and> (v3=v--vu)"
            using union2 chop1 consec2 nat_int.nchop_def v2 v3 vd
              view.vchop_def
            by fastforce
          then show ?thesis using hchops by blast
        qed
      qed
    qed
  qed
next
  assume
    "\<exists>v1 v2 v3 vl vr vu vd. (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu)"
  then obtain v1 v2 v3 vl vr vu vd
    where " (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu)" by blast
  then show "v \<le> v'"
    by (meson horizontal_chop_leq1 horizontal_chop_leq2 order_trans vertical_chop_leq1
        vertical_chop_leq2)
qed

text\<open>The switch relation is compatible with the chopping relations, in the
following sense. If we can chop a view \(v\) into two subviews \(u\) and
\(w\), and we can reach \(v^\prime\) via the switch relation, then
there also exist two subviews \(u^\prime\), \(w^\prime\) of \(v^\prime\),
such that \(u^\prime\) is reachable from \(u\) (and respectively for \(w^\prime\), \(w\)).
\<close>
  (* switch lemmas *)
lemma switch_unique:"(v =c> u) \<and> (v =c> w) \<longrightarrow>u = w"
  using switch_def by auto

lemma switch_exists:"\<exists>c u.( v=c>u)"
  using switch_def by auto

lemma switch_always_exists:"\<forall>c. \<exists>u. (v=c>u)"
  by (metis select_convs switch_def)

lemma switch_origin:" \<exists>u. (u=(own v)>v)"
  using switch_def  by auto

lemma switch_refl:"(v=(own v)>v)"
  by (simp add:switch_def)

lemma switch_symm:"(v=c>u) \<longrightarrow> (u=(own v)>v)"
  by (simp add:switch_def)

lemma switch_trans:"(v=c>u) \<and> (u=d>w) \<longrightarrow> (v=d>w)"
  by (simp add: switch_def)

lemma switch_triangle:"(v=c>u) \<and> (v=d>w) \<longrightarrow> (u=d>w)"
  using switch_def by auto

lemma switch_hchop1:
  "(v=v1\<parallel>v2) \<and> (v=c>v') \<longrightarrow>
     (\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'\<parallel>v2'))"
  by (metis (no_types, hide_lams) select_convs view.hchop_def view.switch_def)

lemma switch_hchop2:
  "(v'=v1'\<parallel>v2') \<and> (v=c>v') \<longrightarrow>
      (\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1\<parallel>v2))"
  by (metis (no_types, hide_lams) select_convs view.hchop_def view.switch_def)

lemma switch_vchop1:
  "(v=v1--v2) \<and> (v=c>v') \<longrightarrow>
      (\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'--v2'))"
  by (metis (no_types, hide_lams) select_convs view.vchop_def view.switch_def)

lemma switch_vchop2:
  "(v'=v1'--v2') \<and> (v=c>v') \<longrightarrow>
       (\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1--v2))"
  by (metis (no_types, hide_lams) select_convs view.vchop_def view.switch_def)

lemma switch_leq:"u' \<le> u \<and> (v=c>u) \<longrightarrow> (\<exists>v'. (v'=c>u') \<and> v' \<le> v)"
proof
  assume assm: "u' \<le> u \<and> (v=c>u)"
  then have more_eq:"more v = more u"
    using view.switch_def by blast
  then obtain v' where v'_def:"v'= \<lparr> ext =ext u', lan = lan u', own = own v\<rparr>"
    by blast
  have ext:"ext v' \<le> ext v" using assm switch_def
    by (simp add: less_eq_view_ext_def v'_def)
  have lan:"lan v' \<le> lan v" using assm switch_def
    by (simp add: less_eq_view_ext_def v'_def)
  have more:"more v' \<le> more v" using more_eq assm by simp
  have less: "v' \<le> v" using less_eq_view_ext_def ext lan more v'_def
    by (simp add: less_eq_view_ext_def)
  have switch:"v' =c> u'" using v'_def switch_def assm
    by (simp add: less_eq_view_ext_def)
  show  "(\<exists>v'. ( v' = c > u') \<and> v' \<le> v)" using switch less by blast
qed
end
end