section \<open>Examples\<close>

theory Examples imports Resolution begin

value "Var ''x''"
value "Fun ''one'' []"
value "Fun ''mul'' [Var ''y'',Var ''y'']"
value "Fun ''add'' [Fun ''mul'' [Var ''y'',Var ''y''], Fun ''one'' []]"

value "Pos ''greater'' [Var ''x'', Var ''y'']"
value "Neg ''less'' [Var ''x'', Var ''y'']"
value "Pos ''less'' [Var ''x'', Var ''y'']"
value "Pos ''equals''
        [Fun ''add''[Fun ''mul''[Var ''y'',Var ''y''], Fun ''one''[]],Var ''x'']"

fun F\<^sub>n\<^sub>a\<^sub>t :: "nat fun_denot" where
  "F\<^sub>n\<^sub>a\<^sub>t f [n,m] =
     (if f = ''add'' then n + m else
      if f = ''mul'' then n * m else 0)"
| "F\<^sub>n\<^sub>a\<^sub>t f [] =
     (if f = ''one''  then 1 else
      if f = ''zero'' then 0 else 0)"
| "F\<^sub>n\<^sub>a\<^sub>t f us = 0"

fun G\<^sub>n\<^sub>a\<^sub>t :: "nat pred_denot" where
  "G\<^sub>n\<^sub>a\<^sub>t p [x,y] =
     (if p = ''less'' \<and> x < y then True else
      if p = ''greater'' \<and> x > y then True else
      if p = ''equals'' \<and> x = y then True else False)"
| "G\<^sub>n\<^sub>a\<^sub>t p us = False"

fun E\<^sub>n\<^sub>a\<^sub>t :: "nat var_denot" where
  "E\<^sub>n\<^sub>a\<^sub>t x =
     (if x = ''x'' then 26 else
      if x = ''y'' then 5 else 0)"

lemma "eval\<^sub>t E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t (Var ''x'') = 26"
  by auto
lemma "eval\<^sub>t E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t (Fun ''one'' []) = 1"
  by auto
lemma "eval\<^sub>t E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t (Fun ''mul'' [Var ''y'',Var ''y'']) = 25"
  by auto
lemma
  "eval\<^sub>t E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t (Fun ''add'' [Fun ''mul'' [Var ''y'',Var ''y''], Fun ''one'' []]) = 26"
  by auto

lemma "eval\<^sub>l E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t G\<^sub>n\<^sub>a\<^sub>t (Pos ''greater'' [Var ''x'', Var ''y'']) = True"
  by auto
lemma "eval\<^sub>l E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t G\<^sub>n\<^sub>a\<^sub>t (Neg ''less'' [Var ''x'', Var ''y'']) = True"
  by auto
lemma "eval\<^sub>l E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t G\<^sub>n\<^sub>a\<^sub>t (Pos ''less'' [Var ''x'', Var ''y'']) = False"
  by auto

lemma "eval\<^sub>l E\<^sub>n\<^sub>a\<^sub>t F\<^sub>n\<^sub>a\<^sub>t G\<^sub>n\<^sub>a\<^sub>t
       (Pos ''equals''
         [Fun ''add'' [Fun ''mul'' [Var ''y'',Var ''y''],Fun ''one'' []]
         ,Var ''x'']
       ) = True"
  by auto

definition PP :: "fterm literal" where
  "PP = Pos ''P'' [Fun ''c'' []]"

definition PQ :: "fterm literal" where
  "PQ = Pos ''Q'' [Fun ''d'' []]"

definition NP :: "fterm literal" where
  "NP = Neg ''P'' [Fun ''c'' []]"

definition NQ :: "fterm literal" where
  "NQ = Neg ''Q'' [Fun ''d'' []]"

theorem empty_mgu:
  assumes "unifier\<^sub>l\<^sub>s \<epsilon> L"
  shows "mgu\<^sub>l\<^sub>s \<epsilon> L"
using assms unfolding unifier\<^sub>l\<^sub>s_def mgu\<^sub>l\<^sub>s_def apply auto
apply (rule_tac x=u in exI)
using empty_comp1 empty_comp2 apply auto
done

theorem unifier_single: "unifier\<^sub>l\<^sub>s \<sigma> {l}"
unfolding unifier\<^sub>l\<^sub>s_def by auto

theorem resolution_rule':
  assumes "C\<^sub>1 \<in> Cs"
  assumes "C\<^sub>2 \<in> Cs"
  assumes "applicable C\<^sub>1 C\<^sub>2 L\<^sub>1 L\<^sub>2 \<sigma>"
  assumes "C = {resolution C\<^sub>1 C\<^sub>2 L\<^sub>1 L\<^sub>2 \<sigma>}"
  shows "resolution_step Cs (Cs \<union> C)"
  using assms resolution_rule by auto

lemma resolution_example1:
   "resolution_deriv {{NP,PQ},{NQ},{PP,PQ}}
                              {{NP,PQ},{NQ},{PP,PQ},{NP},{PP},{}}"
proof -
  have "resolution_step
          {{NP,PQ},{NQ},{PP,PQ}}
         ({{NP,PQ},{NQ},{PP,PQ}} \<union> {{NP}})"
    apply (rule resolution_rule'[of "{NP,PQ}" _ "{NQ}" "{PQ}" "{NQ}" \<epsilon>])
       unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
              NQ_def NP_def PQ_def PP_def resolution_def
       using unifier_single empty_mgu using empty_subls
       apply auto
    done
  then have "resolution_step
          {{NP,PQ},{NQ},{PP,PQ}}
         ({{NP,PQ},{NQ},{PP,PQ},{NP}})"
    by (simp add: insert_commute)
  moreover
  have "resolution_step
         {{NP,PQ},{NQ},{PP,PQ},{NP}}
        ({{NP,PQ},{NQ},{PP,PQ},{NP}} \<union> {{PP}})"
    apply (rule resolution_rule'[of "{NQ}" _ "{PP,PQ}" "{NQ}" "{PQ}" \<epsilon>])
       unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
              NQ_def NP_def PQ_def PP_def resolution_def
       using unifier_single empty_mgu empty_subls apply auto
    done
  then have "resolution_step
         {{NP,PQ},{NQ},{PP,PQ},{NP}}
        ({{NP,PQ},{NQ},{PP,PQ},{NP},{PP}})"
    by (simp add: insert_commute)
  moreover
  have "resolution_step
         {{NP,PQ},{NQ},{PP,PQ},{NP},{PP}}
        ({{NP,PQ},{NQ},{PP,PQ},{NP},{PP}} \<union> {{}})"
    apply (rule resolution_rule'[of "{NP}" _ "{PP}" "{NP}" "{PP}" \<epsilon>])
       unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
              NQ_def NP_def PQ_def PP_def resolution_def
       using unifier_single empty_mgu apply auto
    done
  then have "resolution_step
         {{NP,PQ},{NQ},{PP,PQ},{NP},{PP}}
        ({{NP,PQ},{NQ},{PP,PQ},{NP},{PP},{}})"
    by (simp add: insert_commute)
  ultimately
  have "resolution_deriv {{NP,PQ},{NQ},{PP,PQ}}
                         {{NP,PQ},{NQ},{PP,PQ},{NP},{PP},{}}"
    unfolding resolution_deriv_def by auto
  then show ?thesis by auto
qed

definition Pa :: "fterm literal" where
  "Pa = Pos ''a'' []"

definition Na :: "fterm literal" where
  "Na = Neg ''a'' []"

definition Pb :: "fterm literal" where
  "Pb = Pos ''b'' []"

definition Nb :: "fterm literal" where
  "Nb = Neg ''b'' []"

definition Paa :: "fterm literal" where
  "Paa = Pos ''a'' [Fun ''a'' []]"

definition Naa :: "fterm literal" where
  "Naa = Neg ''a'' [Fun ''a'' []]"

definition Pax :: "fterm literal" where
  "Pax = Pos ''a'' [Var ''x'']"

definition Nax :: "fterm literal" where
  "Nax = Neg ''a'' [Var ''x'']"

definition mguPaaPax :: substitution where
  "mguPaaPax = (\<lambda>x. if x = ''x'' then Fun ''a'' [] else Var x)"

lemma mguPaaPax_mgu: "mgu\<^sub>l\<^sub>s mguPaaPax {Paa,Pax}"
proof -
  let ?\<sigma> = "\<lambda>x. if x = ''x'' then Fun ''a'' [] else Var x"
  have a: "unifier\<^sub>l\<^sub>s (\<lambda>x. if x = ''x'' then Fun ''a'' [] else Var x) {Paa,Pax}" unfolding Paa_def Pax_def unifier\<^sub>l\<^sub>s_def by auto
  have b: "\<forall>u. unifier\<^sub>l\<^sub>s u {Paa,Pax} \<longrightarrow> (\<exists>i. u = ?\<sigma> \<cdot> i)"
    proof (rule;rule)
      fix u
      assume "unifier\<^sub>l\<^sub>s u {Paa,Pax}"
      then have uuu: "u ''x'' = Fun ''a'' []" unfolding unifier\<^sub>l\<^sub>s_def Paa_def Pax_def by auto
      have "?\<sigma> \<cdot> u = u"
        proof
          fix x
          {
            assume "x=''x''"
            moreover
            have "(?\<sigma> \<cdot> u) ''x'' =  Fun ''a'' []" unfolding composition_def by auto
            ultimately have "(?\<sigma> \<cdot> u) x = u x" using uuu by auto
          }
          moreover
          {
            assume "x\<noteq>''x''"
            then have "(?\<sigma> \<cdot> u) x = (\<epsilon> x) \<cdot>\<^sub>t u" unfolding composition_def by auto
            then have "(?\<sigma> \<cdot> u) x = u x" by auto
          }
          ultimately show "(?\<sigma> \<cdot> u) x = u x" by auto
        qed
      then have "\<exists>i. ?\<sigma> \<cdot> i = u" by auto
      then show "\<exists>i. u = ?\<sigma> \<cdot> i" by auto
     qed
   from a b show ?thesis unfolding mgu\<^sub>l\<^sub>s_def unfolding mguPaaPax_def by auto
qed

lemma resolution_example2:
   "resolution_deriv {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}}
                              {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na},{}}"
proof -
  have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}} \<union> {{Na,Pb}})"
    apply (rule resolution_rule'[of "{Pax}" _ "{Na,Pb,Naa}" "{Pax}" "{Naa}" mguPaaPax ])
       using mguPaaPax_mgu unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
          Nb_def Na_def Pax_def Pa_def Pb_def Naa_def Paa_def mguPaaPax_def resolution_def
       apply auto
     apply (rule_tac x=Na in image_eqI)
      unfolding Na_def apply auto
    apply (rule_tac x=Pb in image_eqI)
     unfolding Pb_def apply auto
    done
  then have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb}})"
    by (simp add: insert_commute)
  moreover
  have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb}} \<union> {{Na}})"
    apply (rule resolution_rule'[of "{Nb,Na}" _ "{Na,Pb}" "{Nb}" "{Pb}" \<epsilon>])
       unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
                 Pb_def Nb_def Na_def PP_def resolution_def
       using unifier_single empty_mgu apply auto
    done
  then have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na}})"
    by (simp add: insert_commute)
  moreover
  have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na}} \<union> {{}})"
    apply (rule resolution_rule'[of "{Na}" _ "{Pa}" "{Na}" "{Pa}" \<epsilon>])
       unfolding applicable_def vars\<^sub>l\<^sub>s_def  vars\<^sub>l_def
                  Pa_def Nb_def Na_def PP_def resolution_def
       using unifier_single empty_mgu apply auto
    done
  then have "resolution_step
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na}}
         ({{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na},{}})"
    by (simp add: insert_commute)
  ultimately
  have "resolution_deriv {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}}
          {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa},{Na,Pb},{Na},{}}"
    unfolding resolution_deriv_def by auto
  then show ?thesis by auto
qed

lemma resolution_example1_sem: "\<not>eval\<^sub>c\<^sub>s F G {{NP, PQ}, {NQ}, {PP, PQ}}"
  using resolution_example1 derivation_sound_refute by auto

lemma resolution_example2_sem: "\<not>eval\<^sub>c\<^sub>s F G {{Nb,Na},{Pax},{Pa},{Na,Pb,Naa}}"
  using resolution_example2 derivation_sound_refute by auto

end


(*  Title:      HOL/Imperative_HOL/ex/Imperative_Reverse.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>An imperative in-place reversal on arrays\<close>

theory Imperative_Reverse
imports Subarray "../Imperative_HOL"
begin

fun swap :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "swap a i j = do {
     x \<leftarrow> Array.nth a i;
     y \<leftarrow> Array.nth a j;
     Array.upd i y a;
     Array.upd j x a;
     return ()
   }"

fun rev :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "rev a i j = (if (i < j) then do {
     swap a i j;
     rev a (i + 1) (j - 1)
   }
   else return ())"

declare swap.simps [simp del] rev.simps [simp del]

lemma swap_pointwise: assumes "effect (swap a i j) h h' r"
  shows "Array.get h' a ! k = (if k = i then Array.get h a ! j
      else if k = j then Array.get h a ! i
      else Array.get h a ! k)"
using assms unfolding swap.simps
by (elim effect_elims)
 (auto simp: length_def)

lemma rev_pointwise: assumes "effect (rev a i j) h h' r"
  shows "Array.get h' a ! k = (if k < i then Array.get h a ! k
      else if j < k then Array.get h a ! k
      else Array.get h a ! (j - (k - i)))" (is "?P a i j h h'")
using assms proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from rev 1 True
    have eq: "?P a (i + 1) (j - 1) h' h''" by auto

    have "k < i \<or> i = k \<or> (i < k \<and> k < j) \<or> j = k \<or> j < k" by arith
    with True show ?thesis
      by (elim disjE) (auto simp: eq swap_pointwise[OF swp])
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (cases "k = j") (auto elim: effect_elims)
  qed
qed

lemma rev_length:
  assumes "effect (rev a i j) h h' r"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from swp rev 1 True show ?thesis
      unfolding swap.simps
      by (elim effect_elims) fastforce
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (auto elim: effect_elims)
  qed
qed

lemma rev2_rev': assumes "effect (rev a i j) h h' u"
  assumes "j < Array.length h a"
  shows "subarray i (j + 1) a h' = List.rev (subarray i (j + 1) a h)"
proof -
  {
    fix k
    assume "k < Suc j - i"
    with rev_pointwise[OF assms(1)] have "Array.get h' a ! (i + k) = Array.get h a ! (j - k)"
      by auto
  }
  with assms(2) rev_length[OF assms(1)] show ?thesis
  unfolding subarray_def Array.length_def
  by (auto simp add: length_nths' rev_nth min_def nth_nths' intro!: nth_equalityI)
qed

lemma rev2_rev:
  assumes "effect (rev a 0 (Array.length h a - 1)) h h' u"
  shows "Array.get h' a = List.rev (Array.get h a)"
  using rev2_rev'[OF assms] rev_length[OF assms] assms
    by (cases "Array.length h a = 0", auto simp add: Array.length_def
      subarray_def rev.simps[where j=0] elim!: effect_elims)
  (drule sym[of "List.length (Array.get h a)"], simp)

definition "example = (Array.make 10 id \<bind> (\<lambda>a. rev a 0 9))"

export_code example checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


theory HSV_chapter3 imports Complex_Main begin

(* We use the following command to search Isabelle's library
   for theorems that contain a particular pattern. *)
find_theorems "_ \<in> \<rat>"
thm Rats_abs_nat_div_natE

find_theorems "(_ / _)^_"
thm power_divide

(* A proof that the square root of 2 is irrational. *)
theorem sqrt2_irrational: "sqrt 2 \<notin> \<rat>"
proof auto
  assume "sqrt 2 \<in> \<rat>"
  then obtain m n where
    "n \<noteq> 0" and "\<bar>sqrt 2\<bar> = real m / real n" and "coprime m n"
    by (rule Rats_abs_nat_div_natE)
  hence "\<bar>sqrt 2\<bar>^2 = (real m / real n)^2" by auto
  hence "2 = (real m / real n)^2" by simp
  hence "2 = (real m)^2 / (real n)^2" unfolding power_divide by auto
  hence "2 * (real n)^2 = (real m)^2"
    by (simp add: nonzero_eq_divide_eq `n \<noteq> 0`)
  hence "real (2 * n^2) = (real m)^2" by auto
  hence *: "2 * n^2 = m^2"
    using of_nat_power_eq_of_nat_cancel_iff by blast
  hence "even (m^2)" by presburger
  hence "even m" by simp
  then obtain m' where "m = 2 * m'" by auto
  with * have "2 * n^2 = (2 * m')^2" by auto
  hence "2 * n^2 = 4 * m'^2" by simp
  hence "n^2 = 2 * m'^2" by simp
  hence "even (n^2)" by presburger
  hence "even n" by simp
  with `even m` and `coprime m n` show False by auto
qed

(* A proof that there is no greatest even number. *)
theorem "\<forall>n::int. even n \<longrightarrow> (\<exists>m. even m \<and> m > n)"
proof clarify
  fix n::int
  assume "even n"
  hence "even (n+2)" by simp
  moreover
  have "n < (n+2)" by simp
  ultimately
  show "\<exists>m. even m \<and> n < m" by blast
qed

(* The same proof in the procedural style. *)
theorem "\<forall>n::int. even n \<longrightarrow> (\<exists>m. even m \<and> m > n)"
  apply clarify
  apply (rule_tac x="n+2" in exI)
  apply (rule conjI)
  apply simp
  apply (thin_tac "even n")
  apply simp
  done

end


(*  Title:      ZF/Fixedpt.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Least and Greatest Fixed Points; the Knaster-Tarski Theorem\<close>

theory Fixedpt imports Equalities begin

definition
  (*monotone operator from Pow(D) to itself*)
  bnd_mono :: "[i,i=>i]=>o"  where
     "bnd_mono D h == h(D)<=D & (\<forall>W X. W<=X \<longrightarrow> X<=D \<longrightarrow> h(W) \<subseteq> h(X))"

definition
  lfp      :: "[i,i=>i]=>i"  where
     "lfp D h == \<Inter>({X: Pow(D). h(X) \<subseteq> X})"

definition
  gfp      :: "[i,i=>i]=>i"  where
     "gfp D h == \<Union>({X: Pow(D). X \<subseteq> h(X)})"

text\<open>The theorem is proved in the lattice of subsets of @{term D},
      namely @{term "Pow(D)"}, with Inter as the greatest lower bound.\<close>

subsection\<open>Monotone Operators\<close>

lemma bnd_monoI:
    "[| h(D)<=D;
        !!W X. [| W<=D;  X<=D;  W<=X |] ==> h(W) \<subseteq> h(X)
     |] ==> bnd_mono D h"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_monoD1: "bnd_mono D h ==> h(D) \<subseteq> D"
apply (unfold bnd_mono_def)
apply (erule conjunct1)
done

lemma bnd_monoD2: "[| bnd_mono D h;  W<=X;  X<=D |] ==> h(W) \<subseteq> h(X)"
by (unfold bnd_mono_def, blast)

lemma bnd_mono_subset:
    "[| bnd_mono D h;  X<=D |] ==> h(X) \<subseteq> D"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_mono_Un:
     "[| bnd_mono D h;  A \<subseteq> D;  B \<subseteq> D |] ==> h(A) \<union> h(B) \<subseteq> h(A \<union> B)"
apply (unfold bnd_mono_def)
apply (rule Un_least, blast+)
done

(*unused*)
lemma bnd_mono_UN:
     "[| bnd_mono D h;  \<forall>i\<in>I. A(i) \<subseteq> D |]
      ==> (\<Union>i\<in>I. h(A(i))) \<subseteq> h((\<Union>i\<in>I. A(i)))"
apply (unfold bnd_mono_def)
apply (rule UN_least)
apply (elim conjE)
apply (drule_tac x="A(i)" in spec)
apply (drule_tac x="(\<Union>i\<in>I. A(i))" in spec)
apply blast
done

(*Useful??*)
lemma bnd_mono_Int:
     "[| bnd_mono D h;  A \<subseteq> D;  B \<subseteq> D |] ==> h(A \<inter> B) \<subseteq> h(A) \<inter> h(B)"
apply (rule Int_greatest)
apply (erule bnd_monoD2, rule Int_lower1, assumption)
apply (erule bnd_monoD2, rule Int_lower2, assumption)
done

subsection\<open>Proof of Knaster-Tarski Theorem using @{term lfp}\<close>

(*lfp is contained in each pre-fixedpoint*)
lemma lfp_lowerbound:
    "[| h(A) \<subseteq> A;  A<=D |] ==> lfp D h \<subseteq> A"
by (unfold lfp_def, blast)

(*Unfolding the defn of Inter dispenses with the premise bnd_mono(D,h)!*)
lemma lfp_subset: "lfp D h \<subseteq> D"
by (unfold lfp_def Inter_def, blast)

(*Used in datatype package*)
lemma def_lfp_subset:  "A == lfp D h ==> A \<subseteq> D"
apply simp
apply (rule lfp_subset)
done

lemma lfp_greatest:
    "[| h(D) \<subseteq> D;  !!X. [| h(X) \<subseteq> X;  X<=D |] ==> A<=X |] ==> A \<subseteq> lfp D h"
by (unfold lfp_def, blast)

lemma lfp_lemma1:
    "[| bnd_mono D h;  h(A)<=A;  A<=D |] ==> h(lfp D h) \<subseteq> A"
apply (erule bnd_monoD2 [THEN subset_trans])
apply (rule lfp_lowerbound, assumption+)
done

lemma lfp_lemma2: "bnd_mono D h ==> h(lfp D h) \<subseteq> lfp D h"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule_tac [2] lfp_lemma1)
apply (assumption+)
done

lemma lfp_lemma3:
    "bnd_mono D h ==> lfp D h \<subseteq> h(lfp D h)"
apply (rule lfp_lowerbound)
apply (rule bnd_monoD2, assumption)
apply (rule lfp_lemma2, assumption)
apply (erule_tac [2] bnd_mono_subset)
apply (rule lfp_subset)+
done

(*Definition form, to control unfolding*)
lemma def_lfp_unfold:
    "[| A==lfp D h;  bnd_mono D h |] ==> A = h(A)"
apply simp
apply (erule lfp_unfold)
done

subsection\<open>General Induction Rule for Least Fixedpoints\<close>

lemma Collect_is_pre_fixedpt:
    "[| bnd_mono D h;  !!x. x \<in> h(Collect(lfp D h) P) ==> P(x) |]
     ==> h(Collect(lfp D h) P) \<subseteq> Collect(lfp D h)P"
by (blast intro: lfp_lemma2 [THEN subsetD] bnd_monoD2 [THEN subsetD]
                 lfp_subset [THEN subsetD])

(*This rule yields an induction hypothesis in which the components of a
  data structure may be assumed to be elements of lfp D h*)
lemma induct:
    "[| bnd_mono D h;  a \<in> lfp D h;
        !!x. x \<in> h(Collect (lfp D h) P) ==> P(x)
     |] ==> P(a)"
apply (rule Collect_is_pre_fixedpt
              [THEN lfp_lowerbound, THEN subsetD, THEN CollectD2])
apply (rule_tac [3] lfp_subset [THEN Collect_subset [THEN subset_trans]],
       blast+)
done

(*Definition form, to control unfolding*)
lemma def_induct:
    "[| A == lfp D h;  bnd_mono D h;  a:A;
        !!x. x \<in> h(Collect A P) ==> P(x)
     |] ==> P(a)"
by (rule induct, blast+)

(*This version is useful when "A" is not a subset of D
  second premise could simply be h(D \<inter> A) \<subseteq> D or !!X. X<=D ==> h(X)<=D *)
lemma lfp_Int_lowerbound:
    "[| h(D \<inter> A) \<subseteq> A;  bnd_mono D h |] ==> lfp D h \<subseteq> A"
apply (rule lfp_lowerbound [THEN subset_trans])
apply (erule bnd_mono_subset [THEN Int_greatest], blast+)
done

(*Monotonicity of lfp, where h precedes i under a domain-like partial order
  monotonicity of h is not strictly necessary; h must be bounded by D*)
lemma lfp_mono:
  assumes hmono: "bnd_mono D h"
      and imono: "bnd_mono E i"
      and subhi: "!!X. X<=D ==> h(X) \<subseteq> i(X)"
    shows "lfp D h \<subseteq> lfp E i"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule imono)
apply (rule hmono [THEN [2] lfp_Int_lowerbound])
apply (rule Int_lower1 [THEN subhi, THEN subset_trans])
apply (rule imono [THEN bnd_monoD2, THEN subset_trans], auto)
done

(*This (unused) version illustrates that monotonicity is not really needed,
  but both lfp's must be over the SAME set D;  Inter is anti-monotonic!*)
lemma lfp_mono2:
    "[| i(D) \<subseteq> D;  !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> lfp D h \<subseteq> lfp D i"
apply (rule lfp_greatest, assumption)
apply (rule lfp_lowerbound, blast, assumption)
done

lemma lfp_cong:
     "[|D=D'; !!X. X \<subseteq> D' ==> h(X) = h'(X)|] ==> lfp D h = lfp D' h'"
apply (simp add: lfp_def)
apply (rule_tac t=Inter in subst_context)
apply (rule Collect_cong, simp_all)
done

subsection\<open>Proof of Knaster-Tarski Theorem using @{term gfp}\<close>

(*gfp contains each post-fixedpoint that is contained in D*)
lemma gfp_upperbound: "[| A \<subseteq> h(A);  A<=D |] ==> A \<subseteq> gfp D h"
apply (unfold gfp_def)
apply (rule PowI [THEN CollectI, THEN Union_upper])
apply (assumption+)
done

lemma gfp_subset: "gfp D h \<subseteq> D"
by (unfold gfp_def, blast)

(*Used in datatype package*)
lemma def_gfp_subset: "A==gfp D h ==> A \<subseteq> D"
apply simp
apply (rule gfp_subset)
done

lemma gfp_least:
    "[| bnd_mono D h;  !!X. [| X \<subseteq> h(X);  X<=D |] ==> X<=A |] ==>
     gfp D h \<subseteq> A"
apply (unfold gfp_def)
apply (blast dest: bnd_monoD1)
done

lemma gfp_lemma1:
    "[| bnd_mono D h;  A<=h(A);  A<=D |] ==> A \<subseteq> h(gfp D h)"
apply (rule subset_trans, assumption)
apply (erule bnd_monoD2)
apply (rule_tac [2] gfp_subset)
apply (simp add: gfp_upperbound)
done

lemma gfp_lemma2: "bnd_mono D h ==> gfp D h \<subseteq> h(gfp D h)"
apply (rule gfp_least)
apply (rule_tac [2] gfp_lemma1)
apply (assumption+)
done

lemma gfp_lemma3:
    "bnd_mono D h ==> h(gfp D h) \<subseteq> gfp D h"
apply (rule gfp_upperbound)
apply (rule bnd_monoD2, assumption)
apply (rule gfp_lemma2, assumption)
apply (erule bnd_mono_subset, rule gfp_subset)+
done

lemma gfp_unfold: "bnd_mono D h ==> gfp D h = h (gfp D h)"
apply (rule equalityI)
apply (erule gfp_lemma2)
apply (erule gfp_lemma3)
done

(*Definition form, to control unfolding*)
lemma def_gfp_unfold:
    "[| A==gfp D h;  bnd_mono D h |] ==> A = h(A)"
apply simp
apply (erule gfp_unfold)
done

subsection\<open>Coinduction Rules for Greatest Fixed Points\<close>

(*weak version*)
lemma weak_coinduct: "[| a: X;  X \<subseteq> h(X);  X \<subseteq> D |] ==> a \<in> gfp D h"
by (blast intro: gfp_upperbound [THEN subsetD])

lemma coinduct_lemma:
    "[| X \<subseteq> h(X \<union> gfp D h);  X \<subseteq> D;  bnd_mono D h |] ==>
     X \<union> gfp D h \<subseteq> h(X \<union> gfp D h)"
apply (erule Un_least)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (rule Un_upper2 [THEN subset_trans])
apply (rule bnd_mono_Un, assumption+)
apply (rule gfp_subset)
done

(*strong version*)
lemma coinduct:
     "[| bnd_mono D h;  a: X;  X \<subseteq> h(X \<union> gfp D h);  X \<subseteq> D |]
      ==> a \<in> gfp D h"
apply (rule weak_coinduct)
apply (erule_tac [2] coinduct_lemma)
apply (simp_all add: gfp_subset Un_subset_iff)
done

(*Definition form, to control unfolding*)
lemma def_coinduct:
    "[| A == gfp D h;  bnd_mono D h;  a: X;  X \<subseteq> h(X \<union> A);  X \<subseteq> D |] ==>
     a \<in> A"
apply simp
apply (rule coinduct, assumption+)
done

(*The version used in the induction/coinduction package*)
lemma def_Collect_coinduct:
    "[| A == gfp D (%w. Collect D (P w));  bnd_mono D (%w. Collect D (P w));
        a: X;  X \<subseteq> D;  !!z. z: X ==> P(X \<union> A) z |] ==>
     a \<in> A"
apply (rule def_coinduct, assumption+, blast+)
done

(*Monotonicity of gfp!*)
lemma gfp_mono:
    "[| bnd_mono D h;  D \<subseteq> E;
        !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> gfp D h \<subseteq> gfp E i"
apply (rule gfp_upperbound)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (blast del: subsetI intro: gfp_subset)
apply (blast del: subsetI intro: subset_trans gfp_subset)
done

end


(*
    Title:      Examples_Gauss_Jordan_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Examples of computations over matrices represented as nested IArrays*}

theory Examples_Gauss_Jordan_IArrays
imports
  System_Of_Equations_IArrays
  Determinants_IArrays
  Inverse_IArrays
  Code_Bit
  "~~/src/HOL/Library/Code_Target_Numeral"
(*"~~/src/HOL/Library/Code_Real_Approx_By_Float"*)
begin

subsection{*Transformations between nested lists nested IArrays*}
definition iarray_of_iarray_to_list_of_list :: "'a iarray iarray => 'a list list"
  where "iarray_of_iarray_to_list_of_list A = map IArray.list_of (map (op !! A) [0..<IArray.length A])"

text{*The following definitions are also in the file @{text "Examples_on_Gauss_Jordan_Abstract"}.*}

text{*Definitions to transform a matrix to a list of list and vice versa*}
definition vec_to_list :: "'a^'n::{finite, enum} => 'a list"
  where "vec_to_list A = map (op $ A) (enum_class.enum::'n list)"

definition matrix_to_list_of_list :: "'a^'n::{finite, enum}^'m::{finite, enum} => 'a list list"
  where "matrix_to_list_of_list A = map (vec_to_list) (map (op $ A) (enum_class.enum::'m list))"

text{*This definition should be equivalent to @{text "vector_def"} (in suitable types)*}
definition list_to_vec :: "'a list => 'a^'n::{enum, mod_type}"
  where "list_to_vec xs = vec_lambda (% i. xs ! (to_nat i))"

lemma [code abstract]: "vec_nth (list_to_vec xs) = (%i. xs ! (to_nat i))"
  unfolding list_to_vec_def by fastforce

definition list_of_list_to_matrix :: "'a list list => 'a^'n::{enum, mod_type}^'m::{enum, mod_type}"
  where "list_of_list_to_matrix xs = vec_lambda (%i. list_to_vec (xs ! (to_nat i)))"

lemma [code abstract]: "vec_nth (list_of_list_to_matrix xs) = (%i. list_to_vec (xs ! (to_nat i)))"
  unfolding list_of_list_to_matrix_def by auto

subsection{*Examples*}

text{*The following three lemmas are presented in both this file and in the
@{text "Examples_Gauss_Jordan_Abstract"} one. They allow a more convenient printing of rational and
real numbers after evaluation. They have already been added to the repository version of Isabelle,
so after Isabelle2014 they should be removed from here. *}

lemma [code_post]:
  "int_of_integer (- 1) = - 1"
 by simp

lemma [code_abbrev]:
 "(of_rat (- 1) :: real) = - 1"
  by simp

lemma [code_post]:
 "(of_rat (- (1 / numeral k)) :: real) = - 1 / numeral k"
 "(of_rat (- (numeral k / numeral l)) :: real) = - numeral k / numeral l"
 by (simp_all add: of_rat_divide of_rat_minus)

text{*From here on, we do the computations in two ways. The first one consists of executing the abstract functions (which internally will execute the ones over iarrays).
The second one runs directly the functions over iarrays.*}

subsubsection{*Ranks, dimensions and Gauss Jordan algorithm*}
text{*In the following examples, the theorem @{text "matrix_to_iarray_rank"} (which is the file @{text "Gauss_Jordan_IArrays"}
  and it is a code unfold theorem) assures that the computation will be carried out using the iarrays representation.*}
value "vec.dim (col_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (null_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::rat^5^4))"

value "rank_iarray (IArray[IArray[1::rat,0,0,7,5],IArray[1,0,4,8,-1],IArray[1,0,0,9,8],IArray[1,2,3,6,5]])"
(*Identical matrices with coefficients in Z2 and R could have different rank in each field:*)
value "rank_iarray (IArray[IArray[1::real,0,1],IArray[1,1,0],IArray[0,1,1]])"
value "rank_iarray (IArray[IArray[1::bit,0,1],IArray[1,1,0],IArray[0,1,1]])"

text{*Examples on computing the Gauss Jordan algorithm.*}
value "iarray_of_iarray_to_list_of_list (matrix_to_iarray (Gauss_Jordan (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2)))"
value "iarray_of_iarray_to_list_of_list (Gauss_Jordan_iarrays(IArray[IArray[Complex 1 1,Complex 1 (- 1),Complex 0 0],IArray[Complex 2 (- 1),Complex 1 3,Complex 7 3]]))"

subsubsection{*Inverse of a matrix*}
text{*Examples on inverting matrices*}

definition "print_result_some_iarrays A = (if A = None then None else Some (iarray_of_iarray_to_list_of_list (the A)))"

value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8],[3,2,8,0,5,9,8],[3,2,8,4,0,9,8],[3,2,8,4,5,0,8],[3,2,8,4,5,9,0]]::real^7^7)
                    in print_result_some_iarrays (matrix_to_iarray_option (inverse_matrix A))"
value "let A=(IArray[IArray[1::real,1,2,4,5,9,8],IArray[3,0,8,4,5,0,8],IArray[3,2,0,4,5,9,8],IArray[3,2,8,0,5,9,8],IArray[3,2,8,4,0,9,8],IArray[3,2,8,4,5,0,8],IArray[3,2,8,4,5,9,0]])
                    in print_result_some_iarrays (inverse_matrix_iarray A)"

subsubsection{*Determinant of a matrix*}
text{*Examples on computing determinants of matrices*}

value "det (list_of_list_to_matrix ([[1,8,9,1,47],[7,2,2,5,9],[3,2,7,7,4],[9,8,7,5,1],[1,2,6,4,5]])::rat^5^5)"
value "det (list_of_list_to_matrix [[1,2,7,8,9],[3,4,12,10,7],[-5,4,8,7,4],[0,1,2,4,8],[9,8,7,13,11]]::rat^5^5)"

value "det_iarrays (IArray[IArray[1::real,2,7,8,9],IArray[3,4,12,10,7],IArray[-5,4,8,7,4],IArray[0,1,2,4,8],IArray[9,8,7,13,11]])"
value "det_iarrays (IArray[IArray[286,662,263,246,642,656,351,454,339,848],
IArray[307,489,667,908,103,47,120,133,85,834],
IArray[69,732,285,147,527,655,732,661,846,202],
IArray[463,855,78,338,786,954,593,550,913,378],
IArray[90,926,201,362,985,341,540,912,494,427],
IArray[384,511,12,627,131,620,987,996,445,216],
IArray[385,538,362,643,567,804,499,914,332,512],
IArray[879,159,312,187,827,503,823,893,139,546],
IArray[800,376,331,363,840,737,911,886,456,848],
IArray[900,737,280,370,121,195,958,862,957,754::real]])"

subsubsection{*Bases of the fundamental subspaces*}
text{*Examples on computing basis for null space, row space, column space and left null space.*}
(*Null_space basis:*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
  in vec_to_list` (basis_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_null_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_null_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_null_space_iarrays A)"

(*Row_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_row_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_row_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_row_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_row_space_iarrays A)"

(*Col_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_col_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_col_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_col_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_col_space_iarrays A)"

(*Left_null_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_left_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_left_null_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_left_null_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_left_null_space_iarrays A)"

subsubsection{*Consistency and inconsistency*}

text{*Examples on checking the consistency/inconsistency of a system of equations. The theorems @{text "matrix_to_iarray_independent_and_consistent"} and
@{text "matrix_to_iarray_dependent_and_consistent"} which are code theorems and they are in the file @{text "System_Of_Equations_IArrays"}
assure the execution using the iarrays representation.*}

value "independent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "inconsistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[3,0,1],[0,7,0],[0,0,9]])::real^3^5) (list_to_vec([2,0,4,0,0])::real^5)"
value "dependent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0]])::real^3^2) (list_to_vec([3,4])::real^2)"
value "independent_and_consistent (mat 1::real^3^3) (list_to_vec([3,4,5])::real^3)"

subsubsection{*Solving systems of linear equations*}
text{*Examples on solving linear systems.*}
definition "print_result_system_iarrays A = (if A = None then None else Some (IArray.list_of (fst (the A)), IArray.list_of` (snd (the A))))"

value "let A = (list_of_list_to_matrix [[0,0,0],[0,0,0],[0,0,1]]::real^3^3); b=(list_to_vec [4,5,0]::real^3);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"
value "let A = (list_of_list_to_matrix [[3,2,5,2,7],[6,4,7,4,5],[3,2,-1,2,-11],[6,4,1,4,-13]]::real^5^4); b=(list_to_vec [0,0,0,0]::real^4);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"
value "let A = (list_of_list_to_matrix [[4,5,8],[9,8,7],[4,6,1]]::real^3^3); b=(list_to_vec [4,5,8]::real^3);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"

value "let A = (IArray[IArray[0::real,0,0],IArray[0,0,0],IArray[0,0,1]]); b=(IArray[4,5,0]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"
value "let A = (IArray[IArray[3::real,2,5,2,7],IArray[6,4,7,4,5],IArray[3,2,-1,2,-11],IArray[6,4,1,4,-13]]); b=(IArray[0,0,0,0]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"
value "let A = (IArray[IArray[4,5,8],IArray[9::real,8,7],IArray[4,6::real,1]]); b=(IArray[4,5,8]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"

export_code
  rank_iarray
  inverse_matrix_iarray
  det_iarrays
  consistent_iarrays
  inconsistent_iarrays
  independent_and_consistent_iarrays
  dependent_and_consistent_iarrays
  basis_left_null_space_iarrays
  basis_null_space_iarrays
  basis_col_space_iarrays
  basis_row_space_iarrays
  solve_iarrays
  in SML
end


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

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

datatype Heap = Node "Heap" "int" "Heap" | Nil

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

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

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

theorem property0 :
  "((hsort2 xs) = (isort xs))"
  oops

end


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


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


 theory Q1
    imports Main
begin
theorem abba : "(A∧B) ⟶ (B∧A)"
proof -
  have ab:"(A∧B) ⟹ (B∧A) "
  proof -
    assume ab: "A∧B"
    from ab have a: "A" by (rule conjE)
    from ab have b: "B" by (rule conjE)
    from b and a show  ba: "B∧A" by (rule conjI)
  qed
  from ab show "(A∧B)⟶(B∧A)" by (rule impI)
qed
end


subsection "Splay Tree Analysis (Optimal)"

theory Splay_Tree_Analysis_Optimal
imports
  Splay_Tree_Analysis_Base
  Amortized_Framework
  "HOL-Library.Sum_of_Squares"
begin

text\<open>This analysis follows Schoenmakers~\<^cite>\<open>"Schoenmakers-IPL93"\<close>.\<close>

subsubsection "Analysis of splay"

locale Splay_Analysis =
fixes \<alpha> :: real and \<beta> :: real
assumes a1[arith]: "\<alpha> > 1"
assumes A1: "\<lbrakk>1 \<le> x; 1 \<le> y; 1 \<le> z\<rbrakk> \<Longrightarrow>
 (x+y) * (y+z) powr \<beta> \<le> (x+y) powr \<beta> * (x+y+z)"
assumes A2: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> lr; 1 \<le> r\<rbrakk> \<Longrightarrow>
   \<alpha> * (l'+r') * (lr+r) powr \<beta> * (lr+r'+r) powr \<beta>
    \<le> (l'+r') powr \<beta> * (l'+lr+r') powr \<beta> * (l'+lr+r'+r)"
assumes A3: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> ll; 1 \<le> r\<rbrakk> \<Longrightarrow>
  \<alpha> * (l'+r') * (l'+ll) powr \<beta> * (r'+r) powr \<beta>
  \<le> (l'+r') powr \<beta> * (l'+ll+r') powr \<beta> * (l'+ll+r'+r)"
begin

lemma nl2: "\<lbrakk> ll \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  log \<alpha> (ll + lr) + \<beta> * log \<alpha> (lr + r)
  \<le> \<beta> * log \<alpha> (ll + lr) + log \<alpha> (ll + lr + r)"
apply(rule powr_le_cancel_iff[THEN iffD1, OF a1])
apply(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric] A1)
done

definition \<phi> :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> real" where
"\<phi> t1 t2 = \<beta> * log \<alpha> (size1 t1 + size1 t2)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + \<phi> l r"

definition A :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> real" where
"A a t = T_splay a t + \<Phi>(splay a t) - \<Phi> t"

lemma A_simps[simp]: "A a (Node l a r) = 1"
 "a<b \<Longrightarrow> A a (Node (Node ll a lr) b r) = \<phi> lr r - \<phi> lr ll + 1"
 "b<a \<Longrightarrow> A a (Node l b (Node rl a rr)) = \<phi> rl l - \<phi> rr rl + 1"
by(auto simp add: A_def \<phi>_def algebra_simps)

lemma A_ub: "\<lbrakk> bst t; Node la a ra : subtrees t \<rbrakk>
  \<Longrightarrow> A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
proof(induction a t rule: splay.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 4 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 5 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 7 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 10 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 12 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 13 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case (3 b a lb rb ra)
  have "b \<notin> set_tree ra" using "3.prems"(1) by auto
  thus ?case using "3.prems"(1,2) nl2[of "size1 lb" "size1 rb" "size1 ra"]
    by (auto simp: \<phi>_def log_divide algebra_simps)
next
  case (9 a b la lb rb)
  have "b \<notin> set_tree la" using "9.prems"(1) by auto
  thus ?case using "9.prems"(1,2) nl2[of "size1 rb" "size1 lb" "size1 la"]
    by (auto simp add: \<phi>_def log_divide algebra_simps)
next
  case (6 x b a lb rb ra)
  hence 0: "x \<notin> set_tree rb \<and> x \<notin> set_tree ra" using "6.prems"(1) by auto
  hence 1: "x \<in> set_tree lb" using "6.prems" \<open>x<b\<close> by (auto)
  then obtain lu u ru where sp: "splay x lb = Node lu u ru"
    using "6.prems"(1,2) by(cases "splay x lb") auto
  have "b < a" using "6.prems"(1,2) by (auto)
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?rb = "real(size1 rb)"  let ?r = "real(size1 ra)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?rb + ?r) + \<beta> * log \<alpha> (?rb + ?ru + ?r) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?rb + ?ru) + log \<alpha> (?lu + ?rb + ?ru + ?r)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
    show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?lu ?ru ?rb ?r]
      by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 6 0 1 sp
    by(auto simp: A_def \<phi>_def size_if_splay algebra_simps log_divide)
next
  case (8 b x a rb lb ra)
  hence 0: "x \<notin> set_tree lb \<and> x \<notin> set_tree ra" using "8.prems"(1) by(auto)
  hence 1: "x \<in> set_tree rb" using "8.prems" \<open>b<x\<close> \<open>x<a\<close> by (auto)
  then obtain lu u ru where sp: "splay x rb = Node lu u ru"
    using "8.prems"(1,2) by(cases "splay x rb") auto
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?lb = "real(size1 lb)" let ?r = "real(size1 ra)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb) + \<beta> * log \<alpha> (?ru + ?r) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb + ?ru) + log \<alpha> (?lu + ?lb + ?ru + ?r)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
     show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?lu ?ru ?lb ?r]
       by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 8 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
next
  case (11 a x b lb la rb)
  hence 0: "x \<notin> set_tree rb \<and> x \<notin> set_tree la" using "11.prems"(1) by (auto)
  hence 1: "x \<in> set_tree lb" using "11.prems" \<open>a<x\<close> \<open>x<b\<close> by (auto)
  then obtain lu u ru where sp: "splay x lb = Node lu u ru"
    using "11.prems"(1,2) by(cases "splay x lb") auto
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?l = "real(size1 la)"  let ?rb = "real(size1 rb)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?l) + \<beta> * log \<alpha> (?ru + ?rb) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?ru + ?rb) + log \<alpha> (?lu + ?l + ?ru + ?rb)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
    show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?ru ?lu ?rb ?l]
      by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
        (simp add: algebra_simps)
  qed
  thus ?case using 11 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
next
  case (14 a x b rb la lb)
  hence 0: "x \<notin> set_tree lb \<and> x \<notin> set_tree la" using "14.prems"(1) by(auto)
  hence 1: "x \<in> set_tree rb" using "14.prems" \<open>a<x\<close> \<open>b<x\<close> by (auto)
  then obtain lu u ru where sp: "splay x rb = Node lu u ru"
    using "14.prems"(1,2) by(cases "splay x rb") auto
  let ?la = "real(size1 la)"  let ?lb = "real(size1 lb)"
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?la + ?lb) + \<beta> * log \<alpha> (?lu + ?la + ?lb) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb + ?ru) + log \<alpha> (?lu + ?lb + ?ru + ?la)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
     show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?ru ?lu ?lb ?la]
       by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 14 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
qed

lemma A_ub2: assumes "bst t" "a : set_tree t"
shows "A a t \<le> log \<alpha> ((size1 t)/2) + 1"
proof -
  from assms(2) obtain la ra where N: "Node la a ra : subtrees t"
    by (metis set_treeE)
  have "A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
    by(rule A_ub[OF assms(1) N])
  also have "\<dots> \<le> log \<alpha> ((size1 t)/2) + 1" by(simp add: field_simps)
  finally show ?thesis by simp
qed

lemma A_ub3: assumes "bst t" shows "A a t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: A_def)
next
  assume "t \<noteq> Leaf"
  from ex_in_set_tree[OF this assms] obtain a' where
    a': "a' \<in> set_tree t"  "splay a' t = splay a t"  "T_splay a' t = T_splay a t"
    by blast
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using A_ub2[OF assms a'(1)] by(simp add: A_def a' log_divide)
qed

definition Am :: "'a::linorder tree \<Rightarrow> real" where
"Am t = T_splay_max t + \<Phi>(splay_max t) - \<Phi> t"

lemma Am_simp3': "\<lbrakk> c<b; bst rr; rr \<noteq> Leaf\<rbrakk> \<Longrightarrow>
  Am (Node l c (Node rl b rr)) =
  (case splay_max rr of Node rrl _ rrr \<Rightarrow>
   Am rr + \<phi> rrl (Node l c rl) + \<phi> l rl - \<phi> rl rr - \<phi> rrl rrr + 1)"
by(auto simp: Am_def \<phi>_def size_if_splay_max algebra_simps neq_Leaf_iff split: tree.split)

lemma Am_ub: "\<lbrakk> bst t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow> Am t \<le> log \<alpha> ((size1 t)/2) + 1"
proof(induction t rule: splay_max.induct)
  case 1 thus ?case by (simp)
next
  case 2 thus ?case by (simp add: Am_def)
next
  case (3 l b rl c rr)
  show ?case
  proof cases
    assume "rr = Leaf"
    thus ?thesis
      using nl2[of 1 "size1 rl" "size1 l"] log_le_cancel_iff[of \<alpha> 2 "2 + real(size rl)"]
      by(auto simp: Am_def \<phi>_def log_divide field_simps
           simp del: log_le_cancel_iff)
  next
    assume "rr \<noteq> Leaf"
    then obtain l' u r' where sp: "splay_max rr = Node l' u r'"
      using splay_max_Leaf_iff tree.exhaust by blast
    hence 1: "size rr = size l' + size r' + 1"
      using size_splay_max[of rr] by(simp)
    let ?l = "real (size1 l)" let ?rl = "real (size1 rl)"
    let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
    have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l + ?rl) + \<beta> * log \<alpha> (?l' + ?l + ?rl) \<le>
      \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?rl + ?r') + log \<alpha> (?l' + ?rl + ?r' + ?l)" (is "?L\<le>?R")
    proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
      show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?r' ?l' ?rl ?l]
        by(simp add: powr_add add.commute add.left_commute mult.commute[of \<beta>] powr_powr[symmetric])
    qed
    thus ?case using 3 sp 1 \<open>rr \<noteq> Leaf\<close>
      by(auto simp add: Am_simp3' \<phi>_def log_divide algebra_simps)
  qed
qed

lemma Am_ub3: assumes "bst t" shows "Am t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: Am_def)
next
  assume "t \<noteq> Leaf"
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using Am_ub[OF assms \<open>t \<noteq> Leaf\<close>] by(simp add: Am_def log_divide)
qed

end

subsubsection "Optimal Interpretation"

lemma mult_root_eq_root:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> root n x * y = root n (x * (y ^ n))"
by(simp add: real_root_mult real_root_pos2)

lemma mult_root_eq_root2:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> y * root n x = root n ((y ^ n) * x)"
by(simp add: real_root_mult real_root_pos2)

lemma powr_inverse_numeral:
  "0 < x \<Longrightarrow> x powr (1 / numeral n) = root (numeral n) x"
by (simp add: root_powr_inverse)

lemmas root_simps = mult_root_eq_root mult_root_eq_root2 powr_inverse_numeral

lemma nl31: "\<lbrakk> (l'::real) \<ge> 1; r' \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  4 * (l' + r') * (lr + r) \<le> (l' + lr + r' + r)^2"
by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + lr + ~1*r']^2))))")

lemma nl32: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (lr + r) * (lr + r' + r) \<le> (l' + lr + r' + r)^3"
proof -
  have 1: "lr + r' + r \<le> l' + lr + r' + r" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> lr + r' + r" using assms by arith
  from mult_mono[OF nl31[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc)
qed

lemma nl3: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (lr + r) * (lr + r' + r)
       \<le> (l' + lr + r') * (l' + lr + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + lr + r'" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl32[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma nl41: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^2"
using assms by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + ~1*ll + r']^2))))")

lemma nl42: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^3"
proof -
  have 1: "l' + r' \<le> l' + ll + r' + r" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl41[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc del: distrib_right_numeral)
qed

lemma nl4: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (l' + ll) * (r' + r)
    \<le> (l' + ll + r') * (l' + ll + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + ll + r'" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl42[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma cancel: "x>(0::real) \<Longrightarrow> c * x ^ 2 * y * z \<le> u * v \<Longrightarrow> c * x ^ 3 * y * z \<le> x * u * v"
by(simp add: power2_eq_square power3_eq_cube)

interpretation S34: Splay_Analysis "root 3 4" "1/3"
proof (standard, goal_cases)
  case 2 thus ?case
    by(simp add: root_simps)
      (auto simp: numeral_eq_Suc split_mult_pos_le intro!: mult_mono)
next
  case 3 thus ?case by(simp add: root_simps cancel nl3)
next
  case 4 thus ?case by(simp add: root_simps cancel nl4)
qed simp

lemma log4_log2: "log 4 x = log 2 x / 2"
proof -
  have "log 4 x = log (2^2) x" by simp
  also have "\<dots> = log 2 x / 2" by(simp only: log_base_pow)
  finally show ?thesis .
qed

declare log_base_root[simp]

lemma A34_ub: assumes "bst t"
shows "S34.A a t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.A a t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.A_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size t + 1) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

lemma Am34_ub: assumes "bst t"
shows "S34.Am t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.Am t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.Am_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size1 t) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

subsubsection "Overall analysis"

fun U where
"U Empty [] = 1" |
"U (Splay _) [t] = (3/2) * log 2 (size1 t) + 1" |
"U (Insert _) [t] = 2 * log 2 (size1 t) + 5/2" |
"U (Delete _) [t] = 3 * log 2 (size1 t) + 3"

interpretation Amortized
where arity = arity and exec = exec and inv = bst
and cost = cost and \<Phi> = S34.\<Phi> and U = U
proof (standard, goal_cases)
  case (1 ss f) show ?case
  proof (cases f)
    case Empty thus ?thesis using 1 by auto
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with Splay bst_splay[OF \<open>bst t\<close>, of a] show ?thesis
      by (auto split: tree.split)
  next
    case (Insert a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with bst_splay[OF \<open>bst t\<close>, of a] Insert show ?thesis
      by (auto simp: splay_bstL[OF \<open>bst t\<close>] splay_bstR[OF \<open>bst t\<close>] split: tree.split)
  next
    case (Delete a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with 1 Delete show ?thesis by(simp add: bst_delete)
  qed
next
  case (2 t) show ?case by(induction t)(simp_all add: S34.\<phi>_def)
next
  case (3 ss f)
  show ?case (is "?l \<le> ?r")
  proof(cases f)
    case Empty thus ?thesis using 3(2) by(simp add: S34.A_def)
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 3 by auto
    thus ?thesis using S34.A_ub3[OF \<open>bst t\<close>] Splay
      by(simp add: S34.A_def log4_log2)
  next
    case [simp]: (Insert a)
    obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    show ?thesis
    proof cases
      assume "t = Leaf" thus ?thesis by(simp add: S34.\<phi>_def log4_log2 T_insert_def)
    next
      assume "t \<noteq> Leaf"
      then obtain l e r where [simp]: "splay a t = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(T_splay a t)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> t"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      have opt: "?t + S34.\<Phi> (splay a t) - ?Ps  \<le> 3/2 * log 2 (real (size1 t)) + 1"
        using S34.A_ub3[OF \<open>bst t\<close>, simplified S34.A_def, of a]
        by (simp add: log4_log2)
      from less_linear[of e a]
      show ?thesis
      proof (elim disjE)
        assume "e=a"
        have nneg: "log 2 (1 + real (size t)) \<ge> 0" by simp
        thus ?thesis using \<open>t \<noteq> Leaf\<close> opt \<open>e=a\<close>
          apply(simp add: field_simps T_insert_def) using nneg by arith
      next
        let ?L = "log 2 (real(size1 l) + 1)"
        assume "e<a" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?L / 2 + ?LR / 2 + 1"
          using \<open>t \<noteq> Leaf\<close> \<open>e<a\<close> by(simp add: S34.\<phi>_def log4_log2 T_insert_def)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a t,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?L/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a t,symmetric] by simp
      next
        let ?R = "log 2 (2 + real(size r))"
        assume "a<e" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?R / 2 + ?LR / 2 + 1"
          using  \<open>t \<noteq> Leaf\<close> \<open>a<e\<close> by(simp add: S34.\<phi>_def log4_log2 T_insert_def)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a t,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?R/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a t,symmetric] by simp
      qed
    qed
  next
    case [simp]: (Delete a)
    obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    show ?thesis
    proof (cases t)
      case Leaf thus ?thesis
        by(simp add: Splay_Tree.delete_def T_delete_def S34.\<phi>_def log4_log2)
    next
      case [simp]: (Node ls x rs)
      then obtain l e r where sp[simp]: "splay a (Node ls x rs) = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(T_splay a t)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> t"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      let ?lslr = "log 2 (real (size ls) + (real (size rs) + 2))"
      have "?lslr \<ge> 0" by simp
      have opt: "?t + S34.\<Phi> (splay a t) - ?Ps  \<le> 3/2 * log 2 (real (size1 t)) + 1"
        using S34.A_ub3[OF \<open>bst t\<close>, simplified S34.A_def, of a]
        by (simp add: log4_log2 field_simps)
      show ?thesis
      proof (cases "e=a")
        case False thus ?thesis using opt
          apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
          using \<open>?lslr \<ge> 0\<close> by arith
      next
        case [simp]: True
        show ?thesis
        proof (cases l)
          case Leaf
          have "S34.\<phi> Leaf r \<ge> 0" by(simp add: S34.\<phi>_def)
          thus ?thesis using Leaf opt
            apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
            using \<open>?lslr \<ge> 0\<close> by arith
        next
          case (Node ll y lr)
          then obtain l' y' r' where [simp]:
            "splay_max (Node ll y lr) = Node l' y' r'"
            using splay_max_Leaf_iff tree.exhaust by blast
          have "bst l" using bst_splay[OF \<open>bst t\<close>, of a] by simp
          have "S34.\<Phi> r' \<ge> 0" apply (induction r') by (auto simp add: S34.\<phi>_def)
          have optm: "real(T_splay_max l) + S34.\<Phi> (splay_max l) - S34.\<Phi> l
            \<le> 3/2 * log 2 (real (size1 l)) + 1"
            using S34.Am_ub3[OF \<open>bst l\<close>, simplified S34.Am_def]
            by (simp add: log4_log2 field_simps Node)
          have 1: "log 4 (2+(real(size l')+real(size r))) \<le>
            log 4 (2+(real(size l)+real(size r)))"
            using size_splay_max[of l] Node by simp
          have 2: "log 4 (2 + (real (size l') + real (size r'))) \<ge> 0" by simp
          have 3: "S34.\<phi> l' r \<le> S34.\<phi> l' r' + S34.\<phi> l r"
            apply(simp add: S34.\<phi>_def) using 1 2 by arith
          have 4: "log 2 (real(size ll) + (real(size lr) + 2)) \<le> ?lslr"
            using size_if_splay[OF sp] Node by simp
          show ?thesis using add_mono[OF opt optm] Node 3
            apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
            using 4 \<open>S34.\<Phi> r' \<ge> 0\<close> by arith
        qed
      qed
    qed
  qed
qed

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 Rene Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and Rene Thiemann
    License:     LGPL
*)

(*
Copyright 2009 Christian Sternagel, René Thiemann, Sarah Winkler, Harald Zankl

This file is part of IsaFoR/CeTA.

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

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

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Monotonicity criteria of Neurauter, Zankl, and Middeldorp\<close>

theory NZM
imports "Abstract-Rewriting.SN_Order_Carrier" Polynomials
begin

text \<open>
We show that our check on monotonicity is strong enough to capture the
exact criterion for polynomials of degree 2 that is presented in \<^cite>\<open>"NZM10"\<close>:
\begin{itemize}
\item $ax^2 + bx + c$ is monotone if $b + a > 0$ and $a \geq 0$
\item $ax^2 + bx + c$ is weakly monotone if $b + a \geq 0$ and $a \geq 0$
\end{itemize}
\<close>

lemma var_monom_x_x [simp]: "var_monom x * var_monom x \<noteq> 1"
  by (unfold eq_monom_sum_var, auto simp: sum_var_monom_mult sum_var_monom_var)

lemma monom_list_x_x[simp]: "monom_list (var_monom x * var_monom x) = [(x,2)]"
  by (transfer, auto simp: monom_mult_list.simps)

lemma assumes b: "b + a > 0" and a: "(a :: int) \<ge> 0"
  shows "check_poly_strict_mono_discrete (>) (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
    extract_def check_poly_strict_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "b > 0 \<and> b \<noteq> 0" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

lemma assumes b: "b + a \<ge> 0" and a: "(a :: int) \<ge> 0"
  shows "check_poly_weak_mono_discrete (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
  note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
    extract_def check_poly_weak_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
    check_poly_gt_def poly_split_def check_poly_ge.simps
  show ?thesis
  proof (cases "a = 0")
    case True
    with b have b: "0 \<le> b" by auto
    show ?thesis using b True by simp
  next
    case False
    have [simp]: "2 = Suc (Suc 0)" by simp
    show ?thesis using False a b by simp
  qed
qed

end


(* License: LGPL *)
(* Author: Julian Parsert *)

theory Lotteries
  imports
    PMF_Composition
    "HOL-Probability.Probability"
begin

section \<open> Lotteries \<close>

definition lotteries_on
  where
    "lotteries_on Oc = {p . (set_pmf p) \<subseteq> Oc}"

lemma lotteries_on_subset:
  assumes "A \<subseteq> B"
  shows "lotteries_on A \<subseteq> lotteries_on B"
  by (metis (no_types, lifting) Collect_mono assms gfp.leq_trans lotteries_on_def)

lemma support_in_outcomes:
  "\<forall>oc. \<forall>p \<in> lotteries_on oc. \<forall>a \<in> set_pmf p. a \<in> oc"
  by (simp add: lotteries_on_def subsetD)

lemma lotteries_on_nonempty:
  assumes "outcomes \<noteq> {}"
  shows "lotteries_on outcomes \<noteq> {}"
  by (auto simp: lotteries_on_def) (metis (full_types) assms
      empty_subsetI ex_in_conv insert_subset set_return_pmf)

lemma finite_support_one_oc:
  assumes "card outcomes = 1"
  shows "\<forall>l \<in> lotteries_on outcomes. finite (set_pmf l)"
  by (metis assms card.infinite finite_subset lotteries_on_def mem_Collect_eq zero_neq_one)

lemma one_outcome_card_support_1:
  assumes "card outcomes = 1"
  shows "\<forall>l \<in> lotteries_on outcomes. card (set_pmf l) = 1"
proof
  fix l
  assume "l \<in> lotteries_on outcomes"
  have "finite outcomes"
    using assms card.infinite by force
  then have "l \<in> lotteries_on outcomes \<longrightarrow> 1 = card (set_pmf l)"
    by (metis assms card_eq_0_iff card_mono finite_support_one_oc le_neq_implies_less
        less_one lotteries_on_def mem_Collect_eq set_pmf_not_empty)
  then show "card (set_pmf l) = 1"
    by (simp add: \<open>l \<in> lotteries_on outcomes\<close>)
qed

lemma finite_nempty_ex_degernate_in_lotteries:
  assumes "out \<noteq> {}"
  assumes "finite out"
  shows "\<exists>e \<in> lotteries_on out. \<exists>x \<in> out. pmf e x = 1"
proof (rule ccontr)
  assume a: "\<not> (\<exists>e\<in>lotteries_on out. \<exists>x\<in>out. pmf e x = 1)"
  then have subset: "\<forall>e \<in> lotteries_on out. set_pmf e \<subseteq> out"
    using lotteries_on_def by (simp add: lotteries_on_def)
  then have "\<forall>e. e \<in> lotteries_on out \<longrightarrow> ((\<Sum>i\<in>set_pmf e. pmf e i) = 1)"
    using sum_pmf_eq_1 by (metis subset  assms(2) finite_subset order_refl)
  then show False
    by (metis (no_types, lifting) a assms(1) assms(2) card.empty card_gt_0_iff card_seteq
        empty_subsetI finite.emptyI finite_insert insert_subset lotteries_on_def subsetI
        measure_measure_pmf_finite mem_Collect_eq nat_less_le pmf.rep_eq set_pmf_of_set )
qed

lemma card_support_1_probability_1:
  assumes "card (set_pmf p) = 1"
  shows "\<forall>e \<in> set_pmf p. pmf p e = 1"
  by(auto) (metis assms card_1_singletonE card_ge_0_finite
      card_subset_eq ex_card le_numeral_extra(4) measure_measure_pmf_finite
      pmf.rep_eq singletonD sum_pmf_eq_1 zero_less_one)

lemma one_outcome_card_lotteries_1:
  assumes "card outcomes = 1"
  shows "card (lotteries_on outcomes) = 1"
proof -
  obtain x :: 'a where
    x: "outcomes = {x}"
    using assms card_1_singletonE by blast
  have exl: "\<exists>l \<in> lotteries_on outcomes. pmf l x = 1"
    by (metis x assms card.infinite empty_iff
        finite_nempty_ex_degernate_in_lotteries insert_iff zero_neq_one)
  have pmfs: "\<forall>l \<in> lotteries_on outcomes. set_pmf l = {x}"
    by (simp add: lotteries_on_def set_pmf_subset_singleton x)
  have "\<forall>l \<in> lotteries_on outcomes. pmf l x = 1"
    by (simp add: lotteries_on_def set_pmf_subset_singleton x)
  then show ?thesis
    by (metis exl empty_iff is_singletonI' is_singleton_altdef
        order_refl pmfs set_pmf_subset_singleton)
qed

lemma return_pmf_card_equals_set:
  shows "card {return_pmf x |x. x \<in> S} = card S"
proof-
  have "{return_pmf x |x. x \<in> S} = return_pmf ` S"
    by blast
  also have "card \<dots> = card S"
    by (intro card_image) (auto simp: inj_on_def)
  finally show "card {return_pmf x |x. x \<in> S} = card S" .
qed

lemma card_degen_lotteries_equals_outcomes:
  shows "card {x \<in> lotteries_on out. card (set_pmf x) = 1} = card out"
proof -
  consider (empty) "out = {}" | (not_empty) "out \<noteq> {}"
    by blast
  then show ?thesis
  proof (cases)
    case not_empty
    define DG where
      DG: "DG = {x \<in> lotteries_on out. card (set_pmf x) = 1}"
    define AP where
      AP: "AP = {return_pmf x |x. x \<in> out}"
    have **: "card AP = card out"
      using AP return_pmf_card_equals_set by blast
    have *: "\<forall>d \<in> DG. d \<in> AP"
    proof
      fix l
      assume "l \<in> DG"
      then have "l \<in> lotteries_on out \<and> 1 = card (set_pmf l)"
        using DG by force
      then obtain x where
        x: "x \<in> out" "set_pmf l = {x}"
        by (metis (no_types) card_1_singletonE singletonI support_in_outcomes)
      have "return_pmf x = l"
        using set_pmf_subset_singleton x(2) by fastforce
      then show "l \<in> AP"
        using AP x(1) by blast
    qed
    moreover have "AP = DG"
    proof
      have "\<forall>e \<in> AP. e \<in> lotteries_on out"
        by(auto simp: lotteries_on_def AP)
      then show "AP \<subseteq> DG" using DG AP by force
    qed (auto simp: *)
    ultimately show ?thesis
      using DG ** by blast
  qed (simp add: lotteries_on_def set_pmf_not_empty)
qed

end


section \<open>Real Factorization\<close>

text \<open>This theory contains an algorithm to completely factorize real polynomials with rational
  coefficients. It internally does a complex polynomial factorization, and then combines
  all non-real roots with their conjugates.\<close>

theory Real_Factorization
imports
  Complex_Algebraic_Numbers
begin

fun delete_cnj :: "complex \<Rightarrow> nat \<Rightarrow> (complex \<times> nat) list \<Rightarrow> (complex \<times> nat) list" where
  "delete_cnj x i ((y,j) # yjs) = (if x = y then if Suc j = i then yjs else if Suc j > i then
    ((y,j - i) # yjs) else delete_cnj x (i - Suc j) yjs else (y,j) # delete_cnj x i yjs)"
| "delete_cnj _ _ [] = []"

lemma delete_cnj_length[termination_simp]: "length (delete_cnj x i yjs) \<le> length yjs"
  by (induct x i yjs rule: delete_cnj.induct, auto)

fun complex_roots_to_real_factorization :: "(complex \<times> nat) list \<Rightarrow> (real poly \<times> nat)list" where
  "complex_roots_to_real_factorization [] = []"
| "complex_roots_to_real_factorization ((x,i) # xs) = (if x \<in> \<real> then
    ([:-(Re x),1:],Suc i) # complex_roots_to_real_factorization xs else
    let xx = cnj x; ys = delete_cnj xx (Suc i) xs; p = map_poly Re ([:-x,1:] * [:-xx,1:])
    in (p,Suc i) # complex_roots_to_real_factorization ys)"

definition factorize_real_poly :: "real poly \<Rightarrow> (real \<times> (real poly \<times> nat) list) option" where
  "factorize_real_poly p \<equiv> map_option
    (\<lambda> (c,ris). (Re c, complex_roots_to_real_factorization ris))
    (factorize_complex_main (map_poly of_real p))"

lemma delete_cnj: assumes
  "order x (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i) \<ge> si" "si \<noteq> 0"
  shows "(\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i) =
    [:- x, 1:] ^ si * (\<Prod>(x, i)\<leftarrow>delete_cnj x si xis. [:- x, 1:] ^ Suc i)"
using assms
proof (induct x si xis rule: delete_cnj.induct)
  case (2 x si)
  hence "order x 1 \<ge> 1" by auto
  hence "[:-x,1:]^1 dvd 1" unfolding order_divides by simp
  from power_le_dvd[OF this, of 1] \<open>si \<noteq> 0\<close> have "[:- x, 1:] dvd 1" by simp
  from divides_degree[OF this]
  show ?case by auto
next
  case (1 x i y j yjs)
  note IH = 1(1-2)
  let ?yj = "[:-y,1:]^Suc j"
  let ?yjs = "(\<Prod>(x,i)\<leftarrow>yjs. [:- x, 1:] ^ Suc i)"
  let ?x = "[: - x, 1 :]"
  let ?xi = "?x ^ i"
  have "monic (\<Prod>(x,i)\<leftarrow>(y, j) # yjs. [:- x, 1:] ^ Suc i)"
    by (rule monic_prod_list_pow) then have "monic (?yj * ?yjs)" by simp
  from monic_imp_nonzero[OF this] have yy0: "?yj * ?yjs \<noteq> 0" by auto
  have id: "(\<Prod>(x,i)\<leftarrow>(y, j) # yjs. [:- x, 1:] ^ Suc i) = ?yj * ?yjs" by simp
  from 1(3-) have ord: "i \<le> order x (?yj * ?yjs)" and i: "i \<noteq> 0" unfolding id by auto
  from ord[unfolded order_mult[OF yy0]] have ord: "i \<le> order x ?yj + order x ?yjs" .
  from this[unfolded order_linear_power']
  have ord: "i \<le> (if y = x then Suc j else 0) + order x ?yjs" by simp
  show ?case
  proof (cases "x = y")
    case False
    from ord False have "i \<le> order x ?yjs" by simp
    note IH = IH(2)[OF False this i]
    from False have del: "delete_cnj x i ((y, j) # yjs) = (y,j) # delete_cnj x i yjs" by simp
    show ?thesis unfolding del id IH
      by (simp add: ac_simps)
  next
    case True note xy = this
    note IH = IH(1)[OF True]
    show ?thesis
    proof (cases "Suc j \<ge> i")
      case False
      from ord have ord: "i - Suc j \<le> order x ?yjs" unfolding xy by simp
      have "?xi = ?x ^ (Suc j + (i - Suc j))" using False by simp
      also have "\<dots> = ?x ^ Suc j * ?x ^ (i - Suc j)"
        unfolding power_add by simp
      finally have xi: "?xi = ?x ^ Suc j * ?x ^ (i - Suc j)" .
      from False have "Suc j \<noteq> i" "\<not> i < Suc j" "i - Suc j \<noteq> 0" by auto
      note IH = IH[OF this(1,2) ord this(3)]
      from xy False have del: "delete_cnj x i ((y, j) # yjs) = delete_cnj x (i - Suc j) yjs" by auto
      show ?thesis unfolding del id unfolding IH xi unfolding xy by simp
    next
      case True
      hence "Suc j = i \<or> i < Suc j" by auto
      thus ?thesis
      proof
        assume i: "Suc j = i"
        from xy i have del: "delete_cnj x i ((y, j) # yjs) = yjs" by simp
        show ?thesis unfolding id del unfolding xy i by simp
      next
        assume ij: "i < Suc j"
        with xy i have del: "delete_cnj x i ((y, j) # yjs) = (y, j - i) # yjs" by simp
        from ij have idd: "Suc j = i + Suc (j - i)" by simp
        show ?thesis unfolding id del unfolding xy idd power_add by simp
      qed
    qed
  qed
qed

lemma factorize_real_poly: assumes fp: "factorize_real_poly p = Some (c,qis)"
  shows
  "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)"
  "(q,j) \<in> set qis \<Longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2}"
proof -
  interpret map_poly_inj_idom_hom of_real..
  have "(p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)) \<and> ((q,j) \<in> set qis \<longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2})"
  proof (cases "p = 0")
    case True
    have "factorize_real_poly p = Some (0,[])" unfolding True
      by (simp add: factorize_real_poly_def factorize_complex_main_def yun_factorization_def)
    with fp have id: "c = 0" "qis = []" by auto
    thus ?thesis unfolding True by simp
  next
    case False note p0 = this
    let ?c = complex_of_real
    let ?rp = "map_poly Re"
    let ?cp = "map_poly ?c"
    let ?p = "?cp p"
    from fp[unfolded factorize_real_poly_def]
      obtain d xis where fp: "factorize_complex_main ?p = Some (d,xis)"
      and c: "c = Re d" and qis: "qis = complex_roots_to_real_factorization xis" by auto
    from factorize_complex_main[OF fp] have p: "?p = smult d (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
      (is "_ = smult d ?q") .
    from arg_cong[OF this, of "\<lambda> p. coeff p (degree p)"]
    have "coeff ?p (degree ?p) = coeff (smult d ?q) (degree (smult d ?q))" .
    also have "coeff ?p (degree ?p) = ?c (coeff p (degree p))" by simp
    also have "coeff (smult d ?q) (degree (smult d ?q)) = d * coeff ?q (degree ?q)"
      by simp
    also have "monic ?q" by (rule monic_prod_list_pow)
    finally have d: "d = ?c (coeff p (degree p))" by auto
    from arg_cong[OF this, of Re, folded c] have c: "c = coeff p (degree p)" by auto
    have "set (coeffs ?p) \<subseteq> \<real>" by auto
    with p have q': "set (coeffs (smult d ?q)) \<subseteq> \<real>" by auto
    from d p0 have d0: "d \<noteq> 0" by auto
    have "smult d ?q = [:d:] * ?q" by auto
    from real_poly_factor[OF q'[unfolded this]] d0 d
    have q: "set (coeffs ?q) \<subseteq> \<real>" by auto
    have "p = ?rp ?p"
      by (rule sym, subst map_poly_map_poly, force, rule map_poly_idI, auto)
    also have "\<dots> = ?rp (smult d ?q)" unfolding p ..
    also have "?q = ?cp (?rp ?q)"
      by (rule sym, rule map_poly_of_real_Re, insert q, auto)
    also have "d = ?c c" unfolding d c ..
    also have "smult (?c c) (?cp (?rp ?q)) = ?cp (smult c (?rp ?q))" by (simp add: hom_distribs)
    also have "?rp \<dots> = smult c (?rp ?q)"
      by (subst map_poly_map_poly, force, rule map_poly_idI, auto)
    finally have p: "p = smult c (?rp ?q)" .
    let ?fact = complex_roots_to_real_factorization
    have "?rp ?q = (\<Prod>(q, i)\<leftarrow>qis. q ^ i) \<and>
      ((q, j) \<in> set qis \<longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1, 2})"
      using q unfolding qis
    proof (induct xis rule: complex_roots_to_real_factorization.induct)
      case 1
      show ?case by simp
    next
      case (2 x i xis)
      note IH = 2(1-2)
      note prems = 2(3)
      let ?xi = "[:- x, 1:] ^ Suc i"
      let ?xis = "(\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
      have id: "(\<Prod>(x, i)\<leftarrow>((x,i) # xis). [:- x, 1:] ^ Suc i) = ?xi * ?xis"
        by simp
      show ?case
      proof (cases "x \<in> \<real>")
        case True
        have xi: "set (coeffs ?xi) \<subseteq> \<real>"
          by (rule real_poly_power, insert True, auto)
        have xis: "set (coeffs ?xis) \<subseteq> \<real>"
          by (rule real_poly_factor[OF prems[unfolded id] xi], rule linear_power_nonzero)
        note IH = IH(1)[OF True xis]
        have "?rp (?xi * ?xis) = ?rp ?xi * ?rp ?xis"
          by (rule map_poly_Re_mult[OF xi xis])
        also have "?rp ?xi = (?rp [: -x,1 :])^Suc i"
          by (rule map_poly_Re_power, insert True, auto)
        also have "?rp [: -x,1 :] = [:-(Re x),1:]" by auto
        also have "?rp ?xis = (\<Prod> (a,b) \<leftarrow> ?fact xis. a ^ b)"
          using IH by auto
        also have "[:- Re x, 1:] ^ Suc i * (\<Prod> (a,b) \<leftarrow> ?fact xis. a ^ b) =
          (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" using True by simp
        finally have idd: "?rp (?xi * ?xis) = (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" .
        show ?thesis unfolding id idd
        proof (intro conjI, force, intro impI)
          assume "(q, j) \<in> set (?fact ((x, i) # xis))"
          hence "(q,j) \<in> set (?fact xis) \<or> (q = [:- Re x, 1:] \<and> j = Suc i)"
            using True by auto
          thus "irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1, 2}"
          proof
            assume "(q,j) \<in> set (?fact xis)"
            with IH show ?thesis by auto
          next
            assume "q = [:- Re x, 1:] \<and> j = Suc i"
            with linear_irreducible_field[of "[:- Re x, 1:]"] show ?thesis by auto
          qed
        qed
      next
        case False
        define xi where "xi = [:Re x * Re x + Im x * Im x, - (2 * Re x), 1:]"
        obtain xx where xx: "xx = cnj x" by auto
        have xi: "xi = ?rp ([:-x,1:] * [:-xx,1:])" unfolding xx xi_def by auto
        have cpxi: "?cp xi = [:-x,1:] * [:-xx,1:]" unfolding xi_def
          by (cases x, auto simp: xx legacy_Complex_simps)
        obtain yis where yis: "yis = delete_cnj xx (Suc i) xis" by auto
        from False have fact: "?fact ((x,i) # xis) = ((xi,Suc i) # ?fact yis)"
          unfolding xi_def xx yis by simp
        note IH = IH(2)[OF False xx yis xi]
        have "irreducible xi"
          apply (fold irreducible_connect_field)
        proof (rule irreducible\<^sub>dI)
          show "degree xi > 0" unfolding xi by auto
          fix q p :: "real poly"
          assume "degree q > 0" "degree q < degree xi" and qp: "xi = q * p"
          hence dq: "degree q = 1" unfolding xi by auto
          have dxi: "degree xi = 2" "xi \<noteq> 0" unfolding xi by auto
          with qp have "q \<noteq> 0" "p \<noteq> 0" by auto
          hence "degree xi = degree q + degree p" unfolding qp
            by (rule degree_mult_eq)
          with dq have dp: "degree p = 1" unfolding dxi by simp
          {
            fix c :: complex
            assume rt: "poly (?cp xi) c = 0"
            hence "poly (?cp q * ?cp p) c = 0" by (simp add: qp hom_distribs)
            hence "(poly (?cp q) c = 0 \<or> poly (?cp p) c = 0)" by auto
            hence "c = roots1 (?cp q) \<or> c = roots1 (?cp p)"
              using roots1[of "?cp q"] roots1[of "?cp p"] dp dq by auto
            hence "c \<in> \<real>" unfolding roots1_def by auto
            hence "c \<noteq> x" using False by auto
          }
          hence "poly (?cp xi) x \<noteq> 0" by auto
          thus False unfolding cpxi by simp
        qed
        hence xi': "irreducible xi" "monic xi" "degree xi = 2"
          unfolding xi by auto
        let ?xxi = "[:- xx, 1:] ^ Suc i"
        let ?yis = "(\<Prod>(x, i)\<leftarrow>yis. [:- x, 1:] ^ Suc i)"
        let ?yi = "(?cp xi)^Suc i"
        have yi: "set (coeffs ?yi) \<subseteq> \<real>"
          by (rule real_poly_power, auto simp: xi)
        have mon: "monic (\<Prod>(x, i)\<leftarrow>(x, i) # xis. [:- x, 1:] ^ Suc i)"
          by (rule monic_prod_list_pow)
        from monic_imp_nonzero[OF this] have xixis: "?xi * ?xis \<noteq> 0" unfolding id by auto
        from False have xxx: "xx \<noteq> x" unfolding xx by (cases x, auto simp: legacy_Complex_simps Reals_def)
        from prems[unfolded id] have prems: "set (coeffs (?xi * ?xis)) \<subseteq> \<real>" .
        from id have "[:- x, 1:] ^ Suc i dvd ?xi * ?xis" by auto
        from xixis this[unfolded order_divides]
        have "order x (?xi * ?xis) \<ge> Suc i" by auto
        with complex_conjugate_order[OF prems xixis, of x, folded xx]
        have "order xx (?xi * ?xis) \<ge> Suc i" by auto
        hence "order xx ?xi + order xx ?xis \<ge> Suc i" unfolding order_mult[OF xixis] .
        also have "order xx ?xi = 0" unfolding order_linear_power' using xxx by simp
        finally have "order xx ?xis \<ge> Suc i" by simp
        hence yis: "?xis = ?xxi * ?yis" unfolding yis
          by (rule delete_cnj, simp)
        hence "?xi * ?xis = (?xi * ?xxi) * ?yis" by (simp only: ac_simps)
        also have "?xi * ?xxi = ([:- x, 1:] * [:- xx, 1:])^Suc i"
          by (metis power_mult_distrib)
        also have "[:- x, 1:] * [:- xx, 1:] = ?cp xi" unfolding cpxi ..
        finally have idd: "?xi * ?xis = (?cp xi)^Suc i * ?yis" by simp
        from prems[unfolded idd] have R: "set (coeffs ((?cp xi)^Suc i * ?yis)) \<subseteq> \<real>" .
        have yis: "set (coeffs ?yis) \<subseteq> \<real>"
          by (rule real_poly_factor[OF R yi], auto, auto simp: xi_def)
        note IH = IH[OF yis]
        have "?rp (?xi * ?xis) = ?rp ?yi * ?rp ?yis" unfolding idd
          by (rule map_poly_Re_mult[OF yi yis])
        also have "?rp ?yi = xi^Suc i" by (fold hom_distribs, rule map_poly_Re_of_real)
        also have "?rp ?yis = (\<Prod> (a,b) \<leftarrow> ?fact yis. a ^ b)"
          using IH by auto
        also have "xi ^ Suc i * (\<Prod> (a,b) \<leftarrow> ?fact yis. a ^ b) =
          (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" unfolding fact by simp
        finally have idd: "?rp (?xi * ?xis) = (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" .
        show ?thesis unfolding id idd fact using IH xi' by auto
      qed
    qed
    thus ?thesis unfolding p by simp
  qed
  thus "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)"
  "(q,j) \<in> set qis \<Longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2}" by blast+
qed
end