(* Title:      Small-Gain Theorem
   Author:     Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
   Maintainer: Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
*)

theory Small_Gain_Theorem
imports
"~~/src/HOL/Probability/Analysis"
"~~/src/HOL/Probability/Probability"
"~~/src/HOL/Library/Function_Algebras"
"~~/L2Norm_Integral"
begin

section \<open> Definitions of Signals\<close>

text \<open>Time Interval Definition\<close>

definition T :: "real set"
  where "T ={t.  (0\<le>t \<and> t<\<infinity>)}"

definition T\<^sub>\<tau> :: "real set"
  where "T\<^sub>\<tau> ={t. (\<forall>\<tau>\<in>T.  0\<le>t \<and> t\<le>\<tau> )}"

lemma T\<^sub>\<tau>_subset_T: "T\<^sub>\<tau> \<subseteq> T"
  using T\<^sub>\<tau>_def T_def by auto

text \<open>Signal Range Definition\<close>

definition R :: "real set"
  where "R ={r.  (-\<infinity><r \<and> r<\<infinity>)}"

text \<open>Signal Definition\<close>

definition Signal ::"(real \<Rightarrow> real) \<Rightarrow> bool"
  where "Signal u = (\<forall>t\<in>T. \<exists>!x\<in>R.  x = u t \<and>  u:T\<rightarrow>R \<and> u t\<in> u ` T \<and> u piecewise_differentiable_on T
                    \<and> continuous_on T u)"

lemma signal_integration_bound:
fixes M
assumes "Signal u"
    and "set_integrable M T u"
  shows "(LINT  t:T|M. (u t)\<^sup>2) < \<infinity>"
using assms by simp

lemma sig1: "Signal u \<Longrightarrow> \<forall>t\<in>T. u t \<in> range (\<lambda>t\<in>T. u t)"
  by auto

lemma sig2: "Signal u \<Longrightarrow> \<forall>t\<in>T. u t \<in> R"
  using Signal_def by blast

lemma sig3: "Signal u \<Longrightarrow> range (\<lambda>t\<in>T. u t) \<subseteq> R"
  unfolding Signal_def  by (simp add:R_def)

lemma sig4: "Signal u \<Longrightarrow>\<forall> A. range (\<lambda>t\<in>T. u t) = (\<lambda>t\<in>T. u t) ` A \<Longrightarrow> A\<subseteq>T "
  using  Signal_def  by blast

section \<open>Definitions of Signals Space\<close>

consts
 signal_prod :: " real  \<Rightarrow> 'a   \<Rightarrow> 'a "  (infixl "\<cdot>"  70)

text \<open>\<open>Domain Space Definition\<close>\<close>

locale Domain_Space =
fixes  D :: "(real \<Rightarrow> real) set"
assumes non_empty_D [iff, intro?]: "D \<noteq> {}"
    and spaceD_mem [iff]: "range (\<lambda>t\<in>T. u t)\<subseteq>R \<Longrightarrow>\<lbrakk>range (\<lambda>t\<in>T. u t) = (\<lambda>t\<in>T. u t)`A \<Longrightarrow>A\<subseteq>T\<rbrakk>\<Longrightarrow>(\<lambda>t\<in>T. u t)\<in>D"
    and spaceD_add1[iff]: "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow> u + s \<in> D"
    and spaceD_add2[simp]:"u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow> u + s = (\<lambda>t\<in>T. u t + s t)"
    and spaceD_add3 :     "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow> u + s = s + u"
    and spaceD_add_assoc: "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow> g\<in>D \<Longrightarrow> (u + s) + g = u + (s + g) "
    and spaceD_pointwise[simp]:"u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow>\<forall>t\<in>T. (u + s)t = u t + s t"
    and spaceD_sub[iff]:       "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow> u - s \<in> D"
    and spaceD_mult1[iff]:     "u\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow> (a \<cdot> u) \<in>D"
    and spaceD_mult2:          "u\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow>\<forall>t\<in>T. (a \<cdot> u)t = a * u t"
    and spaceD_mult_distr1:    "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow> a \<cdot> (u + s) = a \<cdot> u + a \<cdot> s"
    and spaceD_mult_distr2:    "u\<in>D \<Longrightarrow> s\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow>\<forall>t\<in>T.  a \<cdot> (u + s)t = a * u t + a * s t"
    and spaceD_mult_distr3:    "u\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow>b\<in>\<real>\<Longrightarrow> (a + b) \<cdot> u  = a \<cdot> u + b \<cdot> u"
    and spaceD_mult_assoc:     "u\<in>D \<Longrightarrow>a\<in>\<real>\<Longrightarrow>b\<in>\<real>\<Longrightarrow> (a * b) \<cdot> u  = a \<cdot> (b \<cdot> u)"

text \<open>\<open>Range Space Definition\<close>\<close>

locale Range_Space =
fixes  G :: "(real \<Rightarrow> real) set"
assumes non_empty_G [iff, intro?]: "G \<noteq> {}"
    and spaceG_mem[iff]:  "range (\<lambda>t\<in>T. y t)\<subseteq>R \<Longrightarrow> \<lbrakk>range (\<lambda>t\<in>T. y t) = (\<lambda>t\<in>T. y t)`B \<Longrightarrow>B\<subseteq>T\<rbrakk> \<Longrightarrow> (\<lambda>t\<in>T. y t)\<in>G"
    and spaceG_add1[iff]: "y\<in>G \<Longrightarrow> z\<in>G \<Longrightarrow> y + z \<in>G"
    and spaceG_add2[simp]:"y\<in>G \<Longrightarrow> z\<in>G \<Longrightarrow> y + z = (\<lambda>t\<in>T. y t + z t)"
    and spaceG_add3 :     "y\<in>G \<Longrightarrow> z\<in>G \<Longrightarrow> y + z = z + y"
    and spaceG_add_assoc: "y\<in>G \<Longrightarrow> z\<in>G \<Longrightarrow> j\<in>G \<Longrightarrow> (y + z) + j = y + (z + j) "
    and spaceG_pointwise[simp]:"y\<in>G \<Longrightarrow> z\<in>G \<Longrightarrow>\<forall>t\<in>T. (y + z)t = y t + z t"
    and spaceG_mult1[iff]:     "y\<in>G  \<Longrightarrow>a\<in>\<real>\<Longrightarrow> (a \<cdot> y) \<in>G"
    and spaceG_mult2 :         "y\<in>G  \<Longrightarrow>a\<in>\<real>\<Longrightarrow>\<forall>t\<in>T. (a \<cdot> y)t = a * y t"
    and spaceG_mult_distr1 :   "y\<in>G \<Longrightarrow> z\<in>G  \<Longrightarrow>a\<in>\<real>\<Longrightarrow> a \<cdot> (y + z) = a \<cdot> y + a \<cdot> z"
    and spaceG_mult_distr2 :   "y\<in>G \<Longrightarrow> z\<in>G  \<Longrightarrow>a\<in>\<real>\<Longrightarrow>\<forall>t\<in>T.  a \<cdot> (y + z)t = a * y t + a * z t"
    and spaceG_mult_distr3 :   "y\<in>G \<Longrightarrow>a\<in>\<real>\<Longrightarrow>b\<in>\<real>\<Longrightarrow> (a + b) \<cdot> y  = a \<cdot> y + b \<cdot> y"
    and spaceG_mult_assoc :    "y\<in>G  \<Longrightarrow>a\<in>\<real>\<Longrightarrow>b\<in>\<real>\<Longrightarrow> (a * b) \<cdot> y  = a \<cdot> (b \<cdot> y)"

text \<open>\<open>Operator Space Definition\<close>\<close>

locale Operator_Space =
fixes  OP :: "((real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real)) set"
assumes  non_empty_OP [iff, intro?]: "OP \<noteq> {}"
    and  spaceG_mem [iff]:"Domain_Space D \<Longrightarrow> Range_Space G \<Longrightarrow> H\<in>OP"
    and  asm_op1 [iff] :  "H\<in>OP \<Longrightarrow>Domain_Space D\<Longrightarrow>Range_Space G\<Longrightarrow> H: D\<rightarrow>G "
    and  asm_op2 [iff] :  "H\<in>OP \<Longrightarrow>Domain_Space D\<Longrightarrow>Range_Space G\<Longrightarrow> H: G\<rightarrow>D "
    and  asm_op3 [iff] :  "H\<in>OP \<Longrightarrow>range H \<subseteq> T\<rightarrow>R"
    and  asm_op4 [iff] :  "H\<in>OP \<Longrightarrow>Domain_Space D\<Longrightarrow>Range_Space G\<Longrightarrow> H: D\<rightarrow>G \<Longrightarrow>range H = H`D \<Longrightarrow>D \<subseteq> T\<rightarrow>R "
    and  asm_op5 [iff] :  "H\<in>OP \<Longrightarrow>Domain_Space D\<Longrightarrow>Range_Space G\<Longrightarrow> H: G\<rightarrow>D \<Longrightarrow>range H = H`G \<Longrightarrow>G \<subseteq> T\<rightarrow>R "
    and  asm_op6 : "H\<in>OP \<Longrightarrow> Domain_Space D \<Longrightarrow> Range_Space G \<Longrightarrow> s\<in>D \<Longrightarrow> z\<in>G \<Longrightarrow> z= H(s)"

definition Signal_Y :: "(real \<Rightarrow> real) \<Rightarrow> ((real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> ((real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real) set \<Rightarrow> bool"
  where  "Signal_Y y H e OP = (\<forall>a. \<exists>!b.  (a=e \<and> b=y \<and>Operator_Space OP \<and> H\<in>OP \<and> range y \<subseteq> R ) \<longrightarrow>   y = H e )"

(* signal truncation *)
definition trunc :: "(real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> real set \<Rightarrow> real set \<Rightarrow> bool"
  where "trunc u u\<^sub>\<tau> U U\<^sub>\<tau> = (Signal u \<and> u ` T = U \<and> (\<forall>\<tau>\<in>T. \<forall>t\<in>T. if t\<le>\<tau> then ((u t\<in>U \<longrightarrow> u t\<in>U\<^sub>\<tau>) \<and> u t = u\<^sub>\<tau> t)
                           else ((u t\<in>U \<longrightarrow> 0\<in>U\<^sub>\<tau>) \<and> u\<^sub>\<tau> t=0 )))"

text \<open>\<open>Truncation Space Definition\<close>\<close>

locale TR_Space =
  fixes  TR :: "(real \<Rightarrow> real) set"
  assumes non_empty_TR [iff, intro?]: "TR \<noteq> {}"
      and spaceTR_mem [iff]: "trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> (\<lambda>t\<in>T\<^sub>\<tau>. u\<^sub>\<tau> t)\<in>TR"
      and spaceTR_1:      "trunc u u\<^sub>\<tau> U U\<^sub>\<tau>\<Longrightarrow> u\<^sub>\<tau>\<in>TR \<Longrightarrow> U\<^sub>\<tau> \<inter> U =  u\<^sub>\<tau> ` T\<^sub>\<tau>"
      and spaceTR_2[iff]: "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>\<Longrightarrow>trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>\<Longrightarrow> e\<^sub>1\<^sub>\<tau>= u\<^sub>1\<^sub>\<tau> - (H\<^sub>2 e\<^sub>2\<^sub>\<tau>)
                           \<Longrightarrow> e\<^sub>2\<^sub>\<tau>= u\<^sub>2\<^sub>\<tau> + (H\<^sub>1 e\<^sub>1\<^sub>\<tau>) \<Longrightarrow>u\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>u\<^sub>2\<^sub>\<tau>\<in>TR\<Longrightarrow>e\<^sub>1\<^sub>\<tau>\<in>TR"
      and spaceTR_3[iff]: "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>\<Longrightarrow>trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>\<Longrightarrow> e\<^sub>1\<^sub>\<tau>= u\<^sub>1\<^sub>\<tau> - (H\<^sub>2 e\<^sub>2\<^sub>\<tau>)
                           \<Longrightarrow> e\<^sub>2\<^sub>\<tau>= u\<^sub>2\<^sub>\<tau> + (H\<^sub>1 e\<^sub>1\<^sub>\<tau>) \<Longrightarrow>u\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>u\<^sub>2\<^sub>\<tau>\<in>TR\<Longrightarrow>e\<^sub>2\<^sub>\<tau>\<in>TR"
      and spaceTR_4[iff]: "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>\<Longrightarrow>trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>\<Longrightarrow> e\<^sub>1\<^sub>\<tau>= u\<^sub>1\<^sub>\<tau> - (H\<^sub>2 e\<^sub>2\<^sub>\<tau>) \<Longrightarrow> e\<^sub>2\<^sub>\<tau>= u\<^sub>2\<^sub>\<tau> + (H\<^sub>1 e\<^sub>1\<^sub>\<tau>)
                           \<Longrightarrow> Signal_Y y\<^sub>1\<^sub>\<tau> H\<^sub>1 e\<^sub>1\<^sub>\<tau> OP \<Longrightarrow>u\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>u\<^sub>2\<^sub>\<tau>\<in>TR\<Longrightarrow>e\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>  e\<^sub>2\<^sub>\<tau>\<in>TR \<Longrightarrow> y\<^sub>1\<^sub>\<tau>\<in>TR "
      and spaceTR_5[iff]: "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>\<Longrightarrow>trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>\<Longrightarrow> e\<^sub>1\<^sub>\<tau>= u\<^sub>1\<^sub>\<tau> - (H\<^sub>2 e\<^sub>2\<^sub>\<tau>) \<Longrightarrow> e\<^sub>2\<^sub>\<tau>= u\<^sub>2\<^sub>\<tau> + (H\<^sub>1 e\<^sub>1\<^sub>\<tau>)
                           \<Longrightarrow> Signal_Y y\<^sub>2\<^sub>\<tau> H\<^sub>2 e\<^sub>2\<^sub>\<tau> OP
                           \<Longrightarrow>u\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>u\<^sub>2\<^sub>\<tau>\<in>TR\<Longrightarrow>e\<^sub>1\<^sub>\<tau>\<in>TR\<Longrightarrow>  e\<^sub>2\<^sub>\<tau>\<in>TR \<Longrightarrow> y\<^sub>2\<^sub>\<tau>\<in>TR "
      and spaceTR_6 :     "trunc u u\<^sub>\<tau> U U\<^sub>\<tau>\<Longrightarrow>Signal_Y y H e OP\<Longrightarrow> Signal_Y y\<^sub>\<tau> H e\<^sub>\<tau> OP\<Longrightarrow> e\<^sub>\<tau>\<in>TR \<Longrightarrow> y\<^sub>\<tau>\<in>TR
                           \<Longrightarrow> y\<^sub>\<tau> ` T\<^sub>\<tau> \<subseteq> range y\<^sub>\<tau> \<inter> range y"

(* Some lemmas for truncation definition *)

lemma tr1:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> \<exists>t\<in>T.  u\<^sub>\<tau> t\<in>U\<^sub>\<tau> "
  unfolding trunc_def using T_def by force

lemma tr1a:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> \<forall>t\<in>T\<^sub>\<tau>.  u\<^sub>\<tau> t\<in>U\<^sub>\<tau> "
  unfolding trunc_def using T\<^sub>\<tau>_subset_T subset_eq by fastforce

lemma tr1b:" trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t>\<tau> \<longrightarrow>  0\<in>U\<^sub>\<tau> "
  unfolding trunc_def using T_def by force

lemma tr1c:" trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t>\<tau> \<and> t\<notin>T\<^sub>\<tau> \<longrightarrow> 0\<in>U\<^sub>\<tau> "
  unfolding trunc_def using T_def by fastforce

lemma tr1d:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>  u\<^sub>\<tau> ` T\<^sub>\<tau> \<subseteq> U\<^sub>\<tau>"
  unfolding trunc_def using T\<^sub>\<tau>_subset_T by force

lemma tr1e:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> u\<^sub>\<tau> ` T\<^sub>\<tau>  \<subseteq> U"
  unfolding trunc_def using T\<^sub>\<tau>_subset_T by force

lemma tr1f:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> u\<^sub>\<tau> ` T\<^sub>\<tau>  \<subseteq>  u ` T"
  unfolding trunc_def using T\<^sub>\<tau>_subset_T image_iff image_subsetI subsetCE by fastforce

lemma tr1g:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> u ` T\<^sub>\<tau> =  u\<^sub>\<tau> ` T\<^sub>\<tau>"
  unfolding trunc_def using T\<^sub>\<tau>_subset_T by force

lemma tr3:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t>\<tau> \<longrightarrow>  u\<^sub>\<tau> t\<in>U\<^sub>\<tau> \<and> u\<^sub>\<tau> t=0 "
  unfolding trunc_def by force

lemma tr6:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> \<forall>\<tau>\<in>T. \<forall>t\<in>T. t>\<tau> \<Longrightarrow> \<forall>t\<in>T\<^sub>\<tau>.  \<not>(u\<^sub>\<tau> ` T\<^sub>\<tau>  \<subseteq> U) "
  using T\<^sub>\<tau>_subset_T by fast

lemma tr7:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> T = T\<^sub>\<tau> \<Longrightarrow> u ` T = u\<^sub>\<tau> ` T\<^sub>\<tau> "
  using trunc_def by (metis tr1g)

lemma tr8:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> (\<lambda>t\<in>T\<^sub>\<tau>. u t) =  (\<lambda>t\<in>T\<^sub>\<tau>. u\<^sub>\<tau> t)  "
  using trunc_def T\<^sub>\<tau>_def T\<^sub>\<tau>_subset_T by force

lemma tr9:"trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>  u\<^sub>\<tau> ` T\<^sub>\<tau>  \<subseteq>  U\<^sub>\<tau> \<inter> U  "
  by (simp add: tr1d tr1e)

lemma tr10:" trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t\<le>\<tau> \<longrightarrow>  u t\<in>U\<^sub>\<tau> "
  unfolding trunc_def by fastforce

lemma tr11:" trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t\<le>\<tau> \<longrightarrow>  u\<^sub>\<tau> t\<in>U\<^sub>\<tau> "
  unfolding trunc_def by fastforce

lemma tr12:" trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>\<forall>\<tau>\<in>T. \<forall>t\<in>T. t\<le>\<tau> \<longrightarrow>  u\<^sub>\<tau> t  \<in>  U\<^sub>\<tau> \<inter> U "
  unfolding trunc_def by force

(*some lemmas for output signal y*)

lemma sig_Y1: "Signal_Y y H e OP \<Longrightarrow> (\<lambda>t\<in>T. y t) = H (\<lambda>t\<in>T. e t)"
  using Signal_Y_def by metis

lemma sig_Y3: "trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow> Signal_Y y\<^sub>\<tau> H e\<^sub>\<tau> OP\<Longrightarrow> (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>\<tau> t) = H(\<lambda>t\<in>T\<^sub>\<tau>. e\<^sub>\<tau> t) "
  using Signal_Y_def by metis

definition Causality :: "(real \<Rightarrow> real)\<Rightarrow> (real \<Rightarrow> real)\<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real)
                         \<Rightarrow> real set \<Rightarrow> real set \<Rightarrow> ((real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> ((real \<Rightarrow> real)
                         \<Rightarrow> real \<Rightarrow> real) set \<Rightarrow> (real \<Rightarrow> real) set \<Rightarrow> bool"
  where "Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR = ((Operator_Space OP \<and> H\<in>OP \<and>  trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<and> TR_Space TR \<and> u\<^sub>\<tau>\<in>TR \<and> e\<^sub>\<tau>\<in>TR)
                                           \<longrightarrow> H (\<lambda>t\<in>T\<^sub>\<tau>. e t) = H (\<lambda>t\<in>T\<^sub>\<tau>. e\<^sub>\<tau> t))"

lemma Caus1: "Operator_Space OP \<Longrightarrow>H\<in>OP \<Longrightarrow>TR_Space TR\<Longrightarrow>u\<^sub>\<tau>\<in>TR \<and> e\<^sub>\<tau>\<in>TR\<Longrightarrow>trunc u u\<^sub>\<tau> U U\<^sub>\<tau> \<Longrightarrow>Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR
             \<Longrightarrow> H (\<lambda>t\<in>T\<^sub>\<tau>. e t) = H (\<lambda>t\<in>T\<^sub>\<tau>. e\<^sub>\<tau> t)"   using Causality_def by blast

lemma sig_Y_tr:"Signal_Y y H e OP\<Longrightarrow> Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR \<Longrightarrow> (\<lambda>t\<in>T\<^sub>\<tau>. y t) = H(\<lambda>t\<in>T\<^sub>\<tau>. e\<^sub>\<tau> t)"
  using Signal_Y_def by metis

lemma sig_Y_tr1:"Signal_Y y H e OP\<Longrightarrow> Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR \<Longrightarrow> (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>\<tau> t) = H(\<lambda>t\<in>T\<^sub>\<tau>. e\<^sub>\<tau> t)"
  using Signal_Y_def by metis

definition Stability :: "(real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real)\<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> real set \<Rightarrow> real set \<Rightarrow> real \<Rightarrow> real
                        \<Rightarrow> ((real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> real measure \<Rightarrow> ((real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real) set \<Rightarrow> (real \<Rightarrow> real) set \<Rightarrow> bool"
  where "Stability u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> \<gamma> \<beta> H M OP TR = ((Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR) \<longrightarrow> (\<exists>a. \<exists>b. a\<in>T \<and> b\<in>T \<and> \<gamma>=a \<and> \<beta>=b
                                                 \<and> ((L2norm M (\<lambda>t. (H e) t) T\<^sub>\<tau>) \<le> \<gamma> * (L2norm M (\<lambda>t. e\<^sub>\<tau> t) T\<^sub>\<tau>) + \<beta>)))"

lemma stb1: "Causality u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> H OP TR \<Longrightarrow> Stability u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> \<gamma> \<beta> H M OP TR \<Longrightarrow>(\<exists>\<gamma>. \<gamma>\<in>T) \<Longrightarrow>  (\<exists>\<beta>. \<beta>\<in>T)
            \<Longrightarrow> (L2norm M (\<lambda>t. (H e) t) T\<^sub>\<tau> \<le> \<gamma> * (L2norm M (\<lambda>t. e\<^sub>\<tau> t) T\<^sub>\<tau>) + \<beta>)" using Stability_def  by blast

lemma stb2: "Signal_Y y H e OP\<Longrightarrow>Stability u u\<^sub>\<tau> e e\<^sub>\<tau> U U\<^sub>\<tau> \<gamma> \<beta> H M OP TR\<Longrightarrow>(\<exists>\<gamma>. \<gamma>\<in>T) \<Longrightarrow>  (\<exists>\<beta>. \<beta>\<in>T)
            \<Longrightarrow> (L2norm M (\<lambda>t. y t) T\<^sub>\<tau> \<le> \<gamma> * (L2norm M (\<lambda>t. e\<^sub>\<tau> t) T\<^sub>\<tau>) + \<beta>)"
  using Stability_def Signal_Y_def by (metis (mono_tags, hide_lams) add_le_imp_le_right order_refl)

section \<open>\<open>Small-Gain Theorem Definitions\<close>\<close>

text \<open>Closed feedback loop interconnection\<close>

lemma e1:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> H\<^sub>1 e\<^sub>1\<in>G"
    and "e\<^sub>2 = u\<^sub>2 + (H\<^sub>1 e\<^sub>1)"
  shows "e\<^sub>1 = u\<^sub>1 - (H\<^sub>2 e\<^sub>2)"
  using assms Operator_Space.asm_op6 Operator_Space.spaceG_mem eq_iff_diff_eq_0 by fastforce

lemma e2:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> H\<^sub>1 e\<^sub>1\<in>G"
    and "e\<^sub>1 = u\<^sub>1 - (H\<^sub>2 e\<^sub>2)"
  shows "e\<^sub>2 = u\<^sub>2 + (H\<^sub>1 e\<^sub>1)"
  using assms Operator_Space.asm_op6 Operator_Space.spaceG_mem eq_iff_diff_eq_0 by fastforce

lemma e1_1:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G"
    and "e\<^sub>2 = u\<^sub>2 + y\<^sub>1"
  shows "e\<^sub>1 = u\<^sub>1 - y\<^sub>2"
  using assms by (metis Signal_Y_def)

lemma e2_2:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G"
    and "e\<^sub>1 = u\<^sub>1 - y\<^sub>2"
  shows "e\<^sub>2 = u\<^sub>2 + y\<^sub>1"
  using assms by (metis Signal_Y_def)

lemma e1_11:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "(e\<^sub>2 = u\<^sub>2 + y\<^sub>1) "
    and "(e\<^sub>2 = u\<^sub>2 + (H\<^sub>1 e\<^sub>1))"
  shows "(e\<^sub>1 = u\<^sub>1 - y\<^sub>2) \<longleftrightarrow> (e\<^sub>1 = u\<^sub>1 - (H\<^sub>2 e\<^sub>2))"
  using assms  by (metis (full_types) Signal_Y_def)

lemma e2_22:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "Domain_Space D"
    and "Range_Space G"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "e\<^sub>1 = u\<^sub>1 - y\<^sub>2"
    and "e\<^sub>1 = u\<^sub>1 - (H\<^sub>2 e\<^sub>2) "
  shows "(e\<^sub>2 = u\<^sub>2 + y\<^sub>1) \<longleftrightarrow> (e\<^sub>2 = u\<^sub>2 + (H\<^sub>1 e\<^sub>1))"
  using assms  by (metis (full_types) Signal_Y_def)

(* With truncation*)

lemma tr_e1:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>"
    and "trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "TR_Space TR"
    and "u\<^sub>1\<^sub>\<tau>\<in>TR \<and> u\<^sub>2\<^sub>\<tau>\<in>TR \<and> e\<^sub>1\<^sub>\<tau>\<in>TR \<and> e\<^sub>2\<^sub>\<tau>\<in>TR \<and> y\<^sub>1\<^sub>\<tau>\<in>TR \<and> y\<^sub>2\<^sub>\<tau>\<in>TR"
    and "Domain_Space D"
    and "Range_Space G"
    and "Causality u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> H\<^sub>1 OP TR"
    and "Causality u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> H\<^sub>2 OP TR"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "(e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>1 e\<^sub>1)t))"
  shows "e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>2 e\<^sub>2)t)"
  using assms by (metis Signal_Y_def)

lemma tr_e2:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>"
    and "trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "TR_Space TR"
    and "u\<^sub>1\<^sub>\<tau>\<in>TR \<and> u\<^sub>2\<^sub>\<tau>\<in>TR \<and> e\<^sub>1\<^sub>\<tau>\<in>TR \<and> e\<^sub>2\<^sub>\<tau>\<in>TR \<and> y\<^sub>1\<^sub>\<tau>\<in>TR \<and> y\<^sub>2\<^sub>\<tau>\<in>TR"
    and "Domain_Space D"
    and "Range_Space G"
    and "Causality u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> H\<^sub>1 OP TR"
    and "Causality u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> H\<^sub>2 OP TR"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>2 e\<^sub>2)t)"
  shows "e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>1 e\<^sub>1)t)"
  using assms by (metis Signal_Y_def)

lemma tr_e1_11:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>"
    and "trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "TR_Space TR"
    and "u\<^sub>1\<^sub>\<tau>\<in>TR \<and> u\<^sub>2\<^sub>\<tau>\<in>TR \<and> e\<^sub>1\<^sub>\<tau>\<in>TR \<and> e\<^sub>2\<^sub>\<tau>\<in>TR \<and> y\<^sub>1\<^sub>\<tau>\<in>TR \<and> y\<^sub>2\<^sub>\<tau>\<in>TR"
    and "Domain_Space D"
    and "Range_Space G"
    and "Causality u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> H\<^sub>1 OP TR"
    and "Causality u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> H\<^sub>2 OP TR"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "(e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>1 t)) "
    and "(e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>1 e\<^sub>1)t))"
  shows "(e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>2 t)) \<longleftrightarrow> (e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>2 e\<^sub>2)t))"
  using assms by (metis (full_types) sig_Y_tr1)

lemma tr_e2_22:
assumes "Signal u\<^sub>1"
    and "Signal u\<^sub>2"
    and "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau>"
    and "trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>"
    and "Operator_Space OP"
    and "H\<^sub>1\<in>OP"
    and "H\<^sub>2\<in>OP"
    and "TR_Space TR"
    and "u\<^sub>1\<^sub>\<tau>\<in>TR \<and> u\<^sub>2\<^sub>\<tau>\<in>TR \<and> e\<^sub>1\<^sub>\<tau>\<in>TR \<and> e\<^sub>2\<^sub>\<tau>\<in>TR \<and> y\<^sub>1\<^sub>\<tau>\<in>TR \<and> y\<^sub>2\<^sub>\<tau>\<in>TR"
    and "Domain_Space D"
    and "Range_Space G"
    and "Causality u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> H\<^sub>1 OP TR"
    and "Causality u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> H\<^sub>2 OP TR"
    and "Signal_Y y\<^sub>1 H\<^sub>1 e\<^sub>1 OP"
    and "Signal_Y y\<^sub>2 H\<^sub>2 e\<^sub>2 OP"
    and "u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and>  H\<^sub>2 e\<^sub>2\<in>D"
    and "u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and>  H\<^sub>1 e\<^sub>1\<in>G"
    and "e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>2 t)"
    and "e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>2 e\<^sub>2)t)"
  shows "(e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. y\<^sub>1 t)) \<longleftrightarrow> (e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t\<in>T\<^sub>\<tau>. (H\<^sub>1 e\<^sub>1)t))"
  using assms by (metis sig_Y_tr1)

theorem Small_Gain_Theorem:
assumes "\<And>\<tau>. \<tau>\<in>T" and "\<And>t. t\<in>T\<^sub>\<tau>"   and "Signal u\<^sub>1 \<and> Signal u\<^sub>2"
    and "trunc u\<^sub>1 u\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> \<and> trunc u\<^sub>2 u\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau>"and "Operator_Space OP \<Longrightarrow>H\<^sub>1:D\<rightarrow>G \<and> H\<^sub>1\<in>OP \<and> H\<^sub>2:G\<rightarrow>D \<and>H\<^sub>2\<in>OP"
    and "Domain_Space D \<Longrightarrow> u\<^sub>1\<in>D \<and> e\<^sub>1\<in>D \<and> y\<^sub>2\<in>D \<and> H\<^sub>2 e\<^sub>2\<in>D \<and> u\<^sub>1\<^sub>\<tau>\<in>D \<and> e\<^sub>1\<^sub>\<tau>\<in>D \<and> y\<^sub>2\<^sub>\<tau>\<in>D"
    and "Range_Space G  \<Longrightarrow> u\<^sub>2\<in>G \<and> e\<^sub>2\<in>G \<and> y\<^sub>1\<in>G \<and> H\<^sub>1 e\<^sub>1\<in>G \<and> u\<^sub>2\<^sub>\<tau>\<in>G \<and> e\<^sub>2\<^sub>\<tau>\<in>G \<and> y\<^sub>1\<^sub>\<tau>\<in>G"
    and "Causality u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> H\<^sub>1 OP TR " and " Causality u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> H\<^sub>2 OP TR"
    and "TR_Space TR \<Longrightarrow> u\<^sub>1\<^sub>\<tau>\<in>TR \<and> e\<^sub>1\<^sub>\<tau>\<in>TR \<and> y\<^sub>2\<^sub>\<tau>\<in>TR \<and> u\<^sub>2\<^sub>\<tau>\<in>TR \<and> e\<^sub>2\<^sub>\<tau>\<in>TR \<and> y\<^sub>1\<^sub>\<tau>\<in>TR"
    and "e\<^sub>1 = u\<^sub>1 - y\<^sub>2" and "e\<^sub>1 = u\<^sub>1 - (H\<^sub>2 e\<^sub>2)"and "e\<^sub>2 = u\<^sub>2 + y\<^sub>1" and "e\<^sub>2 = u\<^sub>2 + (H\<^sub>1 e\<^sub>1)"
    and "\<And>t. t\<in>T\<^sub>\<tau> \<Longrightarrow>e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t. y\<^sub>2 t)" and "\<And>t. t\<in>T\<^sub>\<tau> \<Longrightarrow>e\<^sub>1\<^sub>\<tau> = u\<^sub>1\<^sub>\<tau> - (\<lambda>t. (H\<^sub>2 e\<^sub>2)t)"
    and "\<And>t. t\<in>T\<^sub>\<tau> \<Longrightarrow>e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t. y\<^sub>1 t)" and "\<And>t. t\<in>T\<^sub>\<tau> \<Longrightarrow>e\<^sub>2\<^sub>\<tau> = u\<^sub>2\<^sub>\<tau> + (\<lambda>t. (H\<^sub>1 e\<^sub>1)t)"
    and "Stability u\<^sub>1 u\<^sub>1\<^sub>\<tau> e\<^sub>1 e\<^sub>1\<^sub>\<tau> U\<^sub>1 U\<^sub>1\<^sub>\<tau> \<gamma>\<^sub>1 \<beta>\<^sub>1 H\<^sub>1 M OP TR" and "Stability u\<^sub>2 u\<^sub>2\<^sub>\<tau> e\<^sub>2 e\<^sub>2\<^sub>\<tau> U\<^sub>2 U\<^sub>2\<^sub>\<tau> \<gamma>\<^sub>2 \<beta>\<^sub>2 H\<^sub>2 M OP TR"
    and "set_integrable M T\<^sub>\<tau> u\<^sub>1\<^sub>\<tau>" "set_integrable M T\<^sub>\<tau> u\<^sub>2\<^sub>\<tau>" "set_integrable M T\<^sub>\<tau> e\<^sub>1\<^sub>\<tau>" "set_integrable M T\<^sub>\<tau> e\<^sub>2\<^sub>\<tau>"
    and "set_integrable M T\<^sub>\<tau> y\<^sub>1\<^sub>\<tau>" "set_integrable M T\<^sub>\<tau> y\<^sub>2\<^sub>\<tau>" "set_integrable M T\<^sub>\<tau> (\<lambda>t. (H\<^sub>1 e\<^sub>1)t)"
    and "set_integrable M T\<^sub>\<tau> (\<lambda>t. (H\<^sub>2 e\<^sub>2)t)" and "set_integrable M T\<^sub>\<tau> (\<lambda>t. (u\<^sub>1\<^sub>\<tau> t)\<^sup>2)"
    and "set_integrable M T\<^sub>\<tau> (\<lambda>t. ((H\<^sub>2 e\<^sub>2)t)\<^sup>2)"and "set_integrable M T\<^sub>\<tau> (\<lambda>t. u\<^sub>1\<^sub>\<tau> t * (H\<^sub>2 e\<^sub>2)t )"
    and "set_integrable M T\<^sub>\<tau> (\<lambda>t. (u\<^sub>2\<^sub>\<tau> t)\<^sup>2)" and "set_integrable M T\<^sub>\<tau> (\<lambda>t. ((H\<^sub>1 e\<^sub>1)t)\<^sup>2)"
    and "set_integrable M T\<^sub>\<tau> (\<lambda>t. u\<^sub>2\<^sub>\<tau> t *(H\<^sub>1 e\<^sub>1)t)"  and "set_integrable M T\<^sub>\<tau> (\<lambda>t. (e\<^sub>1\<^sub>\<tau> t)\<^sup>2)"
    and "set_integrable M T\<^sub>\<tau> (\<lambda>t. (e\<^sub>2\<^sub>\<tau> t)\<^sup>2)"   and "set_integrable M T\<^sub>\<tau> (\<lambda>t. e\<^sub>1\<^sub>\<tau> t * e\<^sub>2\<^sub>\<tau> t )"
    and "(LINT t:T\<^sub>\<tau>|M. (( H\<^sub>2 e\<^sub>2 )t)\<^sup>2 )>0" and "(LINT t:T\<^sub>\<tau>|M. (( H\<^sub>1 e\<^sub>1 )t)\<^sup>2 )>0"
    and "(LINT t:T\<^sub>\<tau>|M. (e\<^sub>2\<^sub>\<tau> t)\<^sup>2 )>0" and " \<gamma>\<^sub>1 * \<gamma>\<^sub>2 <1"
  shows "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )/(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2)"
    and "(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>1 *(L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 * \<beta>\<^sub>2 )/(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2)"
    and "(L2norm M (\<lambda>t. e\<^sub>1 t + e\<^sub>2 t) T\<^sub>\<tau>) \<le> (L2norm M e\<^sub>1 T\<^sub>\<tau>) + (L2norm M e\<^sub>2 T\<^sub>\<tau>)"
proof -
from assms have asm_e1_1:"(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) = (L2norm M (\<lambda>t. u\<^sub>1\<^sub>\<tau> t + - (H\<^sub>2 e\<^sub>2)t) T\<^sub>\<tau>)"
  by (metis minus_apply minus_real_def)

then have asm_e1_2:"(L2norm M (\<lambda>t. u\<^sub>1\<^sub>\<tau> t +  -( H\<^sub>2 e\<^sub>2 )t ) T\<^sub>\<tau>) \<le> (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M (H\<^sub>2 e\<^sub>2) T\<^sub>\<tau>)"
  using assms L2norm_triangle_ineq_nq  by auto

from asm_e1_1 asm_e1_2 have "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) \<le> (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M (H\<^sub>2 e\<^sub>2) T\<^sub>\<tau>)"
  by presburger

note step_e1_1 =this

have "(L2norm M (\<lambda>t. (H\<^sub>2 e\<^sub>2) t) T\<^sub>\<tau> \<le> \<gamma>\<^sub>2 * (L2norm M (\<lambda>t. e\<^sub>2\<^sub>\<tau> t) T\<^sub>\<tau>) + \<beta>\<^sub>2)"
  using assms Stability_def by auto

from this step_e1_1 have "(L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M (H\<^sub>2 e\<^sub>2) T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2))"
  by simp

from this step_e1_1 have e1:"(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2))"
  by force

note step_e1_2 =this

have e2_1:"(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) = (L2norm M (\<lambda>t. u\<^sub>2\<^sub>\<tau> t + (H\<^sub>1 e\<^sub>1)t) T\<^sub>\<tau>)"
  using assms by (metis plus_fun_apply)

then have e2_2:"(L2norm M (\<lambda>t. u\<^sub>2\<^sub>\<tau> t +  ( H\<^sub>1 e\<^sub>1 )t ) T\<^sub>\<tau>) \<le> (L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M (H\<^sub>1 e\<^sub>1) T\<^sub>\<tau>)"
  using assms L2norm_triangle_ineq  by meson

have "(L2norm M (\<lambda>t. (H\<^sub>1 e\<^sub>1) t) T\<^sub>\<tau> \<le> \<gamma>\<^sub>1 * (L2norm M (\<lambda>t. e\<^sub>1\<^sub>\<tau> t) T\<^sub>\<tau>) + \<beta>\<^sub>1)"
  using assms Stability_def by auto

from this e2_2 have e2_3:"(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M (H\<^sub>1 e\<^sub>1) T\<^sub>\<tau>) \<le> (L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1)"
  by simp

from this e2_1 e2_2 have e2_4:"(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>)\<le> ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1))"
  by linarith

from this step_e1_2  have "((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2))
\<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1)) + \<beta>\<^sub>2))"
  using T\<^sub>\<tau>_def assms(1) assms(2) by fastforce

note step_e1_3 =this

then have asm_e1_3: "((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1)) + \<beta>\<^sub>2))
= ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 * \<beta>\<^sub>1 + \<beta>\<^sub>2)"
  by algebra

then have asm_e1_4:"((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 * \<beta>\<^sub>1 + \<beta>\<^sub>2)
= \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )"
  by linarith

then have "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) \<le> \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )"
  using step_e1_1 step_e1_2 step_e1_3 asm_e1_3  by linarith

then have "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) - \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )"
  by force

then have "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>)*(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2 )\<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )"
  by (metis linordered_field_class.sign_simps(24) real_scaleR_def real_vector.scale_right_diff_distrib
      semiring_normalization_rules(12))

with \<open>\<gamma>\<^sub>1 * \<gamma>\<^sub>2 <1\<close> this show "(L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>)\<le> ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>2 *(L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2 + \<gamma>\<^sub>2 * \<beta>\<^sub>1 )/(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2 )"
  by (simp add: less_diff_eq pos_le_divide_eq)

note sig_e1 =this

(* For Signal e2 *)

from e2_4 e1 have e2_5:"((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1)) \<le>
                        ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2)) + \<beta>\<^sub>1))"
  using T\<^sub>\<tau>_def assms(1) assms(2) by fastforce

then have "((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * ((L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>2)) + \<beta>\<^sub>1))
           = \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>)+((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 *\<beta>\<^sub>2))"
  by algebra

then have "(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) \<le> \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>)+((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 *\<beta>\<^sub>2 ))"
  using  e2_4 e2_5 by linarith

then have "(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) - \<gamma>\<^sub>1 * \<gamma>\<^sub>2 * (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 *\<beta>\<^sub>2 ))"
  by force

then have "(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>)*(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2) \<le> ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + (\<gamma>\<^sub>1 * (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 *\<beta>\<^sub>2 ))"
  by (metis linordered_field_class.sign_simps(24) real_scaleR_def real_vector.scale_right_diff_distrib
      semiring_normalization_rules(12))

with \<open>\<gamma>\<^sub>1 * \<gamma>\<^sub>2 <1\<close> this show "(L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) \<le> ((L2norm M u\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>) + \<gamma>\<^sub>1 * (L2norm M u\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + \<beta>\<^sub>1 + \<gamma>\<^sub>1 *\<beta>\<^sub>2 )/(1 - \<gamma>\<^sub>1 * \<gamma>\<^sub>2)"
  by (simp add: less_diff_eq pos_le_divide_eq)

note sig_e2 =this

from sig_e1 sig_e2 have "(L2norm M (\<lambda>t. e\<^sub>1\<^sub>\<tau> t + e\<^sub>2\<^sub>\<tau> t) T\<^sub>\<tau>) \<le> (L2norm M e\<^sub>1\<^sub>\<tau> T\<^sub>\<tau>) + (L2norm M e\<^sub>2\<^sub>\<tau> T\<^sub>\<tau>)"
  using assms L2norm_triangle_ineq by meson

then show "(L2norm M (\<lambda>t. e\<^sub>1 t + e\<^sub>2 t) T\<^sub>\<tau>) \<le> (L2norm M e\<^sub>1 T\<^sub>\<tau>) + (L2norm M e\<^sub>2 T\<^sub>\<tau>)"
  using assms L2norm_triangle_ineq by (metis T_def diff_add_cancel le_add_same_cancel2 mem_Collect_eq)

qed

end


(*  Title:      HOL/Hoare/Pointer_Examples.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Examples of verifications of pointer programs.
*)

theory Pointer_Examples imports HeapSyntax begin

axiomatization where unproven: "PROP A"

section "Verifications"

subsection "List reversal"

text "A short but unreadable proof:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
 apply(fastforce intro:notin_List_update[THEN iffD2])
(* explicit:
 apply clarify
 apply(rename_tac ps b qs)
 apply clarsimp
 apply(rename_tac ps')
 apply(fastforce intro:notin_List_update[THEN iffD2])
 apply(rule_tac x = ps' in exI)
 apply simp
 apply(rule_tac x = "b#qs" in exI)
 apply simp
*)
apply fastforce
done

text\<open>And now with ghost variables @{term ps} and @{term qs}. Even
``more automatic''.\<close>

lemma "VARS next p ps q qs r
  {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
   ps = Ps \<and> qs = Qs}
  WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs \<and> set ps \<inter> set qs = {} \<and>
       rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.next; r^.next := q; q := r;
     qs := (hd ps) # qs; ps := tl ps OD
  {List next q (rev Ps @ Qs)}"
apply vcg_simp
 apply fastforce
apply fastforce
done

text "A longer readable version:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
proof vcg
  fix tl p q r
  assume "List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}"
  thus "\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                rev ps @ qs = rev Ps @ Qs" by fastforce
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> p \<noteq> Null"
         (is "(\<exists>ps qs. ?I ps qs) \<and> _")
  then obtain ps qs a where I: "?I ps qs \<and> p = Ref a"
    by fast
  then obtain ps' where "ps = a # ps'" by fastforce
  hence "List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
         List (tl(p \<rightarrow> q)) p       (a#qs) \<and>
         set ps' \<inter> set (a#qs) = {} \<and>
         rev ps' @ (a#qs) = rev Ps @ Qs"
    using I by fastforce
  thus "\<exists>ps' qs'. List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
                  List (tl(p \<rightarrow> q)) p       qs' \<and>
                  set ps' \<inter> set qs' = {} \<and>
                  rev ps' @ qs' = rev Ps @ Qs" by fast
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> \<not> p \<noteq> Null"
  thus "List tl q (rev Ps @ Qs)" by fastforce
qed

text\<open>Finaly, the functional version. A bit more verbose, but automatic!\<close>

lemma "VARS tl p q r
  {islist tl p \<and> islist tl q \<and>
   Ps = list tl p \<and> Qs = list tl q \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {islist tl p \<and> islist tl q \<and>
       set(list tl p) \<inter> set(list tl q) = {} \<and>
       rev(list tl p) @ (list tl q) = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {islist tl q \<and> list tl q = rev Ps @ Qs}"
apply vcg_simp
  apply clarsimp
 apply clarsimp
apply clarsimp
done

subsection "Searching in a list"

text\<open>What follows is a sequence of successively more intelligent proofs that
a simple loop finds an element in a linked list.

We start with a proof based on the @{term List} predicate. This means it only
works for acyclic lists.\<close>

lemma "VARS tl p
  {List tl p Ps \<and> X \<in> set Ps}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {\<exists>ps. List tl p ps \<and> X \<in> set ps}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
  apply blast
 apply clarsimp
apply clarsimp
done

text\<open>Using @{term Path} instead of @{term List} generalizes the correctness
statement to cyclic lists as well:\<close>

lemma "VARS tl p
  {Path tl p Ps X}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {\<exists>ps. Path tl p ps X}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply blast
 apply fastforce
apply clarsimp
done

text\<open>Now it dawns on us that we do not need the list witness at all --- it
suffices to talk about reachability, i.e.\ we can use relations directly. The
first version uses a relation on @{typ"'a ref"}:\<close>

lemma "VARS tl p
  {(p,X) \<in> {(Ref x,tl x) |x. True}^*}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {(p,X) \<in> {(Ref x,tl x) |x. True}^*}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply(clarsimp elim:converse_rtranclE)
apply(fast elim:converse_rtranclE)
done

text\<open>Finally, a version based on a relation on type @{typ 'a}:\<close>

lemma "VARS tl p
  {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}^*}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}^*}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply clarsimp
apply clarsimp
done

subsection "Splicing two lists"

lemma "VARS tl p q pp qq
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and> size Qs \<le> size Ps}
  pp := p;
  WHILE q \<noteq> Null
  INV {\<exists>as bs qs.
    distinct as \<and> Path tl p as pp \<and> List tl pp bs \<and> List tl q qs \<and>
    set bs \<inter> set qs = {} \<and> set as \<inter> (set bs \<union> set qs) = {} \<and>
    size qs \<le> size bs \<and> splice Ps Qs = as @ splice bs qs}
  DO qq := q^.tl; q^.tl := pp^.tl; pp^.tl := q; pp := q^.tl; q := qq OD
  {List tl p (splice Ps Qs)}"
apply vcg_simp
  apply(rule_tac x = "[]" in exI)
  apply fastforce
 apply clarsimp
 apply(rename_tac y bs qqs)
 apply(case_tac bs) apply simp
 apply clarsimp
 apply(rename_tac x bbs)
 apply(rule_tac x = "as @ [x,y]" in exI)
 apply simp
 apply(rule_tac x = "bbs" in exI)
 apply simp
 apply(rule_tac x = "qqs" in exI)
 apply simp
apply (fastforce simp:List_app)
done

subsection "Merging two lists"

text"This is still a bit rough, especially the proof."

definition cor :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cor P Q \<longleftrightarrow> (if P then True else Q)"

definition cand :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cand P Q \<longleftrightarrow> (if P then Q else False)"

fun merge :: "'a list * 'a list * ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list"
where
  "merge(x#xs,y#ys,f) = (if f x y then x # merge(xs,y#ys,f)
                                  else y # merge(x#xs,ys,f))"
| "merge(x#xs,[],f) = x # merge(xs,[],f)"
| "merge([],y#ys,f) = y # merge([],ys,f)"
| "merge([],[],f) = []"

text\<open>Simplifies the proof a little:\<close>

lemma "VARS hd tl p q r s
 {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {EX rs ps qs a. Path tl r rs s \<and> List tl p ps \<and> List tl q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {List tl r (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(rule conjI)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)
apply clarsimp
apply(rule conjI)
apply (clarsimp)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "ya#bsa" in exI)
apply(simp)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "y#bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bsa" in exI)
apply(simp)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)

apply(clarsimp simp add:List_app)
done

text\<open>And now with ghost variables:\<close>

lemma "VARS elem next p q r s ps qs rs a
 {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null) \<and> ps = Ps \<and> qs = Qs}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
 THEN r := p; p := p^.next; ps := tl ps
 ELSE r := q; q := q^.next; qs := tl qs FI;
 s := r; rs := []; a := addr s;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {Path next r rs s \<and> List next p ps \<and> List next q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y) =
      rs @ a # merge(ps,qs,\<lambda>x y. elem x \<le> elem y) \<and>
      (next a = p \<or> next a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
    THEN s^.next := p; p := p^.next; ps := tl ps
    ELSE s^.next := q; q := q^.next; qs := tl qs FI;
    rs := rs @ [a]; s := s^.next; a := addr s
 OD
 {List next r (merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply(clarsimp)
apply(rule conjI)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)

apply(clarsimp simp add:List_app)
done

text\<open>The proof is a LOT simpler because it does not need
instantiations anymore, but it is still not quite automatic, probably
because of this wrong orientation business.\<close>

text\<open>More of the previous proof without ghost variables can be
automated, but the runtime goes up drastically. In general it is
usually more efficient to give the witness directly than to have it
found by proof.

Now we try a functional version of the abstraction relation @{term
Path}. Since the result is not that convincing, we do not prove any of
the lemmas.\<close>

axiomatization
  ispath :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" and
  path :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> 'a list"

text"First some basic lemmas:"

lemma [simp]: "ispath f p p"
by (rule unproven)
lemma [simp]: "path f p p = []"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow> ispath (f(a := r)) p q"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow>
 path (f(a := r)) p q = path f p q"
by (rule unproven)

text"Some more specific lemmas needed by the example:"

lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow> ispath (f(a := q)) p q"
by (rule unproven)
lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow>
 path (f(a := q)) p q = path (f(a := q)) p (Ref a) @ [a]"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Ref b \<Longrightarrow>
 b \<notin> set (path f p (Ref a))"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> islist f p"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> list f p = path f p (Ref a) @ [a]"
by (rule unproven)

lemma [simp]: "islist f p \<Longrightarrow> distinct (list f p)"
by (rule unproven)

lemma "VARS hd tl p q r s
 {islist tl p & Ps = list tl p \<and> islist tl q & Qs = list tl q \<and>
  set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {EX rs ps qs a. ispath tl r s & rs = path tl r s \<and>
      islist tl p & ps = list tl p \<and> islist tl q & qs = list tl q \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {islist tl r & list tl r = (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp

apply (simp_all add: cand_def cor_def)
  apply (fastforce)
 apply (fastforce simp: eq_sym_conv)
apply(clarsimp)
done

text"The proof is automatic, but requires a numbet of special lemmas."

subsection "Cyclic list reversal"

text\<open>We consider two algorithms for the reversal of circular lists.
\<close>

lemma circular_list_rev_I:
  "VARS next root p q tmp
  {root = Ref r \<and> distPath next root (r#Ps) root}
  p := root; q := root^.next;
  WHILE q \<noteq> root
  INV {\<exists> ps qs. distPath next p ps root \<and> distPath next q qs root \<and>
             root = Ref r \<and> r \<notin> set Ps  \<and> set ps \<inter> set qs = {} \<and>
             Ps = (rev ps) @ qs  }
  DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
  root^.next := p
  { root = Ref r \<and> distPath next root (r#rev Ps) root}"
apply (simp only:distPath_def)
apply vcg_simp
  apply (rule_tac x="[]" in exI)
  apply auto
 apply (drule (2) neq_dP)
 apply clarsimp
 apply(rule_tac x="a # ps" in exI)
apply clarsimp
done

text\<open>In the beginning, we are able to assert @{term"distPath next
root as root"}, with @{term"as"} set to @{term"[]"} or
@{term"[r,a,b,c]"}. Note that @{term"Path next root as root"} would
additionally give us an infinite number of lists with the recurring
sequence @{term"[r,a,b,c]"}.

The precondition states that there exists a non-empty non-repeating
path \mbox{@{term "r # Ps"}} from pointer @{term root} to itself, given that
@{term root} points to location @{term r}. Pointers @{term p} and
@{term q} are then set to @{term root} and the successor of @{term
root} respectively. If @{term "q = root"}, we have circled the loop,
otherwise we set the @{term next} pointer field of @{term q} to point
to @{term p}, and shift @{term p} and @{term q} one step forward. The
invariant thus states that @{term p} and @{term q} point to two
disjoint lists @{term ps} and @{term qs}, such that @{term"Ps = rev ps
@ qs"}. After the loop terminates, one
extra step is needed to close the loop. As expected, the postcondition
states that the @{term distPath} from @{term root} to itself is now
@{term "r # (rev Ps)"}.

It may come as a surprise to the reader that the simple algorithm for
acyclic list reversal, with modified annotations, works for cyclic
lists as well:\<close>

lemma circular_list_rev_II:
"VARS next p q tmp
{p = Ref r \<and> distPath next p (r#Ps) p}
q:=Null;
WHILE p \<noteq> Null
INV
{ ((q = Null) \<longrightarrow> (\<exists>ps. distPath next p (ps) (Ref r) \<and> ps = r#Ps)) \<and>
  ((q \<noteq> Null) \<longrightarrow> (\<exists>ps qs. distPath next q (qs) (Ref r) \<and> List next p ps  \<and>
                   set ps \<inter> set qs = {} \<and> rev qs @ ps = Ps@[r])) \<and>
  \<not> (p = Null \<and> q = Null) }
DO tmp := p; p := p^.next; tmp^.next := q; q:=tmp OD
{q = Ref r \<and> distPath next q (r # rev Ps) q}"
apply (simp only:distPath_def)
apply vcg_simp
  apply clarsimp
  apply clarsimp
 apply (case_tac "(q = Null)")
  apply (fastforce intro: Path_is_List)
 apply clarsimp
 apply (rule_tac x= "bs" in exI)
 apply (rule_tac x= "y # qs" in exI)
 apply clarsimp
apply (auto simp:fun_upd_apply)
done

subsection "Storage allocation"

definition new :: "'a set \<Rightarrow> 'a"
  where "new A = (SOME a. a \<notin> A)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::'a set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow> new (A) \<notin> B"
apply(unfold new_def)
apply(rule someI2_ex)
 apply (fast intro:ex_new_if_finite)
apply (fast)
done

lemma "~finite(UNIV::'a set) \<Longrightarrow>
  VARS xs elem next alloc p q
  {Xs = xs \<and> p = (Null::'a ref)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := Ref(new(set alloc)); alloc := (addr q)#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply new_notin)
apply fastforce
done

end


(*  Title:      HOL/ex/Tree23.thy
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>2-3 Trees\<close>

theory Tree23
imports Main
begin

text\<open>This is a very direct translation of some of the functions in table.ML
in the Isabelle source code. That source is due to Makarius Wenzel and Stefan
Berghofer.

Note that because of complicated patterns and mutual recursion, these
function definitions take a few minutes and can also be seen as stress tests
for the function definition facility.\<close>

type_synonym key = int \<comment> \<open>for simplicity, should be a type class\<close>

datatype ord = LESS | EQUAL | GREATER

definition "ord i j = (if i<j then LESS else if i=j then EQUAL else GREATER)"

datatype 'a tree23 =
  Empty |
  Branch2 "'a tree23" "key * 'a" "'a tree23" |
  Branch3 "'a tree23" "key * 'a" "'a tree23" "key * 'a" "'a tree23"

datatype 'a growth =
  Stay "'a tree23" |
  Sprout "'a tree23" "key * 'a" "'a tree23"

fun add :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a growth" where
"add key y Empty = Sprout Empty (key,y) Empty" |
"add key y (Branch2 left (k,x) right) =
   (case ord key k of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch2 left' (k,x) right)
         | Sprout left1 q left2
           => Stay (Branch3 left1 q left2 (k,x) right))
    | EQUAL => Stay (Branch2 left (k,y) right)
    | GREATER =>
        (case add key y right of
           Stay right' => Stay (Branch2 left (k,x) right')
         | Sprout right1 q right2
           => Stay (Branch3 left (k,x) right1 q right2)))" |
"add key y (Branch3 left (k1,x1) mid (k2,x2) right) =
   (case ord key k1 of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch3 left' (k1,x1) mid (k2,x2) right)
         | Sprout left1 q left2
           => Sprout (Branch2 left1 q left2) (k1,x1) (Branch2 mid (k2,x2) right))
    | EQUAL => Stay (Branch3 left (k1,y) mid (k2,x2) right)
    | GREATER =>
        (case ord key k2 of
           LESS =>
             (case add key y mid of
                Stay mid' => Stay (Branch3 left (k1,x1) mid' (k2,x2) right)
              | Sprout mid1 q mid2
                => Sprout (Branch2 left (k1,x1) mid1) q (Branch2 mid2 (k2,x2) right))
         | EQUAL => Stay (Branch3 left (k1,x1) mid (k2,y) right)
         | GREATER =>
             (case add key y right of
                Stay right' => Stay (Branch3 left (k1,x1) mid (k2,x2) right')
              | Sprout right1 q right2
                => Sprout (Branch2 left (k1,x1) mid) (k2,x2) (Branch2 right1 q right2))))"

definition add0 :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"add0 k y t =
  (case add k y t of Stay t' => t' | Sprout l p r => Branch2 l p r)"

value "add0 5 e (add0 4 d (add0 3 c (add0 2 b (add0 1 a Empty))))"

fun compare where
"compare None (k2, _) = LESS" |
"compare (Some k1) (k2, _) = ord k1 k2"

fun if_eq where
"if_eq EQUAL x y = x" |
"if_eq _ x y = y"

fun del :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> ((key * 'a) * bool * 'a tree23)option"
where
"del (Some k) Empty = None" |
"del None (Branch2 Empty p Empty) = Some(p, (True, Empty))" |
"del None (Branch3 Empty p Empty q Empty) = Some(p, (False, Branch2 Empty q Empty))" |
"del k (Branch2 Empty p Empty) = (case compare k p of
      EQUAL => Some(p, (True, Empty)) | _ => None)" |
"del k (Branch3 Empty p Empty q Empty) = (case compare k p of
      EQUAL => Some(p, (False, Branch2 Empty q Empty))
    | _ => (case compare k q of
        EQUAL => Some(q, (False, Branch2 Empty p Empty))
      | _ => None))" |
"del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))" |
"del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"

definition del0 :: "key \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"del0 k t = (case del (Some k) t of None \<Rightarrow> t | Some(_,(_,t')) \<Rightarrow> t')"

text \<open>Ordered trees\<close>

definition opt_less :: "key option \<Rightarrow> key option \<Rightarrow> bool" where
  "opt_less x y = (case x of None \<Rightarrow> True | Some a \<Rightarrow> (case y of None \<Rightarrow> True | Some b \<Rightarrow> a < b))"

lemma opt_less_simps [simp]:
  "opt_less None y = True"
  "opt_less x None = True"
  "opt_less (Some a) (Some b) = (a < b)"
unfolding opt_less_def by (auto simp add: ord_def split: option.split)

primrec ord' :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> key option \<Rightarrow> bool" where
"ord' x Empty y = opt_less x y" |
"ord' x (Branch2 l p r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) r y)" |
"ord' x (Branch3 l p m q r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) m (Some (fst q)) & ord' (Some (fst q)) r y)"

definition ord0 :: "'a tree23 \<Rightarrow> bool" where
  "ord0 t = ord' None t None"

text \<open>Balanced trees\<close>

inductive full :: "nat \<Rightarrow> 'a tree23 \<Rightarrow> bool" where
"full 0 Empty" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch3 l p m q r)"

inductive_cases full_elims:
  "full n Empty"
  "full n (Branch2 l p r)"
  "full n (Branch3 l p m q r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Empty"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Empty_iff [simp]: "full n Empty \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch2_iff [simp]:
  "full (Suc n) (Branch2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch3_iff [simp]:
  "full (Suc n) (Branch3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

fun height :: "'a tree23 \<Rightarrow> nat" where
"height Empty = 0" |
"height (Branch2 l _ r) = Suc(max (height l) (height r))" |
"height (Branch3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

text\<open>Is a tree balanced?\<close>
fun bal :: "'a tree23 \<Rightarrow> bool" where
"bal Empty = True" |
"bal (Branch2 l _ r) = (bal l & bal r & height l = height r)" |
"bal (Branch3 l _ m _ r) = (bal l & bal m & bal r & height l = height m & height m = height r)"

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text \<open>The \<^term>\<open>add0\<close> function either preserves the height of the
tree, or increases it by one. The constructor returned by the \<^term>\<open>add\<close> function determines which: A return value of the form \<^term>\<open>Stay t\<close> indicates that the height will be the same. A value of the
form \<^term>\<open>Sprout l p r\<close> indicates an increase in height.\<close>

primrec gfull :: "nat \<Rightarrow> 'a growth \<Rightarrow> bool" where
"gfull n (Stay t) \<longleftrightarrow> full n t" |
"gfull n (Sprout l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma gfull_add: "full n t \<Longrightarrow> gfull n (add k y t)"
by (induct set: full, auto split: ord.split growth.split)

text \<open>The \<^term>\<open>add0\<close> operation preserves balance.\<close>

lemma bal_add0: "bal t \<Longrightarrow> bal (add0 k y t)"
unfolding bal_iff_full add0_def
apply (erule exE)
apply (drule gfull_add [of _ _ k y])
apply (cases "add k y t")
apply (auto intro: full.intros)
done

text \<open>The \<^term>\<open>add0\<close> operation preserves order.\<close>

lemma ord_cases:
  fixes a b :: int obtains
  "ord a b = LESS" and "a < b" |
  "ord a b = EQUAL" and "a = b" |
  "ord a b = GREATER" and "a > b"
unfolding ord_def by (rule linorder_cases [of a b]) auto

definition gtree :: "'a growth \<Rightarrow> 'a tree23" where
  "gtree g = (case g of Stay t \<Rightarrow> t | Sprout l p r \<Rightarrow> Branch2 l p r)"

lemma gtree_simps [simp]:
  "gtree (Stay t) = t"
  "gtree (Sprout l p r) = Branch2 l p r"
unfolding gtree_def by simp_all

lemma add0: "add0 k y t = gtree (add k y t)"
  unfolding add0_def by (simp split: growth.split)

lemma ord'_add0:
  "\<lbrakk>ord' k1 t k2; opt_less k1 (Some k); opt_less (Some k) k2\<rbrakk> \<Longrightarrow> ord' k1 (add0 k y t) k2"
unfolding add0
 apply (induct t arbitrary: k1 k2)
   apply simp
  apply clarsimp
  apply (rule_tac a=k and b=a in ord_cases)
    apply simp
    apply (case_tac "add k y t1", simp, simp)
   apply simp
  apply simp
  apply (case_tac "add k y t2", simp, simp)
 apply clarsimp
 apply (rule_tac a=k and b=a in ord_cases)
   apply simp
   apply (case_tac "add k y t1", simp, simp)
  apply simp
 apply simp
 apply (rule_tac a=k and b=aa in ord_cases)
   apply simp
   apply (case_tac "add k y t2", simp, simp)
  apply simp
 apply simp
 apply (case_tac "add k y t3", simp, simp)
done

lemma ord0_add0: "ord0 t \<Longrightarrow> ord0 (add0 k y t)"
  by (simp add: ord0_def ord'_add0)

text \<open>The \<^term>\<open>del\<close> function preserves balance.\<close>

lemma del_extra_simps:
"l \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))"
"l \<noteq> Empty \<or> m \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"
apply -
apply (cases l, cases r, simp_all only: del.simps, simp)
apply (cases l, cases m, cases r, simp_all only: del.simps, simp)
done

fun dfull where
"dfull n None \<longleftrightarrow> True" |
"dfull n (Some (p, (True, t'))) \<longleftrightarrow> full n t'" |
"dfull n (Some (p, (False, t'))) \<longleftrightarrow> full (Suc n) t'"

lemmas dfull_case_intros =
  ord.exhaust [of y "dfull a (case_ord b c d y)"]
  option.exhaust [of y "dfull a (case_option b c y)"]
  prod.exhaust [of y "dfull a (case_prod b y)"]
  bool.exhaust [of y "dfull a (case_bool b c y)"]
  tree23.exhaust [of y "dfull a (Some (b, case_tree23 c d e y))"]
  tree23.exhaust [of y "full a (case_tree23 b c d y)"]
  for a b c d e y

lemma dfull_del: "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
proof -
  { fix n :: "nat" and p :: "key \<times> 'a" and l r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k p = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k p = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch2 l p r)"
    hence "dfull n (del k (Branch2 l p r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     (* This should work, but it is way too slow!
     apply (force split: ord.split option.split bool.split tree23.split) *)
     apply (simp | rule dfull_case_intros)+
     done
  } note A = this
  { fix n :: "nat" and p q :: "key \<times> 'a" and l m r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k q = LESS; compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = EQUAL; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) m)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = GREATER; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) m)"
    and "\<And>n. \<lbrakk>compare k q = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k q = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch3 l p m q r)"
    hence "dfull n (del k (Branch3 l p m q r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     apply (simp | rule dfull_case_intros)+
     done
  } note B = this
  show "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
  proof (induct k t arbitrary: n rule: del.induct, goal_cases)
    case (1 k n)
    thus "dfull n (del (Some k) Empty)" by simp
  next
    case (2 p n)
    thus "dfull n (del None (Branch2 Empty p Empty))" by simp
  next
    case (3 p q n)
    thus "dfull n (del None (Branch3 Empty p Empty q Empty))" by simp
  next
    case (4 v p n)
    thus "dfull n (del (Some v) (Branch2 Empty p Empty))"
      by (simp split: ord.split)
  next
    case (5 v p q n)
    thus "dfull n (del (Some v) (Branch3 Empty p Empty q Empty))"
      by (simp split: ord.split)
  next
    case (26 n)
    thus ?case by simp
  qed (fact A | fact B)+
qed

lemma bal_del0: "bal t \<Longrightarrow> bal (del0 k t)"
unfolding bal_iff_full del0_def
apply (erule exE)
apply (case_tac n, simp, simp)
apply (frule dfull_del [where k="Some k"])
apply (cases "del (Some k) t", force)
apply (rename_tac a, case_tac "a", rename_tac b t', case_tac "b", auto)
done

text\<open>This is a little test harness and should be commented out once the
above functions have been proved correct.\<close>

datatype 'a act = Add int 'a | Del int

fun exec where
"exec [] t = t" |
"exec (Add k x # as) t = exec as (add0 k x t)" |
"exec (Del k # as) t = exec as (del0 k t)"

text\<open>Some quick checks:\<close>

lemma bal_exec: "bal t \<Longrightarrow> bal (exec as t)"
  by (induct as t arbitrary: t rule: exec.induct,
    simp_all add: bal_add0 bal_del0)

lemma "bal(exec as Empty)"
  by (simp add: bal_exec)

lemma "ord0(exec as Empty)"
quickcheck
oops

end