(*header {* Section 3 --- All, Some, No *}*)

theory Section3
imports Main "~~/src/HOL/Library/Order_Relation"

begin

subsection {* Basic definitions *}

text {* \begin{tcolor} The set of atomic propositions is formalized as a
  type. \end{tcolor} *}
typedecl atProp

text {* The inductively defined set of formulas is formalised as a datatype *}
datatype formula =
    All atProp atProp ("All _ are _ ")
  | Some atProp atProp ("Some _ are _")
  | No atProp atProp ("No _ are _")

text {* The carrier of a model can be any type, written as alpha or
  @{typ 'a}.
  A model then is a function that assigns to each atomic proposition
  a subset of @{typ 'a} (its extension, ie, the subset where it is true).*}
type_synonym 'a model = "(atProp \<Rightarrow>'a set)"

text {* \begin{tcolor}The satisfiability relation is formalized as a Boolean valued
  function. The notation (@{text "_ \<Turnstile> _"}) allows us to use the usual
  mathematical notation \begin{qcolor}$M\models\phi$\end{qcolor} in Isabelle.\end{tcolor}*}
fun M_satisfies :: "'a model \<Rightarrow> formula \<Rightarrow> bool" ("_ \<Turnstile> _")
where
   "M_satisfies MM (All x are y) = (MM x \<subseteq> MM y)"
 | "M_satisfies MM (Some x are y) = (\<exists>e. e \<in> MM x \<inter> MM y)"
 | "M_satisfies MM (No x are y) = (MM x \<inter> MM y = {})"

thm M_satisfies.simps

(* model satisfies theory *)
definition M_satisfies_G :: "'a model \<Rightarrow> formula set \<Rightarrow> bool" ("_ \<Turnstile>M _")
where
  "M_satisfies_G M G  \<equiv> \<forall>f. f \<in> G \<longrightarrow> (M \<Turnstile> f)"

(* some useful rewrites for simplification, thanks to Thomas Tuerk *)
lemma M_satisfies_G_I [intro!]:
 "(\<And>f. f \<in> G \<Longrightarrow> M \<Turnstile> f) \<Longrightarrow> (M \<Turnstile>M G)"
unfolding M_satisfies_G_def by auto

lemma M_satisfies_G_rewrites [simp] :
  "(M \<Turnstile>M {})" (is ?g1) (* ak *)
  "(M \<Turnstile>M (insert g G)) \<longleftrightarrow> ((M \<Turnstile> g) \<and> (M \<Turnstile>M G))" (is ?g2)
  "(M \<Turnstile>M (G1 \<union> G2)) \<longleftrightarrow> ((M \<Turnstile>M G1) \<and> (M \<Turnstile>M G2))" (is ?g3)
proof -
  show ?g1 by auto (* thanks to intro-rule above *)
next
  show ?g2 unfolding M_satisfies_G_def by auto
next
  show ?g3 unfolding M_satisfies_G_def by auto
qed

lemma M_satisfies_G_mono :
assumes "G' \<subseteq> G"
    and "M \<Turnstile>M G"
  shows "M \<Turnstile>M G'"
using assms
  by (metis M_satisfies_G_def in_mono)

(* semantic consequence *)
definition G_satisfies :: "formula set \<Rightarrow> formula \<Rightarrow> 'a itself \<Rightarrow> bool" ("_ \<Turnstile>G _ _")
(* TT: use itself types, passing types around (and nothing else) is what they are for) *)
where
  "G_satisfies G f (ty :: 'a itself) \<equiv> \<forall> (M::'a model). (M \<Turnstile>M G) \<longrightarrow> (M \<Turnstile> f)"

lemma G_satisfies_I [intro]:
 "(\<And>(M::'a model). M \<Turnstile>M G \<Longrightarrow> M \<Turnstile> f) \<Longrightarrow> (G \<Turnstile>G f (ty :: 'a itself))"
unfolding G_satisfies_def by auto

(* Example 9 *)
lemma example_9: "{(All p are q), (Some p are r)} \<Turnstile>G (Some q are r) (TYPE (atProp))"
apply (rule G_satisfies_I)
apply (auto)
done

(* Example 10 *)
lemma example_10: "{(All p are v), (All q are w), (No v are w)} \<Turnstile>G (No p are q) (TYPE(atProp))"
apply (rule G_satisfies_I)
apply (auto)
done

(* Figure 3. The logical system for S *)
inductive der :: "formula \<Rightarrow> bool" ("\<turnstile>X _")
  where
    initA: "\<turnstile>X All X are X"
  | initS2: "\<turnstile>X Some X are Y \<Longrightarrow> \<turnstile>X Some X are X"
  | initN: "\<turnstile>X No X are X \<Longrightarrow> \<turnstile>X No X are Y"
  | initN2: "\<turnstile>X No X are X \<Longrightarrow> \<turnstile>X All X are Y"
  | transA: "\<lbrakk>\<turnstile>X All X are Y; \<turnstile>X All Y are Z\<rbrakk> \<Longrightarrow> \<turnstile>X All X are Z"
  | transS: "\<lbrakk>\<turnstile>X All Y are Z; \<turnstile>X Some X are Y\<rbrakk> \<Longrightarrow> \<turnstile>X Some X are Z"
  | transN: "\<lbrakk>\<turnstile>X All X are Y; \<turnstile>X No Y are Z\<rbrakk> \<Longrightarrow> \<turnstile>X No X are Z"
  | reflS: "\<turnstile>X Some X are Y \<Longrightarrow> \<turnstile>X Some Y are X"
  | reflN: "\<turnstile>X No X are Y \<Longrightarrow> \<turnstile>X No Y are X"
  | any: "\<lbrakk>\<turnstile>X Some X are Y; \<turnstile>X No X are Y\<rbrakk>  \<Longrightarrow> \<turnstile>X _"

inductive derarg :: "formula set \<Rightarrow> formula \<Rightarrow> bool" (" _ \<turnstile> _")
  for hs
  where
    initA: "hs \<turnstile> All X are X"
  | initS2: "hs \<turnstile> Some X are Y \<Longrightarrow> hs \<turnstile> Some X are X"
  | initN: "hs \<turnstile> No X are X \<Longrightarrow> hs \<turnstile> No X are Y"
  | initN2: "hs \<turnstile> No X are X \<Longrightarrow> hs \<turnstile> All X are Y"
  | transA: "\<lbrakk>hs \<turnstile> All X are Y; hs \<turnstile> All Y are Z\<rbrakk> \<Longrightarrow> hs \<turnstile> All X are Z"
  | transS: "\<lbrakk>hs \<turnstile> All Y are Z; hs \<turnstile> Some X are Y\<rbrakk> \<Longrightarrow> hs \<turnstile> Some X are Z"
  | transN: "\<lbrakk>hs \<turnstile> All X are Y; hs \<turnstile> No Y are Z\<rbrakk> \<Longrightarrow> hs \<turnstile> No X are Z"
  | reflS: "hs \<turnstile> Some X are Y \<Longrightarrow> hs \<turnstile> Some Y are X"
  | reflN: "hs \<turnstile> No X are Y \<Longrightarrow> hs \<turnstile> No Y are X"
  | any: "\<lbrakk>hs \<turnstile> Some X are Y; hs \<turnstile> No X are Y\<rbrakk>  \<Longrightarrow> hs \<turnstile> _"
  | ass: "f \<in> hs \<Longrightarrow>  hs \<turnstile> f"

(* ak: how to prove this for a generic G? *)
lemma G_derives_mono :
assumes "hs \<turnstile> f"
    and "hs \<subseteq> hs'"
shows "hs' \<turnstile> f"
(* apply (rule derarg.induct)
apply (rule assms)
apply (rule initA)
apply (rule initS2)
ak *)
using assms
proof (induct rule: derarg.induct)
  case (initA X)
  show ?case
  by (rule derarg.initA)
next
  case (initS2 X Y)
  from derarg.initS2[OF initS2(2)] initS2(3)
  show ?case .
next
  case (initN X Y)
  from derarg.initN[OF initN(2)] initN(3)
  show ?case .
next
  case (initN2 X Y)
  from derarg.initN2[OF initN2(2)] initN2(3)
  show ?case .
next
  case (transA X Y Z)
  from derarg.transA[OF transA(2) transA(4)] transA(5)
  show ?case by simp
next
  case(transS X Y Z)
  from derarg.transS[OF transS(2) transS(4)] transS(5)
  show ?case by simp
next
  case(transN X Y Z)
  from derarg.transN[OF transN(2) transN(4)] transN(5)
  show ?case by simp
next
  case(reflS X Y)
  from derarg.reflS[OF reflS(2)] reflS(3)
  show ?case .
next
  case(reflN X Y)
  from derarg.reflN[OF reflN(2)] reflN(3)
  show ?case .
next
  case(any X Y)
  from derarg.any[OF any(2) any(4)] any(5)
  show ?case by simp
next
  case(ass f)
  hence "f \<in> hs'" by auto
  from derarg.ass[OF this]
  show ?case .
print_cases
thm derarg.induct
qed

(* Example 14 *)
lemma example_14 : "{All p are v, All q are w, No v are w} \<turnstile> No p are q" (is "?hs \<turnstile> _")
proof -
  have p1: "?hs \<turnstile> All p are v" by (rule ass, simp)
  have p2: "?hs \<turnstile> All q are w" by (rule ass, simp)
  have p3: "?hs \<turnstile> No v are w" by (rule ass, simp)

  have p4: "?hs \<turnstile> No p are w" using transN [OF p1 p3] .
  have p5: "?hs \<turnstile> No w are p" using reflN [OF p4] .
  have p6: "?hs \<turnstile> No q are p" using transN [OF p2 p5] .
  show ?thesis using reflN [OF p6] .
qed

(* Section 3.3 *)

(* !!! from section 2 !!! *)

(* order induced on atomic propositions by a theory *)
definition less_equal_prop::
  "atProp \<Rightarrow> formula set \<Rightarrow> atProp \<Rightarrow> bool" ("_ \<lesssim> _ _")  where
  "less_equal_prop x G y \<equiv> G \<turnstile> All x are y"

(* TT: export the theorems for trans and refl, since they are useful in the following *)
lemma less_equal_prop_refl [simp]:
  "\<And>G x. x \<lesssim>G x"
unfolding less_equal_prop_def
  by (simp add: derarg.initA)

lemma less_equal_prop_trans:
  "\<And>G x y z. x \<lesssim>G y \<Longrightarrow> y \<lesssim>G z \<Longrightarrow> x \<lesssim>G z"
unfolding less_equal_prop_def
by (metis derarg.transA)

lemma less_equal_prop_ass [simp] :
  "(All u are v) \<in> G \<Longrightarrow> less_equal_prop u G v"
unfolding less_equal_prop_def by (rule ass) (* ak what does ass refer to ? *)

(* Proposition 2.1 *)
lemma prop_2_1:
  fixes G
  defines R_def: "R \<equiv> { (x,y). less_equal_prop x G y }"
  shows "preorder_on UNIV R" (* ak explain preorder_on UNIV *)
proof -
  have "refl R"
    by (simp add: refl_on_def R_def)
  have "trans R"
    by (metis assms less_equal_prop_trans mem_Collect_eq old.prod.case trans_def)
  with `refl R` show ?thesis by (simp add: preorder_on_def)
qed

(* TT: use top-level pattern matching, since it gives nicer rewrites ak *)

(* the set of all All formulas *)
fun form_all :: "formula \<Rightarrow> bool" where
    "form_all (All _ are _) = True"
  | "form_all _ = False"

lemma form_all_alt_def :
  "form_all f \<longleftrightarrow> (\<exists>p q. (f = All p are q))"
by (cases f) auto

(* the set of all Some formulas *)
fun form_some :: "formula \<Rightarrow> bool" where
    "form_some (Some _ are _) = True"
  | "form_some _ = False"

lemma form_some_alt_def :
  "form_some f \<longleftrightarrow> (\<exists>p q. (f = Some p are q))"
by (cases f) auto

(* the set of all No formulas *)
fun form_no :: "formula \<Rightarrow> bool" where
    "form_no (No _ are _) = True"
  | "form_no _ = False"

lemma form_no_alt_def :
  "form_no f \<longleftrightarrow> (\<exists>p q. (f = No p are q))"
by (cases f) auto

lemma forms_complete :
  "form_all f \<or> form_some f \<or> form_no f"
by (cases f) simp_all

lemma forms_distinct :
  "\<not>(form_all f) \<or> \<not>(form_some f)"
  "\<not>(form_all f) \<or> \<not>(form_no f)"
  "\<not>(form_some f) \<or> \<not>(form_no f)"
by (cases f, simp_all)+

definition "all_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_all x) }"
definition "some_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_some x) }"

(* TT: add useful rewrite early to simplifier *)
lemma in_all_formulas [simp] :
  "f \<in> all_formulas \<longleftrightarrow> form_all f"
unfolding all_formulas_def by simp

lemma in_some_formulas [simp] :
  "f \<in> some_formulas \<longleftrightarrow> form_some f"
unfolding some_formulas_def by simp

(* TT: now this is trivial *)

lemma "(All x are y) \<in> all_formulas" by simp
lemma "(No x are y) \<notin> some_formulas" by simp

definition "all_gamma G = G \<inter> all_formulas"
definition "some_gamma G = G \<inter> some_formulas"

definition "all_some_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_all x \<or> form_some x) }"
definition "all_some_gamma G = G \<inter> all_some_formulas"

(* TT: often it is useful to establish connections to existing constructs *)
lemma all_some_formulas_alt_def :
  "all_some_formulas = all_formulas \<union> some_formulas"
unfolding all_some_formulas_def all_formulas_def some_formulas_def by auto

lemma in_all_some_formulas [simp] :
  "f \<in> all_some_formulas \<longleftrightarrow> \<not>(form_no f)"
unfolding all_some_formulas_alt_def
by (cases f) simp_all

lemma all_some_gamma_alt_def :
  "all_some_gamma G = all_gamma G \<union> some_gamma G"
unfolding all_some_gamma_def all_some_formulas_alt_def all_gamma_def some_gamma_def
by auto

(* TT: I prefer this definition, since it introduces less cases and looks clearer.
       Due to less cases better for automation *)

definition char_model_ex6 :: "formula set \<Rightarrow> formula model" ("_ \<lbrakk>_\<rbrakk>") where
  "char_model_ex6 G u = {Some x are y | x y. ((Some x are y) \<in> G) \<and>
     (less_equal_prop x G u \<or> less_equal_prop y G u)}"
thm char_model_ex6_def

lemma exercise_6_1:
  fixes G
  defines "M \<equiv> char_model_ex6 G"
  assumes G_sub: "G \<subseteq> all_some_formulas"
  shows "M \<Turnstile>M G"
proof (rule M_satisfies_G_I)
  fix g
  assume "g \<in> G"
  show "M \<Turnstile> g"
  proof (cases g)
    case (No x y)
    with `g \<in> G` G_sub have False by auto
    thus ?thesis ..
  next
    case (All x y)
    note g_is_All = All

    from `g \<in> G` g_is_All
    have "less_equal_prop x G y"
      by auto

    thus ?thesis
      unfolding g_is_All M_def
      by (auto simp add: char_model_ex6_def)
         (metis less_equal_prop_trans)+
  next
    case (Some x y)
    note g_is_Some = Some

    have "g \<in> char_model_ex6 G x" "g \<in> char_model_ex6 G y"
      using `g \<in> G`
      unfolding g_is_Some char_model_ex6_def
      by simp_all
    thus ?thesis
      unfolding M_def g_is_Some
      by simp blast
  qed
qed

lemma exercise_6_2:
  fixes G
  defines "M \<equiv> char_model_ex6 G"
  assumes G_sub: "G \<subseteq> all_some_formulas"
  assumes M_sat: "M \<Turnstile> Some p are q"
  shows "G \<turnstile> Some p are q"
proof -
  have "\<exists>x y. (Some x are y) \<in> (M p \<inter> M q)"
  proof -
    from M_sat have "M p \<inter> M q \<noteq> {}" by auto
    then obtain e where "e \<in> M p" and "e \<in> M q" by auto

    from `e \<in> M p` have "form_some e"
      unfolding M_def by (auto simp add: char_model_ex6_def)

    from `form_some e` `e \<in> M p` `e \<in> M q`
    show ?thesis unfolding form_some_alt_def by auto
  qed
  then obtain x y where in_Mp: "(Some x are y) \<in> M p"
                    and in_Mq: "(Some x are y) \<in> M q" by auto

  from in_Mp have in_G: "(Some x are y) \<in> G"
    unfolding M_def char_model_ex6_def by simp

  from in_Mp in_Mq have some_x_y_p_q : "((x \<lesssim>G p) \<or> (y \<lesssim>G p))" "((x \<lesssim>G q) \<or> (y \<lesssim>G q))"
    unfolding M_def char_model_ex6_def by simp_all
  thus ?thesis
    by (metis ass derarg.initS2 derarg.reflS derarg.transS in_G less_equal_prop_def)
qed

(*declare [[show_types]]*)

lemma exercise_7_1:
  fixes G
  defines "G' \<equiv> G \<inter> all_some_formulas"
  defines "M \<equiv> char_model_ex6 G'"
  assumes G_sat: "G \<Turnstile>G Some p are q (TYPE(formula))"
  assumes M_sat_G: "M \<Turnstile>M G"
  shows "G \<turnstile> Some p are q"
proof -

  have 1: "G' \<subseteq> all_some_formulas"
    by (metis G'_def Int_lower2)
 (* have 2: "M \<Turnstile>M G'"
    by (metis G'_def M_sat_G M_satisfies_G_rewrites(3) sup_inf_absorb)
  *)
  have 2: "M \<Turnstile> Some p are q"
    using G_sat M_sat_G
    unfolding G_satisfies_def
    by simp

  from 1 2 have "G' \<turnstile> Some p are q"
    using exercise_6_2[of G']
    unfolding M_def
    by metis
  thus ?thesis
    by (metis G'_def G_derives_mono Int_lower1)
qed

lemma exercise_7_2:
  fixes G
  defines "G' \<equiv> G \<inter> all_some_formulas"
  defines "M \<equiv> char_model_ex6 G'"
  assumes G_sat: "G \<Turnstile>G Some p are q (TYPE(formula))"
  assumes not_M_sat_G: "\<not>(M \<Turnstile>M G)"
  shows "G \<turnstile> Some p are q"
proof -
  from not_M_sat_G have 1: "\<exists> f \<in> G. \<not>(M \<Turnstile> f)"
    by (metis M_satisfies_G_def)

  then obtain x y where "(No x are y) \<in> G" and  "\<not>(M \<Turnstile> No x are y)"
    by (metis G'_def IntI Int_lower2 M_def M_satisfies_G_def exercise_6_1 form_no.elims(2) in_all_some_formulas)

  then have "M x \<inter> M y \<noteq> {}" by simp
  then have "G' \<turnstile> Some x are y"
    using exercise_6_2[of G']
    by (metis G'_def IntE M_def M_satisfies.simps(2) ex_in_conv subsetI)

  then have "G \<turnstile> Some x are y"
    by (metis G'_def G_derives_mono Int_lower1)

  from `(No x are y) \<in> G` have "G \<turnstile> No x are y" by (rule derarg.ass)
  thus ?thesis
    using `G \<turnstile> Some x are y`
    by (metis derarg.any)
qed

definition "no_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_no x) }"

definition "no_gamma G = G \<inter> no_formulas"

definition "all_no_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_all x \<or> form_no x) }"
definition "all_no_gamma G = G \<inter> all_no_formulas"

definition "all_some_no_formulas = {x. x \<in> (UNIV::formula set) \<and> (form_all x \<or> form_some x \<or> form_no x) }"

(* TT: often it is useful to establish connections to existing constructs *)
lemma all_no_formulas_alt_def :
  "all_no_formulas = all_formulas \<union> no_formulas"
unfolding all_no_formulas_def all_formulas_def no_formulas_def by auto

lemma in_all_no_formulas [simp] :
  "f \<in> all_no_formulas \<longleftrightarrow> \<not>(form_some f)"
unfolding all_no_formulas_alt_def
by (metis (lifting) UNIV_I all_no_formulas_alt_def all_no_formulas_def all_some_formulas_def forms_distinct(1) in_all_some_formulas mem_Collect_eq)

lemma all_no_gamma_alt_def :
  "all_no_gamma G = all_gamma G \<union> no_gamma G"
unfolding all_no_gamma_def all_no_formulas_alt_def all_gamma_def no_gamma_def
by auto

definition up_closed :: "atProp set \<Rightarrow> formula set \<Rightarrow> bool" where
  "up_closed A G \<equiv> \<forall>v \<in> A. \<forall>w. (v \<lesssim>G w) \<longrightarrow> w \<in> A"

definition does_not_derive :: "atProp set \<Rightarrow> formula set \<Rightarrow> bool" where
  "does_not_derive A G \<equiv> \<forall>v \<in> A. \<forall>w \<in> A. \<not>(G \<turnstile> No v are w)"

definition "M_ex7 G \<equiv> {A. A \<subseteq> (UNIV::atProp set) \<and> (up_closed A G) \<and> (does_not_derive A G) }"

definition char_model_ex8 :: "formula set \<Rightarrow> (atProp set) model" where
  "char_model_ex8 G v = { A. A \<in> (M_ex7 G) \<and> v \<in> A }"

lemma exercise_8_1:
  fixes G
  defines "M \<equiv> char_model_ex8 G"
  assumes G_sub: "G \<subseteq> all_no_formulas"
  shows "M \<Turnstile>M G"
proof (rule M_satisfies_G_I)
  fix g
  assume "g \<in> G"

  show "M \<Turnstile> g"
  proof (cases g)
    case (Some x y)
    with `g \<in> G` G_sub have False by auto
    thus ?thesis ..
  next
    case (All x y)
    then have "x \<lesssim>G y"
      using `g \<in> G`
      by (metis less_equal_prop_ass)
    then have "M x \<subseteq> M y"
      unfolding M_def char_model_ex8_def M_ex7_def
      by simp (metis (lifting, no_types) Collect_mono up_closed_def)
    thus ?thesis
      by (metis M_satisfies.simps(1) All)
  next
    case (No x y)
    then have g_derives_n : "G \<turnstile> No x are y"
      using `g \<in> G`
      by (metis ass)
    {
      fix X
      assume "X \<in> M x"
      have "X \<notin> M y"
        proof (rule notI)
          assume "X \<in> M y"
          have 1: "x \<in> X"
            by (metis (lifting) M_def `X \<in> M x` char_model_ex8_def mem_Collect_eq)
          have 2: "y \<in> X"
            by (metis (lifting) M_def `X \<in> M y` char_model_ex8_def mem_Collect_eq)
          from 1 2 `X \<in> M x` have "\<not>(G \<turnstile> No x are y)"
            unfolding M_def char_model_ex8_def M_ex7_def does_not_derive_def
            by auto
          then have "X \<notin> M x"
            by (metis g_derives_n)
          with `X \<in> M x` show False by metis
        qed
    }
    hence "M x \<inter> M y = {}" by auto
    thus ?thesis
      by (metis M_satisfies.simps(3) No)
  qed
qed

lemma exercise_8_2:
  fixes G
  defines "M \<equiv> char_model_ex8 G"
  assumes G_sub: "G \<subseteq> all_no_formulas"
  assumes g_in_all_no : "g \<in> all_no_formulas"
  and "M \<Turnstile> g"
  shows "G \<turnstile> g"
proof -
  show ?thesis
  proof (cases g)
    case(Some x y)
    with g_in_all_no have False by simp
    thus ?thesis ..
  next
    case(All x y)
    {
      define Ax where "Ax = { z. x \<lesssim>G z }"

      have ?thesis
      proof (cases "Ax \<in> M_ex7 G")
        case (True)
        have x_in_Ax : "x \<in> Ax"
          by (metis Ax_def less_equal_prop_refl mem_Collect_eq)
        have "M \<Turnstile> All x are y"
          using exercise_8_1[of G]
          by (metis All `M \<Turnstile> g`)
        then have "M x \<subseteq> M y" by simp
        from x_in_Ax `Ax \<in> M_ex7 G` have Ax_in_Mx : "Ax \<in> M x"
          by (metis (lifting) M_def char_model_ex8_def mem_Collect_eq)
        from `M x \<subseteq> M y` Ax_in_Mx have Ax_in_My : "Ax \<in> M y"
          by (metis subsetD)
        from Ax_in_My Ax_def have y_in_Ax : "y \<in> Ax"
          by (metis (lifting) M_def char_model_ex8_def mem_Collect_eq)
        from x_in_Ax y_in_Ax Ax_def have "x \<lesssim>G y"
          by (metis mem_Collect_eq)
        then have A_in_M: "G \<turnstile> All x are y"
          by (metis less_equal_prop_def)
        thus ?thesis by (metis All)
      next
        case (False)
        then have "\<not>(does_not_derive Ax G)"
          by (metis (lifting, no_types) M_ex7_def less_equal_prop_trans mem_Collect_eq Ax_def top_greatest up_closed_def)
        then have "\<exists>v \<in> Ax. \<exists>w \<in> Ax. (G \<turnstile> No v are w)"
          unfolding M_ex7_def does_not_derive_def
          by simp
        then obtain v w where no_v_w : "(G \<turnstile> No v are w)" by metis
        then have cases_x :"(x \<lesssim>G v)" "(x \<lesssim>G w)"
          by (metis (mono_tags) `\<exists>v\<in>Ax. \<exists>w\<in>Ax. (G \<turnstile> No v are w)` derarg.initN2 derarg.reflN derarg.transN less_equal_prop_def mem_Collect_eq order_refl Ax_def set_rev_mp)+

        from cases_x(1) have all_x_v : "G \<turnstile> All x are v" by (metis less_equal_prop_def)
        from all_x_v no_v_w have no_x_w : "G \<turnstile> No x are w" by (metis all_x_v derarg.transN)
        from no_x_w cases_x(2) have "G \<turnstile> No x are x" by (metis derarg.reflN derarg.transN less_equal_prop_def)
        then have "G \<turnstile> All x are y" by (rule derarg.initN2)
        thus ?thesis by (metis All)
      qed
    }
    thus ?thesis
      by metis
  next
    case (No x y)
    {
      define Axy where "Axy = { z. (x \<lesssim>G z) \<or> (y \<lesssim>G z) }"

      have "Axy \<notin> M_ex7 G"
      proof (rule notI)
        assume "Axy \<in> M_ex7 G"
        from `M \<Turnstile> g` No have "M x \<inter> M y = {}" by simp
        have 1 : "Axy \<in> M x"
          by (metis (lifting, no_types) Axy_def M_def `Axy \<in> M_ex7 G` char_model_ex8_def less_equal_prop_refl mem_Collect_eq)
        have 2 : "Axy \<in> M y"
          by (metis (lifting, no_types) Axy_def M_def `Axy \<in> M_ex7 G` char_model_ex8_def less_equal_prop_refl mem_Collect_eq)
        from 1 2 have "M x \<inter> M y \<noteq> {}" by auto
        with `M x \<inter> M y = {}` show False by simp
      qed
      then have "\<not>(does_not_derive Axy G)"
        by (metis (lifting) Axy_def M_ex7_def less_equal_prop_trans mem_Collect_eq subset_UNIV up_closed_def)
      then have "\<exists>v \<in> Axy. \<exists>w \<in> Axy. (G \<turnstile> No v are w)"
        unfolding M_ex7_def does_not_derive_def
        by simp
      then obtain v w where "G \<turnstile> No v are w" "v \<in> Axy" "w \<in> Axy" by auto
      then have cases : "(x \<lesssim>G v) \<or> (y \<lesssim>G v)" "(x \<lesssim>G w) \<or> (y \<lesssim>G w)"
        by (metis mem_Collect_eq Axy_def)+

      note case1_e = disjE[OF cases(1)]
      note case2_e = disjE[OF cases(2)]
      note cases_elim = case1_e[case_product case2_e, case_names 1 2 3 4]
      have ?thesis
      proof (cases rule: cases_elim)
        case 1
        then have "G \<turnstile> All x are v" "G \<turnstile> All x are w" by (metis less_equal_prop_def)+
        with `G \<turnstile> No v are w` have "G \<turnstile> No x are w" by (metis derarg.transN)
        then have "G \<turnstile> No w are x" by (rule derarg.reflN)
        with `G \<turnstile> All x are w` have "G \<turnstile> No x are x" by (rule derarg.transN)
        then have "G \<turnstile> No x are y" by (rule derarg.initN)
        thus ?thesis by (metis No)
      next
        case 2
        then have "G \<turnstile> All x are v" "G \<turnstile> All y are w" by (metis less_equal_prop_def)+
        with `G \<turnstile> No v are w` have "G \<turnstile> No x are w" by (metis derarg.transN)
        then have "G \<turnstile> No w are x" by (rule derarg.reflN)
        with `G \<turnstile> All y are w` have "G \<turnstile> No x are y" by (metis derarg.reflN derarg.transN)
        thus ?thesis by (metis No)
      next
        case 3
        then have "G \<turnstile> All y are v" "G \<turnstile> All x are w" by (metis less_equal_prop_def)+
        with `G \<turnstile> No v are w` have "G \<turnstile> No y are w" by (metis derarg.transN)
        then have "G \<turnstile> No w are y" by (rule derarg.reflN)
        with `G \<turnstile> All x are w` have "G \<turnstile> No x are y" by (metis derarg.transN)
        thus ?thesis by (metis No)
      next
        case 4
        then have "G \<turnstile> All y are v" "G \<turnstile> All y are w" by (metis less_equal_prop_def)+
        with `G \<turnstile> No v are w` have "G \<turnstile> No y are w" by (metis derarg.transN)
        then have "G \<turnstile> No w are y" by (rule derarg.reflN)
        with `G \<turnstile> All y are w` have "G \<turnstile> No y are y" by (rule derarg.transN)
        then have "G \<turnstile> No x are y" by (metis derarg.initN derarg.reflN)
        thus ?thesis by (metis No)
      qed
    }
    thus ?thesis by metis
  qed
qed

lemma a :"(A::formula set) \<inter> all_some_no_formulas \<equiv> A"
proof -
  have "\<forall>a \<in> A. a \<in> all_some_no_formulas"
    by (metis (lifting) UNIV_I all_some_no_formulas_def forms_complete mem_Collect_eq)
  then have "A \<subseteq> {x \<in> UNIV. form_all x \<or> form_some x \<or> form_no x}"
    by (metis all_some_no_formulas_def subsetI)
  then have "A = A \<inter> {x \<in> UNIV. form_all x \<or> form_some x \<or> form_no x}"
    by (metis eq_iff inf.bounded_iff inf.cobounded1 subset_refl)
  then show "(A::formula set) \<inter> all_some_no_formulas \<equiv> A"
    unfolding all_some_no_formulas_def by auto
qed

lemma intersect:
  fixes G
  defines "Gall_no \<equiv> G \<inter> all_no_formulas"
    and "Gsome \<equiv> G \<inter> some_formulas"
    shows "G = Gall_no \<union> Gsome"
proof (simp add:Gall_no_def all_no_formulas_def Gsome_def some_formulas_def)
  have 1: "G \<inter> ({x. form_all x \<or> form_no x} \<union> {x. form_some x}) = G \<inter> {x. form_all x \<or> form_no x} \<union> G \<inter> {x. form_some x}"
    by auto
  have 2: "({x. form_all x \<or> form_no x} \<union> {x. form_some x}) = all_some_no_formulas"
  proof -
    have "Collect form_all \<union> (Collect form_some \<union> Collect form_no) = all_some_no_formulas"
      using all_some_no_formulas_def by auto
    thus "{x. form_all x \<or> form_no x} \<union> {x. form_some x} = all_some_no_formulas"
      by (metis Collect_disj_eq sup_commute sup_left_commute)
  qed
  have "G \<inter> all_some_no_formulas = G \<inter> {x. form_all x \<or> form_no x} \<union> G \<inter> {x. form_some x}"
    by (metis "1" "2" Collect_disj_eq a)
  then have "G = G \<inter> {x. form_all x \<or> form_no x} \<union> G \<inter> {x. form_some x}"
    by (metis a)
  then show "G = G \<inter> {x. form_all x \<or> form_no x} \<union> G \<inter> {x. form_some x}" by fast
qed

theorem exercise_9:
  fixes G
  assumes G_sat1 : "G \<Turnstile>G g TYPE(formula)"
      and G_sat2 : "G \<Turnstile>G g TYPE((atProp set))"
  shows "G \<turnstile> g"
proof -
  have all_no_form_der_g : "g \<in> all_no_formulas \<Longrightarrow> G \<turnstile> g"
  proof -
    assume "g \<in> all_no_formulas"
    define G' where "G' = G \<inter> all_no_formulas"
    define M where "M = char_model_ex8 G'"
    define Gsome where "Gsome = G \<inter> some_formulas"

    show ?thesis
    proof (cases "M \<Turnstile>M Gsome")
      case(True)
      have "G' \<subseteq> all_no_formulas"
        by (metis G'_def Int_lower2)
      have M_sat_G': "M \<Turnstile>M G'"
        by (metis G'_def M_def exercise_8_1 inf.cobounded1 inf_commute)
      have "G' \<union> Gsome = G"
        by (metis G'_def Gsome_def intersect)
      with M_sat_G' have M_sat_G : "M \<Turnstile>M G"
        by (metis M_satisfies_G_rewrites(3) True)
      then have "M \<Turnstile> g"
        by (metis G_satisfies_def G_sat2)
      then have "G' \<turnstile> g"
        using exercise_8_2[of G' g]
        by (metis M_def `g \<in> all_no_formulas` `G' \<subseteq> all_no_formulas`)
      then show ?thesis
        by (metis G'_def G_derives_mono inf.cobounded2 inf_commute)
    next
      case (False)
      then have "\<not>(M \<Turnstile>M G)"
        by (metis Gsome_def M_satisfies_G_rewrites(3) sup_inf_absorb)
      have "G' \<subseteq> all_no_formulas"
        by (metis G'_def Int_lower2)
      from False have 1: "\<exists>f \<in> Gsome. \<not>(M \<Turnstile> f)" by fast
      obtain f where dNd : "f \<in> Gsome" "\<not>(M \<Turnstile> f)"
        by (metis "1")
      obtain x y where Sxy : "f = Some x are y"
        by (metis Gsome_def Int_iff dNd(1) form_some.elims(2) in_some_formulas)
      from dNd have dNdSxy: "\<not>(M \<Turnstile> Some x are y)"
        by (metis Sxy)
      from dNdSxy have "M x \<inter> M y = {}" by auto
      then obtain f' where derNxy : "M \<Turnstile> f'" "f' = No x are y" by (metis M_satisfies.simps(3))
      have "f' \<in> all_no_formulas"
        by (metis derNxy(2) form_some.simps(3) in_all_no_formulas)
      then have "G' \<turnstile> f'"
        using exercise_8_2[of G' f']
        by (metis M_def `G' \<subseteq> all_no_formulas` derNxy(1))
      then have "G \<turnstile> No x are y" by (metis G'_def G_derives_mono Int_lower1 derNxy(2))
      have "G \<turnstile> Some x are y" by (metis Gsome_def IntE Sxy ass dNd(1))
      with `G \<turnstile> No x are y` show ?thesis by (metis derarg.any)
    qed
  qed

  show ?thesis
  proof (cases g)
    case (Some x y)
    show ?thesis
     by (metis G_sat1 Some exercise_7_1 exercise_7_2)
  next
    case (All x y)
    have "g \<in> all_no_formulas"
     by (metis All form_some.simps(2) in_all_no_formulas)
    with all_no_form_der_g show ?thesis by auto
  next
    case (No x y)
    have "g \<in> all_no_formulas"
     by (metis No form_some.simps(3) in_all_no_formulas)
    with all_no_form_der_g show ?thesis by auto
  qed
qed

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Comparing growth of functions on natural numbers by a preorder relation\<close>

theory Function_Growth
imports Main Preorder Discrete
begin

(* FIXME move *)

context linorder
begin

lemma mono_invE:
  fixes f :: "'a \<Rightarrow> 'b::order"
  assumes "mono f"
  assumes "f x < f y"
  obtains "x < y"
proof
  show "x < y"
  proof (rule ccontr)
    assume "\<not> x < y"
    then have "y \<le> x" by simp
    with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
    with \<open>f x < f y\<close> show False by simp
  qed
qed

end

lemma (in semidom_divide) power_diff:
  fixes a :: 'a
  assumes "a \<noteq> 0"
  assumes "m \<ge> n"
  shows "a ^ (m - n) = (a ^ m) div (a ^ n)"
proof -
  define q where "q = m - n"
  with assms have "m = q + n" by (simp add: q_def)
  with q_def show ?thesis using \<open>a \<noteq> 0\<close> by (simp add: power_add)
qed

subsection \<open>Motivation\<close>

text \<open>
  When comparing growth of functions in computer science, it is common to adhere
  on Landau Symbols (``O-Notation'').  However these come at the cost of notational
  oddities, particularly writing \<open>f = O(g)\<close> for \<open>f \<in> O(g)\<close> etc.

  Here we suggest a different way, following Hardy (G.~H.~Hardy and J.~E.~Littlewood,
  Some problems of Diophantine approximation, Acta Mathematica 37 (1914), p.~225).
  We establish a quasi order relation \<open>\<lesssim>\<close> on functions such that
  \<open>f \<lesssim> g \<longleftrightarrow> f \<in> O(g)\<close>.  From a didactic point of view, this does not only
  avoid the notational oddities mentioned above but also emphasizes the key insight
  of a growth hierarchy of functions:
  \<open>(\<lambda>n. 0) \<lesssim> (\<lambda>n. k) \<lesssim> Discrete.log \<lesssim> Discrete.sqrt \<lesssim> id \<lesssim> \<dots>\<close>.
\<close>

subsection \<open>Model\<close>

text \<open>
  Our growth functions are of type \<open>\<nat> \<Rightarrow> \<nat>\<close>.  This is different
  to the usual conventions for Landau symbols for which \<open>\<real> \<Rightarrow> \<real>\<close>
  would be appropriate, but we argue that \<open>\<real> \<Rightarrow> \<real>\<close> is more
  appropriate for analysis, whereas our setting is discrete.

  Note that we also restrict the additional coefficients to \<open>\<nat>\<close>, something
  we discuss at the particular definitions.
\<close>

subsection \<open>The \<open>\<lesssim>\<close> relation\<close>

definition less_eq_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<lesssim>" 50)
where
  "f \<lesssim> g \<longleftrightarrow> (\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m)"

text \<open>
  This yields \<open>f \<lesssim> g \<longleftrightarrow> f \<in> O(g)\<close>.  Note that \<open>c\<close> is restricted to
  \<open>\<nat>\<close>.  This does not pose any problems since if \<open>f \<in> O(g)\<close> holds for
  a \<open>c \<in> \<real>\<close>, it also holds for \<open>\<lceil>c\<rceil> \<in> \<nat>\<close> by transitivity.
\<close>

lemma less_eq_funI [intro?]:
  assumes "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m"
  shows "f \<lesssim> g"
  unfolding less_eq_fun_def by (rule assms)

lemma not_less_eq_funI:
  assumes "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * g m < f m"
  shows "\<not> f \<lesssim> g"
  using assms unfolding less_eq_fun_def linorder_not_le [symmetric] by blast

lemma less_eq_funE [elim?]:
  assumes "f \<lesssim> g"
  obtains n c where "c > 0" and "\<And>m. m > n \<Longrightarrow> f m \<le> c * g m"
  using assms unfolding less_eq_fun_def by blast

lemma not_less_eq_funE:
  assumes "\<not> f \<lesssim> g" and "c > 0"
  obtains m where "m > n" and "c * g m < f m"
  using assms unfolding less_eq_fun_def linorder_not_le [symmetric] by blast

subsection \<open>The \<open>\<approx>\<close> relation, the equivalence relation induced by \<open>\<lesssim>\<close>\<close>

definition equiv_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<cong>" 50)
where
  "f \<cong> g \<longleftrightarrow>
    (\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n. \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m)"

text \<open>
  This yields \<open>f \<cong> g \<longleftrightarrow> f \<in> \<Theta>(g)\<close>.  Concerning \<open>c\<^sub>1\<close> and \<open>c\<^sub>2\<close>
  restricted to @{typ nat}, see note above on \<open>(\<lesssim>)\<close>.
\<close>

lemma equiv_funI:
  assumes "\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n. \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
  shows "f \<cong> g"
  unfolding equiv_fun_def by (rule assms)

lemma not_equiv_funI:
  assumes "\<And>c\<^sub>1 c\<^sub>2 n. c\<^sub>1 > 0 \<Longrightarrow> c\<^sub>2 > 0 \<Longrightarrow>
    \<exists>m>n. c\<^sub>1 * f m < g m \<or> c\<^sub>2 * g m < f m"
  shows "\<not> f \<cong> g"
  using assms unfolding equiv_fun_def linorder_not_le [symmetric] by blast

lemma equiv_funE:
  assumes "f \<cong> g"
  obtains n c\<^sub>1 c\<^sub>2 where "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
    and "\<And>m. m > n \<Longrightarrow> f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
  using assms unfolding equiv_fun_def by blast

lemma not_equiv_funE:
  fixes n c\<^sub>1 c\<^sub>2
  assumes "\<not> f \<cong> g" and "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
  obtains m where "m > n"
    and "c\<^sub>1 * f m < g m \<or> c\<^sub>2 * g m < f m"
  using assms unfolding equiv_fun_def linorder_not_le [symmetric] by blast

subsection \<open>The \<open>\<prec>\<close> relation, the strict part of \<open>\<lesssim>\<close>\<close>

definition less_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<prec>" 50)
where
  "f \<prec> g \<longleftrightarrow> f \<lesssim> g \<and> \<not> g \<lesssim> f"

lemma less_funI:
  assumes "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m"
    and "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * f m < g m"
  shows "f \<prec> g"
  using assms unfolding less_fun_def less_eq_fun_def linorder_not_less [symmetric] by blast

lemma not_less_funI:
  assumes "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * g m < f m"
    and "\<exists>c>0. \<exists>n. \<forall>m>n. g m \<le> c * f m"
  shows "\<not> f \<prec> g"
  using assms unfolding less_fun_def less_eq_fun_def linorder_not_less [symmetric] by blast

lemma less_funE [elim?]:
  assumes "f \<prec> g"
  obtains n c where "c > 0" and "\<And>m. m > n \<Longrightarrow> f m \<le> c * g m"
    and "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * f m < g m"
proof -
  from assms have "f \<lesssim> g" and "\<not> g \<lesssim> f" by (simp_all add: less_fun_def)
  from \<open>f \<lesssim> g\<close> obtain n c where *:"c > 0" "m > n \<Longrightarrow> f m \<le> c * g m" for m
    by (rule less_eq_funE) blast
  { fix c n :: nat
    assume "c > 0"
    with \<open>\<not> g \<lesssim> f\<close> obtain m where "m > n" "c * f m < g m"
      by (rule not_less_eq_funE) blast
    then have **: "\<exists>m>n. c * f m < g m" by blast
  } note ** = this
  from * ** show thesis by (rule that)
qed

lemma not_less_funE:
  assumes "\<not> f \<prec> g" and "c > 0"
  obtains m where "m > n" and "c * g m < f m"
    | d q where "\<And>m. d > 0 \<Longrightarrow> m > q \<Longrightarrow> g q \<le> d * f q"
  using assms unfolding less_fun_def linorder_not_less [symmetric] by blast

text \<open>
  I did not find a proof for \<open>f \<prec> g \<longleftrightarrow> f \<in> o(g)\<close>.  Maybe this only
  holds if \<open>f\<close> and/or \<open>g\<close> are of a certain class of functions.
  However \<open>f \<in> o(g) \<longrightarrow> f \<prec> g\<close> is provable, and this yields a
  handy introduction rule.

  Note that D. Knuth ignores \<open>o\<close> altogether.  So what \dots

  Something still has to be said about the coefficient \<open>c\<close> in
  the definition of \<open>(\<prec>)\<close>.  In the typical definition of \<open>o\<close>,
  it occurs on the \emph{right} hand side of the \<open>(>)\<close>.  The reason
  is that the situation is dual to the definition of \<open>O\<close>: the definition
  works since \<open>c\<close> may become arbitrary small.  Since this is not possible
  within @{term \<nat>}, we push the coefficient to the left hand side instead such
  that it may become arbitrary big instead.
\<close>

lemma less_fun_strongI:
  assumes "\<And>c. c > 0 \<Longrightarrow> \<exists>n. \<forall>m>n. c * f m < g m"
  shows "f \<prec> g"
proof (rule less_funI)
  have "1 > (0::nat)" by simp
  with assms [OF this] obtain n where *: "m > n \<Longrightarrow> 1 * f m < g m" for m
    by blast
  have "\<forall>m>n. f m \<le> 1 * g m"
  proof (rule allI, rule impI)
    fix m
    assume "m > n"
    with * have "1 * f m < g m" by simp
    then show "f m \<le> 1 * g m" by simp
  qed
  with \<open>1 > 0\<close> show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m" by blast
  fix c n :: nat
  assume "c > 0"
  with assms obtain q where "m > q \<Longrightarrow> c * f m < g m" for m by blast
  then have "c * f (Suc (q + n)) < g (Suc (q + n))" by simp
  moreover have "Suc (q + n) > n" by simp
  ultimately show "\<exists>m>n. c * f m < g m" by blast
qed

subsection \<open>\<open>\<lesssim>\<close> is a preorder\<close>

text \<open>This yields all lemmas relating \<open>\<lesssim>\<close>, \<open>\<prec>\<close> and \<open>\<cong>\<close>.\<close>

interpretation fun_order: preorder_equiv less_eq_fun less_fun
  rewrites "fun_order.equiv = equiv_fun"
proof -
  interpret preorder: preorder_equiv less_eq_fun less_fun
  proof
    fix f g h
    show "f \<lesssim> f"
    proof
      have "\<exists>n. \<forall>m>n. f m \<le> 1 * f m" by auto
      then show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * f m" by blast
    qed
    show "f \<prec> g \<longleftrightarrow> f \<lesssim> g \<and> \<not> g \<lesssim> f"
      by (fact less_fun_def)
    assume "f \<lesssim> g" and "g \<lesssim> h"
    show "f \<lesssim> h"
    proof
      from \<open>f \<lesssim> g\<close> obtain n\<^sub>1 c\<^sub>1
        where "c\<^sub>1 > 0" and P\<^sub>1: "\<And>m. m > n\<^sub>1 \<Longrightarrow> f m \<le> c\<^sub>1 * g m"
        by rule blast
      from \<open>g \<lesssim> h\<close> obtain n\<^sub>2 c\<^sub>2
        where "c\<^sub>2 > 0" and P\<^sub>2: "\<And>m. m > n\<^sub>2 \<Longrightarrow> g m \<le> c\<^sub>2 * h m"
        by rule blast
      have "\<forall>m>max n\<^sub>1 n\<^sub>2. f m \<le> (c\<^sub>1 * c\<^sub>2) * h m"
      proof (rule allI, rule impI)
        fix m
        assume Q: "m > max n\<^sub>1 n\<^sub>2"
        from P\<^sub>1 Q have *: "f m \<le> c\<^sub>1 * g m" by simp
        from P\<^sub>2 Q have "g m \<le> c\<^sub>2 * h m" by simp
        with \<open>c\<^sub>1 > 0\<close> have "c\<^sub>1 * g m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by simp
        with * show "f m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by (rule order_trans)
      qed
      then have "\<exists>n. \<forall>m>n. f m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by rule
      moreover from \<open>c\<^sub>1 > 0\<close> \<open>c\<^sub>2 > 0\<close> have "c\<^sub>1 * c\<^sub>2 > 0" by simp
      ultimately show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * h m" by blast
    qed
  qed
  from preorder.preorder_equiv_axioms show "class.preorder_equiv less_eq_fun less_fun" .
  show "preorder_equiv.equiv less_eq_fun = equiv_fun"
  proof (rule ext, rule ext, unfold preorder.equiv_def)
    fix f g
    show "f \<lesssim> g \<and> g \<lesssim> f \<longleftrightarrow> f \<cong> g"
    proof
      assume "f \<cong> g"
      then obtain n c\<^sub>1 c\<^sub>2 where "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
        and *: "\<And>m. m > n \<Longrightarrow> f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
        by (rule equiv_funE) blast
      have "\<forall>m>n. f m \<le> c\<^sub>1 * g m"
      proof (rule allI, rule impI)
        fix m
        assume "m > n"
        with * show "f m \<le> c\<^sub>1 * g m" by simp
      qed
      with \<open>c\<^sub>1 > 0\<close> have "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m" by blast
      then have "f \<lesssim> g" ..
      have "\<forall>m>n. g m \<le> c\<^sub>2 * f m"
      proof (rule allI, rule impI)
        fix m
        assume "m > n"
        with * show "g m \<le> c\<^sub>2 * f m" by simp
      qed
      with \<open>c\<^sub>2 > 0\<close> have "\<exists>c>0. \<exists>n. \<forall>m>n. g m \<le> c * f m" by blast
      then have "g \<lesssim> f" ..
      from \<open>f \<lesssim> g\<close> and \<open>g \<lesssim> f\<close> show "f \<lesssim> g \<and> g \<lesssim> f" ..
    next
      assume "f \<lesssim> g \<and> g \<lesssim> f"
      then have "f \<lesssim> g" and "g \<lesssim> f" by auto
      from \<open>f \<lesssim> g\<close> obtain n\<^sub>1 c\<^sub>1 where "c\<^sub>1 > 0"
        and P\<^sub>1: "\<And>m. m > n\<^sub>1 \<Longrightarrow> f m \<le> c\<^sub>1 * g m" by rule blast
      from \<open>g \<lesssim> f\<close> obtain n\<^sub>2 c\<^sub>2 where "c\<^sub>2 > 0"
        and P\<^sub>2: "\<And>m. m > n\<^sub>2 \<Longrightarrow> g m \<le> c\<^sub>2 * f m" by rule blast
      have "\<forall>m>max n\<^sub>1 n\<^sub>2. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
      proof (rule allI, rule impI)
        fix m
        assume Q: "m > max n\<^sub>1 n\<^sub>2"
        from P\<^sub>1 Q have "f m \<le> c\<^sub>1 * g m" by simp
        moreover from P\<^sub>2 Q have "g m \<le> c\<^sub>2 * f m" by simp
        ultimately show "f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m" ..
      qed
      with \<open>c\<^sub>1 > 0\<close> \<open>c\<^sub>2 > 0\<close> have "\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n.
        \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m" by blast
      then show "f \<cong> g" by (rule equiv_funI)
    qed
  qed
qed

declare fun_order.antisym [intro?]

subsection \<open>Simple examples\<close>

text \<open>
  Most of these are left as constructive exercises for the reader.  Note that additional
  preconditions to the functions may be necessary.  The list here is by no means to be
  intended as complete construction set for typical functions, here surely something
  has to be added yet.
\<close>

text \<open>@{prop "(\<lambda>n. f n + k) \<cong> f"}\<close>

lemma equiv_fun_mono_const:
  assumes "mono f" and "\<exists>n. f n > 0"
  shows "(\<lambda>n. f n + k) \<cong> f"
proof (cases "k = 0")
  case True then show ?thesis by simp
next
  case False
  show ?thesis
  proof
    show "(\<lambda>n. f n + k) \<lesssim> f"
    proof
      from \<open>\<exists>n. f n > 0\<close> obtain n where "f n > 0" ..
      have "\<forall>m>n. f m + k \<le> Suc k * f m"
      proof (rule allI, rule impI)
        fix m
        assume "n < m"
        with \<open>mono f\<close> have "f n \<le> f m"
          using less_imp_le_nat monoE by blast
        with  \<open>0 < f n\<close> have "0 < f m" by auto
        then obtain l where "f m = Suc l" by (cases "f m") simp_all
        then show "f m + k \<le> Suc k * f m" by simp
      qed
      then show "\<exists>c>0. \<exists>n. \<forall>m>n. f m + k \<le> c * f m" by blast
    qed
    show "f \<lesssim> (\<lambda>n. f n + k)"
    proof
      have "f m \<le> 1 * (f m + k)" for m by simp
      then show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * (f m + k)" by blast
    qed
  qed
qed

lemma
  assumes "strict_mono f"
  shows "(\<lambda>n. f n + k) \<cong> f"
proof (rule equiv_fun_mono_const)
  from assms show "mono f" by (rule strict_mono_mono)
  show "\<exists>n. 0 < f n"
  proof (rule ccontr)
    assume "\<not> (\<exists>n. 0 < f n)"
    then have "\<And>n. f n = 0" by simp
    then have "f 0 = f 1" by simp
    moreover from \<open>strict_mono f\<close> have "f 0 < f 1"
      by (simp add: strict_mono_def)
    ultimately show False by simp
  qed
qed

lemma
  "(\<lambda>n. Suc k * f n) \<cong> f"
proof
  show "(\<lambda>n. Suc k * f n) \<lesssim> f"
  proof
    have "Suc k * f m \<le> Suc k * f m" for m by simp
    then show "\<exists>c>0. \<exists>n. \<forall>m>n. Suc k * f m \<le> c * f m" by blast
  qed
  show "f \<lesssim> (\<lambda>n. Suc k * f n)"
  proof
    have "f m \<le> 1 * (Suc k * f m)" for m by simp
    then show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * (Suc k * f m)" by blast
  qed
qed

lemma
  "f \<lesssim> (\<lambda>n. f n + g n)"
  by rule auto

lemma
  "(\<lambda>_. 0) \<prec> (\<lambda>n. Suc k)"
  by (rule less_fun_strongI) auto

lemma
  "(\<lambda>_. k) \<prec> Discrete.log"
proof (rule less_fun_strongI)
  fix c :: nat
  have "\<forall>m>2 ^ (Suc (c * k)). c * k < Discrete.log m"
  proof (rule allI, rule impI)
    fix m :: nat
    assume "2 ^ Suc (c * k) < m"
    then have "2 ^ Suc (c * k) \<le> m" by simp
    with log_mono have "Discrete.log (2 ^ (Suc (c * k))) \<le> Discrete.log m"
      by (blast dest: monoD)
    moreover have "c * k < Discrete.log (2 ^ (Suc (c * k)))" by simp
    ultimately show "c * k < Discrete.log m" by auto
  qed
  then show "\<exists>n. \<forall>m>n. c * k < Discrete.log m" ..
qed

(*lemma
  "Discrete.log \<prec> Discrete.sqrt"
proof (rule less_fun_strongI)*)
text \<open>@{prop "Discrete.log \<prec> Discrete.sqrt"}\<close>

lemma
  "Discrete.sqrt \<prec> id"
proof (rule less_fun_strongI)
  fix c :: nat
  assume "0 < c"
  have "\<forall>m>(Suc c)\<^sup>2. c * Discrete.sqrt m < id m"
  proof (rule allI, rule impI)
    fix m
    assume "(Suc c)\<^sup>2 < m"
    then have "(Suc c)\<^sup>2 \<le> m" by simp
    with mono_sqrt have "Discrete.sqrt ((Suc c)\<^sup>2) \<le> Discrete.sqrt m" by (rule monoE)
    then have "Suc c \<le> Discrete.sqrt m" by simp
    then have "c < Discrete.sqrt m" by simp
    moreover from \<open>(Suc c)\<^sup>2 < m\<close> have "Discrete.sqrt m > 0" by simp
    ultimately have "c * Discrete.sqrt m < Discrete.sqrt m * Discrete.sqrt m" by simp
    also have "\<dots> \<le> m" by (simp add: power2_eq_square [symmetric])
    finally show "c * Discrete.sqrt m < id m" by simp
  qed
  then show "\<exists>n. \<forall>m>n. c * Discrete.sqrt m < id m" ..
qed

lemma
  "id \<prec> (\<lambda>n. n\<^sup>2)"
  by (rule less_fun_strongI) (auto simp add: power2_eq_square)

lemma
  "(\<lambda>n. n ^ k) \<prec> (\<lambda>n. n ^ Suc k)"
  by (rule less_fun_strongI) auto

(*lemma
  "(\<lambda>n. n ^ k) \<prec> (\<lambda>n. 2 ^ n)"
proof (rule less_fun_strongI)*)
text \<open>@{prop "(\<lambda>n. n ^ k) \<prec> (\<lambda>n. 2 ^ n)"}\<close>

end


theory Scratch
imports Porder
begin

datatype 'a myList =
  myNil |
  myCons 'a "'a myList"

fun myBelow :: "'a::below myList \<Rightarrow> 'a myList \<Rightarrow> bool"  where
  "myBelow myNil y = True" |
  "myBelow (myCons b xs) myNil = False" |
  "myBelow (myCons b xs) (myCons c ys) = ((below b c) \<and> (myBelow xs ys))"

instantiation myList :: (below) below
begin
  definition below_myList_def [simp]:
    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. myBelow x y)"
  instance ..
end

lemma refl_less_myList: "(x::('a::po) myList) \<sqsubseteq> x"
  apply (induction x)
  apply simp
  apply auto
  done

lemma antisym_help: "myBelow (myCons a x) (y::('a::po) myList) \<Longrightarrow> myBelow y (myCons a x) \<Longrightarrow> myCons a x = y"
  apply (induction y rule:myBelow.induct)
  apply auto
  apply (metis myBelow.simps(2) myList.exhaust)
  by (metis below_antisym)

lemma antisym_less_myList: "(x::('a::po) myList) \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
  apply (induction x)
  apply auto
  apply (metis myBelow.simps(2) myList.exhaust)
  by (metis antisym_help)

lemma trans_help: "(\<And>y. myBelow ys y \<Longrightarrow> myBelow y xs \<Longrightarrow> myBelow ys xs) \<Longrightarrow>
       myBelow (myCons c ys) (z::('a::po) myList)  \<Longrightarrow> myBelow z (myCons b xs) \<Longrightarrow> myBelow ys xs"
  by (metis myBelow.elims(2) myBelow.simps(3) myList.distinct(1) myList.exhaust)

lemma trans_less_myList: "(x::('a::po) myList) \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  apply (induction x arbitrary: y rule:myBelow.induct)
  apply auto
  apply (metis myBelow.elims(2) myBelow.simps(3) myList.distinct(1) myList.exhaust rev_below_trans)
  by (metis trans_help)

instantiation myList :: (po)po
begin
  instance
  apply intro_classes
  apply (metis refl_less_myList)
  apply (metis trans_less_myList)
  apply (metis antisym_less_myList)
  done
end


theory ex2_06 imports Main begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l v r) = v # contents l @ contents r"

fun treesum :: "nat tree \<Rightarrow> nat" where
"treesum Tip = 0" |
"treesum (Node l v r) = v + treesum l + treesum r"

value "contents (Node (Node Tip x Tip) y (Node Tip z Tip))"
value "treesum (Node (Node Tip 1 Tip) 2 (Node Tip 4 Tip))"

theorem "treesum t = listsum (contents t)"
apply(induction t)
apply auto
done

end


(*  Title:      HOL/Computational_Algebra/Fraction_Field.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section\<open>A formalization of the fraction field of any integral domain;
         generalization of theory Rat from int to any integral domain\<close>

theory Fraction_Field
imports MainRLT
begin

subsection \<open>General fractions construction\<close>

subsubsection \<open>Construction of the type of fractions\<close>

context idom begin

definition fractrel :: "'a \<times> 'a \<Rightarrow> 'a * 'a \<Rightarrow> bool" where
  "fractrel = (\<lambda>x y. snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x)"

lemma fractrel_iff [simp]:
  "fractrel x y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"
  by (simp add: fractrel_def)

lemma symp_fractrel: "symp fractrel"
  by (simp add: symp_def)

lemma transp_fractrel: "transp fractrel"
proof (rule transpI, unfold split_paired_all)
  fix a b a' b' a'' b'' :: 'a
  assume A: "fractrel (a, b) (a', b')"
  assume B: "fractrel (a', b') (a'', b'')"
  have "b' * (a * b'') = b'' * (a * b')" by (simp add: ac_simps)
  also from A have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by (simp add: ac_simps)
  also from B have "a' * b'' = a'' * b'" by auto
  also have "b * (a'' * b') = b' * (a'' * b)" by (simp add: ac_simps)
  finally have "b' * (a * b'') = b' * (a'' * b)" .
  moreover from B have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with A B show "fractrel (a, b) (a'', b'')" by auto
qed

lemma part_equivp_fractrel: "part_equivp fractrel"
using _ symp_fractrel transp_fractrel
by(rule part_equivpI)(rule exI[where x="(0, 1)"]; simp)

end

quotient_type (overloaded) 'a fract = "'a :: idom \<times> 'a" / partial: "fractrel"
by(rule part_equivp_fractrel)

subsubsection \<open>Representation and basic operations\<close>

lift_definition Fract :: "'a :: idom \<Rightarrow> 'a \<Rightarrow> 'a fract"
  is "\<lambda>a b. if b = 0 then (0, 1) else (a, b)"
  by simp

lemma Fract_cases [cases type: fract]:
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0"
by transfer simp

lemma Fract_induct [case_names Fract, induct type: fract]:
  "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
  by (cases q) simp

lemma eq_fract:
  shows "\<And>a b c d. b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b = Fract c d \<longleftrightarrow> a * d = c * b"
    and "\<And>a. Fract a 0 = Fract 0 1"
    and "\<And>a c. Fract 0 a = Fract 0 c"
by(transfer; simp)+

instantiation fract :: (idom) comm_ring_1
begin

lift_definition zero_fract :: "'a fract" is "(0, 1)" by simp

lemma Zero_fract_def: "0 = Fract 0 1"
by transfer simp

lift_definition one_fract :: "'a fract" is "(1, 1)" by simp

lemma One_fract_def: "1 = Fract 1 1"
by transfer simp

lift_definition plus_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * snd r + fst r * snd q, snd q * snd r)"
by(auto simp add: algebra_simps)

lemma add_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
by transfer simp

lift_definition uminus_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. (- fst x, snd x)"
by simp

lemma minus_fract [simp]:
  fixes a b :: "'a::idom"
  shows "- Fract a b = Fract (- a) b"
by transfer simp

lemma minus_fract_cancel [simp]: "Fract (- a) (- b) = Fract a b"
  by (cases "b = 0") (simp_all add: eq_fract)

definition diff_fract_def: "q - r = q + - (r::'a fract)"

lemma diff_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  by (simp add: diff_fract_def)

lift_definition times_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * fst r, snd q * snd r)"
by(simp add: algebra_simps)

lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)"
by transfer simp

lemma mult_fract_cancel:
  "c \<noteq> 0 \<Longrightarrow> Fract (c * a) (c * b) = Fract a b"
by transfer simp

instance
proof
  fix q r s :: "'a fract"
  show "(q * r) * s = q * (r * s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q * r = r * q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "1 * q = q"
    by (cases q) (simp add: One_fract_def eq_fract)
  show "(q + r) + s = q + (r + s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q + r = r + q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "0 + q = q"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "- q + q = 0"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "q - r = q + - r"
    by (cases q, cases r) (simp add: eq_fract)
  show "(q + r) * s = q * s + r * s"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "(0::'a fract) \<noteq> 1"
    by (simp add: Zero_fract_def One_fract_def eq_fract)
qed

end

lemma of_nat_fract: "of_nat k = Fract (of_nat k) 1"
  by (induct k) (simp_all add: Zero_fract_def One_fract_def)

lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k"
  by (rule of_nat_fract [symmetric])

lemma fract_collapse:
  "Fract 0 k = 0"
  "Fract 1 1 = 1"
  "Fract k 0 = 0"
by(transfer; simp)+

lemma fract_expand:
  "0 = Fract 0 1"
  "1 = Fract 1 1"
  by (simp_all add: fract_collapse)

lemma Fract_cases_nonzero:
  obtains (Fract) a b where "q = Fract a b" and "b \<noteq> 0" and "a \<noteq> 0"
    | (0) "q = 0"
proof (cases "q = 0")
  case True
  then show thesis using 0 by auto
next
  case False
  then obtain a b where "q = Fract a b" and "b \<noteq> 0" by (cases q) auto
  with False have "0 \<noteq> Fract a b" by simp
  with \<open>b \<noteq> 0\<close> have "a \<noteq> 0" by (simp add: Zero_fract_def eq_fract)
  with Fract \<open>q = Fract a b\<close> \<open>b \<noteq> 0\<close> show thesis by auto
qed

subsubsection \<open>The field of rational numbers\<close>

context idom
begin

subclass ring_no_zero_divisors ..

end

instantiation fract :: (idom) field
begin

lift_definition inverse_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. if fst x = 0 then (0, 1) else (snd x, fst x)"
by(auto simp add: algebra_simps)

lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a"
by transfer simp

definition divide_fract_def: "q div r = q * inverse (r:: 'a fract)"

lemma divide_fract [simp]: "Fract a b div Fract c d = Fract (a * d) (b * c)"
  by (simp add: divide_fract_def)

instance
proof
  fix q :: "'a fract"
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by (cases q rule: Fract_cases_nonzero)
      (simp_all add: fract_expand eq_fract mult.commute)
next
  fix q r :: "'a fract"
  show "q div r = q * inverse r" by (simp add: divide_fract_def)
next
  show "inverse 0 = (0:: 'a fract)"
    by (simp add: fract_expand) (simp add: fract_collapse)
qed

end

subsubsection \<open>The ordered field of fractions over an ordered idom\<close>

instantiation fract :: (linordered_idom) linorder
begin

lemma less_eq_fract_respect:
  fixes a b a' b' c d c' d' :: 'a
  assumes neq: "b \<noteq> 0"  "b' \<noteq> 0"  "d \<noteq> 0"  "d' \<noteq> 0"
  assumes eq1: "a * b' = a' * b"
  assumes eq2: "c * d' = c' * d"
  shows "((a * d) * (b * d) \<le> (c * b) * (b * d)) \<longleftrightarrow> ((a' * d') * (b' * d') \<le> (c' * b') * (b' * d'))"
proof -
  let ?le = "\<lambda>a b c d. ((a * d) * (b * d) \<le> (c * b) * (b * d))"
  {
    fix a b c d x :: 'a
    assume x: "x \<noteq> 0"
    have "?le a b c d = ?le (a * x) (b * x) c d"
    proof -
      from x have "0 < x * x"
        by (auto simp add: zero_less_mult_iff)
      then have "?le a b c d =
          ((a * d) * (b * d) * (x * x) \<le> (c * b) * (b * d) * (x * x))"
        by (simp add: mult_le_cancel_right)
      also have "... = ?le (a * x) (b * x) c d"
        by (simp add: ac_simps)
      finally show ?thesis .
    qed
  } note le_factor = this

  let ?D = "b * d" and ?D' = "b' * d'"
  from neq have D: "?D \<noteq> 0" by simp
  from neq have "?D' \<noteq> 0" by simp
  then have "?le a b c d = ?le (a * ?D') (b * ?D') c d"
    by (rule le_factor)
  also have "... = ((a * b') * ?D * ?D' * d * d' \<le> (c * d') * ?D * ?D' * b * b')"
    by (simp add: ac_simps)
  also have "... = ((a' * b) * ?D * ?D' * d * d' \<le> (c' * d) * ?D * ?D' * b * b')"
    by (simp only: eq1 eq2)
  also have "... = ?le (a' * ?D) (b' * ?D) c' d'"
    by (simp add: ac_simps)
  also from D have "... = ?le a' b' c' d'"
    by (rule le_factor [symmetric])
  finally show "?le a b c d = ?le a' b' c' d'" .
qed

lift_definition less_eq_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> bool"
  is "\<lambda>q r. (fst q * snd r) * (snd q * snd r) \<le> (fst r * snd q) * (snd q * snd r)"
by (clarsimp simp add: less_eq_fract_respect)

definition less_fract_def: "z < (w::'a fract) \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"

lemma le_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  by transfer simp

lemma less_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  by (simp add: less_fract_def less_le_not_le ac_simps)

instance
proof
  fix q r s :: "'a fract"
  assume "q \<le> r" and "r \<le> s"
  then show "q \<le> s"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract e f"
    show "Fract a b \<le> Fract e f"
    proof -
      from neq obtain bb: "0 < b * b" and dd: "0 < d * d" and ff: "0 < f * f"
        by (auto simp add: zero_less_mult_iff linorder_neq_iff)
      have "(a * d) * (b * d) * (f * f) \<le> (c * b) * (b * d) * (f * f)"
      proof -
        from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
          by simp
        with ff show ?thesis by (simp add: mult_le_cancel_right)
      qed
      also have "... = (c * f) * (d * f) * (b * b)"
        by (simp only: ac_simps)
      also have "... \<le> (e * d) * (d * f) * (b * b)"
      proof -
        from neq 2 have "(c * f) * (d * f) \<le> (e * d) * (d * f)"
          by simp
        with bb show ?thesis by (simp add: mult_le_cancel_right)
      qed
      finally have "(a * f) * (b * f) * (d * d) \<le> e * b * (b * f) * (d * d)"
        by (simp only: ac_simps)
      with dd have "(a * f) * (b * f) \<le> (e * b) * (b * f)"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by simp
    qed
  qed
next
  fix q r :: "'a fract"
  assume "q \<le> r" and "r \<le> q"
  then show "q = r"
  proof (induct q, induct r)
    fix a b c d :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract a b"
    show "Fract a b = Fract c d"
    proof -
      from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      also have "... \<le> (a * d) * (b * d)"
      proof -
        from neq 2 have "(c * b) * (d * b) \<le> (a * d) * (d * b)"
          by simp
        then show ?thesis by (simp only: ac_simps)
      qed
      finally have "(a * d) * (b * d) = (c * b) * (b * d)" .
      moreover from neq have "b * d \<noteq> 0" by simp
      ultimately have "a * d = c * b" by simp
      with neq show ?thesis by (simp add: eq_fract)
    qed
  qed
next
  fix q r :: "'a fract"
  show "q \<le> q"
    by (induct q) simp
  show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
    by (simp only: less_fract_def)
  show "q \<le> r \<or> r \<le> q"
    by (induct q, induct r)
       (simp add: mult.commute, rule linorder_linear)
qed

end

instantiation fract :: (linordered_idom) linordered_field
begin

definition abs_fract_def2:
  "\<bar>q\<bar> = (if q < 0 then -q else (q::'a fract))"

definition sgn_fract_def:
  "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"

theorem abs_fract [simp]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
  unfolding abs_fract_def2 not_le [symmetric]
  by transfer (auto simp add: zero_less_mult_iff le_less)

instance proof
  fix q r s :: "'a fract"
  assume "q \<le> r"
  then show "s + q \<le> s + r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b \<le> Fract c d"
    show "Fract e f + Fract a b \<le> Fract e f + Fract c d"
    proof -
      let ?F = "f * f" from neq have F: "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      from neq le have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      with F have "(a * d) * (b * d) * ?F * ?F \<le> (c * b) * (b * d) * ?F * ?F"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by (simp add: field_simps)
    qed
  qed
next
  fix q r s :: "'a fract"
  assume "q < r" and "0 < s"
  then show "s * q < s * r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b < Fract c d"
    assume gt: "0 < Fract e f"
    show "Fract e f * Fract a b < Fract e f * Fract c d"
    proof -
      let ?E = "e * f" and ?F = "f * f"
      from neq gt have "0 < ?E"
        by (auto simp add: Zero_fract_def order_less_le eq_fract)
      moreover from neq have "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      moreover from neq le have "(a * d) * (b * d) < (c * b) * (b * d)"
        by simp
      ultimately have "(a * d) * (b * d) * ?E * ?F < (c * b) * (b * d) * ?E * ?F"
        by (simp add: mult_less_cancel_right)
      with neq show ?thesis
        by (simp add: ac_simps)
    qed
  qed
qed (fact sgn_fract_def abs_fract_def2)+

end

instantiation fract :: (linordered_idom) distrib_lattice
begin

definition inf_fract_def:
  "(inf :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = min"

definition sup_fract_def:
  "(sup :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = max"

instance
  by standard (simp_all add: inf_fract_def sup_fract_def max_min_distrib2)

end

lemma fract_induct_pos [case_names Fract]:
  fixes P :: "'a::linordered_idom fract \<Rightarrow> bool"
  assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
  shows "P q"
proof (cases q)
  case (Fract a b)
  {
    fix a b :: 'a
    assume b: "b < 0"
    have "P (Fract a b)"
    proof -
      from b have "0 < - b" by simp
      then have "P (Fract (- a) (- b))"
        by (rule step)
      then show "P (Fract a b)"
        by (simp add: order_less_imp_not_eq [OF b])
    qed
  }
  with Fract show "P q"
    by (auto simp add: linorder_neq_iff step)
qed

lemma zero_less_Fract_iff: "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
  by (auto simp add: Zero_fract_def zero_less_mult_iff)

lemma Fract_less_zero_iff: "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
  by (auto simp add: Zero_fract_def mult_less_0_iff)

lemma zero_le_Fract_iff: "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: Zero_fract_def zero_le_mult_iff)

lemma Fract_le_zero_iff: "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (auto simp add: Zero_fract_def mult_le_0_iff)

lemma one_less_Fract_iff: "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma Fract_less_one_iff: "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma one_le_Fract_iff: "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
  by (auto simp add: One_fract_def mult_le_cancel_right)

lemma Fract_le_one_iff: "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
  by (auto simp add: One_fract_def mult_le_cancel_right)

end


(* Author: Tobias Nipkow *)

section "Sorting"

theory Sorting
imports
  Complex_Main
  "HOL-Library.Multiset"
begin

hide_const List.insort

declare Let_def [simp]

subsection "Insertion Sort"

fun insort :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort x [] = [x]" |
"insort x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort x ys))"

fun isort :: "'a::linorder list \<Rightarrow> 'a list" where
"isort [] = []" |
"isort (x#xs) = insort x (isort xs)"

subsubsection "Functional Correctness"

lemma mset_insort: "mset (insort x xs) = add_mset x (mset xs)"
apply(induction xs)
apply auto
done

lemma mset_isort: "mset (isort xs) = mset xs"
apply(induction xs)
apply simp
apply (simp add: mset_insort)
done

lemma set_insort: "set (insort x xs) = insert x (set xs)"
by (metis mset_insort set_mset_add_mset_insert set_mset_mset)

lemma sorted_insort: "sorted (insort a xs) = sorted xs"
apply(induction xs)
apply(auto simp add: set_insort)
done

lemma sorted_isort: "sorted (isort xs)"
apply(induction xs)
apply(auto simp: sorted_insort)
done

subsubsection "Time Complexity"

text \<open>We count the number of function calls.\<close>

text\<open>
\<open>insort x [] = [x]\<close>
\<open>insort x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort x ys))\<close>
\<close>
fun t_insort :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> nat" where
"t_insort x [] = 1" |
"t_insort x (y#ys) =
  (if x \<le> y then 0 else t_insort x ys) + 1"

text\<open>
\<open>isort [] = []\<close>
\<open>isort (x#xs) = insort x (isort xs)\<close>
\<close>
fun t_isort :: "'a::linorder list \<Rightarrow> nat" where
"t_isort [] = 1" |
"t_isort (x#xs) = t_isort xs + t_insort x (isort xs) + 1"

lemma t_insort_length: "t_insort x xs \<le> length xs + 1"
apply(induction xs)
apply auto
done

lemma length_insort: "length (insort x xs) = length xs + 1"
apply(induction xs)
apply auto
done

lemma length_isort: "length (isort xs) = length xs"
apply(induction xs)
apply (auto simp: length_insort)
done

lemma t_isort_length: "t_isort xs \<le> (length xs + 1) ^ 2"
proof(induction xs)
  case Nil show ?case by simp
next
  case (Cons x xs)
  have "t_isort (x#xs) = t_isort xs + t_insort x (isort xs) + 1" by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + t_insort x (isort xs) + 1"
    using Cons.IH by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + length xs + 1 + 1"
    using t_insort_length[of x "isort xs"] by (simp add: length_isort)
  also have "\<dots> \<le> (length(x#xs) + 1) ^ 2"
    by (simp add: power2_eq_square)
  finally show ?case .
qed

subsection "Merge Sort"

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

fun msort :: "'a::linorder list \<Rightarrow> 'a list" where
"msort xs = (let n = length xs in
  if n \<le> 1 then xs
  else merge (msort (take (n div 2) xs)) (msort (drop (n div 2) xs)))"

declare msort.simps [simp del]

subsubsection "Functional Correctness"

lemma mset_merge: "mset(merge xs ys) = mset xs + mset ys"
by(induction xs ys rule: merge.induct) auto

lemma mset_msort: "mset (msort xs) = mset xs"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs])
  next
    assume "\<not> ?n \<le> 1"
    hence "mset (msort xs) = mset (msort ?ys) + mset (msort ?zs)"
      by(simp add: msort.simps[of xs] mset_merge)
    also have "\<dots> = mset ?ys + mset ?zs"
      using \<open>\<not> ?n \<le> 1\<close> by(simp add: "1.IH")
    also have "\<dots> = mset (?ys @ ?zs)" by (simp del: append_take_drop_id)
    also have "\<dots> = mset xs" by simp
    finally show ?thesis .
  qed
qed

text \<open>Via the previous lemma or directly:\<close>

lemma set_merge: "set(merge xs ys) = set xs \<union> set ys"
by (metis mset_merge set_mset_mset set_mset_union)

lemma "set(merge xs ys) = set xs \<union> set ys"
by(induction xs ys rule: merge.induct) (auto)

lemma sorted_merge: "sorted (merge xs ys) \<longleftrightarrow> (sorted xs \<and> sorted ys)"
by(induction xs ys rule: merge.induct) (auto simp: set_merge)

lemma sorted_msort: "sorted (msort xs)"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs] sorted01)
  next
    assume "\<not> ?n \<le> 1"
    thus ?thesis using "1.IH"
      by(simp add: sorted_merge msort.simps[of xs])
  qed
qed

subsubsection "Time Complexity"

text \<open>We only count the number of comparisons between list elements.\<close>

fun c_merge :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> nat" where
"c_merge [] ys = 0" |
"c_merge xs [] = 0" |
"c_merge (x#xs) (y#ys) = 1 + (if x \<le> y then c_merge xs (y#ys) else c_merge (x#xs) ys)"

lemma c_merge_ub: "c_merge xs ys \<le> length xs + length ys"
by (induction xs ys rule: c_merge.induct) auto

fun c_msort :: "'a::linorder list \<Rightarrow> nat" where
"c_msort xs =
  (let n = length xs;
       ys = take (n div 2) xs;
       zs = drop (n div 2) xs
   in if n \<le> 1 then 0
      else c_msort ys + c_msort zs + c_merge (msort ys) (msort zs))"

declare c_msort.simps [simp del]

lemma length_merge: "length(merge xs ys) = length xs + length ys"
apply (induction xs ys rule: merge.induct)
apply auto
done

lemma length_msort: "length(msort xs) = length xs"
proof (induction xs rule: msort.induct)
  case (1 xs)
  thus ?case by (auto simp: msort.simps[of xs] length_merge)
qed
text \<open>Why structured proof?
   To have the name "xs" to specialize msort.simps with xs
   to ensure that msort.simps cannot be used recursively.
Also works without this precaution, but that is just luck.\<close>

lemma c_msort_le: "length xs = 2^k \<Longrightarrow> c_msort xs \<le> k * 2^k"
proof(induction k arbitrary: xs)
  case 0 thus ?case by (simp add: c_msort.simps)
next
  case (Suc k)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof (cases "?n \<le> 1")
    case True
    thus ?thesis by(simp add: c_msort.simps)
  next
    case False
    have "c_msort(xs) =
      c_msort ?ys + c_msort ?zs + c_merge (msort ?ys) (msort ?zs)"
      by (simp add: c_msort.simps msort.simps)
    also have "\<dots> \<le> c_msort ?ys + c_msort ?zs + length ?ys + length ?zs"
      using c_merge_ub[of "msort ?ys" "msort ?zs"] length_msort[of ?ys] length_msort[of ?zs]
      by arith
    also have "\<dots> \<le> k * 2^k + c_msort ?zs + length ?ys + length ?zs"
      using Suc.IH[of ?ys] Suc.prems by simp
    also have "\<dots> \<le> k * 2^k + k * 2^k + length ?ys + length ?zs"
      using Suc.IH[of ?zs] Suc.prems by simp
    also have "\<dots> = 2 * k * 2^k + 2 * 2 ^ k"
      using Suc.prems by simp
    finally show ?thesis by simp
  qed
qed

(* Beware of implicit conversions: *)
lemma c_msort_log: "length xs = 2^k \<Longrightarrow> c_msort xs \<le> length xs * log 2 (length xs)"
using c_msort_le[of xs k] apply (simp add: log_nat_power algebra_simps)
by (metis (mono_tags) numeral_power_eq_of_nat_cancel_iff of_nat_le_iff of_nat_mult)

subsection "Bottom-Up Merge Sort"

fun merge_adj :: "('a::linorder) list list \<Rightarrow> 'a list list" where
"merge_adj [] = []" |
"merge_adj [xs] = [xs]" |
"merge_adj (xs # ys # zss) = merge xs ys # merge_adj zss"

text \<open>For the termination proof of \<open>merge_all\<close> below.\<close>
lemma length_merge_adjacent[simp]: "length (merge_adj xs) = (length xs + 1) div 2"
by (induction xs rule: merge_adj.induct) auto

fun merge_all :: "('a::linorder) list list \<Rightarrow> 'a list" where
"merge_all [] = []" |
"merge_all [xs] = xs" |
"merge_all xss = merge_all (merge_adj xss)"

definition msort_bu :: "('a::linorder) list \<Rightarrow> 'a list" where
"msort_bu xs = merge_all (map (\<lambda>x. [x]) xs)"

subsubsection "Functional Correctness"

lemma mset_merge_adj:
  "\<Union># (image_mset mset (mset (merge_adj xss))) = \<Union># (image_mset mset (mset xss))"
by(induction xss rule: merge_adj.induct) (auto simp: mset_merge)

lemma mset_merge_all:
  "mset (merge_all xss) = (\<Union># (mset (map mset xss)))"
by(induction xss rule: merge_all.induct) (auto simp: mset_merge mset_merge_adj)

lemma mset_msort_bu: "mset (msort_bu xs) = mset xs"
by(simp add: msort_bu_def mset_merge_all comp_def)

lemma sorted_merge_adj:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). sorted xs"
by(induction xss rule: merge_adj.induct) (auto simp: sorted_merge)

lemma sorted_merge_all:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> sorted (merge_all xss)"
apply(induction xss rule: merge_all.induct)
using [[simp_depth_limit=3]] by (auto simp add: sorted_merge_adj)

lemma sorted_msort_bu: "sorted (msort_bu xs)"
by(simp add: msort_bu_def sorted_merge_all)

subsubsection "Time Complexity"

fun c_merge_adj :: "('a::linorder) list list \<Rightarrow> nat" where
"c_merge_adj [] = 0" |
"c_merge_adj [xs] = 0" |
"c_merge_adj (xs # ys # zss) = c_merge xs ys + c_merge_adj zss"

fun c_merge_all :: "('a::linorder) list list \<Rightarrow> nat" where
"c_merge_all [] = 0" |
"c_merge_all [xs] = 0" |
"c_merge_all xss = c_merge_adj xss + c_merge_all (merge_adj xss)"

definition c_msort_bu :: "('a::linorder) list \<Rightarrow> nat" where
"c_msort_bu xs = c_merge_all (map (\<lambda>x. [x]) xs)"

lemma length_merge_adj:
  "\<lbrakk> even(length xss); \<forall>xs \<in> set xss. length xs = m \<rbrakk>
  \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). length xs = 2*m"
by(induction xss rule: merge_adj.induct) (auto simp: length_merge)

lemma c_merge_adj: "\<forall>xs \<in> set xss. length xs = m \<Longrightarrow> c_merge_adj xss \<le> m * length xss"
proof(induction xss rule: c_merge_adj.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 x y) thus ?case using c_merge_ub[of x y] by (simp add: algebra_simps)
qed

lemma c_merge_all: "\<lbrakk> \<forall>xs \<in> set xss. length xs = m; length xss = 2^k \<rbrakk>
  \<Longrightarrow> c_merge_all xss \<le> m * k * 2^k"
proof (induction xss arbitrary: k m rule: c_merge_all.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 xs ys xss)
  let ?xss = "xs # ys # xss"
  let ?xss2 = "merge_adj ?xss"
  obtain k' where k': "k = Suc k'" using "3.prems"(2)
    by (metis length_Cons nat.inject nat_power_eq_Suc_0_iff nat.exhaust)
  have "even (length ?xss)" using "3.prems"(2) k' by auto
  from length_merge_adj[OF this "3.prems"(1)]
  have *: "\<forall>x \<in> set(merge_adj ?xss). length x = 2*m" .
  have **: "length ?xss2 = 2 ^ k'" using "3.prems"(2) k' by auto
  have "c_merge_all ?xss = c_merge_adj ?xss + c_merge_all ?xss2" by simp
  also have "\<dots> \<le> m * 2^k + c_merge_all ?xss2"
    using "3.prems"(2) c_merge_adj[OF "3.prems"(1)] by (auto simp: algebra_simps)
  also have "\<dots> \<le> m * 2^k + (2*m) * k' * 2^k'"
    using "3.IH"[OF * **] by simp
  also have "\<dots> = m * k * 2^k"
    using k' by (simp add: algebra_simps)
  finally show ?case .
qed

corollary c_msort_bu: "length xs = 2 ^ k \<Longrightarrow> c_msort_bu xs \<le> k * 2 ^ k"
using c_merge_all[of "map (\<lambda>x. [x]) xs" 1] by (simp add: c_msort_bu_def)

subsection "Quicksort"

fun quicksort :: "('a::linorder) list \<Rightarrow> 'a list" where
"quicksort []     = []" |
"quicksort (x#xs) = quicksort (filter (\<lambda>y. y < x) xs) @ [x] @ quicksort (filter (\<lambda>y. x \<le> y) xs)"

lemma mset_quicksort: "mset (quicksort xs) = mset xs"
apply (induction xs rule: quicksort.induct)
apply (auto simp: not_le)
done

lemma set_quicksort: "set (quicksort xs) = set xs"
by(rule mset_eq_setD[OF mset_quicksort])

lemma sorted_quicksort: "sorted (quicksort xs)"
apply (induction xs rule: quicksort.induct)
apply (auto simp add: sorted_append set_quicksort)
done

subsection "Insertion Sort w.r.t. Keys and Stability"

text \<open>Note that \<^const>\<open>insort_key\<close> is already defined in theory \<^theory>\<open>HOL.List\<close>.
Thus some of the lemmas are already present as well.\<close>

fun isort_key :: "('a \<Rightarrow> 'k::linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"isort_key f [] = []" |
"isort_key f (x # xs) = insort_key f x (isort_key f xs)"

subsubsection "Standard functional correctness"

lemma mset_insort_key: "mset (insort_key f x xs) = add_mset x (mset xs)"
by(induction xs) simp_all

lemma mset_isort_key: "mset (isort_key f xs) = mset xs"
by(induction xs) (simp_all add: mset_insort_key)

lemma set_isort_key: "set (isort_key f xs) = set xs"
by (rule mset_eq_setD[OF mset_isort_key])

lemma sorted_insort_key: "sorted (map f (insort_key f a xs)) = sorted (map f xs)"
by(induction xs)(auto simp: set_insort_key)

lemma sorted_isort_key: "sorted (map f (isort_key f xs))"
by(induction xs)(simp_all add: sorted_insort_key)

subsubsection "Stability"

lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
by (cases xs) auto

lemma filter_insort_key_neg:
  "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
by (induction xs) simp_all

lemma filter_insort_key_pos:
  "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
by (induction xs) (auto, subst insort_is_Cons, auto)

lemma sort_key_stable: "filter (\<lambda>y. f y = k) (isort_key f xs) = filter (\<lambda>y. f y = k) xs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thus ?case
  proof (cases "f a = k")
    case False thus ?thesis  by (simp add: Cons.IH filter_insort_key_neg)
  next
    case True
    have "filter (\<lambda>y. f y = k) (isort_key f (a # xs))
      = filter (\<lambda>y. f y = k) (insort_key f a (isort_key f xs))"  by simp
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) (isort_key f xs))"
      by (simp add: True filter_insort_key_pos sorted_isort_key)
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) xs)"  by (simp add: Cons.IH)
    also have "\<dots> = a # (filter (\<lambda>y. f y = k) xs)"  by(simp add: True insort_is_Cons)
    also have "\<dots> = filter (\<lambda>y. f y = k) (a # xs)" by (simp add: True)
    finally show ?thesis .
  qed
qed

end


(* Author: Tobias Nipkow *)

section "Sorting"

theory Sorting
imports
  Complex_Main
  "HOL-Library.Multiset"
begin

hide_const List.insort

declare Let_def [simp]

subsection "Insertion Sort"

fun insort :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort x [] = [x]" |
"insort x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort x ys))"

fun isort :: "'a::linorder list \<Rightarrow> 'a list" where
"isort [] = []" |
"isort (x#xs) = insort x (isort xs)"

subsubsection "Functional Correctness"

lemma mset_insort: "mset (insort x xs) = {#x#} + mset xs"
apply(induction xs)
apply auto
done

lemma mset_isort: "mset (isort xs) = mset xs"
apply(induction xs)
apply simp
apply (simp add: mset_insort)
done

lemma set_insort: "set (insort x xs) = {x} \<union> set xs"
by(simp add: mset_insort flip: set_mset_mset)

lemma sorted_insort: "sorted (insort a xs) = sorted xs"
apply(induction xs)
apply(auto simp add: set_insort)
done

lemma sorted_isort: "sorted (isort xs)"
apply(induction xs)
apply(auto simp: sorted_insort)
done

subsubsection "Time Complexity"

text \<open>We count the number of function calls.\<close>

text\<open>
\<open>insort x [] = [x]\<close>
\<open>insort x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort x ys))\<close>
\<close>
fun T_insort :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> nat" where
"T_insort x [] = 1" |
"T_insort x (y#ys) =
  (if x \<le> y then 0 else T_insort x ys) + 1"

text\<open>
\<open>isort [] = []\<close>
\<open>isort (x#xs) = insort x (isort xs)\<close>
\<close>
fun T_isort :: "'a::linorder list \<Rightarrow> nat" where
"T_isort [] = 1" |
"T_isort (x#xs) = T_isort xs + T_insort x (isort xs) + 1"

lemma T_insort_length: "T_insort x xs \<le> length xs + 1"
apply(induction xs)
apply auto
done

lemma length_insort: "length (insort x xs) = length xs + 1"
apply(induction xs)
apply auto
done

lemma length_isort: "length (isort xs) = length xs"
apply(induction xs)
apply (auto simp: length_insort)
done

lemma T_isort_length: "T_isort xs \<le> (length xs + 1) ^ 2"
proof(induction xs)
  case Nil show ?case by simp
next
  case (Cons x xs)
  have "T_isort (x#xs) = T_isort xs + T_insort x (isort xs) + 1" by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + T_insort x (isort xs) + 1"
    using Cons.IH by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + length xs + 1 + 1"
    using T_insort_length[of x "isort xs"] by (simp add: length_isort)
  also have "\<dots> \<le> (length(x#xs) + 1) ^ 2"
    by (simp add: power2_eq_square)
  finally show ?case .
qed

subsection "Merge Sort"

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

fun msort :: "'a::linorder list \<Rightarrow> 'a list" where
"msort xs = (let n = length xs in
  if n \<le> 1 then xs
  else merge (msort (take (n div 2) xs)) (msort (drop (n div 2) xs)))"

declare msort.simps [simp del]

subsubsection "Functional Correctness"

lemma mset_merge: "mset(merge xs ys) = mset xs + mset ys"
by(induction xs ys rule: merge.induct) auto

lemma mset_msort: "mset (msort xs) = mset xs"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs])
  next
    assume "\<not> ?n \<le> 1"
    hence "mset (msort xs) = mset (msort ?ys) + mset (msort ?zs)"
      by(simp add: msort.simps[of xs] mset_merge)
    also have "\<dots> = mset ?ys + mset ?zs"
      using \<open>\<not> ?n \<le> 1\<close> by(simp add: "1.IH")
    also have "\<dots> = mset (?ys @ ?zs)" by (simp del: append_take_drop_id)
    also have "\<dots> = mset xs" by simp
    finally show ?thesis .
  qed
qed

text \<open>Via the previous lemma or directly:\<close>

lemma set_merge: "set(merge xs ys) = set xs \<union> set ys"
by (metis mset_merge set_mset_mset set_mset_union)

lemma "set(merge xs ys) = set xs \<union> set ys"
by(induction xs ys rule: merge.induct) (auto)

lemma sorted_merge: "sorted (merge xs ys) \<longleftrightarrow> (sorted xs \<and> sorted ys)"
by(induction xs ys rule: merge.induct) (auto simp: set_merge)

lemma sorted_msort: "sorted (msort xs)"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs] sorted01)
  next
    assume "\<not> ?n \<le> 1"
    thus ?thesis using "1.IH"
      by(simp add: sorted_merge msort.simps[of xs])
  qed
qed

subsubsection "Time Complexity"

text \<open>We only count the number of comparisons between list elements.\<close>

fun C_merge :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> nat" where
"C_merge [] ys = 0" |
"C_merge xs [] = 0" |
"C_merge (x#xs) (y#ys) = 1 + (if x \<le> y then C_merge xs (y#ys) else C_merge (x#xs) ys)"

lemma C_merge_ub: "C_merge xs ys \<le> length xs + length ys"
by (induction xs ys rule: C_merge.induct) auto

fun C_msort :: "'a::linorder list \<Rightarrow> nat" where
"C_msort xs =
  (let n = length xs;
       ys = take (n div 2) xs;
       zs = drop (n div 2) xs
   in if n \<le> 1 then 0
      else C_msort ys + C_msort zs + C_merge (msort ys) (msort zs))"

declare C_msort.simps [simp del]

lemma length_merge: "length(merge xs ys) = length xs + length ys"
apply (induction xs ys rule: merge.induct)
apply auto
done

lemma length_msort: "length(msort xs) = length xs"
proof (induction xs rule: msort.induct)
  case (1 xs)
  show ?case
    by (auto simp: msort.simps [of xs] 1 length_merge)
qed
text \<open>Why structured proof?
   To have the name "xs" to specialize msort.simps with xs
   to ensure that msort.simps cannot be used recursively.
Also works without this precaution, but that is just luck.\<close>

lemma C_msort_le: "length xs = 2^k \<Longrightarrow> C_msort xs \<le> k * 2^k"
proof(induction k arbitrary: xs)
  case 0 thus ?case by (simp add: C_msort.simps)
next
  case (Suc k)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof (cases "?n \<le> 1")
    case True
    thus ?thesis by(simp add: C_msort.simps)
  next
    case False
    have "C_msort(xs) =
      C_msort ?ys + C_msort ?zs + C_merge (msort ?ys) (msort ?zs)"
      by (simp add: C_msort.simps msort.simps)
    also have "\<dots> \<le> C_msort ?ys + C_msort ?zs + length ?ys + length ?zs"
      using C_merge_ub[of "msort ?ys" "msort ?zs"] length_msort[of ?ys] length_msort[of ?zs]
      by arith
    also have "\<dots> \<le> k * 2^k + C_msort ?zs + length ?ys + length ?zs"
      using Suc.IH[of ?ys] Suc.prems by simp
    also have "\<dots> \<le> k * 2^k + k * 2^k + length ?ys + length ?zs"
      using Suc.IH[of ?zs] Suc.prems by simp
    also have "\<dots> = 2 * k * 2^k + 2 * 2 ^ k"
      using Suc.prems by simp
    finally show ?thesis by simp
  qed
qed

(* Beware of implicit conversions: *)
lemma C_msort_log: "length xs = 2^k \<Longrightarrow> C_msort xs \<le> length xs * log 2 (length xs)"
using C_msort_le[of xs k] apply (simp add: log_nat_power algebra_simps)
by (metis (mono_tags) numeral_power_eq_of_nat_cancel_iff of_nat_le_iff of_nat_mult)

subsection "Bottom-Up Merge Sort"

fun merge_adj :: "('a::linorder) list list \<Rightarrow> 'a list list" where
"merge_adj [] = []" |
"merge_adj [xs] = [xs]" |
"merge_adj (xs # ys # zss) = merge xs ys # merge_adj zss"

text \<open>For the termination proof of \<open>merge_all\<close> below.\<close>
lemma length_merge_adjacent[simp]: "length (merge_adj xs) = (length xs + 1) div 2"
by (induction xs rule: merge_adj.induct) auto

fun merge_all :: "('a::linorder) list list \<Rightarrow> 'a list" where
"merge_all [] = []" |
"merge_all [xs] = xs" |
"merge_all xss = merge_all (merge_adj xss)"

definition msort_bu :: "('a::linorder) list \<Rightarrow> 'a list" where
"msort_bu xs = merge_all (map (\<lambda>x. [x]) xs)"

subsubsection "Functional Correctness"

abbreviation mset_mset :: "'a list list \<Rightarrow> 'a multiset" where
"mset_mset xss \<equiv> \<Sum>\<^sub># (image_mset mset (mset xss))"

lemma mset_merge_adj:
  "mset_mset (merge_adj xss) = mset_mset xss"
by(induction xss rule: merge_adj.induct) (auto simp: mset_merge)

lemma mset_merge_all:
  "mset (merge_all xss) = mset_mset xss"
by(induction xss rule: merge_all.induct) (auto simp: mset_merge mset_merge_adj)

lemma mset_msort_bu: "mset (msort_bu xs) = mset xs"
by(simp add: msort_bu_def mset_merge_all multiset.map_comp comp_def)

lemma sorted_merge_adj:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). sorted xs"
by(induction xss rule: merge_adj.induct) (auto simp: sorted_merge)

lemma sorted_merge_all:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> sorted (merge_all xss)"
apply(induction xss rule: merge_all.induct)
using [[simp_depth_limit=3]] by (auto simp add: sorted_merge_adj)

lemma sorted_msort_bu: "sorted (msort_bu xs)"
by(simp add: msort_bu_def sorted_merge_all)

subsubsection "Time Complexity"

fun C_merge_adj :: "('a::linorder) list list \<Rightarrow> nat" where
"C_merge_adj [] = 0" |
"C_merge_adj [xs] = 0" |
"C_merge_adj (xs # ys # zss) = C_merge xs ys + C_merge_adj zss"

fun C_merge_all :: "('a::linorder) list list \<Rightarrow> nat" where
"C_merge_all [] = 0" |
"C_merge_all [xs] = 0" |
"C_merge_all xss = C_merge_adj xss + C_merge_all (merge_adj xss)"

definition C_msort_bu :: "('a::linorder) list \<Rightarrow> nat" where
"C_msort_bu xs = C_merge_all (map (\<lambda>x. [x]) xs)"

lemma length_merge_adj:
  "\<lbrakk> even(length xss); \<forall>xs \<in> set xss. length xs = m \<rbrakk>
  \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). length xs = 2*m"
by(induction xss rule: merge_adj.induct) (auto simp: length_merge)

lemma C_merge_adj: "\<forall>xs \<in> set xss. length xs = m \<Longrightarrow> C_merge_adj xss \<le> m * length xss"
proof(induction xss rule: C_merge_adj.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 x y) thus ?case using C_merge_ub[of x y] by (simp add: algebra_simps)
qed

lemma C_merge_all: "\<lbrakk> \<forall>xs \<in> set xss. length xs = m; length xss = 2^k \<rbrakk>
  \<Longrightarrow> C_merge_all xss \<le> m * k * 2^k"
proof (induction xss arbitrary: k m rule: C_merge_all.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 xs ys xss)
  let ?xss = "xs # ys # xss"
  let ?xss2 = "merge_adj ?xss"
  obtain k' where k': "k = Suc k'" using "3.prems"(2)
    by (metis length_Cons nat.inject nat_power_eq_Suc_0_iff nat.exhaust)
  have "even (length ?xss)" using "3.prems"(2) k' by auto
  from length_merge_adj[OF this "3.prems"(1)]
  have *: "\<forall>x \<in> set(merge_adj ?xss). length x = 2*m" .
  have **: "length ?xss2 = 2 ^ k'" using "3.prems"(2) k' by auto
  have "C_merge_all ?xss = C_merge_adj ?xss + C_merge_all ?xss2" by simp
  also have "\<dots> \<le> m * 2^k + C_merge_all ?xss2"
    using "3.prems"(2) C_merge_adj[OF "3.prems"(1)] by (auto simp: algebra_simps)
  also have "\<dots> \<le> m * 2^k + (2*m) * k' * 2^k'"
    using "3.IH"[OF * **] by simp
  also have "\<dots> = m * k * 2^k"
    using k' by (simp add: algebra_simps)
  finally show ?case .
qed

corollary C_msort_bu: "length xs = 2 ^ k \<Longrightarrow> C_msort_bu xs \<le> k * 2 ^ k"
using C_merge_all[of "map (\<lambda>x. [x]) xs" 1] by (simp add: C_msort_bu_def)

subsection "Quicksort"

fun quicksort :: "('a::linorder) list \<Rightarrow> 'a list" where
"quicksort []     = []" |
"quicksort (x#xs) = quicksort (filter (\<lambda>y. y < x) xs) @ [x] @ quicksort (filter (\<lambda>y. x \<le> y) xs)"

lemma mset_quicksort: "mset (quicksort xs) = mset xs"
apply (induction xs rule: quicksort.induct)
apply (auto simp: not_le)
done

lemma set_quicksort: "set (quicksort xs) = set xs"
by(rule mset_eq_setD[OF mset_quicksort])

lemma sorted_quicksort: "sorted (quicksort xs)"
apply (induction xs rule: quicksort.induct)
apply (auto simp add: sorted_append set_quicksort)
done

subsection "Insertion Sort w.r.t. Keys and Stability"

text \<open>Note that \<^const>\<open>insort_key\<close> is already defined in theory \<^theory>\<open>HOL.List\<close>.
Thus some of the lemmas are already present as well.\<close>

fun isort_key :: "('a \<Rightarrow> 'k::linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"isort_key f [] = []" |
"isort_key f (x # xs) = insort_key f x (isort_key f xs)"

subsubsection "Standard functional correctness"

lemma mset_insort_key: "mset (insort_key f x xs) = {#x#} + mset xs"
by(induction xs) simp_all

lemma mset_isort_key: "mset (isort_key f xs) = mset xs"
by(induction xs) (simp_all add: mset_insort_key)

lemma set_isort_key: "set (isort_key f xs) = set xs"
by (rule mset_eq_setD[OF mset_isort_key])

lemma sorted_insort_key: "sorted (map f (insort_key f a xs)) = sorted (map f xs)"
by(induction xs)(auto simp: set_insort_key)

lemma sorted_isort_key: "sorted (map f (isort_key f xs))"
by(induction xs)(simp_all add: sorted_insort_key)

subsubsection "Stability"

lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
by (cases xs) auto

lemma filter_insort_key_neg:
  "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
by (induction xs) simp_all

lemma filter_insort_key_pos:
  "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
by (induction xs) (auto, subst insort_is_Cons, auto)

lemma sort_key_stable: "filter (\<lambda>y. f y = k) (isort_key f xs) = filter (\<lambda>y. f y = k) xs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thus ?case
  proof (cases "f a = k")
    case False thus ?thesis  by (simp add: Cons.IH filter_insort_key_neg)
  next
    case True
    have "filter (\<lambda>y. f y = k) (isort_key f (a # xs))
      = filter (\<lambda>y. f y = k) (insort_key f a (isort_key f xs))"  by simp
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) (isort_key f xs))"
      by (simp add: True filter_insort_key_pos sorted_isort_key)
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) xs)"  by (simp add: Cons.IH)
    also have "\<dots> = a # (filter (\<lambda>y. f y = k) xs)"  by(simp add: True insort_is_Cons)
    also have "\<dots> = filter (\<lambda>y. f y = k) (a # xs)" by (simp add: True)
    finally show ?thesis .
  qed
qed

end


theory Vedic
    imports Main
begin

text\<open>
A book about Vedic mathematics describes three methods to make the calculation of squares of natural numbers easier:

\begin{itemize}
\item {\em MM1}: Numbers whose predecessors have squares that are known or can easily be calculated. For example:
\\ Needed: $61^2$
\\ Given: $60^2 = 3600$
\\ Observe: $61^2 = 3600 + 60 + 61 = 3721$

\item {\em MM2}: Numbers greater than, but near 100. For example:
\\ Needed: $102^2$
\\ Let $h = 102 - 100 = 2$ , $h^2 = 4$
\\ Observe: $102^2 = (102+h)$ shifted two places to the left $ + h^2 = 10404$

\item {\em MM3}: Numbers ending in $5$. For example:
\\ Needed: $85^2$
\\ Observe: $85^2 = (8 * 9)$ appended to $ 25 = 7225$
\\ Needed: $995^2$
\\ Observe: $995^2 = (99 * 100)$ appended to $ 25 = 990025 $
\end{itemize}

In this exercise we will show that these methods are not so magical after all!

\begin{itemize}
\item Based on {\em MM1} define a function @{term "sq"} that calculates the square of a natural number.
\item Prove the correctness of @{term "sq"} (i.e.\ @{term "sq n = n * n"}).
\item Formulate and prove the correctness of {\em MM2}.\\ Hints:
  \begin{itemize}
  \item Generalise {\em MM2} for an arbitrary constant (instead of $100$).
  \item Universally quantify all variables other than the induction variable.
  \end{itemize}
\item Formulate and prove the correctness of {\em MM3}.\\ Hints:
  \begin{itemize}
  \item Try to formulate the property `numbers ending in $5$' such that it is easy to get to the rest of the number.
  \item Proving the binomial formula for $(a+b)^2$ can be of some help.
  \end{itemize}
\end{itemize}
\<close>

primrec sq :: "nat \<Rightarrow> nat"
  where
"sq 0 = 0" |
"sq (Suc n) = (if (10 dvd (Suc n))
               then (Suc n) * (Suc n)
               else (Suc n) + n + (sq n))"

lemma MM1[simp]:"sq n = n * n"
  apply (induction n) by auto

definition sq1 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
"sq1 n c = (let h = (n - c) in (n + h) * c + (sq h))"

lemma sq1_zero[simp]:"sq1 0 c = 0"
  by (simp add: sq1_def)

lemma MM2:"\<forall>c. c \<le> n \<Longrightarrow> (sq1 n c) = n*n"
  apply (simp add: Let_def sq1_def)
  apply (induction n , auto)
  by presburger

value "75 div 10::nat"

lemma bin_theorem_squared[simp]:"((a::nat) + b)^2 = a^2 + 2 * a * b + b^2"
  by algebra

definition sq2 :: "nat \<Rightarrow> nat"
  where
"sq2 n = (let c = n div 10 in ((Suc c) * c) * 100 + 25)"

value "sq2 35 = sq 35"
value "remaninder"

definition div_rem :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "div_rem a b q r = (b = a * q + r)"

lemma MM3:"div_rem 10 n c 5 \<Longrightarrow> ((Suc c) * c) * 100 + 25 = sq n"
  apply (simp add: Let_def sq2_def div_rem_def)
  apply (induction n, auto)
  by algebra

(*<*) end (*>*)