(*  Title:      HOL/Cardinals/Wellorder_Relation.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order relations.
*)

section \<open>Well-Order Relations\<close>

theory Wellorder_Relation
  imports Wellfounded_More
begin

context wo_rel
begin

subsection \<open>Auxiliaries\<close>

lemma PREORD: "Preorder r"
  using WELL order_on_defs[of _ r] by auto

lemma PARORD: "Partial_order r"
  using WELL order_on_defs[of _ r] by auto

lemma cases_Total2:
  "\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<Longrightarrow> phi a b);
              ((b,a) \<in> r - Id \<Longrightarrow> phi a b); (a = b \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
  using TOTALS by auto

subsection \<open>Well-founded induction and recursion adapted to non-strict well-order relations\<close>

lemma worec_unique_fixpoint:
  assumes ADM: "adm_wo H" and fp: "f = H f"
  shows "f = worec H"
proof-
  have "adm_wf (r - Id) H"
    unfolding adm_wf_def
    using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "f = wfrec (r - Id) H"
    using fp WF wfrec_unique_fixpoint[of "r - Id" H] by simp
  thus ?thesis unfolding worec_def .
qed

subsubsection \<open>Properties of max2\<close>

lemma max2_iff:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "((max2 a b, c) \<in> r) = ((a,c) \<in> r \<and> (b,c) \<in> r)"
proof
  assume "(max2 a b, c) \<in> r"
  thus "(a,c) \<in> r \<and> (b,c) \<in> r"
    using assms max2_greater[of a b] TRANS trans_def[of r] by blast
next
  assume "(a,c) \<in> r \<and> (b,c) \<in> r"
  thus "(max2 a b, c) \<in> r"
    using assms max2_among[of a b] by auto
qed

subsubsection \<open>Properties of minim\<close>

lemma minim_Under:
  "\<lbrakk>B \<le> Field r; B \<noteq> {}\<rbrakk> \<Longrightarrow> minim B \<in> Under B"
  by(auto simp add: Under_def minim_inField minim_least)

lemma equals_minim_Under:
  "\<lbrakk>B \<le> Field r; a \<in> B; a \<in> Under B\<rbrakk>
 \<Longrightarrow> a = minim B"
  by(auto simp add: Under_def equals_minim)

lemma minim_iff_In_Under:
  assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
  shows "(a = minim B) = (a \<in> B \<and> a \<in> Under B)"
proof
  assume "a = minim B"
  thus "a \<in> B \<and> a \<in> Under B"
    using assms minim_in minim_Under by simp
next
  assume "a \<in> B \<and> a \<in> Under B"
  thus "a = minim B"
    using assms equals_minim_Under by simp
qed

lemma minim_Under_under:
  assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
  shows "Under A = under (minim A)"
proof-
  have "minim A \<in> A"
    using assms minim_in by auto
  then have "Under A \<le> under (minim A)"
    by (simp add: Under_decr under_Under_singl)
  moreover have "under (minim A) \<le> Under A"
    by (meson NE SUB TRANS minim_Under subset_eq under_Under_trans)
  ultimately show ?thesis by blast
qed

lemma minim_UnderS_underS:
  assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
  shows "UnderS A = underS (minim A)"
proof-
  have "minim A \<in> A"
    using assms minim_in by auto
  then have "UnderS A \<le> underS (minim A)"
    by (simp add: UnderS_decr underS_UnderS_singl)
  moreover have "underS (minim A) \<le> UnderS A"
    by (meson ANTISYM NE SUB TRANS minim_Under subset_eq underS_Under_trans)
  ultimately show ?thesis by blast
qed

subsubsection \<open>Properties of supr\<close>

lemma supr_Above:
  assumes "Above B \<noteq> {}"
  shows "supr B \<in> Above B"
  by (simp add: assms Above_Field minim_in supr_def)

lemma supr_greater:
  assumes "Above B \<noteq> {}" "b \<in> B"
  shows "(b, supr B) \<in> r"
  using assms Above_def supr_Above by fastforce

lemma supr_least_Above:
  assumes "a \<in> Above B"
  shows "(supr B, a) \<in> r"
  by (simp add: assms Above_Field minim_least supr_def)

lemma supr_least:
  "\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (supr B, a) \<in> r"
  by(auto simp add: supr_least_Above Above_def)

lemma equals_supr_Above:
  assumes "a \<in> Above B" "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
  shows "a = supr B"
  by (simp add: assms Above_Field equals_minim supr_def)

lemma equals_supr:
  assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
    ABV: "\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r" and
    MINIM: "\<And> a'. \<lbrakk> a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
  shows "a = supr B"
proof-
  have "a \<in> Above B"
    unfolding Above_def using ABV IN by simp
  moreover
  have "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
    unfolding Above_def using MINIM by simp
  ultimately show ?thesis
    using equals_supr_Above SUB by auto
qed

lemma supr_inField:
  assumes "Above B \<noteq> {}"
  shows "supr B \<in> Field r"
  by (simp add: Above_Field assms minim_inField supr_def)

lemma supr_above_Above:
  assumes SUB: "B \<le> Field r" and  ABOVE: "Above B \<noteq> {}"
  shows "Above B = above (supr B)"
  apply (clarsimp simp: Above_def above_def set_eq_iff)
  by (meson ABOVE FieldI2 SUB TRANS supr_greater supr_least transD)

lemma supr_under:
  assumes "a \<in> Field r"
  shows "a = supr (under a)"
proof-
  have "under a \<le> Field r"
    using under_Field[of r] by auto
  moreover
  have "under a \<noteq> {}"
    using assms Refl_under_in[of r] REFL by auto
  moreover
  have "a \<in> Above (under a)"
    using in_Above_under[of _ r] assms by auto
  moreover
  have "\<forall>a' \<in> Above (under a). (a,a') \<in> r"
    by (auto simp: Above_def above_def REFL Refl_under_in assms)
  ultimately show ?thesis
    using equals_supr_Above by auto
qed

subsubsection \<open>Properties of successor\<close>

lemma suc_least:
  "\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (suc B, a) \<in> r"
  by(auto simp add: suc_least_AboveS AboveS_def)

lemma equals_suc:
  assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
    ABVS: "\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r" and
    MINIM: "\<And> a'. \<lbrakk>a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> a' \<noteq> b \<and> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
  shows "a = suc B"
proof-
  have "a \<in> AboveS B"
    unfolding AboveS_def using ABVS IN by simp
  moreover
  have "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
    unfolding AboveS_def using MINIM by simp
  ultimately show ?thesis
    using equals_suc_AboveS SUB by auto
qed

lemma suc_above_AboveS:
  assumes SUB: "B \<le> Field r" and
    ABOVE: "AboveS B \<noteq> {}"
  shows "AboveS B = above (suc B)"
  using assms
proof(unfold AboveS_def above_def, auto)
  fix a assume "a \<in> Field r" "\<forall>b \<in> B. a \<noteq> b \<and> (b,a) \<in> r"
  with suc_least assms
  show "(suc B,a) \<in> r" by auto
next
  fix b assume "(suc B, b) \<in> r"
  thus "b \<in> Field r"
    using REFL refl_on_def[of _ r] by auto
next
  fix a b
  assume 1: "(suc B, b) \<in> r" and 2: "a \<in> B"
  with assms suc_greater[of B a]
  have "(a,suc B) \<in> r" by auto
  thus "(a,b) \<in> r"
    using 1 TRANS trans_def[of r] by blast
next
  fix a
  assume "(suc B, a) \<in> r" and 2: "a \<in> B"
  thus False
    by (metis ABOVE ANTISYM SUB antisymD suc_greater)
qed

lemma suc_singl_pred:
  assumes IN: "a \<in> Field r" and ABOVE_NE: "aboveS a \<noteq> {}" and
    REL: "(a',suc {a}) \<in> r" and DIFF: "a' \<noteq> suc {a}"
  shows "a' = a \<or> (a',a) \<in> r"
proof-
  have *: "suc {a} \<in> Field r \<and> a' \<in> Field r"
    using WELL REL well_order_on_domain by metis
  {assume **: "a' \<noteq> a"
    hence "(a,a') \<in> r \<or> (a',a) \<in> r"
      using TOTAL IN * by (auto simp add: total_on_def)
    moreover
    {assume "(a,a') \<in> r"
      with ** * assms WELL suc_least[of "{a}" a']
      have "(suc {a},a') \<in> r" by auto
      with REL DIFF * ANTISYM antisym_def[of r]
      have False by simp
    }
    ultimately have "(a',a) \<in> r"
      by blast
  }
  thus ?thesis by blast
qed

lemma under_underS_suc:
  assumes IN: "a \<in> Field r" and ABV: "aboveS a \<noteq> {}"
  shows "underS (suc {a}) = under a"
proof -
  have "AboveS {a} \<noteq> {}"
    using ABV aboveS_AboveS_singl[of r] by auto
  then have 2: "a \<noteq> suc {a} \<and> (a,suc {a}) \<in> r"
    using suc_greater[of "{a}" a] IN  by auto
  have "underS (suc {a}) \<le> under a"
    using ABV IN REFL Refl_under_in underS_E under_def wo_rel.suc_singl_pred wo_rel_axioms by fastforce
  moreover
  have "under a \<le> underS (suc {a})"
    by (simp add: "2" ANTISYM TRANS subsetI underS_I under_underS_trans)
  ultimately show ?thesis by blast
qed

subsubsection \<open>Properties of order filters\<close>

lemma ofilter_Under[simp]:
  assumes "A \<le> Field r"
  shows "ofilter(Under A)"
  by (clarsimp simp: ofilter_def) (meson TRANS Under_Field subset_eq under_Under_trans)

lemma ofilter_UnderS[simp]:
  assumes "A \<le> Field r"
  shows "ofilter(UnderS A)"
  by (clarsimp simp: ofilter_def) (meson ANTISYM TRANS UnderS_Field subset_eq under_UnderS_trans)

lemma ofilter_Int[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A Int B)"
  unfolding ofilter_def by blast

lemma ofilter_Un[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A \<union> B)"
  unfolding ofilter_def by blast

lemma ofilter_INTER:
  "\<lbrakk>I \<noteq> {}; \<And> i. i \<in> I \<Longrightarrow> ofilter(A i)\<rbrakk> \<Longrightarrow> ofilter (\<Inter>i \<in> I. A i)"
  unfolding ofilter_def by blast

lemma ofilter_Inter:
  "\<lbrakk>S \<noteq> {}; \<And> A. A \<in> S \<Longrightarrow> ofilter A\<rbrakk> \<Longrightarrow> ofilter (\<Inter>S)"
  unfolding ofilter_def by blast

lemma ofilter_Union:
  "(\<And> A. A \<in> S \<Longrightarrow> ofilter A) \<Longrightarrow> ofilter (\<Union>S)"
  unfolding ofilter_def by blast

lemma ofilter_under_Union:
  "ofilter A \<Longrightarrow> A = \<Union>{under a| a. a \<in> A}"
  using ofilter_under_UNION [of A] by auto

subsubsection \<open>Other properties\<close>

lemma Trans_Under_regressive:
  assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
  shows "Under(Under A) \<le> Under A"
  by (metis INT_E NE REFL Refl_under_Under SUB empty_iff minim_Under minim_Under_under subsetI)

lemma ofilter_suc_Field:
  assumes OF: "ofilter A" and NE: "A \<noteq> Field r"
  shows "ofilter (A \<union> {suc A})"
  by (metis NE OF REFL Refl_under_underS ofilter_underS_Field suc_underS under_ofilter)

(* FIXME: needed? *)
declare
  minim_in[simp]
  minim_inField[simp]
  minim_least[simp]
  under_ofilter[simp]
  underS_ofilter[simp]
  Field_ofilter[simp]

end

abbreviation "worec \<equiv> wo_rel.worec"
abbreviation "adm_wo \<equiv> wo_rel.adm_wo"
abbreviation "isMinim \<equiv> wo_rel.isMinim"
abbreviation "minim \<equiv> wo_rel.minim"
abbreviation "max2 \<equiv> wo_rel.max2"
abbreviation "supr \<equiv> wo_rel.supr"
abbreviation "suc \<equiv> wo_rel.suc"

end


section "BIT is pairwise"

theory BIT_pairwise
imports List_Factoring BIT
begin

lemma L_nths: "S \<subseteq> {..<length init}
  \<Longrightarrow> map_pmf (\<lambda>l. nths l S) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (nths init S)))"
proof(induct init arbitrary: S)
  case (Cons a as)
  then have passt: "{j. Suc j \<in> S} \<subseteq> {..<length as}" by auto

  have " map_pmf (\<lambda>l. nths l S) (Prob_Theory.bv (length (a # as))) =
    Prob_Theory.bv (length as) \<bind>
    (\<lambda>x. bernoulli_pmf (1 / 2) \<bind>
          (\<lambda>xa. return_pmf
                  ((if 0 \<in> S then [xa] else []) @ nths x {j. Suc j \<in> S})))"
      by(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf nths_Cons)
  also have "\<dots> = (bernoulli_pmf (1 / 2)) \<bind>
          (\<lambda>xa. (Prob_Theory.bv (length as) \<bind>
    (\<lambda>x. return_pmf ((if 0 \<in> S then [xa] else []) @ nths x {j. Suc j \<in> S}))))"
        by(rule bind_commute_pmf)
   also have "\<dots> = (bernoulli_pmf (1 / 2)) \<bind>
          (\<lambda>xa. (map_pmf (\<lambda>x. (nths x {j. Suc j \<in> S})) (Prob_Theory.bv (length as)))
              \<bind>  (\<lambda>xs. return_pmf ((if 0 \<in> S then [xa] else []) @ xs)))"
      by(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def)
   also have "\<dots> = (bernoulli_pmf (1 / 2)) \<bind>
          (\<lambda>xa. Prob_Theory.bv (length (nths as {j. Suc j \<in> S}))
              \<bind>  (\<lambda>xs. return_pmf ((if 0 \<in> S then [xa] else []) @ xs)))"
        using Cons(1)[OF passt] by auto
   also have "\<dots> = Prob_Theory.bv (length (nths (a # as) S))"
      apply(auto simp add: nths_Cons bind_return_pmf')
      by(rule bind_commute_pmf)
   finally show ?case .
qed (simp)

lemma L_nths_Lxy:
  assumes "x\<in>set init" "y\<in>set init" "x\<noteq>y" "distinct init"
  shows "map_pmf (\<lambda>l. nths l {index init x,index init y}) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (Lxy init {x,y})))"
proof -
  from assms(4) have setinit: "(index init) ` set init = {0..<length init}"
  proof(induct init)
    case (Cons a as)
    with Cons have iH: "index as ` set as = {0..<length as}" by auto
    from Cons have 1:"(set as \<inter> {x. (a \<noteq> x)}) = set as" by fastforce
    have 2: "(\<lambda>a. Suc (index as a)) ` set as =
            (\<lambda>a. Suc a) ` ((index as) ` set as )" by auto
    show ?case
    apply(simp add: 1 2 iH) by auto
  qed simp

  have xy_le: "index init x<length init" "index init y<length init" using assms by auto
  have "map_pmf (\<lambda>l. nths l {index init x,index init y}) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (nths init {index init x,index init y})))"
        apply(rule L_nths)
        using assms(1,2) by auto
  moreover have "length (Lxy init {x,y}) = length (nths init {index init x,index init y})"
  proof -
    have "set (Lxy init {x,y}) = {x,y}"
      using assms(1,2) by(simp add: Lxy_set_filter)
    moreover have "card {x,y} = 2" using assms(3) by auto
    moreover have "distinct (Lxy init {x,y})" using assms(4) by(simp add: Lxy_distinct)
    ultimately have 1: "length (Lxy init {x,y}) = 2" by(simp add: distinct_card[symmetric])
    have "set (nths init {index init x,index init y}) = {(init ! i) | i.  i < length init \<and> i \<in> {index init x,index init y}}"
      using assms(1,2) by(simp add: set_nths)
    moreover have "card {(init ! i) | i.  i < length init \<and> i \<in> {index init x,index init y}} = 2"
    proof -
      have 1: "{(init ! i) | i.  i < length init \<and> i \<in> {index init x,index init y}} = {init ! index init x, init ! index init y}" using xy_le by blast
      also have "\<dots> = {x,y}" using nth_index assms(1,2) by auto
      finally show ?thesis using assms(3) by auto
    qed
    moreover have "distinct (nths init {index init x,index init y})" using assms(4) by(simp)
    ultimately have 2: "length (nths init {index init x,index init y}) = 2" by(simp add: distinct_card[symmetric])
    show ?thesis using 1 2 by simp
  qed
  ultimately show ?thesis by simp
qed

lemma nths_map: "map f (nths xs S) = nths (map f xs) S"
apply(induct xs arbitrary: S) by(simp_all  add: nths_Cons)

lemma nths_empty: "(\<forall>i\<in>S. i\<ge>length xs) \<Longrightarrow> nths xs S = []"
proof -
  assume "(\<forall>i\<in>S. i\<ge>length xs)"
  then have "set (nths xs S) = {}" apply(simp add: set_nths) by force
  then show "nths xs S = []" by simp
qed

lemma nths_project': "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> i<j
   \<Longrightarrow> nths xs {i,j} = [xs!i, xs!j]"
proof -
  assume il: "i < length xs" and jl: "j < length xs" and ij: "i<j"

  from il obtain a as where dec1: "a @ [xs!i] @ as = xs"
           and "a = take i xs" "as=drop (Suc i) xs"
           and length_a: "length a = i" and length_as: "length as = length xs - i - 1"using id_take_nth_drop by fastforce
  have "j\<ge>length (a @ [xs!i])" using length_a ij by auto
  then have "((a @ [xs!i]) @ as) ! j = as ! (j-length (a @ [xs ! i]))" using nth_append[where xs="a @ [xs!i]" and ys="as"]
    by(simp)
  then have xsj: "xs ! j = as ! (j-i-1)" using dec1 length_a by auto
  have las: "(j-i-1) < length as" using length_as jl ij by simp
  obtain b c where dec2: "b @ [xs!j] @ c = as"
            and "b = take (j-i-1) as" "c=drop (Suc (j-i-1)) as"
            and length_b: "length b = j-i-1" using id_take_nth_drop[OF las] xsj by force
  have xs_dec: "a @ [xs!i] @ b @ [xs!j] @ c = xs" using dec1 dec2 by auto

  have s2: "{k. (k + i \<in> {i, j})} = {0,j-i}"  using ij by force
  have s3: "{k. (k  + length [xs ! i] \<in> {0, j-i})} = {j-i-1}"  using ij by force
  have s4: "{k. (k  + length b \<in> {j-i-1})} = {0}"  using length_b by force
  have s5: "{k. (k  + length [xs!j] \<in> {0})} = {}" by force
  have l1: "nths a {i,j} = []"
    apply(rule nths_empty) using length_a ij by fastforce
  have l2: "nths b {j - Suc i} = []"
    apply(rule nths_empty) using length_b ij by fastforce
  have "nths ( a @ [xs!i] @ b @ [xs!j] @ c) {i,j} = [xs!i, xs!j]"
      apply(simp only: nths_append length_a s2 s3 s4 s5)
      by(simp add: l1 l2)
  then show "nths xs {i,j} = [xs!i, xs!j]" unfolding xs_dec .
qed

lemma nths_project:
  assumes  "i < length xs" "j < length xs" "i<j"
   shows "nths xs {i,j} ! 0 = xs ! i \<and> nths xs {i,j} ! 1 = xs ! j"
proof -
  from assms have "nths xs {i,j} = [xs!i, xs!j]" by(rule nths_project')
  then show ?thesis by simp
qed

lemma BIT_pairwise':
  assumes "set qs \<subseteq> set init"
    "(x,y)\<in> {(x,y). x \<in> set init \<and> y\<in>set init \<and> x\<noteq>y}"
   and  xny:"x \<noteq> y" and dinit: "distinct init"
  shows "Pbefore_in x y BIT qs init = Pbefore_in x y BIT (Lxy qs {x,y}) (Lxy init {x,y})"
proof -
  from assms have xyininit: "{x, y} \<subseteq> set init"
        and qsininit: "set qs \<subseteq> set init" by auto

  have xyininit': "{y,x} \<subseteq> set init" using xyininit by auto

  have a: "x \<in> set init" "y\<in>set init" using assms by auto

    { fix n
    have strong: "set qs \<subseteq> set init \<Longrightarrow>
      map_pmf (\<lambda>(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs) =
      config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y}) " (is "?inv \<Longrightarrow> ?L qs = ?R qs")
    proof (induct qs rule: rev_induct)
      case Nil

      have " map_pmf (\<lambda>(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init [])
          =  map_pmf (\<lambda>w. (Lxy init {x,y}, (w, Lxy init {x,y}))) (map_pmf (\<lambda>l. nths l {index init x,index init y}) (Prob_Theory.bv (length init)))"
              by(simp add: bind_return_pmf map_pmf_def bind_assoc_pmf split_def BIT_init_def)
      also have "\<dots> = map_pmf (\<lambda>w. (Lxy init {x,y}, (w, Lxy init {x,y}))) (Prob_Theory.bv (length (Lxy init {x, y})))"
          using L_nths_Lxy[OF a xny dinit] by simp
      also have "\<dots> = config_rand BIT  (Lxy init {x, y}) (Lxy [] {x, y})"
          by(simp add: BIT_init_def bind_return_pmf bind_assoc_pmf map_pmf_def)
      finally show ?case .
    next
      case (snoc q qs)
      then have qininit: "q \<in>  set init"
            and qsininit: "set qs \<subseteq> set init" using qsininit by auto

      from  snoc(1)[OF qsininit] have iH: "?L qs = ?R qs" by (simp add: split_def)

      show ?case
      proof (cases "q \<in> {x,y}")
        case True
        note whatisq=this

        have "?L (qs@[q]) =
         map_pmf (\<lambda>(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs \<bind>
              (\<lambda>s. BIT_step s q \<bind> (\<lambda>(a, nis). return_pmf (step (fst s) q a, nis))))"
             by(simp add: split_def config'_rand_snoc)
        also have "\<dots> =
        map_pmf (\<lambda>(l,(w,i)). (Lxy l {x,y}, (nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs) \<bind>
        (\<lambda>s.
            BIT_step s q \<bind>
            (\<lambda>(a, nis). return_pmf (step (fst s) q a, nis))) "
           apply(simp add: map_pmf_def split_def bind_return_pmf bind_assoc_pmf)
           apply(simp add: BIT_step_def bind_return_pmf)
        proof (rule bind_pmf_cong, goal_cases)
          case (2 z)
          let ?s = "fst z"
          let ?b = "fst (snd z)"

          from 2 have z: "set (?s) = set init" using config_rand_set[of BIT, simplified]  by metis
          with True have qLxy: "q \<in> set (Lxy (?s) {x, y})" using   xyininit by (simp add: Lxy_set_filter)
          from 2 have dz: "distinct (?s)" using dinit config_rand_distinct[of BIT, simplified] by metis
          then have dLxy: "distinct (Lxy (?s) {x, y})" using Lxy_distinct by auto

          from 2 have [simp]: "snd (snd z) = init" using config_n_init3[simplified]   by metis

          from 2 have [simp]: "length (fst (snd z)) = length init" using config_n_fst_init_length2[simplified] by metis

          have indexinbounds: "index init x < length init" "index init y < length init"  using a by auto
          from a xny have indnot: "index init x \<noteq> index init y" by auto

          have f1: "index init x < length (fst (snd z))" using xyininit by auto
          have f2: "index init y < length (fst (snd z))" using xyininit by auto
          have 3: "index init x \<noteq> index init y" using xny xyininit by auto

          from dinit have dfil: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)
          have Lxy_set: "set (Lxy init {x, y}) = {x,y}" apply(simp add: Lxy_set_filter) using xyininit by fast
          then have xLxy: "x\<in>set (Lxy init {x, y})" by auto
          have Lxy_length: "length (Lxy init {x, y}) = 2" using dfil Lxy_set xny distinct_card by fastforce
          have 31:  "index (Lxy init {x, y}) x < 2"
              and  32:  "index (Lxy init {x, y}) y < 2" using Lxy_set xyininit Lxy_length by auto
          have 33: "index (Lxy init {x, y}) x \<noteq> index (Lxy init {x,y}) y"
            using xny xLxy by auto

          have a1: "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})" (is "?A=?B")
          proof (simp only: list_eq_iff_nth_eq, goal_cases)
            case 1

            {assume ass: "index init x < index init y"
              then have "index (Lxy init {x,y}) x < index (Lxy init {x,y}) y"
                using Lxy_mono[OF xyininit dinit] before_in_def a(2) by force
              with 31 32 have ix: "index (Lxy init {x,y}) x = 0"
                      and iy: "index (Lxy init {x,y}) y = 1" by auto

             have g1: "(nths (fst (snd z)) {index init x,index init y})
                        = [(fst (snd z)) ! index init x, (fst (snd z)) ! index init y]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact

            have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                  = [flip (index init (q)) (fst (snd z))!index init x,
                        flip (index init (q)) (fst (snd z))!index init y]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact
            also have "\<dots> = flip (index (Lxy init {x,y}) (q)) [(fst (snd z)) ! index init x, (fst (snd z)) ! index init y]"
              apply(cases "q=x")
                apply(simp add: ix) using flip_other[OF f2 f1 3] flip_itself[OF f1] apply(simp)
                using whatisq apply(simp add: iy) using flip_other[OF f1 f2 3[symmetric]] flip_itself[OF f2] by(simp)
            finally have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})"
                    by(simp add: g1)

            }note cas1=this
            have man: "{x,y} = {y,x}" by auto
            {assume "~ index init x < index init y"
              then have ass: "index init y < index init x" using 3 by auto
              then have "index (Lxy init {x,y}) y < index (Lxy init {x,y}) x"
                using Lxy_mono[OF xyininit' dinit] xyininit a(1) man by(simp add: before_in_def)
              with 31 32 have ix: "index (Lxy init {x,y}) x = 1"
                      and iy: "index (Lxy init {x,y}) y = 0" by auto

             have g1: "(nths (fst (snd z)) {index init y,index init x})
                        = [(fst (snd z)) ! index init y, (fst (snd z)) ! index init x]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact

            have man2: "{index init x,index init y} = {index init y,index init x}" by auto
            have "nths (flip (index init (q)) (fst (snd z))) {index init y,index init x}
                  = [flip (index init (q)) (fst (snd z))!index init y,
                        flip (index init (q)) (fst (snd z))!index init x]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact
            also have "\<dots> = flip (index (Lxy init {x,y}) (q)) [(fst (snd z)) ! index init y, (fst (snd z)) ! index init x]"
              apply(cases "q=x")
                apply(simp add: ix) using flip_other[OF f2 f1 3] flip_itself[OF f1] apply(simp)
                using whatisq apply(simp add: iy) using flip_other[OF f1 f2 3[symmetric]] flip_itself[OF f2] by(simp)
            finally have "nths (flip (index init (q)) (fst (snd z))) {index init y,index init x}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init y,index init x})"
                    by(simp add: g1)
            then have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})"
                    using man2 by auto
            } note cas2=this

            from cas1 cas2 3 show ?case by metis
          qed

          have a: "nths (fst (snd z)) {index init x, index init y} ! (index (Lxy init {x,y}) (q))
                    = fst (snd z) ! (index init (q))"
          proof -
            from 31 32  33have ca: "(index (Lxy init {x,y}) x = 0 \<and> index (Lxy init {x,y}) y = 1)
                    \<or> (index (Lxy init {x,y}) x = 1 \<and> index (Lxy init {x,y}) y = 0)" by force
            show ?thesis
            proof (cases "index (Lxy init {x,y}) x = 0")
              case True

              from True ca have y1: "index (Lxy init {x,y}) y = 1" by auto
              with True have "index (Lxy init {x,y}) x < index (Lxy init {x,y}) y" by auto
              then have xy: "index init x < index init y" using dinit dfil Lxy_mono
                      using "32" before_in_def Lxy_length xyininit by fastforce

              have 4: " {index init y, index init x} =  {index init x, index init y}" by auto

              have "nths (fst (snd z)) {index init x, index init y} ! index (Lxy init {x,y}) x = (fst (snd z)) ! index init x"
                       "nths (fst (snd z)) {index init x, index init y} ! index (Lxy init {x,y}) y = (fst (snd z)) ! index init y"
                       unfolding True y1
                          by (simp_all only: nths_project[OF f1 f2 xy])
              with whatisq show ?thesis by auto
           next
              case False
              with ca have x1: "index (Lxy init {x,y}) x = 1" by auto
              from dinit have dfil: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)

              from x1 ca have y1: "index (Lxy init {x,y}) y = 0" by auto
              with x1 have "index (Lxy init {x,y}) y < index (Lxy init {x,y}) x" by auto
              then have xy: "index init y < index init x" using dinit dfil Lxy_mono
                      using "32" before_in_def Lxy_length xyininit by (metis a(2) indnot linorder_neqE_nat not_less0 y1)

              have 4: " {index init y, index init x} =  {index init x, index init y}" by auto

              have "nths (?b) {index init x, index init y} ! index (Lxy init {x,y}) x = (?b) ! index init x"
                       "nths (?b) {index init x, index init y} ! index (Lxy init {x,y}) y = (?b) ! index init y"
                       unfolding x1 y1
                        using 4 nths_project[OF  f2 f1 xy]
                          by simp_all
              with whatisq show ?thesis by auto
           qed
         qed

          have b: "Lxy (mtf2 (length ?s) (q) ?s) {x, y}
                =  mtf2 (length (Lxy ?s {x, y})) (q) (Lxy ?s {x, y})" (is "?A = ?B")
          proof -
                have sA: "set ?A = {x,y}" using z xyininit by(simp add: Lxy_set_filter)
                then have xlxymA: "x \<in> set ?A"
                      and ylxymA: "y \<in> set ?A" by auto
                have dA: "distinct ?A" apply(rule Lxy_distinct) by(simp add: dz)
                have lA: "length ?A = 2" using xny sA dA distinct_card by fastforce
                from lA ylxymA have yindA: "index ?A y < 2" by auto
                from lA xlxymA have xindA: "index ?A x < 2" by auto
                have geA: "{x,y} \<subseteq> set (mtf2 (length ?s) (q) ?s)" using xyininit z by auto
                have geA': "{y,x} \<subseteq> set (mtf2 (length ?s) (q) (?s))" using xyininit z by auto
                have man: "{y,x} = {x,y}" by auto

                have sB: "set ?B = {x,y}" using z xyininit by(simp add: Lxy_set_filter)
                then have xlxymB: "x \<in> set ?B"
                  and ylxymB: "y \<in> set ?B" by auto
                have dB: "distinct ?B" apply(simp) apply(rule Lxy_distinct) by(simp add: dz)
                have lB: "length ?B = 2" using xny sB dB distinct_card by fastforce
                from lB ylxymB have yindB: "index ?B y < 2" by auto
                from lB xlxymB have xindB: "index ?B x < 2" by auto

                show ?thesis
                proof (cases "q = x")
                  case True
                  then have xby: "x < y in (mtf2 (length (?s)) (q) (?s))"
                    apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: dz)
                  then have "x < y in ?A" using Lxy_mono[OF geA] dz by(auto)
                  then have "index ?A x < index ?A y" unfolding before_in_def by auto
                  then have in1: "index ?A x = 0"
                          and in2: "index ?A y = 1"  using yindA by auto
                  have "?A = [?A!0,?A!1]"
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(auto simp: lA) apply(case_tac i) by(auto)
                  also have "\<dots> = [?A!index ?A x, ?A!index ?A y]" by(simp only: in1 in2)
                  also have "\<dots> = [x,y]" using xlxymA ylxymA  by simp
                  finally have end1: "?A  = [x,y]" .

                  have "x < y in ?B"
                    using True apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: Lxy_distinct dz Lxy_set_filter)
                  then have "index ?B x < index ?B y"
                            unfolding before_in_def by auto
                  then have in1: "index ?B x = 0"
                          and in2: "index ?B y = 1"
                            using yindB by auto

                  have "?B = [?B!0, ?B!1]"
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(simp only: lB)
                            apply(auto) apply(case_tac i) by(auto)
                  also have "\<dots> = [?B!index ?B x,  ?B!index ?B y]"
                                 by(simp only: in1 in2)
                  also have "\<dots> = [x,y]" using xlxymB ylxymB  by simp
                  finally have end2: "?B = [x,y]" .

                  then show "?A = ?B " using end1 end2 by simp
              next
                  case False
                  with whatisq have qsy: "q=y" by simp
                  then have xby: "y < x in (mtf2 (length (?s)) (q) (?s))"
                    apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: dz)
                  then have "y < x in ?A" using Lxy_mono[OF geA'] man dz by auto
                  then have "index ?A y < index ?A x" unfolding before_in_def by auto
                  then have in1: "index ?A y = 0"
                          and in2: "index ?A x = 1"  using xindA by auto
                  have "?A = [?A!0,?A!1]"
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(auto simp: lA) apply(case_tac i) by(auto)
                  also have "\<dots> = [?A!index ?A y, ?A!index ?A x]" by(simp only: in1 in2)
                  also have "\<dots> = [y,x]" using xlxymA ylxymA  by simp
                  finally have end1: "?A  = [y,x]" .

                  have "y < x in ?B"
                    using qsy apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: Lxy_distinct dz Lxy_set_filter)
                  then have "index ?B y < index ?B x"
                            unfolding before_in_def by auto
                  then have in1: "index ?B y = 0"
                          and in2: "index ?B x = 1"
                            using xindB by auto

                  have "?B = [?B!0, ?B!1]"
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(simp only: lB)
                            apply(auto) apply(case_tac i) by(auto)
                  also have "\<dots> = [?B!index ?B y,  ?B!index ?B x]"
                                 by(simp only: in1 in2)
                  also have "\<dots> = [y,x]" using xlxymB ylxymB  by(simp )
                  finally have end2: "?B = [y,x]" .

                  then show "?A = ?B " using end1 end2 by simp
              qed
           qed

          have a2: " Lxy (step (?s) (q) (if ?b ! (index init (q)) then 0 else length (?s), [])) {x, y}
              = step (Lxy (?s) {x, y}) (q) (if nths (?b) {index init x, index init y} ! (index (Lxy init {x,y}) (q))
                              then 0
                              else length (Lxy (?s) {x, y}), [])"
               apply(auto simp add: a step_def) by(simp add: b)

           show ?case using a1 a2 by(simp)
        qed simp
        also have "\<dots> = ?R (qs@[q])"
          using True apply(simp add: Lxy_snoc take_Suc_conv_app_nth config'_rand_snoc)
          using iH by(simp add: split_def )
        finally show ?thesis .
      next
        case False
        then have qnx: "(q) \<noteq> x" and qny: "(q) \<noteq> y" by auto

        let ?proj="(\<lambda>a. (Lxy (fst a) {x, y}, (nths (fst (snd a)) {index init x, index init y}, Lxy init {x, y})))"

        have "map_pmf ?proj (config_rand BIT init (qs@[q]))
             = map_pmf ?proj (config_rand (BIT_init, BIT_step) init qs
                \<bind> (\<lambda>p. BIT_step p (q) \<bind> (\<lambda>pa. return_pmf (step (fst p) (q) (fst pa), snd pa)))) "
               by (simp add: split_def take_Suc_conv_app_nth config'_rand_snoc)
        also have "\<dots> = map_pmf ?proj (config_rand (BIT_init, BIT_step) init qs)"
            apply(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf BIT_step_def)
            proof (rule bind_pmf_cong, goal_cases)
              case (2 z)
              let ?s = "fst z"
              let ?m = "snd (snd z)"
              let ?b = "fst (snd z)"

              from 2 have sf_init: "?m = init" using config_n_init3 by auto

              from 2 have ff_len: "length (?b) = length init" using config_n_fst_init_length2 by auto

              have ff_ix: "index init x < length (?b)" unfolding ff_len using a(1) by auto
              have ff_iy: "index init y < length (?b)" unfolding ff_len using a(2) by auto
              have ff_q: "index init (q) < length (?b)" unfolding ff_len using qininit by auto
              have iq_ix: "index init (q) \<noteq> index init x" using a(1) qnx by auto
              have iq_iy: "index init (q) \<noteq> index init y" using a(2) qny by auto
              have ix_iy: "index init x \<noteq> index init y" using a(2) xny by auto

              from 2 have s_set[simp]: "set (?s) = set init" using config_rand_set by force
              have s_xin: "x\<in>set (?s)" using a(1) by simp
              have s_yin: "y\<in>set (?s)" using a(2) by simp
              from 2 have s_dist: "distinct (?s)" using config_rand_distinct dinit by force
              have s_qin: "q \<in> set (?s)" using qininit by simp

              have fstfst: "nths (flip (index ?m (q)) (?b))
              {index init x, index init y}
                  = nths (?b) {index init x, index init y}" (is "nths ?A ?I = nths ?B ?I")
              proof (cases "index init x < index init y")
                case True
                have "nths ?A ?I = [?A!index init x, ?A!index init y]"
                      apply(rule nths_project')
                        by(simp_all add: ff_ix ff_iy True)
                also have "\<dots> = [?B!index init x, ?B!index init y]"
                  unfolding sf_init using flip_other ff_ix ff_iy ff_q iq_ix iq_iy by auto
                also have "\<dots> = nths ?B ?I"
                      apply(rule nths_project'[symmetric])
                        by(simp_all add: ff_ix ff_iy True)
                finally show ?thesis .
              next
                case False
                then have yx: "index init y < index init x" using ix_iy by auto
                have man: "?I =  {index init y, index init x}" by auto
                have "nths ?A {index init y, index init x}  = [?A!index init y, ?A!index init x]"
                      apply(rule nths_project')
                        by(simp_all add: ff_ix ff_iy yx)
                also have "\<dots> = [?B!index init y, ?B!index init x]"
                  unfolding sf_init using flip_other ff_ix ff_iy ff_q iq_ix iq_iy by auto
                also have "\<dots> = nths ?B {index init y, index init x}"
                      apply(rule nths_project'[symmetric])
                        by(simp_all add: ff_ix ff_iy yx)
                finally show ?thesis by(simp add: man)
              qed

              have snd: "Lxy (step (?s) (q)
                  (if ?b ! index ?m (q) then 0 else length (?s),
                   [])) {x, y} = Lxy (?s) {x, y}" (is "Lxy ?A {x,y} = Lxy ?B {x,y}")
              proof (cases "x < y in ?B")
                case True
                note B=this
                then have A: "x<y in ?A" apply(auto simp add: step_def split_def)
                  apply(rule x_stays_before_y_if_y_not_moved_to_front)
                    by(simp_all add: a s_dist qny[symmetric] qininit)

                have "Lxy ?A {x,y} = [x,y]"
                  apply(rule Lxy_project)
                    by(simp_all add: xny set_step distinct_step A s_dist a)
                also have "... = Lxy ?B {x,y}"
                  apply(rule Lxy_project[symmetric])
                    by(simp_all add: xny B s_dist a)
                finally show ?thesis .
              next
                case False
                then have B: "y < x in ?B" using not_before_in[OF s_xin s_yin] xny by simp
                then have A: "y < x in ?A " apply(auto simp add: step_def split_def)
                  apply(rule x_stays_before_y_if_y_not_moved_to_front)
                    by(simp_all add: a s_dist qnx[symmetric] qininit)
                have man: "{x,y} = {y,x}" by auto
                have "Lxy ?A {y,x} = [y,x]"
                  apply(rule Lxy_project)
                    by(simp_all add: xny[symmetric] set_step distinct_step A s_dist a)
                also have "... = Lxy ?B {y,x}"
                  apply(rule Lxy_project[symmetric])
                    by(simp_all add: xny[symmetric] B s_dist a)
                finally show ?thesis using man by auto
              qed

              show ?case by(simp add: fstfst snd)
            qed simp
        also have "\<dots> = config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y})"
          using iH by (auto simp: split_def)
        also have "\<dots> = ?R (qs@[q])"
          using False by(simp add: Lxy_snoc)
        finally show ?thesis by (simp add: split_def)
      qed
    qed
    } note strong=this

  {
    fix n::nat
    have "Pbefore_in x y BIT qs init =
        map_pmf (\<lambda>p. x < y in fst p)
            (map_pmf (\<lambda>(l, (w, i)). (Lxy l {x, y}, (nths w {index init x, index init y}, Lxy init {x, y})))
                  (config_rand BIT init qs))"
                  unfolding Pbefore_in_def apply(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf split_def)
                  apply(rule bind_pmf_cong)
                    apply(simp)
                    proof (goal_cases)
                      case (1 z)
                      let ?s = "fst z"
                      from 1 have u: "set (?s) = set init" using config_rand[of BIT, simplified] by metis
                      from 1 have v: "distinct (?s)" using dinit config_rand[of BIT, simplified] by metis
                      have "(x < y in ?s) = (x < y in Lxy (?s) {x, y})"
                        apply(rule Lxy_mono)
                          using u xyininit apply(simp)
                          using v by simp
                      then show ?case by simp
                    qed
     also have "\<dots> = map_pmf (\<lambda>p. x < y in fst p) (config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y}))"
        apply(subst strong) using assms by simp_all
     also have "\<dots> = Pbefore_in x y BIT (Lxy qs {x, y}) (Lxy init {x, y})" unfolding Pbefore_in_def by simp
     finally have "Pbefore_in x y BIT qs init =
        Pbefore_in x y BIT (Lxy qs {x, y}) (Lxy init {x, y})" .

  } note fine=this

  with assms show ?thesis by simp
qed

theorem BIT_pairwise: "pairwise BIT"
apply(rule pairwise_property_lemma)
  apply(rule BIT_pairwise')
    by(simp_all add: BIT_step_def)

end


section \<open>\<open>Extra_Operator_Norm\<close> -- Additional facts bout the operator norm\<close>

theory Extra_Operator_Norm
  imports "HOL-Analysis.Operator_Norm"
    Extra_General
    "HOL-Analysis.Bounded_Linear_Function"
    Extra_Vector_Spaces
begin

text \<open>This theorem complements \<^theory>\<open>HOL-Analysis.Operator_Norm\<close>
      additional useful facts about operator norms.\<close>

lemma onorm_sphere:
  fixes f :: "'a::{real_normed_vector, not_singleton} \<Rightarrow> 'b::real_normed_vector"
  assumes a1: "bounded_linear f"
  shows \<open>onorm f = Sup {norm (f x) | x. norm x = 1}\<close>
proof(cases \<open>f = (\<lambda> _. 0)\<close>)
  case True
  have \<open>(UNIV::'a set) \<noteq> {0}\<close>
    by simp
  hence \<open>\<exists>x::'a. norm x = 1\<close>
    using  ex_norm1
    by blast
  have \<open>norm (f x) = 0\<close>
    for x
    by (simp add: True)
  hence \<open>{norm (f x) | x. norm x = 1} = {0}\<close>
    using \<open>\<exists>x. norm x = 1\<close> by auto
  hence v1: \<open>Sup {norm (f x) | x. norm x = 1} = 0\<close>
    by simp
  have \<open>onorm f = 0\<close>
    by (simp add: True onorm_eq_0)
  thus ?thesis using v1 by simp
next
  case False
  have \<open>y \<in> {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    if "y \<in> {norm (f x) / norm x |x. True}"
    for y
  proof(cases \<open>y = 0\<close>)
    case True
    thus ?thesis
      by simp
  next
    case False
    have \<open>\<exists> x. y = norm (f x) / norm x\<close>
      using \<open>y \<in> {norm (f x) / norm x |x. True}\<close> by auto
    then obtain x where \<open>y = norm (f x) / norm x\<close>
      by blast
    hence \<open>y = \<bar>(1/norm x)\<bar> * norm ( f x )\<close>
      by simp
    hence \<open>y = norm ( (1/norm x) *\<^sub>R f x )\<close>
      by simp
    hence \<open>y = norm ( f ((1/norm x) *\<^sub>R x) )\<close>
      apply (subst linear_cmul[of f])
      by (simp_all add: assms bounded_linear.linear)
    moreover have \<open>norm ((1/norm x) *\<^sub>R x) = 1\<close>
      using False \<open>y = norm (f x) / norm x\<close> by auto
    ultimately have \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      by blast
    thus ?thesis by blast
  qed
  moreover have "y \<in> {norm (f x) / norm x |x. True}"
    if \<open>y \<in> {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    for y
  proof(cases \<open>y = 0\<close>)
    case True
    thus ?thesis
      by auto
  next
    case False
    hence \<open>y \<notin> {0}\<close>
      by simp
    hence \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      using that by auto
    hence \<open>\<exists> x. norm x = 1 \<and> y = norm (f x)\<close>
      by auto
    then obtain x where \<open>norm x = 1\<close> and \<open>y = norm (f x)\<close>
      by auto
    have \<open>y = norm (f x) / norm x\<close> using  \<open>norm x = 1\<close>  \<open>y = norm (f x)\<close>
      by simp
    thus ?thesis
      by auto
  qed
  ultimately have \<open>{norm (f x) / norm x |x. True} = {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    by blast
  hence \<open>Sup {norm (f x) / norm x |x. True} = Sup ({norm (f x) |x. norm x = 1} \<union> {0})\<close>
    by simp
  moreover have \<open>Sup {norm (f x) |x. norm x = 1} \<ge> 0\<close>
  proof-
    have \<open>\<exists> x::'a. norm x = 1\<close>
      by (metis (full_types) False assms linear_simps(3) norm_sgn)
    then obtain x::'a where \<open>norm x = 1\<close>
      by blast
    have \<open>norm (f x) \<ge> 0\<close>
      by simp
    hence \<open>\<exists> x::'a. norm x = 1 \<and> norm (f x) \<ge> 0\<close>
      using \<open>norm x = 1\<close> by blast
    hence \<open>\<exists> y \<in> {norm (f x) |x. norm x = 1}. y \<ge> 0\<close>
      by blast
    then obtain y::real where \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      and \<open>y \<ge> 0\<close>
      by auto
    have \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close>
      using \<open>y \<in> {norm (f x) |x. norm x = 1}\<close> by blast
    moreover have \<open>bdd_above {norm (f x) |x. norm x = 1}\<close>
      using bdd_above_norm_f
      by (metis (mono_tags, lifting) a1)
    ultimately have \<open>y \<le> Sup {norm (f x) |x. norm x = 1}\<close>
      using \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      by (simp add: cSup_upper)
    thus ?thesis using \<open>y \<ge> 0\<close> by simp
  qed
  moreover have \<open>Sup ({norm (f x) |x. norm x = 1} \<union> {0}) = Sup {norm (f x) |x. norm x = 1}\<close>
  proof-
    have \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close>
      by (simp add: assms(1) ex_norm1)
    moreover have \<open>bdd_above {norm (f x) |x. norm x = 1}\<close>
      using a1 bdd_above_norm_f by force
    have \<open>{0::real} \<noteq> {}\<close>
      by simp
    moreover have \<open>bdd_above {0::real}\<close>
      by simp
    ultimately have \<open>Sup ({norm (f x) |x. norm x = 1} \<union> {(0::real)})
             = max (Sup {norm (f x) |x. norm x = 1}) (Sup {0::real})\<close>
      by (metis (lifting) \<open>0 \<le> Sup {norm (f x) |x. norm x = 1}\<close> \<open>bdd_above {0}\<close> \<open>bdd_above {norm (f x) |x. norm x = 1}\<close> \<open>{0} \<noteq> {}\<close> \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close> cSup_singleton cSup_union_distrib max.absorb_iff1 sup.absorb_iff1)
    moreover have \<open>Sup {(0::real)} = (0::real)\<close>
      by simp
    moreover have \<open>Sup {norm (f x) |x. norm x = 1} \<ge> 0\<close>
      by (simp add: \<open>0 \<le> Sup {norm (f x) |x. norm x = 1}\<close>)
    ultimately show ?thesis
      by simp
  qed
  moreover have \<open>Sup ( {norm (f x) |x. norm x = 1} \<union> {0})
           = max (Sup {norm (f x) |x. norm x = 1}) (Sup {0}) \<close>
    using calculation(2) calculation(3) by auto
  ultimately have w1: "Sup {norm (f x) / norm x | x. True} = Sup {norm (f x) | x. norm x = 1}"
    by simp

  have \<open>(SUP x. norm (f x) / (norm x)) = Sup {norm (f x) / norm x | x. True}\<close>
    by (simp add: full_SetCompr_eq)
  also have \<open>... = Sup {norm (f x) | x. norm x = 1}\<close>
    using w1 by auto
  ultimately  have \<open>(SUP x. norm (f x) / (norm x)) = Sup {norm (f x) | x. norm x = 1}\<close>
    by linarith
  thus ?thesis unfolding onorm_def by blast
qed

lemma onormI:
  assumes "\<And>x. norm (f x) \<le> b * norm x"
    and "x \<noteq> 0" and "norm (f x) = b * norm x"
  shows "onorm f = b"
  apply (unfold onorm_def, rule cSup_eq_maximum)
   apply (smt (verit) UNIV_I assms(2) assms(3) image_iff nonzero_mult_div_cancel_right norm_eq_zero)
  by (smt (verit, del_insts) assms(1) assms(2) divide_nonneg_nonpos norm_ge_zero norm_le_zero_iff pos_divide_le_eq rangeE zero_le_mult_iff)

end


theory base
  imports Main
begin

(*Override Sledgehammer and Nitpick default params (inherited by all downstream theories)*)
declare[[smt_timeout=30]]
sledgehammer_params[isar_proof=false, max_facts=30]
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2]

declare[[show_types]]
declare[[syntax_ambiguity_warning=false]]

(*We hide some Isabelle/HOL constants and notation from the libraries to avoid overloading*)
hide_const(open) Set.subset Set.subset_eq Set.supset Set.supset_eq
                 Set.union Set.inter Set.image Set.vimage
                 Set.is_empty Set.member Set.is_singleton
                 Relation.converse Relation.Range Relation.total
                 Complete_Lattices.Inter Complete_Lattices.Union
                 List.list.Nil List.list.map
                 Hilbert_Choice.bijection Fun.comp Transitive_Closure.reflcl
                 Product_Type.fst Product_Type.snd

no_notation (*We don't use anything from the Isabelle library *)
  Set.subset  ("'(\<subset>')") and Set.subset  ("(_/ \<subset> _)" [51, 51] 50) and
  Set.subset_eq  ("'(\<subseteq>')") and Set.subset_eq  ("(_/ \<subseteq> _)" [51, 51] 50) and
  Set.supset  ("'(\<supset>')") and Set.supset  ("(_/ \<supset> _)" [51, 51] 50) and
  Set.supset_eq  ("'(\<supseteq>')") and Set.supset_eq  ("(_/ \<supseteq> _)" [51, 51] 50) and
  Set.union (infixl "\<union>" 65) and Set.inter (infixl "\<inter>" 70) and
  Complete_Lattices.Inter ("\<Inter>") and Complete_Lattices.Union ("\<Union>")

(*Sets are encoded as predicates (i.e. functions with a bool-type codomain)*)
type_synonym 'a Set = \<open>'a \<Rightarrow> bool\<close>
(*Relations as curried binary functions into a bool-type codomain *)
type_synonym 'a Rel = \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close>

subsection \<open>Boolean structure\<close>

(*We introduce below some operations on sets which endow them with a Boolean algebra structure.*)
named_theorems connSet

(*Two important 0-ary operations (aka. 'constants'). The "universal" and the "empty" set.*)
abbreviation univ::"'a Set" ("\<UU>")
  where "\<UU> \<equiv> \<lambda>x. True"
abbreviation empty::"'a Set" ("\<emptyset>")
  where "\<emptyset> \<equiv> \<lambda>x. False"

(*Set complement is a unary operation*)
definition compl::"'a Set \<Rightarrow> 'a Set" ("\<midarrow>") (*or type: ('a Set, 'a)\<rho> *)
  where \<open>\<midarrow>A \<equiv> \<lambda>x. \<not>A x\<close>
(*We can also define some binary operations on sets *)
definition inter::"'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set" (infixr "\<inter>" 54)
  where "A \<inter> B \<equiv> \<lambda>x. A x \<and> B x"
definition union::"'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set" (infixr "\<union>" 53)
  where "A \<union> B \<equiv> \<lambda>x. A x \<or> B x"
definition impl::"'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set" (infixr "\<rightarrow>" 55)
  where "A \<rightarrow> B \<equiv> \<lambda>x. A x \<longrightarrow> B x" (** (set-)implication*)
definition diff::"'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set" (infixr "\<leftharpoonup>" 55)
  where "A \<leftharpoonup> B \<equiv> \<lambda>x. A x \<and> \<not>B x" (** (set-)difference*)

declare compl_def[connSet] inter_def[connSet] union_def[connSet]
        impl_def[connSet] diff_def[connSet]

(*Union and intersection can be generalized to the infinitary case (i.e. operating on arbitrary sets of sets)*)
definition biginter::"('a Set)Set \<Rightarrow> 'a Set" ("\<Inter>")
  where "\<Inter>S \<equiv> \<lambda>x. \<forall>A. S A \<longrightarrow> A x"
definition bigunion:: "('a Set)Set \<Rightarrow> 'a Set" ("\<Union>")
  where "\<Union>S \<equiv> \<lambda>x. \<exists>A. S A  \<and>  A x"

subsection \<open>Order structure\<close>

(*The algebra of sets is ordered by the standard subset relation, as defined below.*)
definition subset::"('a Set)Rel" (infixr "\<subseteq>" 52)
  where "A \<subseteq> B \<equiv> \<forall>x. A x \<longrightarrow> B x"
    (*Equality between sets is defined as usual*)
definition eqset::\<open>('a Set)Rel\<close> (infix "\<approx>" 51)
  where eqset_def: \<open>A \<approx> B \<equiv> \<forall>x. A x \<longleftrightarrow> B x\<close>

declare subset_def[connSet] eqset_def[connSet]

abbreviation (input) supset::"('a Set)Rel" (infixr "\<supseteq>" 52)
  where "A \<supseteq> B \<equiv> B \<subseteq> A"
abbreviation subset'::\<open>('a Set)Rel\<close> (infix "\<subset>" 52)
  where \<open>A \<subset> B \<equiv> (A \<subseteq> B) \<and> \<not>(A \<approx> B)\<close>
abbreviation (input) psupset::"('a Set)Rel" (infixr "\<supset>" 52)
  where "A \<supset> B \<equiv> B \<subset> A"

(*We also introduce some useful relativized variants*)
definition subset_rel::\<open>'a Set \<Rightarrow> ('a Set)Rel\<close> ("_ \<subseteq>\<^sub>_ _")
  where \<open>A \<subseteq>\<^sub>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longrightarrow> B x)\<close>
definition eqset_rel::\<open>'a Set \<Rightarrow> ('a Set)Rel\<close> ("_ \<approx>\<^sub>_ _")
  where \<open>A \<approx>\<^sub>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longleftrightarrow> B x)\<close>

declare subset_rel_def[connSet] eqset_rel_def[connSet]

abbreviation psubset_rel::\<open>'a Set \<Rightarrow> ('a Set)Rel\<close> ("_\<subset>\<^sub>_ _")
  where \<open>A \<subset>\<^sub>U B \<equiv> (A \<subseteq>\<^sub>U B) \<and> \<not>(A \<approx>\<^sub>U B)\<close>

lemma subset_rel_char: "(A \<subseteq>\<^sub>U B) = (U \<inter> A \<subseteq> U \<inter> B)" by (smt (verit, best) inter_def subset_def subset_rel_def)
lemma eqset_rel_char: "(A \<approx>\<^sub>U B) = (U \<inter> A \<approx> U \<inter> B)" by (smt (z3) eqset_def eqset_rel_def inter_def)

(*Some useful equivalences:*)
lemma eqset_def2: "(A \<approx> B) = (A \<subseteq> B \<and> B \<subseteq> A)"
  by (metis (mono_tags, lifting) eqset_def subset_def)
lemma eqset_rel_def2: "(A \<approx>\<^sub>U B) = (A \<subseteq>\<^sub>U B \<and> B \<subseteq>\<^sub>U A)"
  by (simp add: eqset_def2 eqset_rel_char subset_rel_char)
lemma subset_contrapos: "(\<midarrow>B \<subseteq> \<midarrow>A) = (A \<subseteq> B)"
  by (metis (full_types) compl_def subset_def)
lemma subset_rel_contrapos: "(\<midarrow>B \<subseteq>\<^sub>U \<midarrow>A) = (A \<subseteq>\<^sub>U B)"
  by (smt (verit) compl_def subset_rel_def)
lemma eqset_ext: "(A \<approx> B) = (A = B)"
  using eqset_def by auto
lemma eqset_rel_ext: "(A \<approx>\<^sub>U B) = ((A \<inter> U) = (B \<inter> U))"
  sorry (*TODO reconstruct*)

subsection \<open>Atoms\<close>

(*(Boolean) algebras of sets are atomic, their atoms being the singleton sets.
  We can easily create singleton sets by partially applying HOL equality *)
abbreviation (input) unitset::"'a \<Rightarrow> 'a Set" ("{_}")
  where \<open>{a} \<equiv> \<lambda>x. x = a\<close>
(* We can extrapolate the above notation to provide some convenient set-builder notation on demand: *)
abbreviation (input) pairset::"'a \<Rightarrow> 'a \<Rightarrow> 'a Set" ("{_,_}")
  where \<open>{a,b} \<equiv> \<lambda>x. x = a \<or> x = b\<close>
abbreviation (input) tripleset::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a Set" ("{_,_,_}")
  where \<open>{a,b,c} \<equiv> \<lambda>x. x = a \<or> x = b \<or> x = c\<close>
(* (add more on demand)*)

subsection \<open>(Endo-)Relations\<close>

(*We define the transpose of an arbitrary binary function as swapping the first and second arguments.
 Note that the transpose/converse of a relation is just the special case with 'a = 'b and 'c = bool.*)
abbreviation (input) transpose::"('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'c)" ("(_)\<^sup>T" [90])
  where \<open>f\<^sup>T \<equiv> \<lambda>a b. f b a\<close>
abbreviation rel_cluster::"'a Rel \<Rightarrow> 'a Rel" ("_\<^sup>=" [90])
  where \<open>R\<^sup>= \<equiv> \<lambda>a b. R a b \<and> R\<^sup>T a b\<close> (* 'undoes' R leaving only R-clusters*)

(*The set of least (resp. greatest) elements of a set A wrt. a relation R*)
definition least::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-least")
  where \<open>R-least \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<longrightarrow> R m x)\<close>
definition greatest::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-greatest")
  where \<open>R-greatest \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<longrightarrow> R x m)\<close>

(*The set of minimal (resp. maximal) elements of a set A wrt. a relation R can be defined in two ways:*)
(*(1) Using R-clusters for equality comparison (cycles are possible) *)
definition minimal::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-min")
  where \<open>R-min \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<and> R x m \<longrightarrow> R\<^sup>= x m)\<close>
definition maximal::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-max")
  where \<open>R-max \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<and> R m x \<longrightarrow> R\<^sup>= x m)\<close>
(*(2) Using (=) for comparison (no cycles posible) *)
definition minimal_eq::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-min\<^sup>=")
  where \<open>R-min\<^sup>= \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<and> R x m \<longrightarrow> x = m)\<close>
definition maximal_eq::"'a Rel \<Rightarrow> ('a Set \<Rightarrow> 'a Set)" ("_-max\<^sup>=")
  where \<open>R-max\<^sup>= \<equiv> \<lambda>A. \<lambda>m. A m \<and> (\<forall>x. A x \<and> R m x \<longrightarrow> x = m)\<close>

lemma greatest__least_trans: \<open>R-greatest = R\<^sup>T-least\<close>
  by (simp add: least_def greatest_def)
lemma max_min_trans:  \<open>R-max = R\<^sup>T-min\<close>
  unfolding minimal_def maximal_def by simp
lemma max_min_eq_trans:  \<open>R-max\<^sup>= = R\<^sup>T-min\<^sup>=\<close>
  unfolding minimal_eq_def maximal_eq_def by simp

subsection \<open>Pairs\<close>

type_synonym ('a)Pair = "bool \<Rightarrow> 'a" (*type for pairs*)

definition fst::"'a Pair \<Rightarrow> 'a" ("fst")
  where "fst p \<equiv> p False"
definition snd::"'a Pair \<Rightarrow> 'a" ("snd")
  where "snd p \<equiv> p True"
definition mkPair::"'a \<Rightarrow> 'a \<Rightarrow> 'a Pair" ("\<langle>_,_\<rangle>")
  where "\<langle>A,B\<rangle> \<equiv> \<lambda>X. if X then B else A"

lemma fst_prop[simp]: "fst\<langle>X,Y\<rangle> = X" by (simp add: mkPair_def fst_def)
lemma snd_prop[simp]: "snd\<langle>X,Y\<rangle> = Y" by (simp add: mkPair_def snd_def)
lemma mkPair_prop[simp]: "\<langle>fst X, snd X\<rangle> = X" unfolding mkPair_def fst_def snd_def by fastforce

abbreviation pair_swap::"'a Pair \<Rightarrow> 'a Pair" ("_\<Zcat>")
  where "p\<Zcat> \<equiv> \<langle>snd p, fst p\<rangle>"

definition curry::"('a Pair)Set \<Rightarrow> ('a)Rel" ("\<lfloor>_\<rfloor>"[90])
  where "curry r \<equiv> \<lambda>A B. r\<langle>A,B\<rangle>"
definition uncurry::"('a)Rel \<Rightarrow> ('a Pair)Set"  ("\<lceil>_\<rceil>"[91])
  where "uncurry r \<equiv> \<lambda>p. r (fst p) (snd p)"

lemma curry_prop1[simp]: "\<lceil>\<lfloor>r\<rfloor>\<rceil> = r" by (simp add: curry_def uncurry_def)
lemma curry_prop2[simp]: "\<lfloor>\<lceil>r\<rceil>\<rfloor> = r" by (simp add: curry_def uncurry_def)

subsection \<open>Fixed-points\<close>

(*For a given unary set-operator (mapping sets to sets) returns the set of its fixed-points.*)
abbreviation (input) fp :: \<open>('a Set \<Rightarrow> 'a Set) \<Rightarrow> ('a Set)Set\<close> ("fp")
  where \<open>fp \<phi> \<equiv> \<lambda>S. (\<phi> S) \<approx> S\<close>
abbreviation (input) fp_rel:: \<open>'a Set \<Rightarrow> ('a Set \<Rightarrow> 'a Set) \<Rightarrow> ('a Set)Set\<close> ("fp\<^sup>_")
  where \<open>fp\<^sup>U \<phi> \<equiv> \<lambda>S. (\<phi> S) \<approx>\<^sub>U S\<close>

lemma fp_rel_prop: \<open>fp \<phi> S \<Longrightarrow> fp\<^sup>U \<phi> S\<close> by (simp add: eqset_ext eqset_rel_def)

(*Useful lemma(?)*)
lemma fp_prop1: \<open>(\<forall>U. (\<lambda>X Y. X \<subseteq>\<^sub>U Y)-least (fp\<^sup>U F) S) \<longrightarrow> (\<subseteq>)-least (fp F) S\<close>
  unfolding least_def by (metis (mono_tags, opaque_lifting) eqset_def2 eqset_rel_def fp_rel_prop subset_def subset_rel_def)

(* Definition of a monotone function (wrt. an universe U).*)
definition MONO::"('a Set \<Rightarrow> 'b Set) \<Rightarrow> bool" ("MONO")
  where \<open>MONO F \<equiv> \<forall>A B. A \<subseteq> B \<longrightarrow> F A \<subseteq> F B\<close>
definition MONO_rel::"'a Set \<Rightarrow> ('a Set \<Rightarrow> 'a Set) \<Rightarrow> bool" ("MONO\<^sup>_")
  where \<open>MONO\<^sup>U F \<equiv> \<forall>A B. (A \<subseteq>\<^sub>U B \<longrightarrow> F A \<subseteq>\<^sub>U F B)\<close>

(* Weak variant of the Knaster-Tarski Theorem (in different formulations):
 Any monotone function on a powerset lattice has a least/greatest fixed-point.*)
lemma wKTl': \<open>MONO F \<Longrightarrow> let S = \<Inter>(\<lambda>X. F X \<subseteq> X) in ((\<subseteq>)-least (fp F) S)\<close> unfolding least_def MONO_def biginter_def by (smt (verit, best) eqset_def2 subset_def)
lemma wKTg': \<open>MONO F \<Longrightarrow> let S = \<Union>(\<lambda>X. X \<subseteq> F X) in ((\<subseteq>)-greatest (fp F) S)\<close> unfolding greatest_def MONO_def bigunion_def by (smt (verit, del_insts) eqset_def2 subset_def)
lemma wKTl:  \<open>MONO F \<Longrightarrow> \<exists>S. (\<subseteq>)-least (fp F) S\<close> using wKTl' by auto
lemma wKTg:  \<open>MONO F \<Longrightarrow> \<exists>S. (\<subseteq>)-greatest (fp F) S\<close> using wKTg' by auto

lemma wKTl_rel': \<open>MONO\<^sup>U F \<Longrightarrow> let S = \<Inter>(\<lambda>X. F X \<subseteq>\<^sub>U X) in ((\<subseteq>)-least (fp\<^sup>U F) S)\<close> unfolding MONO_rel_def least_def biginter_def subset_rel_def eqset_rel_def subset_def by (smt (z3))
lemma wKTg_rel': \<open>MONO\<^sup>U F \<Longrightarrow> let S = \<Union>(\<lambda>X. X \<subseteq>\<^sub>U F X) in ((\<subseteq>)-greatest (fp\<^sup>U F) S)\<close>  unfolding MONO_rel_def greatest_def bigunion_def subset_rel_def eqset_rel_def subset_def by (smt (z3))

lemma wKTl_rel: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. (\<subseteq>)-least (fp\<^sup>U F) S\<close> using wKTl_rel' by auto
lemma wKTl_relw: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. (\<lambda>X Y. X \<subseteq>\<^sub>U Y)-least (fp\<^sup>U F) S\<close> using wKTl_rel by (smt (verit, del_insts) least_def subset_def subset_rel_def)
lemma wKTg_rel: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. (\<subseteq>)-greatest (fp\<^sup>U F) S\<close> using wKTg_rel' by auto
lemma wKTg_relw: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. (\<lambda>X Y. X \<subseteq>\<^sub>U Y)-greatest (fp\<^sup>U F) S\<close> using wKTg_rel by (smt (verit, del_insts) greatest_def subset_def subset_rel_def)

end


theory ValueSimilarity
imports Value CValue Pointwise
begin

text {*
This theory formalizes Section 3 of \cite{functionspaces}. Their domain $D$ is our type @{typ Value},
their domain $E$ is our type @{typ CValue} and $A$ corresponds to @{typ CValue'}.

In our case, the construction of the domains was taken care of by the Nominal package
(\cite{nominal}), so where \cite{functionspaces} refers to elements of the domain approximations
$D_n$ resp. $E_n$, these are just elements of @{typ Value} resp. @{typ CValue} here. Therefore the
\emph{n-injection} $\phi_n^E \colon E_n \to E$ is the identity here.

The projections correspond to the take-functions generated by the Nominal package:
\begin{alignstar}
\psi_n^E &\colon E \to E_n &\text{ corresponds to }&&@{term CValue_take}@{text "::"}&@{typeof "CValue_take :: nat \<Rightarrow> CValue \<rightarrow> CValue" } \\
\psi_n^A &\colon A \to A &\text{ corresponds to }&&@{term CValue'_take}@{text "::"}&@{typeof CValue'_take} \\
\psi_n^D &\colon D \to D_n &\text{ corresponds to }&&@{term Value_take}@{text "::"}&@{typeof Value_take}.
\end{alignstar}

The syntactic overloading of $e(a)(c)$ to mean either $\mathrm{ |mathsf{Ap}}_{E_n}^|bot$ or $\mathrm{ |mathsf{AP}}_{E}^|bot$
turns into our non-overloaded @{text "_ \<down>CFn _"}@{text "::"}@{typeof "op \<down>CFn"}.
*}

text {*
To have our presentation closer to \cite{functionspaces}, we introduce some notation:
*}

notation Value_take ("\<psi>\<^sup>D\<^bsub>_\<^esub>")
notation CValue_take ("\<psi>\<^sup>E\<^bsub>_\<^esub>")
notation CValue'_take ("\<psi>\<^sup>A\<^bsub>_\<^esub>")

subsubsection {* A note about section 2.3 *}

text {*
Section 2.3 of  \cite{functionspaces} contains equations (2) and (3) which do not hold in general. We demonstrate that fact here
using our corresponding definition, but the counter-example carry over to the original forumlation.
Lemma (2) is a generalisation of (3) to the resourced semantics, so the counter-example for
(3) is the simpler and more educating:
*}

lemma counter_example:
  assumes "Equation (3)": "\<And> n d d'. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  shows "False"
proof-
  def n == "1::nat"
  def d == "Fn\<cdot>(\<Lambda> e. (e \<down>Fn \<bottom>) \<down>Fn \<bottom>)"
  def d' == "Fn\<cdot>(\<Lambda> _. Fn\<cdot>(\<Lambda> _. Fn\<cdot>(\<Lambda> _. \<bottom>)))"
  have "Fn\<cdot>(\<Lambda> _. \<bottom>) = \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d')"
    by (simp add: d_def d'_def n_def cfun_map_def)
  also
  have "\<dots> = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
    using "Equation (3)".
  also have "\<dots> = \<bottom>"
    by (simp add: d_def d'_def n_def)
  finally show False by simp
qed

text {* A suitable substitute for the lemma can be found in 4.3.5 (1) in \cite{fullabstraction},
which in our setting becomes the following (note the extra invocation of @{term "Value_take n"} on
the left hand side):
*}

lemma "Abramsky 4,3,5 (1)":
  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  by (cases d)(auto simp add: Value.take_take)

text {*
The problematic equations are used in the proof of the only-if direction of proposition 9 in
\cite{functionspaces}. It can be fixed by applying take-induction, which inserts the
extra call to @{term "Value_take n"} in the right spot.
*}

subsubsection {* Working with @{typ Value} and @{typ CValue} *}

text {* Combined case distinguishing and induction rules. *}

lemma value_CValue_cases:
  obtains
  "x = \<bottom>" "y = \<bottom>" |
  f where "x = Fn\<cdot>f" "y = \<bottom>" |
  g where "x = \<bottom>" "y = CFn \<cdot> g" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g"
by (metis CValue'.exhaust Value.exhaust)

lemma Value_CValue_take_induct:
  assumes "adm (split P)"
  assumes "\<And> n. P (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) (\<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)"
  shows "P x y"
proof-
  have "split P (\<Squnion>n. (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x, \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y))"
    by (rule admD[OF `adm (split P)` ch2ch_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF CValue_chain_take]]])
       (simp add: assms(2))
  hence "split P (x,y)"
    by (simp add: lub_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF CValue_chain_take]]
                  Value.reach CValue_reach)
  thus ?thesis by simp
qed

subsubsection {* Restricted similarity is defined recursively *}

text {* The base case *}

inductive similar'_base :: "Value \<Rightarrow> CValue' \<Rightarrow> bool" where
  bot_similar'_base[simp,intro]: "similar'_base \<bottom> \<bottom>"

inductive_cases [elim!]:
   "similar'_base x y"

text {* The inductive case *}

inductive similar'_step :: "(Value \<Rightarrow> CValue' \<Rightarrow> bool) \<Rightarrow> Value \<Rightarrow> CValue' \<Rightarrow> bool" for s where
  bot_similar'_step[intro!]: "similar'_step s \<bottom> \<bottom>" |
  Fun_similar'_step[intro]: "(\<And> x y . s x (y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> s (f\<cdot>x) (g\<cdot>y\<cdot>C\<^sup>\<infinity>)) \<Longrightarrow> similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

inductive_cases [elim!]:
   "similar'_step s x \<bottom>"
   "similar'_step s \<bottom> y"
   "similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

text {*
We know create the restricted similarity relation, by primitive recursion over @{term n}.

This cannot be done using an inductive definition, as it would not be monotone.
 *}

fun similar' where
 "similar' 0 = similar'_base" |
 "similar' (Suc n) = similar'_step (similar' n)"
declare similar'.simps[simp del]

abbreviation similar'_syn  ("_ \<triangleleft>\<triangleright>\<^bsub>_\<^esub> _" [50,50,50] 50)
  where "similar'_syn x n y \<equiv> similar' n x y"

lemma similar'_botI[intro!,simp]: "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom>"
  by (cases n) (auto simp add: similar'.simps)

lemma similar'_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
using assms by (auto simp add: similar'.simps)

lemma similar'_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
using assms by (auto simp add: similar'.simps)

lemma bot_or_not_bot':
  "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases n) (auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)

lemma similar'_bot[elim_format, elim!]:
    "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> x \<Longrightarrow> x = \<bottom>"
    "y \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom> \<Longrightarrow> y = \<bottom>"
by (metis bot_or_not_bot')+

subsubsection {* Moving up and down the similarity relations *}

text {*
These correspond to Lemma 7 in |cite{functionspaces}.
*}

lemma similar'_down: "d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e"
  and similar'_up: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e"
proof (induction n arbitrary: d e)
  case (Suc n) case 1 with  Suc
  show ?case
  by (cases d e rule:value_CValue_cases) auto
next
  case (Suc n) case 2 with Suc
  show ?case
  by (cases d e rule:value_CValue_cases) auto
qed auto

text {*
A generalisation of the above, doing multiple steps at once.
*}

lemma similar'_up_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: dec_induct )
     (auto dest: similar'_up simp add: Value.take_take CValue'.take_take min_absorb2)

lemma similar'_down_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: inc_induct )
     (auto dest: similar'_down simp add: Value.take_take CValue'.take_take min_absorb1)

lemma similar'_take: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>e"
  apply (drule similar'_up)
  apply (drule similar'_down)
  apply (simp add: Value.take_take CValue'.take_take)
  done

subsubsection {* Admissibility *}

text {*
A technical prerequisite for induction is admissibility of the predicate, i.e.\ that the predicate
holds for the limit of a chain, given that it holds for all elements.
*}

lemma similar'_base_adm: "adm (\<lambda> x. similar'_base (fst x) (snd x))"
proof (rule admI)
  case (goal1 Y)
  from goal1 have "Y = (\<lambda> _ . \<bottom>)" by (metis PairE fst_eqD inst_prod_pcpo case_prod_beta similar'_base.simps snd_eqD)
  thus ?case by auto
qed

lemma similar'_step_adm:
  assumes "adm (\<lambda> x. s (fst x) (snd x))"
  shows "adm (\<lambda> x. similar'_step s (fst x) (snd x))"
proof (rule admI)
  case (goal1 Y)
  from `chain Y`
  have "chain (\<lambda> i. fst (Y i))" by (rule ch2ch_fst)
  thus ?case
  proof(rule Value_chainE)
    assume "(\<lambda>i. fst (Y i)) = (\<lambda> _ . \<bottom>)"
    hence *: "\<And> i. fst (Y i) = \<bottom>" by metis
    with goal1(2)[unfolded split_beta]
    have "\<And> i. snd (Y i) = \<bottom>" by auto
    hence "Y = (\<lambda> i. (\<bottom>, \<bottom>))" using * by (metis surjective_pairing)
    thus ?thesis by auto
  next
    fix n
    fix Y'
    assume "chain Y'" and "(\<lambda>i. fst (Y i)) = (\<lambda> m. (if m < n then \<bottom> else Fn\<cdot>(Y' (m-n))))"
    hence Y': "\<And> i. fst (Y (i+n)) = Fn\<cdot>(Y' i)" by (metis add_diff_cancel_right' not_add_less2)
    with goal1(2)[unfolded split_beta]
    have "\<And> i. \<exists> g'. snd (Y (i+n)) = CFn\<cdot>g'"  by (metis CValue'.con_rews Value.con_rews similar'_step.simps)
    then obtain Y'' where Y'': "\<And> i. snd (Y (i+n)) = CFn\<cdot>(Y'' i)" by metis

    have "chain Y''"
      apply (rule chainI)
      apply (rule iffD1[OF CValue'.inverts])
      apply (subst (1 2) Y''[symmetric])
      by (metis add_Suc_right comm_semiring_1_class.normalizing_semiring_rules(24) goal1(1) po_class.chain_def snd_monofun)

    have "similar'_step s (Fn\<cdot>(\<Squnion> i. (Y' i))) (CFn \<cdot> (\<Squnion> i. Y'' i))"
    proof (rule Fun_similar'_step)
      fix x y
      from goal1(2) Y' Y''
      have "\<And>i. similar'_step s (Fn\<cdot>(Y' i)) (CFn\<cdot>(Y'' i))" by metis
      moreover
      assume "s x (y\<cdot>C\<^sup>\<infinity>)"
      ultimately
      have "\<And>i. s (Y' i\<cdot>x) (Y'' i\<cdot>y\<cdot>C\<^sup>\<infinity>)" by auto
      hence "split s (\<Squnion> i. ((Y' i)\<cdot>x, (Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>))"
        apply -
        apply (rule admD[OF adm_case_prod[where P = "\<lambda>_ . s", OF assms]])
        apply (simp add:  `chain Y'`  `chain Y''`)
        apply simp
        done
      thus "s ((\<Squnion> i. Y' i)\<cdot>x) ((\<Squnion> i. Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>)"
        by (simp add: lub_Pair  ch2ch_Rep_cfunL contlub_cfun_fun  `chain Y'`  `chain Y''`)
    qed
    hence "similar'_step s (fst (\<Squnion> i. Y (i+n))) (snd (\<Squnion> i. Y (i+n)))"
      by (simp add: Y' Y''
          cont2contlubE[OF cont_fst chain_shift[OF goal1(1)]]  cont2contlubE[OF cont_snd chain_shift[OF goal1(1)]]
           contlub_cfun_arg[OF `chain Y''`] contlub_cfun_arg[OF `chain Y'`])
    thus "similar'_step s (fst (\<Squnion> i. Y i)) (snd (\<Squnion> i. Y i))"
      by (simp add: lub_range_shift[OF `chain Y`])
  qed
qed

lemma similar'_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> snd x)"
  by (induct n) (auto simp add: similar'.simps intro: similar'_base_adm similar'_step_adm)

lemma similar'_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g x)"
  by (rule adm_subst[OF _ similar'_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

subsubsection {* The real similarity relation *}

text {*
This is the goal of the theory: A relation between @{typ Value} and @{typ CValue'}.
*}

definition similar :: "Value \<Rightarrow> CValue' \<Rightarrow> bool" (infix "\<triangleleft>\<triangleright>" 50) where
  "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (\<forall>n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)"

lemma similarI:
  "(\<And> n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y) \<Longrightarrow> x \<triangleleft>\<triangleright> y"
  unfolding similar_def by blast

lemma similarE:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y"
  unfolding similar_def by blast

lemma [elim_format, elim!]: "\<bottom> \<triangleleft>\<triangleright> y \<Longrightarrow> y = \<bottom>"
  unfolding similar_def
  apply (cases y)
  apply auto
  apply (erule_tac x = "Suc 0" in allE)
  apply auto
  done

lemma take_similar'_similar:
  assumes "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y"
  shows  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y"
proof(rule similarI)
  fix m
  from assms
  have "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y" by (rule similar'_take)
  moreover
  have "n \<le> m \<or> m \<le> n" by auto
  ultimately
  show "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)"
    by (auto elim: similar'_up_le similar'_down_le dest: similar'_take
        simp add: min_absorb2 min_absorb1 Value.take_take CValue'.take_take)
qed

lemma bot_or_not_bot:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases x y rule:value_CValue_cases) auto

lemma slimilar_bot_cases[consumes 1, case_names bot Fn]:
  assumes "x \<triangleleft>\<triangleright> y"
  obtains "x = \<bottom>" "y = \<bottom>" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g"
using assms
by (metis bot_or_not_bot CValue'.exhaust Value.exhaust)

lemma similar_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright> snd x)"
  unfolding similar_def
  by (intro adm_lemmas similar'_admI cont2cont)

lemma similar_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright> g x)"
  by (rule adm_subst[OF _ similar_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

text {*
Having constructed the relation we can how show that it indeed is the desired relation,
relating $|bot$ with $|bot$ and functions with functions, if they take related arguments to related values.
This corresponds to Proposition 9 in |cite{functionspaces}.
*}

lemma similar_nice_def: "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (x = \<bottom> \<and> y = \<bottom> \<or> (\<exists> f g. x = Fn\<cdot>f \<and> y = CFn\<cdot>g \<and> (\<forall> a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>)))"
  (is "?L \<longleftrightarrow> ?R")
proof
  assume "?L"
  thus "?R"
  proof (cases x y rule:slimilar_bot_cases)
    case bot thus ?thesis by simp
  next
    case (Fn f g)
    note `?L`[unfolded Fn]
    have "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    proof(intro impI allI)
      fix a b
      assume "a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>"

      show "f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
      proof(rule similarI)
        fix n
        have "adm (\<lambda>(b, a). \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>b) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(g\<cdot>a\<cdot>C\<^sup>\<infinity>))"
          by (intro adm_case_prod similar'_admI cont2cont)
        thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>a) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(g\<cdot>b\<cdot>C\<^sup>\<infinity>)"
        proof (induct a b rule: Value_CValue_take_induct[consumes 1])
          txt {* This take induction is required to avoid the wrong equation shown above. *}
          fix m

          from `a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>`
          have "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similarE)
          hence "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similar'_up_le[rotated]) auto
          moreover
          from `Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g`
          have "\<psi>\<^sup>D\<^bsub>Suc (max m n)\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>Suc (max m n)\<^esub> \<psi>\<^sup>A\<^bsub>Suc (max m n)\<^esub>\<cdot>(CFn\<cdot>g)" by (rule similarE)
          ultimately
          have "\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a))) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>A\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>E\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>b))\<cdot>C\<^sup>\<infinity>)"
            by auto
          hence " \<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>A\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (simp add: Value.take_take cfun_map_map CValue'.take_take ID_def eta_cfun min_absorb2 min_absorb1)
          thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (rule similar'_down_le[rotated]) auto
        qed
      qed
    qed
    thus ?thesis unfolding Fn by simp
  qed
next
  assume "?R"
  thus "?L"
  proof(elim conjE disjE exE ssubst)
    show "\<bottom> \<triangleleft>\<triangleright> \<bottom>" by simp
  next
    fix f g
    assume imp: "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    show "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
    proof (rule similarI)
      fix n
      show "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(CFn\<cdot>g)"
      proof(cases n)
        case 0 thus ?thesis by simp
      next
        case (Suc n)
        { fix x y
          assume "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity>"
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(y\<cdot>C\<^sup>\<infinity>)" by (rule take_similar'_similar)
          hence "f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright> g\<cdot>(\<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>" using imp by auto
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>)"
            by (rule similarE)
        }
        with Suc
        show ?thesis by auto
      qed
    qed
  qed
qed

lemma similar_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
by (metis assms similar_nice_def)

lemma similar_FnD[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>"
  shows "f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
using assms
by (subst (asm) similar_nice_def) auto

lemma similar_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
by (metis assms similar_FnD)

subsubsection {* The similarity relation lifted pointwise to functions. *}

abbreviation fun_similar :: "('a::type \<Rightarrow> Value) \<Rightarrow> ('a \<Rightarrow> CValue) \<Rightarrow> bool"  (infix "\<triangleleft>\<triangleright>\<^sup>*" 50) where
  "fun_similar \<equiv> pointwise (\<lambda>x y. x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>)"

lemma fun_similar_fmap_bottom[simp]: "\<bottom> \<triangleleft>\<triangleright>\<^sup>* \<bottom>"
  by auto

lemma fun_similarE[elim]:
  assumes "m \<triangleleft>\<triangleright>\<^sup>* m'"
  assumes "(\<And>x. (m  x) \<triangleleft>\<triangleright> (m' x)\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> Q"
  shows Q
  using assms unfolding pointwise_def by blast

end


section "Current Proofs"

theory Current_Proof
imports Current_Aux Stack_Proof
begin

lemma push_list [simp]: "list (push x current) = x # list current"
  by(induction x current rule: push.induct) auto

lemma pop_list [simp]:
    "\<lbrakk>0 < size current; invar current\<rbrakk> \<Longrightarrow> fst (pop current) # tl (list current) = list current"
  by(induction current rule: pop.induct)(auto simp: size_not_empty list_not_empty)

lemma drop_first_list [simp]: "\<lbrakk>invar current; 0 < size current\<rbrakk>
  \<Longrightarrow> list (drop_first current) = tl (list current)"
  by(induction current rule: pop.induct)(auto simp: drop_Suc)

lemma invar_push: "invar current \<Longrightarrow> invar (push x current)"
  by(induction x current rule: push.induct) auto

lemma invar_pop: "\<lbrakk>0 < size current; invar current; pop current = (x, current')\<rbrakk>
   \<Longrightarrow> invar current'"
  by(induction current arbitrary: x rule: pop.induct) auto

lemma invar_drop_first: "\<lbrakk>0 < size current; invar current\<rbrakk> \<Longrightarrow> invar (drop_first current)"
  using invar_pop
  by (metis eq_snd_iff)

lemma list_size [simp]: "\<lbrakk>invar current; list current = []; 0 < size current\<rbrakk> \<Longrightarrow> False"
  by(induction current)(auto simp: size_not_empty list_empty)

lemma size_new_push [simp]: "invar current \<Longrightarrow> size_new (push x current) = Suc (size_new current)"
  by(induction x current rule: push.induct) auto

lemma size_push [simp]: "size (push x current) = Suc (size current)"
  by(induction x current rule: push.induct) auto

lemma size_new_pop [simp]: "\<lbrakk>0 < size_new current; invar current \<rbrakk>
  \<Longrightarrow> Suc (size_new (drop_first current)) = size_new current"
  by(induction current rule: pop.induct) auto

lemma size_pop [simp]: "\<lbrakk>0 < size current; invar current \<rbrakk>
   \<Longrightarrow> Suc (size (drop_first current)) = size current"
  by(induction current rule: pop.induct) auto

lemma size_pop_suc [simp]: "\<lbrakk>0 < size current; invar current; pop current = (x, current') \<rbrakk>
   \<Longrightarrow> Suc (size current') = size current"
  by(induction current rule: pop.induct) auto

lemma size_pop_sub: "\<lbrakk>0 < size current; invar current; pop current = (x, current') \<rbrakk>
   \<Longrightarrow> size current' = size current - 1"
  by(induction current rule: pop.induct) auto

lemma size_drop_first_sub: "\<lbrakk>0 < size current; invar current \<rbrakk>
   \<Longrightarrow> size (drop_first current) = size current - 1"
  by(induction current rule: pop.induct) auto

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Soft-Types for Sets\<close>
theory Sets
  imports
    Soft_Types.Soft_Types_HOL
    HOTG.Pairs
begin

subsection \<open>Sets, Elements, and Subsets\<close>

abbreviation Set :: "set type"
  where "Set \<equiv> Any"

definition Element :: "set \<Rightarrow> set type"
  where [typedef]: "Element A \<equiv> type (\<lambda>x. x \<in> A)"

lemma Element_covariant: "a : Element A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> a : Element B"
  by unfold_types auto

definition Subset :: "set \<Rightarrow> set type"
  where [typedef, type_simp]: "Subset A \<equiv> Element (powerset A)"

lemma Subset_covariant: "a : Subset A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> a : Subset B"
  by unfold_types auto

lemma mem_iff_Element: "a \<in> A \<longleftrightarrow> a : Element A" by unfold_types

corollary
  ElementI: "a \<in> A \<Longrightarrow> a : Element A" and
  ElementD: "a : Element A \<Longrightarrow> a \<in> A"
  by (auto iff: mem_iff_Element)

lemma Subset_iff: "A \<subseteq> B \<longleftrightarrow> A : Subset B" by unfold_types auto

corollary
  SubsetI: "A \<subseteq> B \<Longrightarrow> A : Subset B" and
  SubsetD: "A : Subset B \<Longrightarrow> A \<subseteq> B"
  by (auto iff: Subset_iff)

lemma subset_self [derive]: "A : Subset A"
  by unfold_types auto

text \<open>Declare basic soft type translations.\<close>

(*Note: soft type translations go on the right of the "\<rightleftharpoons>".
  This should either be documented, or else made unnecessary.*)
soft_type_translation
  "a \<in> A" \<rightleftharpoons> "a : Element A" by unfold_types

soft_type_translation
  "A \<subseteq> B" \<rightleftharpoons> "A : Subset B" by unfold_types auto

soft_type_translation
  "\<forall>x \<in> A. P x" \<rightleftharpoons> "\<forall>x : Element A. P x"
  by unfold_types auto

soft_type_translation
  "\<exists>x \<in> A. P x" \<rightleftharpoons> "\<exists>x : Element A. P x"
  by unfold_types auto

(* Note Kevin: Think about removing collections all together? *)
subsection \<open>Collections\<close>

definition Collection :: "set type \<Rightarrow> set type"
  where [typedef]: "Collection T \<equiv> type (\<lambda>x. \<forall>y \<in> x. y : T)"

lemma CollectionI: "(\<And>x. x \<in> C \<Longrightarrow> x : T) \<Longrightarrow> C : Collection T"
  by unfold_types auto

lemma Collection_memD: "C : Collection T \<Longrightarrow> x \<in> C \<Longrightarrow> x : T"
  by unfold_types auto

lemma Collection_covariant:
  assumes "C : Collection T"
  and "\<And>x. x : T \<Longrightarrow> x \<in> C \<Longrightarrow> x : T'"
  shows "C : Collection T'"
  using assms by (intro CollectionI) (auto dest: Collection_memD)

lemma Collection_covariant':
  assumes "C : Collection T"
  and "\<And>x. x : T \<Longrightarrow> x : T'"
  shows "C : Collection T'"
  using assms Collection_covariant by auto

lemma Subset_if_Collecten_Element [derive]:
  "A : Collection (Element B) \<Longrightarrow> A : Subset B"
  by unfold_types blast

lemma Collection_Element_if_Subset:
  "A : Subset B \<Longrightarrow> A : Collection (Element B)"
  by unfold_types blast

subsection \<open>Basic Constant Types\<close>

text \<open>
The following typing rules are less general than what could be proved, since the
\<^term>\<open>Bool\<close> soft type is trivial. But the rules also determine the behavior of
type inference.

The rule for \<^term>\<open>HOL.All\<close> currently needs to be restricted due to a deficiency
in the elaboration algorithm.
\<close>

lemma
  [type]: "(\<in>) : (Element A) \<Rightarrow> (Subset A) \<Rightarrow> Bool" and
  [type]: "powerset : Collection T \<Rightarrow> Collection (Collection T)" and
  [type]: "union : Collection (Collection T) \<Rightarrow> Collection T" and
  [type]: "repl : Collection T \<Rightarrow> (T \<Rightarrow> S) \<Rightarrow> Collection S" and

  [type]: "HOL.All : ((T :: set type) \<Rightarrow> Bool) \<Rightarrow> Bool" and
  [type]: "{} : Subset A" and
  [type]: "(\<subseteq>) : Subset A \<Rightarrow> Subset A \<Rightarrow> Bool" and
  [type]: "insert : Element A \<Rightarrow> Subset A \<Rightarrow> Subset A" and

  [type]: "(\<union>) : Subset A \<Rightarrow> Subset A \<Rightarrow> Subset A" and
  [type]: "(\<inter>) : Subset A \<Rightarrow> Subset A \<Rightarrow> Subset A" and
  [type]: "collect : Subset A \<Rightarrow> (Element A \<Rightarrow> Bool) \<Rightarrow> Subset A" and
  [type]: "(\<times>) : Subset A \<Rightarrow> Subset B \<Rightarrow> Subset (A \<times> B)"
  by unfold_types auto

end


(* Author: Alexander Maletzky *)

section \<open>Properties of the Lexicographic Order on Power-Products\<close>

theory Lex_Order_PP
  imports Polynomials.Power_Products
begin

text \<open>We prove some useful properties of the purely lexicographic order relation on
  power-products.\<close>

lemma lex_pm_keys_leE:
  assumes "lex_pm s t" and "x \<in> keys (s::'x::linorder \<Rightarrow>\<^sub>0 'a::add_linorder_min)"
  obtains y where "y \<in> keys t" and "y \<le> x"
  using assms(1) unfolding lex_pm_alt
proof (elim disjE exE conjE)
  assume "s = t"
  show ?thesis
  proof
    from assms(2) show "x \<in> keys t" by (simp only: \<open>s = t\<close>)
  qed (fact order.refl)
next
  fix y
  assume 1: "lookup s y < lookup t y" and 2: "\<forall>y'<y. lookup s y' = lookup t y'"
  show ?thesis
  proof (cases "y \<le> x")
    case True
    from zero_min 1 have "0 < lookup t y" by (rule le_less_trans)
    hence "y \<in> keys t" by (simp add: dual_order.strict_implies_not_eq in_keys_iff)
    thus ?thesis using True ..
  next
    case False
    hence "x < y" by simp
    with 2 have "lookup s x = lookup t x" by simp
    with assms(2) have "x \<in> keys t" by (simp only: in_keys_iff not_False_eq_True)
    thus ?thesis using order.refl ..
  qed
qed

lemma lex_pm_strict_plus_left:
  assumes "lex_pm_strict s t" and "\<And>x y. x \<in> keys t \<Longrightarrow> y \<in> keys u \<Longrightarrow> x < y"
  shows "lex_pm_strict (u + s) (t::_ \<Rightarrow>\<^sub>0 'a::add_linorder_min)"
proof -
  from assms(1) obtain x where 1: "lookup s x < lookup t x" and 2: "\<And>y. y < x \<Longrightarrow> lookup s y = lookup t y"
    by (auto simp: lex_pm_strict_def less_poly_mapping_def less_fun_def)
  from 1 have "x \<in> keys t" by (auto simp flip: lookup_not_eq_zero_eq_in_keys)
  have lookup_u: "lookup u z = 0" if "z \<le> x" for z
  proof (rule ccontr)
    assume "lookup u z \<noteq> 0"
    hence "z \<in> keys u" by (simp add: in_keys_iff)
    with \<open>x \<in> keys t\<close> have "x < z" by (rule assms(2))
    with that show False by simp
  qed
  from 1 have "lookup (u + s) x < lookup t x" by (simp add: lookup_add lookup_u)
  moreover have "lookup (u + s) y = lookup t y" if "y < x" for y using that
    by (simp add: lookup_add 2 lookup_u)
  ultimately show ?thesis by (auto simp: lex_pm_strict_def less_poly_mapping_def less_fun_def)
qed

end (* theory *)


theory T61
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end