(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)
theory Myhill_1
imports "Folds"
        "~~/src/HOL/Library/While_Combinator"
begin

section {* First direction of MN: @{text "finite partition \<Rightarrow> regular language"} *}

notation
  conc (infixr "\<cdot>" 100) and
  star ("_\<star>" [101] 102)

lemma Pair_Collect [simp]:
  shows "(x, y) \<in> {(x, y). P x y} \<longleftrightarrow> P x y"
by simp

text {* Myhill-Nerode relation *}

definition
  str_eq :: "'a lang \<Rightarrow> ('a list \<times> 'a list) set" ("\<approx>_" [100] 100)
where
  "\<approx>A \<equiv> {(x, y).  (\<forall>z. x @ z \<in> A \<longleftrightarrow> y @ z \<in> A)}"

abbreviation
  str_eq_applied :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<approx>_ _")
where
  "x \<approx>A y \<equiv> (x, y) \<in> \<approx>A"

definition
  finals :: "'a lang \<Rightarrow> 'a lang set"
where
  "finals A \<equiv> {\<approx>A `` {s} | s . s \<in> A}"

lemma lang_is_union_of_finals:
  shows "A = \<Union> finals A"
unfolding finals_def
unfolding Image_def
unfolding str_eq_def
by (auto) (metis append_Nil2)

lemma finals_in_partitions:
  shows "finals A \<subseteq> (UNIV // \<approx>A)"
unfolding finals_def quotient_def
by auto

subsection {* Equational systems *}

text {* The two kinds of terms in the rhs of equations. *}

datatype 'a trm =
   Lam "'a rexp"            (* Lambda-marker *)
 | Trn "'a lang" "'a rexp"     (* Transition *)

fun
  lang_trm::"'a trm \<Rightarrow> 'a lang"
where
  "lang_trm (Lam r) = lang r"
| "lang_trm (Trn X r) = X \<cdot> lang r"

fun
  lang_rhs::"('a trm) set \<Rightarrow> 'a lang"
where
  "lang_rhs rhs = \<Union> (lang_trm ` rhs)"

lemma lang_rhs_set:
  shows "lang_rhs {Trn X r | r. P r} = \<Union>{lang_trm (Trn X r) | r. P r}"
by (auto)

lemma lang_rhs_union_distrib:
  shows "lang_rhs A \<union> lang_rhs B = lang_rhs (A \<union> B)"
by simp

text {* Transitions between equivalence classes *}

definition
  transition :: "'a lang \<Rightarrow> 'a \<Rightarrow> 'a lang \<Rightarrow> bool" ("_ \<Turnstile>_\<Rightarrow>_" [100,100,100] 100)
where
  "Y \<Turnstile>c\<Rightarrow> X \<equiv> Y \<cdot> {[c]} \<subseteq> X"

text {* Initial equational system *}

definition
  "Init_rhs CS X \<equiv>
      if ([] \<in> X) then
          {Lam One} \<union> {Trn Y (Atom c) | Y c. Y \<in> CS \<and> Y \<Turnstile>c\<Rightarrow> X}
      else
          {Trn Y (Atom c)| Y c. Y \<in> CS \<and> Y \<Turnstile>c\<Rightarrow> X}"

definition
  "Init CS \<equiv> {(X, Init_rhs CS X) | X.  X \<in> CS}"

subsection {* Arden Operation on equations *}

fun
  Append_rexp :: "'a rexp \<Rightarrow> 'a trm \<Rightarrow> 'a trm"
where
  "Append_rexp r (Lam rexp)   = Lam (Times rexp r)"
| "Append_rexp r (Trn X rexp) = Trn X (Times rexp r)"

definition
  "Append_rexp_rhs rhs rexp \<equiv> (Append_rexp rexp) ` rhs"

definition
  "Arden X rhs \<equiv>
     Append_rexp_rhs (rhs - {Trn X r | r. Trn X r \<in> rhs}) (Star (\<Uplus> {r. Trn X r \<in> rhs}))"

subsection {* Substitution Operation on equations *}

definition
  "Subst rhs X xrhs \<equiv>
        (rhs - {Trn X r | r. Trn X r \<in> rhs}) \<union> (Append_rexp_rhs xrhs (\<Uplus> {r. Trn X r \<in> rhs}))"

definition
  Subst_all :: "('a lang \<times> ('a trm) set) set \<Rightarrow> 'a lang \<Rightarrow> ('a trm) set \<Rightarrow> ('a lang \<times> ('a trm) set) set"
where
  "Subst_all ES X xrhs \<equiv> {(Y, Subst yrhs X xrhs) | Y yrhs. (Y, yrhs) \<in> ES}"

definition
  "Remove ES X xrhs \<equiv>
      Subst_all  (ES - {(X, xrhs)}) X (Arden X xrhs)"

subsection {* While-combinator and invariants *}

definition
  "Iter X ES \<equiv> (let (Y, yrhs) = SOME (Y, yrhs). (Y, yrhs) \<in> ES \<and> X \<noteq> Y
                in Remove ES Y yrhs)"

lemma IterI2:
  assumes "(Y, yrhs) \<in> ES"
  and     "X \<noteq> Y"
  and     "\<And>Y yrhs. \<lbrakk>(Y, yrhs) \<in> ES; X \<noteq> Y\<rbrakk> \<Longrightarrow> Q (Remove ES Y yrhs)"
  shows "Q (Iter X ES)"
unfolding Iter_def using assms
by (rule_tac a="(Y, yrhs)" in someI2) (auto)

abbreviation
  "Cond ES \<equiv> card ES \<noteq> 1"

definition
  "Solve X ES \<equiv> while Cond (Iter X) ES"

definition
  "distinctness ES \<equiv>
     \<forall> X rhs rhs'. (X, rhs) \<in> ES \<and> (X, rhs') \<in> ES \<longrightarrow> rhs = rhs'"

definition
  "soundness ES \<equiv> \<forall>(X, rhs) \<in> ES. X = lang_rhs rhs"

definition
  "ardenable rhs \<equiv> (\<forall> Y r. Trn Y r \<in> rhs \<longrightarrow> [] \<notin> lang r)"

definition
  "ardenable_all ES \<equiv> \<forall>(X, rhs) \<in> ES. ardenable rhs"

definition
  "finite_rhs ES \<equiv> \<forall>(X, rhs) \<in> ES. finite rhs"

lemma finite_rhs_def2:
  "finite_rhs ES = (\<forall> X rhs. (X, rhs) \<in> ES \<longrightarrow> finite rhs)"
unfolding finite_rhs_def by auto

definition
  "rhss rhs \<equiv> {X | X r. Trn X r \<in> rhs}"

definition
  "lhss ES \<equiv> {Y | Y yrhs. (Y, yrhs) \<in> ES}"

definition
  "validity ES \<equiv> \<forall>(X, rhs) \<in> ES. rhss rhs \<subseteq> lhss ES"

lemma rhss_union_distrib:
  shows "rhss (A \<union> B) = rhss A \<union> rhss B"
by (auto simp add: rhss_def)

lemma lhss_union_distrib:
  shows "lhss (A \<union> B) = lhss A \<union> lhss B"
by (auto simp add: lhss_def)

definition
  "invariant ES \<equiv> finite ES
                \<and> finite_rhs ES
                \<and> soundness ES
                \<and> distinctness ES
                \<and> ardenable_all ES
                \<and> validity ES"

lemma invariantI:
  assumes "soundness ES" "finite ES" "distinctness ES" "ardenable_all ES"
          "finite_rhs ES" "validity ES"
  shows "invariant ES"
using assms by (simp add: invariant_def)

declare [[simproc add: finite_Collect]]

lemma finite_Trn:
  assumes fin: "finite rhs"
  shows "finite {r. Trn Y r \<in> rhs}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)

lemma finite_Lam:
  assumes fin: "finite rhs"
  shows "finite {r. Lam r \<in> rhs}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)

lemma trm_soundness:
  assumes finite:"finite rhs"
  shows "lang_rhs ({Trn X r| r. Trn X r \<in> rhs}) = X \<cdot> (lang (\<Uplus>{r. Trn X r \<in> rhs}))"
proof -
  have "finite {r. Trn X r \<in> rhs}"
    by (rule finite_Trn[OF finite])
  then show "lang_rhs ({Trn X r| r. Trn X r \<in> rhs}) = X \<cdot> (lang (\<Uplus>{r. Trn X r \<in> rhs}))"
    by (simp only: lang_rhs_set lang_trm.simps) (auto simp add: conc_def)
qed

lemma lang_of_append_rexp:
  "lang_trm (Append_rexp r trm) = lang_trm trm \<cdot> lang r"
by (induct rule: Append_rexp.induct)
   (auto simp add: conc_assoc)

lemma lang_of_append_rexp_rhs:
  "lang_rhs (Append_rexp_rhs rhs r) = lang_rhs rhs \<cdot> lang r"
unfolding Append_rexp_rhs_def
by (auto simp add: conc_def lang_of_append_rexp)

subsection {* Intial Equational Systems *}

lemma defined_by_str:
  assumes "s \<in> X" "X \<in> UNIV // \<approx>A"
  shows "X = \<approx>A `` {s}"
using assms
unfolding quotient_def Image_def str_eq_def
by auto

lemma every_eqclass_has_transition:
  assumes has_str: "s @ [c] \<in> X"
  and     in_CS:   "X \<in> UNIV // \<approx>A"
  obtains Y where "Y \<in> UNIV // \<approx>A" and "Y \<cdot> {[c]} \<subseteq> X" and "s \<in> Y"
proof -
  def Y \<equiv> "\<approx>A `` {s}"
  have "Y \<in> UNIV // \<approx>A"
    unfolding Y_def quotient_def by auto
  moreover
  have "X = \<approx>A `` {s @ [c]}"
    using has_str in_CS defined_by_str by blast
  then have "Y \<cdot> {[c]} \<subseteq> X"
    unfolding Y_def Image_def conc_def
    unfolding str_eq_def
    by clarsimp
  moreover
  have "s \<in> Y" unfolding Y_def
    unfolding Image_def str_eq_def by simp
  ultimately show thesis using that by blast
qed

lemma l_eq_r_in_eqs:
  assumes X_in_eqs: "(X, rhs) \<in> Init (UNIV // \<approx>A)"
  shows "X = lang_rhs rhs"
proof
  show "X \<subseteq> lang_rhs rhs"
  proof
    fix x
    assume in_X: "x \<in> X"
    { assume empty: "x = []"
      then have "x \<in> lang_rhs rhs" using X_in_eqs in_X
        unfolding Init_def Init_rhs_def
        by auto
    }
    moreover
    { assume not_empty: "x \<noteq> []"
      then obtain s c where decom: "x = s @ [c]"
        using rev_cases by blast
      have "X \<in> UNIV // \<approx>A" using X_in_eqs unfolding Init_def by auto
      then obtain Y where "Y \<in> UNIV // \<approx>A" "Y \<cdot> {[c]} \<subseteq> X" "s \<in> Y"
        using decom in_X every_eqclass_has_transition by metis
      then have "x \<in> lang_rhs {Trn Y (Atom c)| Y c. Y \<in> UNIV // \<approx>A \<and> Y \<Turnstile>c\<Rightarrow> X}"
        unfolding transition_def
        using decom by (force simp add: conc_def)
      then have "x \<in> lang_rhs rhs" using X_in_eqs in_X
        unfolding Init_def Init_rhs_def by simp
    }
    ultimately show "x \<in> lang_rhs rhs" by blast
  qed
next
  show "lang_rhs rhs \<subseteq> X" using X_in_eqs
    unfolding Init_def Init_rhs_def transition_def
    by auto
qed

lemma finite_Init_rhs:
  fixes CS::"(('a::finite) lang) set"
  assumes finite: "finite CS"
  shows "finite (Init_rhs CS X)"
using assms unfolding Init_rhs_def transition_def by simp

lemma Init_ES_satisfies_invariant:
  fixes A::"(('a::finite) lang)"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  shows "invariant (Init (UNIV // \<approx>A))"
proof (rule invariantI)
  show "soundness (Init (UNIV // \<approx>A))"
    unfolding soundness_def
    using l_eq_r_in_eqs by auto
  show "finite (Init (UNIV // \<approx>A))" using finite_CS
    unfolding Init_def by simp
  show "distinctness (Init (UNIV // \<approx>A))"
    unfolding distinctness_def Init_def by simp
  show "ardenable_all (Init (UNIV // \<approx>A))"
    unfolding ardenable_all_def Init_def Init_rhs_def ardenable_def
   by auto
  show "finite_rhs (Init (UNIV // \<approx>A))"
    using finite_Init_rhs[OF finite_CS]
    unfolding finite_rhs_def Init_def by auto
  show "validity (Init (UNIV // \<approx>A))"
    unfolding validity_def Init_def Init_rhs_def rhss_def lhss_def
    by auto
qed

subsection {* Interations *}

lemma Arden_preserves_soundness:
  assumes l_eq_r: "X = lang_rhs rhs"
  and not_empty: "ardenable rhs"
  and finite: "finite rhs"
  shows "X = lang_rhs (Arden X rhs)"
proof -
  def A \<equiv> "lang (\<Uplus>{r. Trn X r \<in> rhs})"
  def b \<equiv> "{Trn X r | r. Trn X r \<in> rhs}"
  def B \<equiv> "lang_rhs (rhs - b)"
  have not_empty2: "[] \<notin> A"
    using finite_Trn[OF finite] not_empty
    unfolding A_def ardenable_def by simp
  have "X = lang_rhs rhs" using l_eq_r by simp
  also have "\<dots> = lang_rhs (b \<union> (rhs - b))" unfolding b_def by auto
  also have "\<dots> = lang_rhs b \<union> B" unfolding B_def by (simp only: lang_rhs_union_distrib)
  also have "\<dots> = X \<cdot> A \<union> B"
    unfolding b_def
    unfolding trm_soundness[OF finite]
    unfolding A_def
    by blast
  finally have "X = X \<cdot> A \<union> B" .
  then have "X = B \<cdot> A\<star>"
    by (simp add: reversed_Arden[OF not_empty2])
  also have "\<dots> = lang_rhs (Arden X rhs)"
    unfolding Arden_def A_def B_def b_def
    by (simp only: lang_of_append_rexp_rhs lang.simps)
  finally show "X = lang_rhs (Arden X rhs)" by simp
qed

lemma Append_preserves_finite:
  "finite rhs \<Longrightarrow> finite (Append_rexp_rhs rhs r)"
by (auto simp: Append_rexp_rhs_def)

lemma Arden_preserves_finite:
  "finite rhs \<Longrightarrow> finite (Arden X rhs)"
by (auto simp: Arden_def Append_preserves_finite)

lemma Append_preserves_ardenable:
  "ardenable rhs \<Longrightarrow> ardenable (Append_rexp_rhs rhs r)"
apply (auto simp: ardenable_def Append_rexp_rhs_def)
by (case_tac x, auto simp: conc_def)

lemma ardenable_set_sub:
  "ardenable rhs \<Longrightarrow> ardenable (rhs - A)"
by (auto simp:ardenable_def)

lemma ardenable_set_union:
  "\<lbrakk>ardenable rhs; ardenable rhs'\<rbrakk> \<Longrightarrow> ardenable (rhs \<union> rhs')"
by (auto simp:ardenable_def)

lemma Arden_preserves_ardenable:
  "ardenable rhs \<Longrightarrow> ardenable (Arden X rhs)"
by (simp only:Arden_def Append_preserves_ardenable ardenable_set_sub)

lemma Subst_preserves_ardenable:
  "\<lbrakk>ardenable rhs; ardenable xrhs\<rbrakk> \<Longrightarrow> ardenable (Subst rhs X xrhs)"
by (simp only: Subst_def Append_preserves_ardenable ardenable_set_union ardenable_set_sub)

lemma Subst_preserves_soundness:
  assumes substor: "X = lang_rhs xrhs"
  and finite: "finite rhs"
  shows "lang_rhs (Subst rhs X xrhs) = lang_rhs rhs" (is "?Left = ?Right")
proof-
  def A \<equiv> "lang_rhs (rhs - {Trn X r | r. Trn X r \<in> rhs})"
  have "?Left = A \<union> lang_rhs (Append_rexp_rhs xrhs (\<Uplus>{r. Trn X r \<in> rhs}))"
    unfolding Subst_def
    unfolding lang_rhs_union_distrib[symmetric]
    by (simp add: A_def)
  moreover have "?Right = A \<union> lang_rhs {Trn X r | r. Trn X r \<in> rhs}"
  proof-
    have "rhs = (rhs - {Trn X r | r. Trn X r \<in> rhs}) \<union> ({Trn X r | r. Trn X r \<in> rhs})" by auto
    thus ?thesis
      unfolding A_def
      unfolding lang_rhs_union_distrib
      by simp
  qed
  moreover
  have "lang_rhs (Append_rexp_rhs xrhs (\<Uplus>{r. Trn X r \<in> rhs})) = lang_rhs {Trn X r | r. Trn X r \<in> rhs}"
    using finite substor by (simp only: lang_of_append_rexp_rhs trm_soundness)
  ultimately show ?thesis by simp
qed

lemma Subst_preserves_finite_rhs:
  "\<lbrakk>finite rhs; finite yrhs\<rbrakk> \<Longrightarrow> finite (Subst rhs Y yrhs)"
by (auto simp: Subst_def Append_preserves_finite)

lemma Subst_all_preserves_finite:
  assumes finite: "finite ES"
  shows "finite (Subst_all ES Y yrhs)"
using assms unfolding Subst_all_def by simp

declare [[simproc del: finite_Collect]]

lemma Subst_all_preserves_finite_rhs:
  "\<lbrakk>finite_rhs ES; finite yrhs\<rbrakk> \<Longrightarrow> finite_rhs (Subst_all ES Y yrhs)"
by (auto intro:Subst_preserves_finite_rhs simp add:Subst_all_def finite_rhs_def)

lemma append_rhs_preserves_cls:
  "rhss (Append_rexp_rhs rhs r) = rhss rhs"
apply (auto simp: rhss_def Append_rexp_rhs_def)
apply (case_tac xa, auto simp: image_def)
by (rule_tac x = "Times ra r" in exI, rule_tac x = "Trn x ra" in bexI, simp+)

lemma Arden_removes_cl:
  "rhss (Arden Y yrhs) = rhss yrhs - {Y}"
apply (simp add:Arden_def append_rhs_preserves_cls)
by (auto simp: rhss_def)

lemma lhss_preserves_cls:
  "lhss (Subst_all ES Y yrhs) = lhss ES"
by (auto simp: lhss_def Subst_all_def)

lemma Subst_updates_cls:
  "X \<notin> rhss xrhs \<Longrightarrow>
      rhss (Subst rhs X xrhs) = rhss rhs \<union> rhss xrhs - {X}"
apply (simp only:Subst_def append_rhs_preserves_cls rhss_union_distrib)
by (auto simp: rhss_def)

lemma Subst_all_preserves_validity:
  assumes sc: "validity (ES \<union> {(Y, yrhs)})"        (is "validity ?A")
  shows "validity (Subst_all ES Y (Arden Y yrhs))"  (is "validity ?B")
proof -
  { fix X xrhs'
    assume "(X, xrhs') \<in> ?B"
    then obtain xrhs
      where xrhs_xrhs': "xrhs' = Subst xrhs Y (Arden Y yrhs)"
      and X_in: "(X, xrhs) \<in> ES" by (simp add:Subst_all_def, blast)
    have "rhss xrhs' \<subseteq> lhss ?B"
    proof-
      have "lhss ?B = lhss ES" by (auto simp add:lhss_def Subst_all_def)
      moreover have "rhss xrhs' \<subseteq> lhss ES"
      proof-
        have "rhss xrhs' \<subseteq>  rhss xrhs \<union> rhss (Arden Y yrhs) - {Y}"
        proof -
          have "Y \<notin> rhss (Arden Y yrhs)"
            using Arden_removes_cl by auto
          thus ?thesis using xrhs_xrhs' by (auto simp: Subst_updates_cls)
        qed
        moreover have "rhss xrhs \<subseteq> lhss ES \<union> {Y}" using X_in sc
          apply (simp only:validity_def lhss_union_distrib)
          by (drule_tac x = "(X, xrhs)" in bspec, auto simp:lhss_def)
        moreover have "rhss (Arden Y yrhs) \<subseteq> lhss ES \<union> {Y}"
          using sc
          by (auto simp add: Arden_removes_cl validity_def lhss_def)
        ultimately show ?thesis by auto
      qed
      ultimately show ?thesis by simp
    qed
  } thus ?thesis by (auto simp only:Subst_all_def validity_def)
qed

lemma Subst_all_satisfies_invariant:
  assumes invariant_ES: "invariant (ES \<union> {(Y, yrhs)})"
  shows "invariant (Subst_all ES Y (Arden Y yrhs))"
proof (rule invariantI)
  have Y_eq_yrhs: "Y = lang_rhs yrhs"
    using invariant_ES by (simp only:invariant_def soundness_def, blast)
   have finite_yrhs: "finite yrhs"
    using invariant_ES by (auto simp:invariant_def finite_rhs_def)
  have ardenable_yrhs: "ardenable yrhs"
    using invariant_ES by (auto simp:invariant_def ardenable_all_def)
  show "soundness (Subst_all ES Y (Arden Y yrhs))"
  proof -
    have "Y = lang_rhs (Arden Y yrhs)"
      using Y_eq_yrhs invariant_ES finite_yrhs
      using finite_Trn[OF finite_yrhs]
      apply(rule_tac Arden_preserves_soundness)
      apply(simp_all)
      unfolding invariant_def ardenable_all_def ardenable_def
      apply(auto)
      done
    thus ?thesis using invariant_ES
      unfolding invariant_def finite_rhs_def2 soundness_def Subst_all_def
      by (auto simp add: Subst_preserves_soundness simp del: lang_rhs.simps)
  qed
  show "finite (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES by (simp add:invariant_def Subst_all_preserves_finite)
  show "distinctness (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES
    unfolding distinctness_def Subst_all_def invariant_def by auto
  show "ardenable_all (Subst_all ES Y (Arden Y yrhs))"
  proof -
    { fix X rhs
      assume "(X, rhs) \<in> ES"
      hence "ardenable rhs"  using invariant_ES
        by (auto simp add:invariant_def ardenable_all_def)
      with ardenable_yrhs
      have "ardenable (Subst rhs Y (Arden Y yrhs))"
        by (simp add:ardenable_yrhs
               Subst_preserves_ardenable Arden_preserves_ardenable)
    } thus ?thesis by (auto simp add:ardenable_all_def Subst_all_def)
  qed
  show "finite_rhs (Subst_all ES Y (Arden Y yrhs))"
  proof-
    have "finite_rhs ES" using invariant_ES
      by (simp add:invariant_def finite_rhs_def)
    moreover have "finite (Arden Y yrhs)"
    proof -
      have "finite yrhs" using invariant_ES
        by (auto simp:invariant_def finite_rhs_def)
      thus ?thesis using Arden_preserves_finite by auto
    qed
    ultimately show ?thesis
      by (simp add:Subst_all_preserves_finite_rhs)
  qed
  show "validity (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES Subst_all_preserves_validity by (auto simp add: invariant_def)
qed

lemma Remove_in_card_measure:
  assumes finite: "finite ES"
  and     in_ES: "(X, rhs) \<in> ES"
  shows "(Remove ES X rhs, ES) \<in> measure card"
proof -
  def f \<equiv> "\<lambda> x. ((fst x)::'a lang, Subst (snd x) X (Arden X rhs))"
  def ES' \<equiv> "ES - {(X, rhs)}"
  have "Subst_all ES' X (Arden X rhs) = f ` ES'"
    apply (auto simp: Subst_all_def f_def image_def)
    by (rule_tac x = "(Y, yrhs)" in bexI, simp+)
  then have "card (Subst_all ES' X (Arden X rhs)) \<le> card ES'"
    unfolding ES'_def using finite by (auto intro: card_image_le)
  also have "\<dots> < card ES" unfolding ES'_def
    using in_ES finite by (rule_tac card_Diff1_less)
  finally show "(Remove ES X rhs, ES) \<in> measure card"
    unfolding Remove_def ES'_def by simp
qed

lemma Subst_all_cls_remains:
  "(X, xrhs) \<in> ES \<Longrightarrow> \<exists> xrhs'. (X, xrhs') \<in> (Subst_all ES Y yrhs)"
by (auto simp: Subst_all_def)

lemma card_noteq_1_has_more:
  assumes card:"Cond ES"
  and e_in: "(X, xrhs) \<in> ES"
  and finite: "finite ES"
  shows "\<exists>(Y, yrhs) \<in> ES. (X, xrhs) \<noteq> (Y, yrhs)"
proof-
  have "card ES > 1" using card e_in finite
    by (cases "card ES") (auto)
  then have "card (ES - {(X, xrhs)}) > 0"
    using finite e_in by auto
  then have "(ES - {(X, xrhs)}) \<noteq> {}" using finite by (rule_tac notI, simp)
  then show "\<exists>(Y, yrhs) \<in> ES. (X, xrhs) \<noteq> (Y, yrhs)"
    by auto
qed

lemma iteration_step_measure:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd:     "Cond ES "
  shows "(Iter X ES, ES) \<in> measure card"
proof -
  have fin: "finite ES" using Inv_ES unfolding invariant_def by simp
  then obtain Y yrhs
    where Y_in_ES: "(Y, yrhs) \<in> ES" and not_eq: "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES " "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "(Iter X ES, ES) \<in> measure card"
  apply(rule IterI2)
  apply(rule Remove_in_card_measure)
  apply(simp_all add: fin)
  done
qed

lemma iteration_step_invariant:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd: "Cond ES"
  shows "invariant (Iter X ES)"
proof -
  have finite_ES: "finite ES" using Inv_ES by (simp add: invariant_def)
  then obtain Y yrhs
    where Y_in_ES: "(Y, yrhs) \<in> ES" and not_eq: "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES" "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "invariant (Iter X ES)"
  proof(rule IterI2)
    fix Y yrhs
    assume h: "(Y, yrhs) \<in> ES" "X \<noteq> Y"
    then have "ES - {(Y, yrhs)} \<union> {(Y, yrhs)} = ES" by auto
    then show "invariant (Remove ES Y yrhs)" unfolding Remove_def
      using Inv_ES
      by (rule_tac Subst_all_satisfies_invariant) (simp)
  qed
qed

lemma iteration_step_ex:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd: "Cond ES"
  shows "\<exists>xrhs'. (X, xrhs') \<in> (Iter X ES)"
proof -
  have finite_ES: "finite ES" using Inv_ES by (simp add: invariant_def)
  then obtain Y yrhs
    where "(Y, yrhs) \<in> ES" "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES " "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "\<exists>xrhs'. (X, xrhs') \<in> (Iter X ES)"
  apply(rule IterI2)
  unfolding Remove_def
  apply(rule Subst_all_cls_remains)
  using X_in_ES
  apply(auto)
  done
qed

subsection {* The conclusion of the first direction *}

lemma Solve:
  fixes A::"('a::finite) lang"
  assumes fin: "finite (UNIV // \<approx>A)"
  and     X_in: "X \<in> (UNIV // \<approx>A)"
  shows "\<exists>rhs. Solve X (Init (UNIV // \<approx>A)) = {(X, rhs)} \<and> invariant {(X, rhs)}"
proof -
  def Inv \<equiv> "\<lambda>ES. invariant ES \<and> (\<exists>rhs. (X, rhs) \<in> ES)"
  have "Inv (Init (UNIV // \<approx>A))" unfolding Inv_def
      using fin X_in by (simp add: Init_ES_satisfies_invariant, simp add: Init_def)
  moreover
  { fix ES
    assume inv: "Inv ES" and crd: "Cond ES"
    then have "Inv (Iter X ES)"
      unfolding Inv_def
      by (auto simp add: iteration_step_invariant iteration_step_ex) }
  moreover
  { fix ES
    assume inv: "Inv ES" and not_crd: "\<not>Cond ES"
    from inv obtain rhs where "(X, rhs) \<in> ES" unfolding Inv_def by auto
    moreover
    from not_crd have "card ES = 1" by simp
    ultimately
    have "ES = {(X, rhs)}" by (auto simp add: card_Suc_eq)
    then have "\<exists>rhs'. ES = {(X, rhs')} \<and> invariant {(X, rhs')}" using inv
      unfolding Inv_def by auto }
  moreover
    have "wf (measure card)" by simp
  moreover
  { fix ES
    assume inv: "Inv ES" and crd: "Cond ES"
    then have "(Iter X ES, ES) \<in> measure card"
      unfolding Inv_def
      apply(clarify)
      apply(rule_tac iteration_step_measure)
      apply(auto)
      done }
  ultimately
  show "\<exists>rhs. Solve X (Init (UNIV // \<approx>A)) = {(X, rhs)} \<and> invariant {(X, rhs)}"
    unfolding Solve_def by (rule while_rule)
qed

lemma every_eqcl_has_reg:
  fixes A::"('a::finite) lang"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  and X_in_CS: "X \<in> (UNIV // \<approx>A)"
  shows "\<exists>r. X = lang r"
proof -
  from finite_CS X_in_CS
  obtain xrhs where Inv_ES: "invariant {(X, xrhs)}"
    using Solve by metis

  def A \<equiv> "Arden X xrhs"
  have "rhss xrhs \<subseteq> {X}" using Inv_ES
    unfolding validity_def invariant_def rhss_def lhss_def
    by auto
  then have "rhss A = {}" unfolding A_def
    by (simp add: Arden_removes_cl)
  then have eq: "{Lam r | r. Lam r \<in> A} = A" unfolding rhss_def
    by (auto, case_tac x, auto)

  have "finite A" using Inv_ES unfolding A_def invariant_def finite_rhs_def
    using Arden_preserves_finite by auto
  then have fin: "finite {r. Lam r \<in> A}" by (rule finite_Lam)

  have "X = lang_rhs xrhs" using Inv_ES unfolding invariant_def soundness_def
    by simp
  then have "X = lang_rhs A" using Inv_ES
    unfolding A_def invariant_def ardenable_all_def finite_rhs_def
    by (rule_tac Arden_preserves_soundness) (simp_all add: finite_Trn)
  then have "X = lang_rhs {Lam r | r. Lam r \<in> A}" using eq by simp
  then have "X = lang (\<Uplus>{r. Lam r \<in> A})" using fin by auto
  then show "\<exists>r. X = lang r" by blast
qed

lemma bchoice_finite_set:
  assumes a: "\<forall>x \<in> S. \<exists>y. x = f y"
  and     b: "finite S"
  shows "\<exists>ys. (\<Union> S) = \<Union>(f ` ys) \<and> finite ys"
using bchoice[OF a] b
apply(erule_tac exE)
apply(rule_tac x="fa ` S" in exI)
apply(auto)
done

theorem Myhill_Nerode1:
  fixes A::"('a::finite) lang"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  shows   "\<exists>r. A = lang r"
proof -
  have fin: "finite (finals A)"
    using finals_in_partitions finite_CS by (rule finite_subset)
  have "\<forall>X \<in> (UNIV // \<approx>A). \<exists>r. X = lang r"
    using finite_CS every_eqcl_has_reg by blast
  then have a: "\<forall>X \<in> finals A. \<exists>r. X = lang r"
    using finals_in_partitions by auto
  then obtain rs::"('a rexp) set" where "\<Union> (finals A) = \<Union>(lang ` rs)" "finite rs"
    using fin by (auto dest: bchoice_finite_set)
  then have "A = lang (\<Uplus>rs)"
    unfolding lang_is_union_of_finals[symmetric] by simp
  then show "\<exists>r. A = lang r" by blast
qed

end


(*
Title: Kleene Algebra with Converse
Author: Cameron Calk, Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Kleene algebra with converse\<close>

theory "KA_conv"
  imports KA_light

begin

text \<open>We start from involutive dioids and Kleene algebra and then add a so-called strong Gelfand property
to obtain an operation of coverse that is closer to algebras of paths and relations.\<close>

subsection \<open>Involutive Kleene algebra\<close>

class invol_op =
  fixes invol :: "'a \<Rightarrow> 'a" ("_\<^sup>\<circ>" [101] 100)

class involutive_dioid = dioid + invol_op +
  assumes inv_invol [simp]: "(x\<^sup>\<circ>)\<^sup>\<circ> = x"
  and inv_contrav [simp]: "(x \<cdot> y)\<^sup>\<circ> = y\<^sup>\<circ> \<cdot> x\<^sup>\<circ>"
  and inv_sup [simp]: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> + y\<^sup>\<circ>"

begin

lemma inv_zero [simp]: "0\<^sup>\<circ> = 0"
proof-
  have "0\<^sup>\<circ> = (0\<^sup>\<circ> \<cdot> 0)\<^sup>\<circ>"
    by simp
  also have "\<dots> = 0\<^sup>\<circ> \<cdot> (0\<^sup>\<circ>)\<^sup>\<circ>"
    using local.inv_contrav by blast
  also have "\<dots> =  0\<^sup>\<circ> \<cdot> 0"
    by simp
  also have "\<dots> = 0"
    by simp
  finally show ?thesis.
qed

lemma inv_one [simp]: "1\<^sup>\<circ> = 1"
proof-
  have "1\<^sup>\<circ> = 1\<^sup>\<circ> \<cdot> (1\<^sup>\<circ>)\<^sup>\<circ>"
    by simp
  also have "\<dots> = (1\<^sup>\<circ> \<cdot> 1)\<^sup>\<circ>"
    using local.inv_contrav by presburger
  also have "\<dots> = (1\<^sup>\<circ>)\<^sup>\<circ>"
    by simp
  also have "\<dots> = 1"
    by simp
  finally show ?thesis.
qed

lemma inv_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
  by (metis local.inv_sup local.order_def)

lemma inv_adj: "(x\<^sup>\<circ> \<le> y) = (x \<le> y\<^sup>\<circ>)"
  using inv_iso by fastforce

end

text \<open>Here is an equivalent axiomatisation.\<close>

class involutive_dioid_alt = dioid +
  fixes inv_alt :: "'a \<Rightarrow> 'a"
  assumes inv_alt: "(inv_alt x \<le> y) = (x \<le> inv_alt y)"
  and inv_alt_contrav [simp]: "inv_alt (x \<cdot> y) = inv_alt y \<cdot> inv_alt x"

sublocale involutive_dioid_alt \<subseteq> altinv: involutive_dioid inv_alt _ _ _ _ _ _
  apply unfold_locales
    apply simp_all
  using local.inv_alt local.order_eq_iff apply force
  by (meson local.add_lub local.dual_order.eq_iff local.inv_alt)

sublocale involutive_dioid \<subseteq> altinv: involutive_dioid_alt _ _ _ _ _ _ invol
  by (unfold_locales, simp_all add: local.inv_adj)

class involutive_kleene_algebra = involutive_dioid + kleene_algebra

begin

lemma inv_star: "(x\<^sup>\<star>)\<^sup>\<circ> = (x\<^sup>\<circ>)\<^sup>\<star>"
proof (rule order.antisym)
  have "((x\<^sup>\<circ>)\<^sup>\<star>)\<^sup>\<circ> = (1 + (x\<^sup>\<circ>)\<^sup>\<star> \<cdot> x\<^sup>\<circ>)\<^sup>\<circ>"
    by simp
  also have "\<dots> = 1 + (x\<^sup>\<circ>)\<^sup>\<circ> \<cdot> ((x\<^sup>\<circ>)\<^sup>\<star>)\<^sup>\<circ>"
    using local.inv_contrav local.inv_one local.inv_sup by presburger
  finally have "1 + x \<cdot> ((x\<^sup>\<circ>)\<^sup>\<star>)\<^sup>\<circ> \<le> ((x\<^sup>\<circ>)\<^sup>\<star>)\<^sup>\<circ>"
    by simp
  hence "x\<^sup>\<star> \<le> ((x\<^sup>\<circ>)\<^sup>\<star>)\<^sup>\<circ>"
    using local.star_inductl by force
  thus "(x\<^sup>\<star>)\<^sup>\<circ> \<le> (x\<^sup>\<circ>)\<^sup>\<star>"
    by (simp add: local.inv_adj)
next
  have "(x\<^sup>\<star>)\<^sup>\<circ> = (1 + x\<^sup>\<star> \<cdot> x)\<^sup>\<circ>"
    by simp
  also have "\<dots> = 1 + x\<^sup>\<circ> \<cdot> (x\<^sup>\<star>)\<^sup>\<circ>"
    using local.inv_contrav local.inv_one local.inv_sup by presburger
  finally have "1 + x\<^sup>\<circ> \<cdot> (x\<^sup>\<star>)\<^sup>\<circ> \<le> (x\<^sup>\<star>)\<^sup>\<circ>"
    by simp
  thus "(x\<^sup>\<circ>)\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<circ>"
    using local.star_inductl by force
qed

end

subsection \<open>Kleene algebra with converse\<close>

text \<open>The name "strong Gelfand property" has been borrowed from Palmigiano and Re.\<close>

class dioid_converse = involutive_dioid +
  assumes strong_gelfand: "x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x"

lemma (in dioid_converse) subid_conv: "x \<le> 1 \<Longrightarrow> x\<^sup>\<circ> = x"
proof (rule order.antisym)
  assume h: "x \<le> 1"
  have "x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x"
    by (simp add: local.strong_gelfand)
  also have "\<dots> \<le> 1 \<cdot> x\<^sup>\<circ> \<cdot> 1"
    using h local.dd.mult_iso local.mult_isor by presburger
  also have "\<dots> =  x\<^sup>\<circ>"
    by simp
  finally show "x \<le> x\<^sup>\<circ>"
    by simp
  thus "x\<^sup>\<circ> \<le> x"
    by (simp add: local.inv_adj)
qed

lemma (in involutive_dioid)
  shows  "\<exists>f. (\<forall>x. x \<le> f x \<cdot> x) \<and> (\<forall>x y. f (x \<cdot> f y) = f (x \<cdot> y)) \<and> (\<forall>x y. f (x + y) = f x + f y) \<and> (\<forall>x. f x \<le> 1) \<and> (f 0 = 0)"
  nitpick (* 3-element counterexample *)
  oops

lemma (in dioid_converse)
  shows  "\<exists>f. (\<forall>x. x \<le> f x \<cdot> x) \<and> (\<forall>x y. f (x \<cdot> f y) = f (x \<cdot> y)) \<and> (\<forall>x y. f (x + y) = f x + f y) \<and> (\<forall>x. f x \<le> 1) \<and> (f 0 = 0)"
  nitpick (* no proof no counterexample *)
  oops

class kleene_algebra_converse = involutive_kleene_algebra + dioid_converse

end


theory IICF_Indexed_Array_List
imports
  "HOL-Library.Rewrite"
  "../Intf/IICF_List"
  "List-Index.List_Index"
  IICF_Array
  IICF_MS_Array_List
begin

  text \<open>We implement distinct lists of natural numbers in the range \<open>{0..<N}\<close>
    by a length counter and two arrays of size \<open>N\<close>.
    The first array stores the list, and the second array stores the positions of
    the elements in the list, or \<open>N\<close> if the element is not in the list.

    This allows for an efficient index query.

    The implementation is done in two steps:
      First, we use a list and a fixed size list for the index mapping.
      Second, we refine the lists to arrays.
 \<close>

  type_synonym aial = "nat list \<times> nat list"

  locale ial_invar = fixes
         maxsize :: nat
    and  l :: "nat list"
    and qp :: "nat list"
    assumes maxsize_eq[simp]: "maxsize = length qp"
    assumes l_distinct[simp]: "distinct l"
    assumes l_set: "set l \<subseteq> {0..<length qp}"
    assumes qp_def: "\<forall>k<length qp. qp!k = (if k\<in>set l then List_Index.index l k else length qp)"
  begin
    lemma l_len: "length l \<le> length qp"
    proof -
      from card_mono[OF _ l_set] have "card (set l) \<le> length qp" by auto
      with distinct_card[OF l_distinct] show ?thesis by simp
    qed

    lemma idx_len[simp]: "i<length l \<Longrightarrow> l!i < length qp"
      using l_set
      by (metis atLeastLessThan_iff nth_mem psubsetD psubsetI)

    lemma l_set_simp[simp]: "k\<in>set l \<Longrightarrow> k < length qp"
      by (auto dest: subsetD[OF l_set])

    lemma qpk_idx: "k<length qp \<Longrightarrow> qp ! k < length l \<longleftrightarrow> k \<in> set l"
    proof (rule iffI)
      assume A: "k<length qp"
      {
        assume "qp!k < length l"
        hence "qp!k < length qp" using l_len by simp
        with spec[OF qp_def, of k] A show "k\<in>set l"
          by (auto split: if_split_asm)
      }
      {
        assume "k\<in>set l"
        thus "qp!k<length l"
          using qp_def by (auto split: if_split_asm) []
      }
    qed

    lemma lqpk[simp]: "k \<in> set l \<Longrightarrow> l ! (qp ! k) = k"
      using spec[OF qp_def, of k] by auto

    lemma "\<lbrakk>i<length l; j<length l; l!i=l!j\<rbrakk> \<Longrightarrow> i=j"
      by (simp add: nth_eq_iff_index_eq)

    lemmas index_swap[simp] = index_swap_if_distinct[folded swap_def, OF l_distinct]

    lemma swap_invar:
      assumes "i<length l" "j<length l"
      shows "ial_invar (length qp) (swap l i j) (qp[l ! j := i, l ! i := j])"
      using assms
      apply unfold_locales
      apply auto []
      apply auto []
      apply auto []
      apply (auto simp: simp: nth_list_update nth_eq_iff_index_eq index_nth_id) []
      using qp_def apply auto [2]
      done

  end

  definition "ial_rel1 maxsize \<equiv> br fst (uncurry (ial_invar maxsize))"

  definition ial_assn2 :: "nat \<Rightarrow> nat list * nat list \<Rightarrow> _" where
    "ial_assn2 maxsize \<equiv> prod_assn (marl_assn maxsize nat_assn) (array_assn nat_assn)"

(*  definition "ial_assn maxsize \<equiv> hr_comp (ial_assn2 maxsize) (ial_rel1 maxsize)"*)

  definition "ial_assn maxsize A \<equiv> hr_comp (hr_comp (ial_assn2 maxsize) (ial_rel1 maxsize)) (\<langle>the_pure A\<rangle>list_rel)"
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "ial_assn maxsize A" for maxsize A]

(*  lemma ial_assn_precise[constraint_rules]: "precise (ial_assn maxsize)"
    unfolding ial_assn_def ial_rel1_def ial_assn2_def
    apply constraint_rules
*)

  subsection \<open>Empty\<close>

  definition op_ial_empty_sz :: "nat \<Rightarrow> 'a list"
    where [simp]: "op_ial_empty_sz ms \<equiv> op_list_empty"

  context fixes maxsize :: nat begin
  sepref_register "PR_CONST (op_ial_empty_sz maxsize)"
  end

  context
    fixes maxsize :: nat (* If we do not fix maxsize here, the FCOMP-rule will
      derive a more general rule with two different maxsizes! *)
    notes [fcomp_norm_unfold] = ial_assn_def[symmetric]
    notes [simp] = hn_ctxt_def pure_def
  begin

    definition "aial_empty \<equiv> do {
      let l = op_marl_empty_sz maxsize;
      let qp = op_array_replicate maxsize maxsize;
      RETURN (l,qp)
    }"

    lemma aial_empty_impl: "(aial_empty,RETURN op_list_empty) \<in> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
      unfolding aial_empty_def
      apply (refine_vcg nres_relI)
      apply (clarsimp simp: ial_rel1_def br_def)
      apply unfold_locales
      apply auto
      done

    (* Note: This lemma requires some setup to handle maxsize simultaneously
      as a parameter, and as a constant.
    *)
    context
      notes [id_rules] = itypeI[Pure.of maxsize "TYPE(nat)"]
      notes [sepref_import_param] = IdI[of maxsize]
    begin
    sepref_definition ial_empty is "uncurry0 aial_empty" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a ial_assn2 maxsize"
      unfolding aial_empty_def ial_assn2_def
      using [[id_debug]]
      by sepref
    end

    sepref_decl_impl (no_register) ial_empty: ial_empty.refine[FCOMP aial_empty_impl] .
    lemma ial_empty_sz_hnr[sepref_fr_rules]:
      "(uncurry0 local.ial_empty, uncurry0 (RETURN (PR_CONST (op_ial_empty_sz maxsize)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a ial_assn maxsize A"
      using ial_empty_hnr[of A] by simp

    subsection \<open>Swap\<close>
    definition "aial_swap \<equiv> \<lambda>(l,qp) i j. do {
      vi \<leftarrow> mop_list_get l i;
      vj \<leftarrow> mop_list_get l j;
      l \<leftarrow> mop_list_set l i vj;
      l \<leftarrow> mop_list_set l j vi;
      qp \<leftarrow> mop_list_set qp vj i;
      qp \<leftarrow> mop_list_set qp vi j;
      RETURN (l,qp)
    }"

    lemma in_ial_rel1_conv:
      "((pq, qp), l) \<in> ial_rel1 ms \<longleftrightarrow> pq=l \<and> ial_invar ms l qp"
      by (auto simp: ial_rel1_def in_br_conv)

    lemma aial_swap_impl:
      "(aial_swap,mop_list_swap) \<in> ial_rel1 maxsize \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
    proof (intro fun_relI nres_relI; clarsimp simp: in_ial_rel1_conv; refine_vcg; clarsimp)
      fix l qp i j
      assume [simp]: "i<length l" "j<length l" and "ial_invar maxsize l qp"
      then interpret ial_invar maxsize l qp by simp

      show "aial_swap (l, qp) i j \<le> SPEC (\<lambda>c. (c, swap l i j) \<in> ial_rel1 maxsize)"
        unfolding aial_swap_def
        apply refine_vcg
        apply (vc_solve simp add: in_ial_rel1_conv swap_def[symmetric] swap_invar)
        done
    qed

    sepref_definition ial_swap is
      "uncurry2 aial_swap" :: "(ial_assn2 maxsize)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a ial_assn2 maxsize"
      unfolding aial_swap_def ial_assn2_def
      by sepref

    sepref_decl_impl (ismop) test: ial_swap.refine[FCOMP aial_swap_impl]
      uses mop_list_swap.fref .

    subsection \<open>Length\<close>
    definition aial_length :: "aial \<Rightarrow> nat nres"
      where "aial_length \<equiv> \<lambda>(l,_). RETURN (op_list_length l)"

    lemma aial_length_impl: "(aial_length, mop_list_length) \<in> ial_rel1 maxsize \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding ial_rel1_def in_br_conv aial_length_def
      by auto

    sepref_definition ial_length is "aial_length" :: "(ial_assn2 maxsize)\<^sup>k \<rightarrow>\<^sub>a nat_assn"
      unfolding aial_length_def ial_assn2_def
      by sepref

    sepref_decl_impl (ismop) ial_length: ial_length.refine[FCOMP aial_length_impl] .

    subsection \<open>Index\<close>

    definition aial_index :: "aial \<Rightarrow> nat \<Rightarrow> nat nres" where
      "aial_index \<equiv> \<lambda>(l,qp) k. do {
        ASSERT (k\<in>set l);
        i \<leftarrow> mop_list_get qp k;
        RETURN i
      }"

    lemma aial_index_impl:
      "(uncurry aial_index, uncurry mop_list_index) \<in>
        [\<lambda>(l,k). k\<in>set l]\<^sub>f ial_rel1 maxsize \<times>\<^sub>r nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI frefI)
      unfolding ial_rel1_def
    proof (clarsimp simp:  in_br_conv)
      fix l qp k
      assume "ial_invar maxsize l qp"
      then interpret ial_invar maxsize l qp .

      assume "k\<in>set l"
      then show "aial_index (l,qp) k \<le> RETURN (index l k)"
        unfolding aial_index_def
        apply (refine_vcg)
        by (auto simp: qp_def)
    qed

    sepref_definition ial_index is "uncurry aial_index" :: "(ial_assn2 maxsize)\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
      unfolding aial_index_def ial_assn2_def
      by sepref

    sepref_decl_impl (ismop) ial_index: ial_index.refine[FCOMP aial_index_impl] .

    subsection \<open>Butlast\<close>
    definition aial_butlast :: "aial \<Rightarrow> aial nres" where
      "aial_butlast \<equiv> \<lambda>(l,qp). do {
        ASSERT (l\<noteq>[]);
        len \<leftarrow> mop_list_length l;
        k \<leftarrow> mop_list_get l (len - 1);
        l \<leftarrow> mop_list_butlast l;
        qp \<leftarrow> mop_list_set qp k (length qp);
        RETURN (l,qp)
      }"

    lemma aial_butlast_refine: "(aial_butlast, mop_list_butlast) \<in> ial_rel1 maxsize \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding ial_rel1_def
    proof (clarsimp simp: in_br_conv simp del: mop_list_butlast_alt)
      fix l qp
      assume "ial_invar maxsize l qp"
      then interpret ial_invar maxsize l qp .

      {
        assume A: "l\<noteq>[]"
        have "ial_invar (length qp) (butlast l) (qp[l ! (length l - Suc 0) := length qp])"
          apply standard
          apply clarsimp_all
          apply (auto simp: distinct_butlast) []
          using l_set apply (auto dest: in_set_butlastD) []
          using qp_def A l_distinct
          apply (auto simp: nth_list_update neq_Nil_rev_conv index_append simp del: l_distinct)
          done
      } note aux1=this

      show "aial_butlast (l, qp) \<le> \<Down> (br fst (uncurry (ial_invar maxsize))) (mop_list_butlast l)"
        unfolding aial_butlast_def mop_list_butlast_alt
        apply refine_vcg
        apply (clarsimp_all simp: in_br_conv aux1)
        done
    qed

    sepref_definition ial_butlast is aial_butlast :: "(ial_assn2 maxsize)\<^sup>d \<rightarrow>\<^sub>a ial_assn2 maxsize"
      unfolding aial_butlast_def ial_assn2_def by sepref

    sepref_decl_impl (ismop) ial_butlast: ial_butlast.refine[FCOMP aial_butlast_refine] .

    subsection \<open>Append\<close>
    definition aial_append :: "aial \<Rightarrow> nat \<Rightarrow> aial nres" where
      "aial_append \<equiv> \<lambda>(l,qp) k. do {
        ASSERT (k<length qp \<and> k\<notin>set l \<and> length l < length qp);
        len \<leftarrow> mop_list_length l;
        l \<leftarrow> mop_list_append l k;
        qp \<leftarrow> mop_list_set qp k len;
        RETURN (l,qp)
      }"

    lemma aial_append_refine:
      "(uncurry aial_append,uncurry mop_list_append) \<in>
        [\<lambda>(l,k). k<maxsize \<and> k\<notin>set l]\<^sub>f ial_rel1 maxsize \<times>\<^sub>r nat_rel \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
      apply (intro frefI nres_relI)
      unfolding ial_rel1_def
    proof (clarsimp simp: in_br_conv)
      fix l qp k
      assume KLM: "k<maxsize" and KNL: "k\<notin>set l"
      assume "ial_invar maxsize l qp"
      then interpret ial_invar maxsize l qp .

      from KLM have KLL: "k<length qp" by simp

      note distinct_card[OF l_distinct, symmetric]
      also from KNL l_set have "set l \<subseteq> {0..<k} \<union> {Suc k..<length qp}"
        by (auto simp: nat_less_le)
      from card_mono[OF _ this] have "card (set l) \<le> card \<dots>"
        by simp
      also note card_Un_le
      also have "card {0..<k} + card {Suc k..<length qp} = k + (length qp - Suc k)"
        by simp
      also have "\<dots> < length qp" using KLL by simp
      finally have LLEN: "length l < length qp" .

      have aux1[simp]: "ial_invar (length qp) (l @ [k]) (qp[k := length l])"
        apply standard
        apply (clarsimp_all simp: KNL KLL)
        using KLL apply (auto simp: Suc_le_eq LLEN) []
        apply (auto simp: index_append KNL nth_list_update')
        apply (simp add: qp_def)
        apply (simp add: qp_def)
        done

      show "aial_append (l, qp) k \<le> \<Down> (br fst (uncurry (ial_invar maxsize))) (RETURN (l@[k]))"
        unfolding aial_append_def mop_list_append_def
        apply refine_vcg
        apply (clarsimp_all simp: in_br_conv KLL KNL LLEN)
        done
    qed

    private lemma aial_append_impl_aux: "((l, qp), l') \<in> ial_rel1 maxsize \<Longrightarrow> l'=l \<and> maxsize = length qp"
      unfolding ial_rel1_def
      by (clarsimp simp: in_br_conv ial_invar.maxsize_eq[symmetric])

    context
      notes [dest!] = aial_append_impl_aux
    begin
      (* TODO: Should we integrate the domain-condition, or some similar condition,
        as assertion (relating length l and length qp) or into ial_assn2 ? *)
      sepref_definition ial_append is
        "uncurry aial_append" :: "[\<lambda>(lqp,_). lqp\<in>Domain (ial_rel1 maxsize)]\<^sub>a (ial_assn2 maxsize)\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow> ial_assn2 maxsize"
        unfolding aial_append_def ial_assn2_def
        by sepref
    end

    lemma "(\<lambda>b. b<maxsize, X) \<in> A \<rightarrow> bool_rel"
      apply auto
      oops

    context begin
      (* TODO: Maybe inject additional restrictions on sepref_decl_impl command *)
      (* TODO: Maybe require Domain R \<subseteq> {0..<maxsize} instead ? *)
      private lemma append_fref': "\<lbrakk>IS_BELOW_ID R\<rbrakk>
        \<Longrightarrow> (uncurry mop_list_append, uncurry mop_list_append) \<in> \<langle>R\<rangle>list_rel \<times>\<^sub>r R \<rightarrow>\<^sub>f \<langle>\<langle>R\<rangle>list_rel\<rangle>nres_rel"
        by (rule mop_list_append.fref)

      sepref_decl_impl (ismop) ial_append: ial_append.refine[FCOMP aial_append_refine] uses append_fref'
        unfolding IS_BELOW_ID_def
        apply (parametricity; auto simp: single_valued_below_Id)
        done
    end

    (*
    lemmas ial_append_hnr_mop[sepref_fr_rules] = ial_append.refine[FCOMP aial_append_refine]
    lemmas ial_append_hnr[sepref_fr_rules] = ial_append_hnr_mop[FCOMP mk_op_rl2_np[OF mop_list_append_alt]]
    *)

    subsection \<open>Get\<close>

    definition aial_get :: "aial \<Rightarrow> nat \<Rightarrow> nat nres" where
      "aial_get \<equiv> \<lambda>(l,qp) i. mop_list_get l i"

    lemma aial_get_refine: "(aial_get,mop_list_get) \<in> ial_rel1 maxsize \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding aial_get_def ial_rel1_def mop_list_get_def in_br_conv
      apply refine_vcg
      apply clarsimp_all
      done

    sepref_definition ial_get is "uncurry aial_get" :: "(ial_assn2 maxsize)\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
      unfolding aial_get_def ial_assn2_def by sepref

    sepref_decl_impl (ismop) ial_get: ial_get.refine[FCOMP aial_get_refine] .

    subsection \<open>Contains\<close>

    definition aial_contains :: "nat \<Rightarrow> aial \<Rightarrow> bool nres" where
      "aial_contains \<equiv> \<lambda>k (l,qp). do {
        if k<maxsize then do {
          i \<leftarrow> mop_list_get qp k;
          RETURN (i<maxsize)
        } else RETURN False
      }"

    lemma aial_contains_refine: "(uncurry aial_contains,uncurry mop_list_contains)
      \<in> (nat_rel \<times>\<^sub>r ial_rel1 maxsize) \<rightarrow>\<^sub>f \<langle>bool_rel\<rangle>nres_rel"
      apply (intro frefI nres_relI)
      unfolding ial_rel1_def
    proof (clarsimp simp: in_br_conv)
      fix l qp k
      (*assume A: "k<maxsize"*)
      assume "ial_invar maxsize l qp"
      then interpret ial_invar maxsize l qp .

      show "aial_contains k (l, qp) \<le> RETURN (k\<in>set l)"
        unfolding aial_contains_def
        apply refine_vcg
        by (auto simp: l_len qp_def split: if_split_asm)
    qed

    context
      notes [id_rules] = itypeI[Pure.of maxsize "TYPE(nat)"]
      notes [sepref_import_param] = IdI[of maxsize]
    begin
      sepref_definition ial_contains is "uncurry aial_contains" :: "nat_assn\<^sup>k *\<^sub>a (ial_assn2 maxsize)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
        unfolding aial_contains_def ial_assn2_def by sepref
    end

    sepref_decl_impl (ismop) ial_contains: ial_contains.refine[FCOMP aial_contains_refine] .
  end

end


section \<open>Derived facts about quantum registers\<close>

theory Quantum_Extra
  imports
    Laws_Quantum
    Quantum
begin

no_notation meet (infixl "\<sqinter>\<index>" 70)
no_notation Group.mult (infixl "\<otimes>\<index>" 70)
no_notation Order.top ("\<top>\<index>")
unbundle register_notation
unbundle cblinfun_notation

lemma zero_not_register[simp]: \<open>~ register (\<lambda>_. 0)\<close>
  unfolding register_def by simp

lemma register_pair_is_register_converse:
  \<open>register (F;G) \<Longrightarrow> register F\<close> \<open>register (F;G) \<Longrightarrow> register G\<close>
  using [[simproc del: Laws_Quantum.compatibility_warn]]
   apply (cases \<open>register F\<close>)
    apply (auto simp: register_pair_def)[2]
  apply (cases \<open>register G\<close>)
  by (auto simp: register_pair_def)[2]

lemma register_id'[simp]: \<open>register (\<lambda>x. x)\<close>
  using register_id by (simp add: id_def)

lemma register_projector:
  assumes "register F"
  assumes "is_Proj a"
  shows "is_Proj (F a)"
  using assms unfolding register_def is_Proj_algebraic by metis

lemma register_unitary:
  assumes "register F"
  assumes "unitary a"
  shows "unitary (F a)"
  using assms by (smt (verit, best) register_def unitary_def)

lemma compatible_proj_intersect:
  (* I think this also holds without is_Proj premises, but my proof ideas use the Penrose-Moore
     pseudoinverse or simultaneous diagonalization and we do not have an existence theorem for either. *)
  assumes "compatible R S" and "is_Proj a" and "is_Proj b"
  shows "(R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>) = ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)"
proof (rule antisym)
  have "((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (S b *\<^sub>S \<top>)"
    apply (subst swap_registers[OF assms(1)])
    by (simp add: cblinfun_compose_image cblinfun_image_mono)
  moreover have "((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (R a *\<^sub>S \<top>)"
    by (simp add: cblinfun_compose_image cblinfun_image_mono)
  ultimately show \<open>((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>)\<close>
    by auto

  have "is_Proj (R a)"
    using assms(1) assms(2) compatible_register1 register_projector by blast
  have "is_Proj (S b)"
    using assms(1) assms(3) compatible_register2 register_projector by blast
  show \<open>(R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>) \<le> (R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>\<close>
  proof (unfold less_eq_ccsubspace.rep_eq, rule)
    fix \<psi>
    assume asm: \<open>\<psi> \<in> space_as_set ((R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>))\<close>
    then have \<open>\<psi> \<in> space_as_set (R a *\<^sub>S \<top>)\<close>
      by auto
    then have R: \<open>R a *\<^sub>V \<psi> = \<psi>\<close>
      using \<open>is_Proj (R a)\<close> cblinfun_fixes_range is_Proj_algebraic by blast
    from asm have \<open>\<psi> \<in> space_as_set (S b *\<^sub>S \<top>)\<close>
      by auto
    then have S: \<open>S b *\<^sub>V \<psi> = \<psi>\<close>
      using \<open>is_Proj (S b)\<close> cblinfun_fixes_range is_Proj_algebraic by blast
    from R S have \<open>\<psi> = (R a o\<^sub>C\<^sub>L S b) *\<^sub>V \<psi>\<close>
      by (simp add: cblinfun_apply_cblinfun_compose)
    also have \<open>\<dots> \<in> space_as_set ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)\<close>
      apply simp by (metis R S calculation cblinfun_apply_in_image)
    finally show \<open>\<psi> \<in> space_as_set ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)\<close>
      by -
  qed
qed

lemma compatible_proj_mult:
  assumes "compatible R S" and "is_Proj a" and "is_Proj b"
  shows "is_Proj (R a o\<^sub>C\<^sub>L S b)"
  using [[simproc del: Laws_Quantum.compatibility_warn]]
  using assms unfolding is_Proj_algebraic compatible_def
  apply auto
   apply (metis (no_types, lifting) cblinfun_compose_assoc register_mult)
  by (simp add: assms(2) assms(3) is_proj_selfadj register_projector)

lemma unitary_sandwich_register: \<open>unitary a \<Longrightarrow> register (sandwich a)\<close>
  unfolding register_def
  apply (auto simp: sandwich_def)
   apply (metis (no_types, lifting) cblinfun_assoc_left(1) cblinfun_compose_id_right unitaryD1)
  by (simp add: lift_cblinfun_comp(2))

lemma sandwich_tensor:
  fixes a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close>
  assumes \<open>unitary a\<close> \<open>unitary b\<close>
  shows "sandwich (a \<otimes>\<^sub>o b) = sandwich a \<otimes>\<^sub>r sandwich b"
  apply (rule tensor_extensionality)
  by (auto simp: unitary_sandwich_register assms sandwich_def register_tensor_is_register comp_tensor_op tensor_op_adjoint)

lemma sandwich_grow_left:
  fixes a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a ell2\<close>
  assumes "unitary a"
  shows "sandwich a \<otimes>\<^sub>r id = sandwich (a \<otimes>\<^sub>o id_cblinfun)"
  by (simp add: unitary_sandwich_register assms sandwich_tensor sandwich_id)

lemma register_sandwich: \<open>register F \<Longrightarrow> F (sandwich a b) = sandwich (F a) (F b)\<close>
  by (smt (verit, del_insts) register_def sandwich_def)

lemma assoc_ell2_sandwich: \<open>assoc = sandwich assoc_ell2\<close>
  apply (rule tensor_extensionality3')
    apply (simp_all add: unitary_sandwich_register)[2]
  apply (rule equal_ket)
  apply (case_tac x)
  by (simp add: sandwich_def assoc_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor
           flip: tensor_ell2_ket)

lemma assoc_ell2'_sandwich: \<open>assoc' = sandwich assoc_ell2'\<close>
  apply (rule tensor_extensionality3)
    apply (simp_all add: unitary_sandwich_register)[2]
  apply (rule equal_ket)
  apply (case_tac x)
  by (simp add: sandwich_def assoc'_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor
           flip: tensor_ell2_ket)

lemma swap_sandwich: "swap = sandwich Uswap"
  apply (rule tensor_extensionality)
    apply (auto simp: sandwich_def)[2]
  apply (rule tensor_ell2_extensionality)
  by (simp add: sandwich_def cblinfun_apply_cblinfun_compose tensor_op_ell2)

lemma id_tensor_sandwich:
  fixes a :: "'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2"
  assumes "unitary a"
  shows "id \<otimes>\<^sub>r sandwich a = sandwich (id_cblinfun \<otimes>\<^sub>o a)"
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_tensor_is_register comp_tensor_op sandwich_def tensor_op_adjoint unitary_sandwich_register)

lemma compatible_selfbutter_join:
  assumes [register]: "compatible R S"
  shows "R (selfbutter \<psi>) o\<^sub>C\<^sub>L S (selfbutter \<phi>) = (R; S) (selfbutter (\<psi> \<otimes>\<^sub>s \<phi>))"
  apply (subst register_pair_apply[symmetric, where F=R and G=S])
  using assms by auto

lemma register_mult':
  assumes \<open>register F\<close>
  shows \<open>F a *\<^sub>V F b *\<^sub>V c = F (a o\<^sub>C\<^sub>L b) *\<^sub>V c\<close>
  by (simp add: assms lift_cblinfun_comp(4) register_mult)

lemma register_scaleC:
  assumes \<open>register F\<close> shows \<open>F (c *\<^sub>C a) = c *\<^sub>C F a\<close>
  by (simp add: assms complex_vector.linear_scale)

lemma register_bounded_clinear: \<open>register F \<Longrightarrow> bounded_clinear F\<close>
  using bounded_clinear_finite_dim register_def by blast

lemma register_adjoint: "F (a*) = (F a)*" if \<open>register F\<close>
  using register_def that by blast

end


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

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

theorem property0 :
  "((toNat (s n)) = (1 + (toNat n)))"
  oops

end


theory "TTree-HOLCF"
imports TTree "Launchbury.HOLCF-Utils" "Set-Cpo" "Launchbury.HOLCF-Join-Classes"
begin

instantiation ttree :: (type) below
begin
  lift_definition below_ttree :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> bool" is "(\<subseteq>)".
instance..
end

lemma paths_mono: "t \<sqsubseteq> t' \<Longrightarrow> paths t \<sqsubseteq> paths t'"
  by transfer (auto simp add: below_set_def)

lemma paths_mono_iff: "paths t \<sqsubseteq> paths t' \<longleftrightarrow> t \<sqsubseteq> t'"
  by transfer (auto simp add: below_set_def)

lemma ttree_belowI: "(\<And> xs. xs \<in> paths t \<Longrightarrow> xs \<in> paths t') \<Longrightarrow> t \<sqsubseteq> t'"
  by transfer auto

lemma paths_belowI: "(\<And> x xs. x#xs \<in> paths t \<Longrightarrow> x#xs \<in> paths t') \<Longrightarrow> t \<sqsubseteq> t'"
  apply (rule ttree_belowI)
  apply (case_tac xs)
  apply auto
  done

instance ttree :: (type) po
 by standard (transfer, simp)+

lemma is_lub_ttree:
  "S <<| Either S"
  unfolding is_lub_def is_ub_def
  by transfer auto

lemma lub_is_either: "lub S = Either S"
  using is_lub_ttree by (rule lub_eqI)

instance ttree :: (type) cpo
  by standard (rule exI, rule is_lub_ttree)

lemma minimal_ttree[simp, intro!]: "empty \<sqsubseteq> S"
  by transfer simp

instance ttree :: (type) pcpo
  by standard (rule+)

lemma empty_is_bottom: "empty = \<bottom>"
  by (metis below_bottom_iff minimal_ttree)

lemma carrier_bottom[simp]: "carrier \<bottom> = {}"
  unfolding empty_is_bottom[symmetric] by simp

lemma below_anything[simp]:
  "t \<sqsubseteq> anything"
by transfer auto

lemma carrier_mono: "t \<sqsubseteq> t' \<Longrightarrow> carrier t \<subseteq> carrier t'"
  by transfer auto

lemma nxt_mono: "t \<sqsubseteq> t' \<Longrightarrow> nxt t x \<sqsubseteq> nxt t' x"
  by transfer auto

lemma either_above_arg1: "t \<sqsubseteq> t \<oplus>\<oplus> t'"
  by transfer fastforce

lemma either_above_arg2: "t' \<sqsubseteq> t \<oplus>\<oplus> t'"
  by transfer fastforce

lemma either_belowI: "t \<sqsubseteq> t'' \<Longrightarrow> t' \<sqsubseteq> t'' \<Longrightarrow> t \<oplus>\<oplus> t' \<sqsubseteq> t''"
  by transfer auto

lemma both_above_arg1: "t \<sqsubseteq> t \<otimes>\<otimes> t'"
  by transfer fastforce

lemma both_above_arg2: "t' \<sqsubseteq> t \<otimes>\<otimes> t'"
  by transfer fastforce

lemma both_mono1':
  "t \<sqsubseteq> t' \<Longrightarrow> t \<otimes>\<otimes> t'' \<sqsubseteq> t' \<otimes>\<otimes> t''"
  using  both_mono1[folded below_set_def, unfolded paths_mono_iff].

lemma both_mono2':
  "t \<sqsubseteq> t' \<Longrightarrow> t'' \<otimes>\<otimes> t \<sqsubseteq> t'' \<otimes>\<otimes> t'"
  using  both_mono2[folded below_set_def, unfolded paths_mono_iff].

lemma nxt_both_left:
  "possible t x \<Longrightarrow> nxt t x \<otimes>\<otimes> t' \<sqsubseteq> nxt (t \<otimes>\<otimes> t') x"
  by (auto simp add: nxt_both either_above_arg2)

lemma nxt_both_right:
  "possible t' x \<Longrightarrow> t \<otimes>\<otimes> nxt t' x \<sqsubseteq> nxt (t \<otimes>\<otimes> t') x"
  by (auto simp add: nxt_both either_above_arg1)

lemma substitute_mono1': "f \<sqsubseteq> f'\<Longrightarrow> substitute f T t \<sqsubseteq> substitute f' T t"
  using  substitute_mono1[folded below_set_def, unfolded paths_mono_iff] fun_belowD
  by metis

lemma substitute_mono2': "t \<sqsubseteq> t'\<Longrightarrow> substitute f T t \<sqsubseteq> substitute f T t'"
  using  substitute_mono2[folded below_set_def, unfolded paths_mono_iff].

lemma substitute_above_arg: "t \<sqsubseteq> substitute f T t"
  using  substitute_contains_arg[folded below_set_def, unfolded paths_mono_iff].

lemma ttree_contI:
  assumes  "\<And> S. f (Either S) = Either (f ` S)"
  shows "cont f"
proof(rule contI)
  fix Y :: "nat \<Rightarrow> 'a ttree"
  have "range (\<lambda>i. f (Y i)) = f ` range Y" by auto
  also have "Either \<dots> = f (Either (range Y))" unfolding assms(1)..
  also have "Either (range Y) = lub (range Y)" unfolding lub_is_either by simp
  finally
  show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion> i. Y i)" by (metis is_lub_ttree)
qed

lemma ttree_contI2:
  assumes  "\<And> x. paths (f x) = \<Union>(t ` paths x)"
  assumes "[] \<in> t []"
  shows "cont f"
proof(rule contI)
  fix Y :: "nat \<Rightarrow> 'a ttree"
  have "paths (Either (range (\<lambda>i. f (Y i)))) = insert [] (\<Union>x. paths (f (Y x)))"
    by (simp add: paths_Either)
  also have "\<dots> = insert [] (\<Union>x. \<Union>(t ` paths (Y x)))"
    by (simp add: assms(1))
  also have "\<dots> = \<Union>(t ` insert [] (\<Union>x. paths (Y x)))"
    using assms(2) by (auto cong add: SUP_cong_simp)
  also have "\<dots> = \<Union>(t ` paths (Either (range Y)))"
    by (auto simp add: paths_Either)
  also have "\<dots> = paths (f (Either (range Y)))"
    by (simp add: assms(1))
  also have "\<dots> = paths (f (lub (range Y)))" unfolding lub_is_either by simp
  finally
  show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion> i. Y i)" by (metis is_lub_ttree paths_inj)
qed

lemma cont_paths[THEN cont_compose, cont2cont, simp]:
  "cont paths"
  apply (rule set_contI)
  apply (thin_tac _)
  unfolding lub_is_either
  apply transfer
  apply auto
  done

lemma ttree_contI3:
  assumes "cont (\<lambda> x. paths (f x))"
  shows "cont f"
  apply (rule contI2)
  apply (rule monofunI)
  apply (subst paths_mono_iff[symmetric])
  apply (erule cont2monofunE[OF assms])

  apply (subst paths_mono_iff[symmetric])
  apply (subst cont2contlubE[OF cont_paths[OF cont_id]], assumption)
  apply (subst cont2contlubE[OF assms], assumption)
  apply rule
  done

lemma cont_substitute[THEN cont_compose, cont2cont, simp]:
  "cont (substitute f T)"
  apply (rule ttree_contI2)
  apply (rule paths_substitute_substitute'')
  apply (auto intro: substitute''.intros)
  done

lemma cont_both1:
  "cont (\<lambda> x. both x y)"
  apply (rule ttree_contI2[where t = "\<lambda>xs . {zs . \<exists>ys\<in>paths y. zs \<in> xs \<otimes> ys}"])
  apply (rule set_eqI)
  by (auto intro:  simp add: paths_both)

lemma cont_both2:
  "cont (\<lambda> x. both y x)"
  apply (rule ttree_contI2[where t = "\<lambda>ys . {zs . \<exists>xs\<in>paths y. zs \<in> xs \<otimes> ys}"])
  apply (rule set_eqI)
  by (auto intro:  simp add: paths_both)

lemma cont_both[cont2cont,simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda> x. f x \<otimes>\<otimes> g x)"
  by (rule cont_compose2[OF cont_both1 cont_both2])

lemma cont_intersect1:
  "cont (\<lambda> x. intersect x y)"
  by (rule ttree_contI2 [where t = "\<lambda>xs . (if xs \<in> paths y then {xs} else {})"])
    (auto split: if_splits)

lemma cont_intersect2:
  "cont (\<lambda> x. intersect y x)"
  by (rule ttree_contI2 [where t = "\<lambda>xs . (if xs \<in> paths y then {xs} else {})"])
    (auto split: if_splits)

lemma cont_intersect[cont2cont,simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda> x. f x \<inter>\<inter> g x)"
  by (rule cont_compose2[OF cont_intersect1 cont_intersect2])

lemma cont_without[THEN cont_compose, cont2cont,simp]: "cont (without x)"
  by (rule ttree_contI2[where t = "\<lambda> xs.{filter (\<lambda> x'. x' \<noteq> x) xs}"])
     (transfer, auto)

lemma paths_many_calls_subset:
  "t \<sqsubseteq> many_calls x \<otimes>\<otimes> without x t"
  by (metis (full_types) below_set_def paths_many_calls_subset paths_mono_iff)

lemma single_below:
  "[x] \<in> paths t \<Longrightarrow> single x \<sqsubseteq> t" by transfer auto

lemma cont_ttree_restr[THEN cont_compose, cont2cont,simp]: "cont (ttree_restr S)"
  by (rule ttree_contI2[where t = "\<lambda> xs.{filter (\<lambda> x'. x' \<in> S) xs}"])
     (transfer, auto)

lemmas ttree_restr_mono = cont2monofunE[OF cont_ttree_restr[OF cont_id]]

lemma range_filter[simp]: "range (filter P) = {xs. set xs \<subseteq> Collect P}"
  apply auto
  apply (rule_tac x = x in rev_image_eqI)
  apply simp
  apply (rule sym)
  apply (auto simp add: filter_id_conv)
  done

lemma ttree_restr_anything_cont[THEN cont_compose, simp, cont2cont]:
  "cont (\<lambda> S. ttree_restr S anything)"
  apply (rule ttree_contI3)
  apply (rule set_contI)
  apply (auto simp add: filter_paths_conv_free_restr[symmetric] lub_set)
  apply (rule finite_subset_chain)
  apply auto
  done

instance ttree :: (type) Finite_Join_cpo
proof
  fix x y :: "'a ttree"
  show "compatible x y"
    unfolding compatible_def
    apply (rule exI)
    apply (rule is_lub_ttree)
    done
qed

lemma ttree_join_is_either:
   "t \<squnion> t' = t \<oplus>\<oplus> t'"
proof-
  have "t \<oplus>\<oplus> t' = Either {t, t'}" by transfer auto
  thus "t \<squnion> t' = t \<oplus>\<oplus> t'" by (metis lub_is_join is_lub_ttree)
qed

lemma ttree_join_transfer[transfer_rule]: "rel_fun (pcr_ttree (=)) (rel_fun (pcr_ttree (=)) (pcr_ttree (=))) (\<union>) (\<squnion>)"
proof-
  have "(\<squnion>) = ((\<oplus>\<oplus>) :: 'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree)" using ttree_join_is_either by blast
  thus ?thesis using either.transfer  by metis
qed

lemma ttree_restr_join[simp]:
  "ttree_restr S (t \<squnion> t') = ttree_restr S t \<squnion> ttree_restr S t'"
  by transfer auto

lemma nxt_singles_below_singles:
  "nxt (singles S) x \<sqsubseteq> singles S"
  apply auto
  apply transfer
  apply auto
  apply (erule_tac x = xc in  ballE)
  apply (erule order_trans[rotated])
  apply (rule length_filter_mono)
  apply simp
  apply simp
  done

lemma in_carrier_fup[simp]:
  "x' \<in> carrier (fup\<cdot>f\<cdot>u) \<longleftrightarrow> (\<exists> u'. u = up\<cdot>u' \<and> x' \<in> carrier (f\<cdot>u'))"
  by (cases u) auto

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Strong_Bisim_Pres
  imports Strong_Bisim Strong_Sim_Pres
begin

lemma actPres:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act

  assumes "P \<sim> Q"

  shows "\<alpha>.(P) \<sim> \<alpha>.(Q)"
proof -
  let ?X = "{(\<alpha>.(P), \<alpha>.(Q)) | P Q. P \<sim> Q}"
  from assms have "(\<alpha>.(P), \<alpha>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto dest: bisimE intro: actPres)
qed

lemma sumPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<sim> Q"

  shows "P \<oplus> R \<sim> Q \<oplus> R"
proof -
  let ?X = "{(P \<oplus> R, Q \<oplus> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<oplus> R, Q \<oplus> R) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: sumPres reflexive dest: bisimE)
qed

lemma parPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<sim> Q"

  shows "P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(P \<parallel> R, Q \<parallel> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct, auto) (blast intro: parPres dest: bisimE)+
qed

  assumes "P \<sim> Q"

  shows "\<lparr>\<nu>x\<rparr>P \<sim> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | x P Q. P \<sim> Q}"
  from assms have "(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: resPres dest: bisimE)
qed

  assumes "P \<sim> Q"

  shows "!P \<sim> !Q"
proof -
  from assms have "(!P, !Q) \<in> bangRel bisim"
    by(auto intro: BRBang)
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim P Q)
    from `(P, Q) \<in> bangRel bisim` show ?case
    proof(induct)
      case(BRBang P Q)
      note `P \<sim> Q` bisimE(1)
      thus "!P \<leadsto>[bangRel bisim] !Q" by(rule bangPres)
    next
      case(BRPar R T P Q)
      from `R \<sim> T` have "R \<leadsto>[bisim] T" by(rule bisimE)
      moreover note `R \<sim> T` `P \<leadsto>[bangRel bisim] Q` `(P, Q) \<in> bangRel bisim` bangRel.BRPar
      ultimately show ?case by(rule Strong_Sim_Pres.parPresAux)
    qed
  next
    case(cSym P Q)
    thus ?case
      by induct (auto dest: bisimE intro: BRPar BRBang)
  qed
qed

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun altmul :: "Nat => Nat => Nat" where
"altmul (Z) y = Z"
| "altmul (S z) (Z) = Z"
| "altmul (S z) (S x2) =
     plus (plus (plus (S Z) (altmul z x2)) z) x2"

theorem property0 :
  "((altmul x y) = (altmul y x))"
  oops

end


theory quasimax imports Main       (* Quasi-maximality: C. Benzmüller & X. Parent, 2020 *)

(* Quasi-maximality, Deb 1977, means maximal wrt transitive closure of the betterness relation restricted to the menu *)
(* Quasi-maximality: ideally the transitive closure should be paramatrized by a context.
It is restricted to the set of antecedent-worlds. The transitive closure should be recalculated each time
each time the set of worlds in which the antecedent is true changes  *)

begin
typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"

(* Some useful relations for constraining accessibility relations*)

definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"

(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

definition ltc :: "\<alpha>\<Rightarrow>\<sigma>\<Rightarrow>\<alpha>"
  where "ltc R \<phi> \<equiv>  \<lambda>x y.  \<phi> x \<and> \<phi> y \<and> (tc R x y)"

lemma transltc: "\<forall>R \<phi>. transitive (ltc R varphi)"
  by (smt ltc_def tc_def transitive_def)

consts BRel :: "\<alpha>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)
(*Original Max, wrt to R

abbreviation max  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)\<and> x R v  \<longrightarrow>  v  R x))) )"
*)

abbreviation qmax  :: "\<sigma>\<Rightarrow>\<sigma>" ("qmax<_>")(*quasimax, i.e. max wrt to tc(R)*)
  where "qmax<\<phi>> \<equiv> (\<lambda>v. ((\<phi> v) \<and> (\<forall>x. ((\<phi> x) \<and> ((tc BRel) x v)  \<longrightarrow>  ((tc BRel) v x)))) )"

abbreviation subset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation cond  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. qmax<\<phi>> \<^bold>\<subseteq> \<psi>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*Correspondence theory. old stuff
lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)
*)
end


theory Ltake
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Llist"
    "types/ENat"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "is_zero n \<or> lnull xs \<Longrightarrow> lnull (ltake n xs)"
| "lhd (ltake n xs) = lhd xs"
| "ltl (ltake n xs) = ltake (epred n) (ltl xs)"

(* cohipster ltake *)
(* Discovers and proves the following in ca. 70 seconds *)
lemma lemma_a [thy_expl]: "ltake y (ltake y z) = ltake y z"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    auto

lemma lemma_aa [thy_expl]: "ltl (ltake (ESuc y) z) = ltake y (ltl z)"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (metis ENat.discI(2) ENat.sel Llist.sel(2) lnull_def ltake.ctr(1) ltake.simps(4))

lemma lemma_ab [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
 by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    auto

lemma lemma_ac [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y z"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt ENat.collapse(2) ENat.discI(2) lemma_aa ltake.disc(1) ltake.disc(2) ltake.simps(3))

lemma lemma_ad [thy_expl]: "ltake y (ltl (ltake y z)) = ltl (ltake y z)"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.sel(2) ltake.ctr(1) ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_ae [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
 by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    simp

lemma lemma_af [thy_expl]: "ltake y (LCons z (ltake y x2)) = ltake y (LCons z x2)"
 by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.disc(2) Llist.sel(1) Llist.sel(3) Ltake.lemma_ad lemma_ab ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_ag [thy_expl]: "ltake (ESuc y) (ltl (ltake y z)) = ltl (ltake y z)"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (metis lemma_aa lemma_ad)

lemma lemma_ah [thy_expl]: "ltake (ESuc (ESuc y)) (ltake y z) = ltake y z"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (metis ENat.discI(2) lemma_aa lemma_ag ltake.disc_iff(2) ltake.simps(3))

lemma lemma_ai [thy_expl]: "ltake (ESuc EZ) (ltake (ESuc y) z) = ltake (ESuc EZ) z"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (simp add: ltake.ctr(1))
end


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

Basics on order-like relations.
*)

section \<open>Basics on Order-Like Relations\<close>

theory Order_Relation_More
imports MainRLT
begin

subsection \<open>The upper and lower bounds operators\<close>

lemma aboveS_subset_above: "aboveS r a \<le> above r a"
by(auto simp add: aboveS_def above_def)

lemma AboveS_subset_Above: "AboveS r A \<le> Above r A"
by(auto simp add: AboveS_def Above_def)

lemma UnderS_disjoint: "A Int (UnderS r A) = {}"
by(auto simp add: UnderS_def)

lemma aboveS_notIn: "a \<notin> aboveS r a"
by(auto simp add: aboveS_def)

lemma Refl_above_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> above r a"
by(auto simp add: refl_on_def above_def)

lemma in_Above_under: "a \<in> Field r \<Longrightarrow> a \<in> Above r (under r a)"
by(auto simp add: Above_def under_def)

lemma in_Under_above: "a \<in> Field r \<Longrightarrow> a \<in> Under r (above r a)"
by(auto simp add: Under_def above_def)

lemma in_UnderS_aboveS: "a \<in> Field r \<Longrightarrow> a \<in> UnderS r (aboveS r a)"
by(auto simp add: UnderS_def aboveS_def)

lemma UnderS_subset_Under: "UnderS r A \<le> Under r A"
by(auto simp add: UnderS_def Under_def)

lemma subset_Above_Under: "B \<le> Field r \<Longrightarrow> B \<le> Above r (Under r B)"
by(auto simp add: Above_def Under_def)

lemma subset_Under_Above: "B \<le> Field r \<Longrightarrow> B \<le> Under r (Above r B)"
by(auto simp add: Under_def Above_def)

lemma subset_AboveS_UnderS: "B \<le> Field r \<Longrightarrow> B \<le> AboveS r (UnderS r B)"
by(auto simp add: AboveS_def UnderS_def)

lemma subset_UnderS_AboveS: "B \<le> Field r \<Longrightarrow> B \<le> UnderS r (AboveS r B)"
by(auto simp add: UnderS_def AboveS_def)

lemma Under_Above_Galois:
"\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> Above r C) = (C \<le> Under r B)"
by(unfold Above_def Under_def, blast)

lemma UnderS_AboveS_Galois:
"\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> AboveS r C) = (C \<le> UnderS r B)"
by(unfold AboveS_def UnderS_def, blast)

lemma Refl_above_aboveS:
  assumes REFL: "Refl r" and IN: "a \<in> Field r"
  shows "above r a = aboveS r a \<union> {a}"
proof(unfold above_def aboveS_def, auto)
  show "(a,a) \<in> r" using REFL IN refl_on_def[of _ r] by blast
qed

lemma Linear_order_under_aboveS_Field:
  assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
  shows "Field r = under r a \<union> aboveS r a"
proof(unfold under_def aboveS_def, auto)
  assume "a \<in> Field r" "(a, a) \<notin> r"
  with LIN IN order_on_defs[of _ r] refl_on_def[of _ r]
  show False by auto
next
  fix b assume "b \<in> Field r" "(b, a) \<notin> r"
  with LIN IN order_on_defs[of "Field r" r] total_on_def[of "Field r" r]
  have "(a,b) \<in> r \<or> a = b" by blast
  thus "(a,b) \<in> r"
  using LIN IN order_on_defs[of _ r] refl_on_def[of _ r] by auto
next
  fix b assume "(b, a) \<in> r"
  thus "b \<in> Field r"
  using LIN order_on_defs[of _ r] refl_on_def[of _ r] by blast
next
  fix b assume "b \<noteq> a" "(a, b) \<in> r"
  thus "b \<in> Field r"
  using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
qed

lemma Linear_order_underS_above_Field:
assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
shows "Field r = underS r a \<union> above r a"
proof(unfold underS_def above_def, auto)
  assume "a \<in> Field r" "(a, a) \<notin> r"
  with LIN IN order_on_defs[of _ r] refl_on_def[of _ r]
  show False by metis
next
  fix b assume "b \<in> Field r" "(a, b) \<notin> r"
  with LIN IN order_on_defs[of "Field r" r] total_on_def[of "Field r" r]
  have "(b,a) \<in> r \<or> b = a" by blast
  thus "(b,a) \<in> r"
  using LIN IN order_on_defs[of _ r] refl_on_def[of _ r] by auto
next
  fix b assume "b \<noteq> a" "(b, a) \<in> r"
  thus "b \<in> Field r"
  using LIN order_on_defs[of _ r] refl_on_def[of _ r] by blast
next
  fix b assume "(a, b) \<in> r"
  thus "b \<in> Field r"
  using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
qed

lemma under_empty: "a \<notin> Field r \<Longrightarrow> under r a = {}"
unfolding Field_def under_def by auto

lemma Under_Field: "Under r A \<le> Field r"
by(unfold Under_def Field_def, auto)

lemma UnderS_Field: "UnderS r A \<le> Field r"
by(unfold UnderS_def Field_def, auto)

lemma above_Field: "above r a \<le> Field r"
by(unfold above_def Field_def, auto)

lemma aboveS_Field: "aboveS r a \<le> Field r"
by(unfold aboveS_def Field_def, auto)

lemma Above_Field: "Above r A \<le> Field r"
by(unfold Above_def Field_def, auto)

lemma Refl_under_Under:
assumes REFL: "Refl r" and NE: "A \<noteq> {}"
shows "Under r A = (\<Inter>a \<in> A. under r a)"
proof
  show "Under r A \<subseteq> (\<Inter>a \<in> A. under r a)"
  by(unfold Under_def under_def, auto)
next
  show "(\<Inter>a \<in> A. under r a) \<subseteq> Under r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> under r xa"
    hence "\<forall>xa \<in> A. (x,xa) \<in> r"
    by (simp add: under_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
     with * have "x \<in> under r a" by simp
     hence "x \<in> Field r"
     using under_Field[of r a] by auto
    }
    ultimately show "x \<in> Under r A"
    unfolding Under_def by auto
  qed
qed

lemma Refl_underS_UnderS:
assumes REFL: "Refl r" and NE: "A \<noteq> {}"
shows "UnderS r A = (\<Inter>a \<in> A. underS r a)"
proof
  show "UnderS r A \<subseteq> (\<Inter>a \<in> A. underS r a)"
  by(unfold UnderS_def underS_def, auto)
next
  show "(\<Inter>a \<in> A. underS r a) \<subseteq> UnderS r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> underS r xa"
    hence "\<forall>xa \<in> A. x \<noteq> xa \<and> (x,xa) \<in> r"
    by (auto simp add: underS_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
     with * have "x \<in> underS r a" by simp
     hence "x \<in> Field r"
     using underS_Field[of _ r a] by auto
    }
    ultimately show "x \<in> UnderS r A"
    unfolding UnderS_def by auto
  qed
qed

lemma Refl_above_Above:
assumes REFL: "Refl r" and NE: "A \<noteq> {}"
shows "Above r A = (\<Inter>a \<in> A. above r a)"
proof
  show "Above r A \<subseteq> (\<Inter>a \<in> A. above r a)"
  by(unfold Above_def above_def, auto)
next
  show "(\<Inter>a \<in> A. above r a) \<subseteq> Above r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> above r xa"
    hence "\<forall>xa \<in> A. (xa,x) \<in> r"
    by (simp add: above_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
     with * have "x \<in> above r a" by simp
     hence "x \<in> Field r"
     using above_Field[of r a] by auto
    }
    ultimately show "x \<in> Above r A"
    unfolding Above_def by auto
  qed
qed

lemma Refl_aboveS_AboveS:
assumes REFL: "Refl r" and NE: "A \<noteq> {}"
shows "AboveS r A = (\<Inter>a \<in> A. aboveS r a)"
proof
  show "AboveS r A \<subseteq> (\<Inter>a \<in> A. aboveS r a)"
  by(unfold AboveS_def aboveS_def, auto)
next
  show "(\<Inter>a \<in> A. aboveS r a) \<subseteq> AboveS r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> aboveS r xa"
    hence "\<forall>xa \<in> A. xa \<noteq> x \<and> (xa,x) \<in> r"
    by (auto simp add: aboveS_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
     with * have "x \<in> aboveS r a" by simp
     hence "x \<in> Field r"
     using aboveS_Field[of r a] by auto
    }
    ultimately show "x \<in> AboveS r A"
    unfolding AboveS_def by auto
  qed
qed

lemma under_Under_singl: "under r a = Under r {a}"
by(unfold Under_def under_def, auto simp add: Field_def)

lemma underS_UnderS_singl: "underS r a = UnderS r {a}"
by(unfold UnderS_def underS_def, auto simp add: Field_def)

lemma above_Above_singl: "above r a = Above r {a}"
by(unfold Above_def above_def, auto simp add: Field_def)

lemma aboveS_AboveS_singl: "aboveS r a = AboveS r {a}"
by(unfold AboveS_def aboveS_def, auto simp add: Field_def)

lemma Under_decr: "A \<le> B \<Longrightarrow> Under r B \<le> Under r A"
by(unfold Under_def, auto)

lemma UnderS_decr: "A \<le> B \<Longrightarrow> UnderS r B \<le> UnderS r A"
by(unfold UnderS_def, auto)

lemma Above_decr: "A \<le> B \<Longrightarrow> Above r B \<le> Above r A"
by(unfold Above_def, auto)

lemma AboveS_decr: "A \<le> B \<Longrightarrow> AboveS r B \<le> AboveS r A"
by(unfold AboveS_def, auto)

lemma under_incl_iff:
assumes TRANS: "trans r" and REFL: "Refl r" and IN: "a \<in> Field r"
shows "(under r a \<le> under r b) = ((a,b) \<in> r)"
proof
  assume "(a,b) \<in> r"
  thus "under r a \<le> under r b" using TRANS
  by (auto simp add: under_incr)
next
  assume "under r a \<le> under r b"
  moreover
  have "a \<in> under r a" using REFL IN
  by (auto simp add: Refl_under_in)
  ultimately show "(a,b) \<in> r"
  by (auto simp add: under_def)
qed

lemma above_decr:
assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
shows "above r b \<le> above r a"
proof(unfold above_def, auto)
  fix x assume "(b,x) \<in> r"
  with REL TRANS trans_def[of r]
  show "(a,x) \<in> r" by blast
qed

lemma aboveS_decr:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        REL: "(a,b) \<in> r"
shows "aboveS r b \<le> aboveS r a"
proof(unfold aboveS_def, auto)
  assume *: "a \<noteq> b" and **: "(b,a) \<in> r"
  with ANTISYM antisym_def[of r] REL
  show False by auto
next
  fix x assume "x \<noteq> b" "(b,x) \<in> r"
  with REL TRANS trans_def[of r]
  show "(a,x) \<in> r" by blast
qed

lemma under_trans:
assumes TRANS: "trans r" and
        IN1: "a \<in> under r b" and IN2: "b \<in> under r c"
shows "a \<in> under r c"
proof-
  have "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 under_def by fastforce
  hence "(a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  thus ?thesis unfolding under_def by simp
qed

lemma under_underS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> under r b" and IN2: "b \<in> underS r c"
shows "a \<in> underS r c"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 under_def underS_def by fastforce
  hence 1: "(a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  have 2: "b \<noteq> c" using IN2 underS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding underS_def by simp
qed

lemma underS_under_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> underS r b" and IN2: "b \<in> under r c"
shows "a \<in> underS r c"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 under_def underS_def by fast
  hence 1: "(a,c) \<in> r"
  using TRANS trans_def[of r] by fast
  have 2: "a \<noteq> b" using IN1 underS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding underS_def by simp
qed

lemma underS_underS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> underS r b" and IN2: "b \<in> underS r c"
shows "a \<in> underS r c"
proof-
  have "a \<in> under r b"
  using IN1 underS_subset_under by fast
  with assms under_underS_trans show ?thesis by fast
qed

lemma above_trans:
assumes TRANS: "trans r" and
        IN1: "b \<in> above r a" and IN2: "c \<in> above r b"
shows "c \<in> above r a"
proof-
  have "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 above_def by fast
  hence "(a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  thus ?thesis unfolding above_def by simp
qed

lemma above_aboveS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "b \<in> above r a" and IN2: "c \<in> aboveS r b"
shows "c \<in> aboveS r a"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 above_def aboveS_def by fast
  hence 1: "(a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  have 2: "b \<noteq> c" using IN2 aboveS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding aboveS_def by simp
qed

lemma aboveS_above_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "b \<in> aboveS r a" and IN2: "c \<in> above r b"
shows "c \<in> aboveS r a"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
  using IN1 IN2 above_def aboveS_def by fast
  hence 1: "(a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  have 2: "a \<noteq> b" using IN1 aboveS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding aboveS_def by simp
qed

lemma aboveS_aboveS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "b \<in> aboveS r a" and IN2: "c \<in> aboveS r b"
shows "c \<in> aboveS r a"
proof-
  have "b \<in> above r a"
  using IN1 aboveS_subset_above by fast
  with assms above_aboveS_trans show ?thesis by fast
qed

lemma under_Under_trans:
assumes TRANS: "trans r" and
        IN1: "a \<in> under r b" and IN2: "b \<in> Under r C"
shows "a \<in> Under r C"
proof-
  have "b \<in> {u \<in> Field r. \<forall>x. x \<in> C \<longrightarrow> (u, x) \<in> r}"
    using IN2 Under_def by force
  hence "(a,b) \<in> r \<and> (\<forall>c \<in> C. (b,c) \<in> r)"
    using IN1 under_def by fast
  hence "\<forall>c \<in> C. (a,c) \<in> r"
  using TRANS trans_def[of r] by blast
  moreover
  have "a \<in> Field r" using IN1 unfolding Field_def under_def by blast
  ultimately
  show ?thesis unfolding Under_def by blast
qed

lemma underS_Under_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> underS r b" and IN2: "b \<in> Under r C"
shows "a \<in> UnderS r C"
proof-
  from IN1 have "a \<in> under r b"
  using underS_subset_under[of r b] by fast
  with assms under_Under_trans
  have "a \<in> Under r C" by fast
  (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "b \<noteq> a \<and> (a,b) \<in> r"
    using IN1 underS_def[of r b] by auto
    have "\<forall>c \<in> C. (b,c) \<in> r"
    using IN2 Under_def[of r C] by auto
    with * have "(b,a) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
  (*  *)
  ultimately
  show ?thesis unfolding UnderS_def
  using Under_def by force
qed

lemma underS_UnderS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> underS r b" and IN2: "b \<in> UnderS r C"
shows "a \<in> UnderS r C"
proof-
  from IN2 have "b \<in> Under r C"
  using UnderS_subset_Under[of r C] by blast
  with underS_Under_trans assms
  show ?thesis by force
qed

lemma above_Above_trans:
assumes TRANS: "trans r" and
        IN1: "a \<in> above r b" and IN2: "b \<in> Above r C"
shows "a \<in> Above r C"
proof-
  have "(b,a) \<in> r \<and> (\<forall>c \<in> C. (c,b) \<in> r)"
    using IN1[unfolded above_def] IN2[unfolded Above_def] by simp
  hence "\<forall>c \<in> C. (c,a) \<in> r"
  using TRANS trans_def[of r] by blast
  moreover
  have "a \<in> Field r" using IN1[unfolded above_def] Field_def by fast
  ultimately
  show ?thesis unfolding Above_def by auto
qed

lemma aboveS_Above_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> aboveS r b" and IN2: "b \<in> Above r C"
shows "a \<in> AboveS r C"
proof-
  from IN1 have "a \<in> above r b"
  using aboveS_subset_above[of r b] by blast
  with assms above_Above_trans
  have "a \<in> Above r C" by fast
  (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "b \<noteq> a \<and> (b,a) \<in> r"
    using IN1 aboveS_def[of r b] by auto
    have "\<forall>c \<in> C. (c,b) \<in> r"
    using IN2 Above_def[of r C] by auto
    with * have "(a,b) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
  (*  *)
  ultimately
  show ?thesis unfolding AboveS_def
  using Above_def by force
qed

lemma above_AboveS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> above r b" and IN2: "b \<in> AboveS r C"
shows "a \<in> AboveS r C"
proof-
  from IN2 have "b \<in> Above r C"
  using AboveS_subset_Above[of r C] by blast
  with assms above_Above_trans
  have "a \<in> Above r C" by force
  (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "(b,a) \<in> r"
    using IN1 above_def[of r b] by auto
    have "\<forall>c \<in> C. b \<noteq> c \<and> (c,b) \<in> r"
    using IN2 AboveS_def[of r C] by auto
    with * have "b \<noteq> a \<and> (a,b) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
  (*  *)
  ultimately
  show ?thesis unfolding AboveS_def
  using Above_def by force
qed

lemma aboveS_AboveS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> aboveS r b" and IN2: "b \<in> AboveS r C"
shows "a \<in> AboveS r C"
proof-
  from IN2 have "b \<in> Above r C"
  using AboveS_subset_Above[of r C] by blast
  with aboveS_Above_trans assms
  show ?thesis by force
qed

lemma under_UnderS_trans:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        IN1: "a \<in> under r b" and IN2: "b \<in> UnderS r C"
shows "a \<in> UnderS r C"
proof-
  from IN2 have "b \<in> Under r C"
  using UnderS_subset_Under[of r C] by blast
  with assms under_Under_trans
  have "a \<in> Under r C" by force
  (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "(a,b) \<in> r"
    using IN1 under_def[of r b] by auto
    have "\<forall>c \<in> C. b \<noteq> c \<and> (b,c) \<in> r"
    using IN2 UnderS_def[of r C] by blast
    with * have "b \<noteq> a \<and> (b,a) \<in> r" by blast
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
  (*  *)
  ultimately
  show ?thesis unfolding UnderS_def Under_def by fast
qed

subsection \<open>Properties depending on more than one relation\<close>

lemma under_incr2:
"r \<le> r' \<Longrightarrow> under r a \<le> under r' a"
unfolding under_def by blast

lemma underS_incr2:
"r \<le> r' \<Longrightarrow> underS r a \<le> underS r' a"
unfolding underS_def by blast

(* FIXME: r \<leadsto> r'
lemma Under_incr:
"r \<le> r' \<Longrightarrow> Under r A \<le> Under r A"
unfolding Under_def by blast

lemma UnderS_incr:
"r \<le> r' \<Longrightarrow> UnderS r A \<le> UnderS r A"
unfolding UnderS_def by blast

lemma Under_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk>  \<Longrightarrow> Under r A \<le> Under r A'"
unfolding Under_def by blast

lemma UnderS_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk>  \<Longrightarrow> UnderS r A \<le> UnderS r A'"
unfolding UnderS_def by blast
*)

lemma above_incr2:
"r \<le> r' \<Longrightarrow> above r a \<le> above r' a"
unfolding above_def by blast

lemma aboveS_incr2:
"r \<le> r' \<Longrightarrow> aboveS r a \<le> aboveS r' a"
unfolding aboveS_def by blast

(* FIXME
lemma Above_incr:
"r \<le> r' \<Longrightarrow> Above r A \<le> Above r A"
unfolding Above_def by blast

lemma AboveS_incr:
"r \<le> r' \<Longrightarrow> AboveS r A \<le> AboveS r A"
unfolding AboveS_def by blast

lemma Above_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk> \<Longrightarrow> Above r A \<le> Above r A'"
unfolding Above_def by blast

lemma AboveS_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk> \<Longrightarrow> AboveS r A \<le> AboveS r A'"
unfolding AboveS_def by blast
*)

end