section{*Constructive Functions*}

theory Constructive imports Main
begin

  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

  class order_bot_max = order_bot +
    fixes maximal :: "'a \<Rightarrow> bool"
    assumes maximal_def: "maximal x = (\<forall> y . \<not> x < y)"
    assumes [simp]: "\<not> maximal \<bottom>"
    begin
      lemma ex_not_le_bot[simp]: "\<exists> a. \<not> a \<le> \<bottom>"
        apply (subgoal_tac "\<not> maximal \<bottom>")
        apply (subst (asm) maximal_def, simp_all add: less_le, auto)
        apply (rule_tac x = x in exI, auto)
        apply (subgoal_tac "x = \<bottom>", simp)
        by (rule antisym, simp_all)
    end

  instantiation "option" :: (type) order_bot_max
    begin
      definition bot_option_def: "(\<bottom>::'a option) = None"
      definition le_option_def: "((x::'a option) \<le> y) = (x = None \<or> x = y)"
      definition less_option_def: "((x::'a option) < y) = (x \<le> y \<and> \<not> (y \<le> x))"
      definition maximal_option_def: "maximal (x::'a option) = (\<forall> y . \<not> x < y)"

      instance
      proof
        qed (auto simp add: le_option_def less_option_def maximal_option_def bot_option_def)

  context order_bot
    begin
      definition "is_lfp f x = ((f x = x) \<and> (\<forall> y . f y = y \<longrightarrow> x \<le> y))"
      definition "emono f = (\<forall> x y. x \<le> y \<longrightarrow> f x \<le> f y)"

      definition "Lfp f = Eps (is_lfp f)"

      lemma lfp_unique: "is_lfp f x \<Longrightarrow> is_lfp f y \<Longrightarrow> x = y"
        apply (simp add: is_lfp_def)
        by (simp add: local.antisym)

      lemma lfp_exists: "is_lfp f x \<Longrightarrow> Lfp f = x"
        apply (rule lfp_unique, simp_all)
        by (simp add: Lfp_def someI)

      lemma emono_a: "emono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
        by (simp add: emono_def)

      lemma emono_fix: "emono f \<Longrightarrow> f y = y \<Longrightarrow> (f ^^ n) \<bottom> \<le> y"
        apply (induction n)
        apply (simp_all)
        apply (drule emono_a, simp_all)
        by simp

      lemma emono_is_lfp: "emono (f::'a \<Rightarrow> 'a) \<Longrightarrow> (f ^^ (n + 1)) \<bottom> = (f ^^ n) \<bottom> \<Longrightarrow> is_lfp f ((f ^^ n) \<bottom>)"
        apply (simp add: is_lfp_def, safe)
        by (rule emono_fix, simp_all)

      lemma emono_lfp_bot: "emono (f::'a \<Rightarrow> 'a) \<Longrightarrow> (f ^^ (n + 1)) \<bottom> = (f ^^ n) \<bottom> \<Longrightarrow> Lfp f = ((f ^^ n) \<bottom>)"
        apply (drule emono_is_lfp, simp_all)
        by (simp add: lfp_exists)

      lemma emono_up: "emono f \<Longrightarrow> (f ^^ n) \<bottom> \<le> (f ^^ (Suc n)) \<bottom>"
        apply (induction n)
        apply (simp_all)
        by (drule emono_a, simp_all)
    end

   context order
    begin
       definition "min_set A = (SOME n . n \<in> A \<and> (\<forall> x \<in> A . n \<le> x))"
    end

   lemma min_nonempty_nat_set_aux: "\<forall> A . (n::nat) \<in> A \<longrightarrow> (\<exists> k \<in> A . (\<forall> x \<in> A . k \<le> x))"
     apply (induction n, safe)
     apply (rule_tac x = 0 in bexI, simp_all)
     apply (case_tac "0 \<in> A")
     apply (rule_tac x = 0 in bexI, simp_all)
     apply (drule_tac x = "{n . Suc n \<in> A}" in spec)
     apply safe
     apply (rule_tac x = "Suc k" in bexI, simp_all, safe)
     apply (drule_tac x = "x - 1" in spec)
     by (case_tac x, simp_all)

   lemma min_nonempty_nat_set: "(n::nat) \<in> A \<Longrightarrow> (\<exists> k . k \<in> A \<and> (\<forall> x \<in> A . k \<le> x))"
     by (cut_tac min_nonempty_nat_set_aux, auto)

  thm someI_ex

  lemma min_set_nat_aux: "(n::nat) \<in> A \<Longrightarrow> min_set A \<in> A \<and> (\<forall> x \<in> A . min_set A \<le> x)"
    apply (simp add: min_set_def)
    apply (drule min_nonempty_nat_set)
    by (rule someI_ex, simp_all)

  lemma "(n::nat) \<in> A \<Longrightarrow> min_set A \<in> A \<and> min_set A \<le> n"
    by (simp add: min_set_nat_aux)

  lemma min_set_in: "(n::nat) \<in> A \<Longrightarrow> min_set A \<in> A"
    by (simp add: min_set_nat_aux)

  lemma min_set_less: "(n::nat) \<in> A \<Longrightarrow> min_set A \<le> n"
    by (simp add: min_set_nat_aux)

  definition "mono_a f = (\<forall> a b a' b'. (a::'a::order) \<le> a' \<and> (b::'b::order) \<le> b' \<longrightarrow> f a b \<le> f a' b')"

  class fin_cpo = order_bot_max +

    assumes fin_up_chain: "(\<forall> i:: nat . a i \<le> a (Suc i)) \<Longrightarrow> \<exists> n . \<forall> i \<ge> n . a i = a n"
    begin
      lemma emono_ex_lfp: "emono f \<Longrightarrow> \<exists> n . is_lfp f ((f ^^ n) \<bottom>)"
        apply (cut_tac a = "\<lambda> i . (f ^^ i) \<bottom>" in fin_up_chain)
        apply (safe, rule emono_up, simp)
        apply (rule_tac x= n in exI)
        apply (rule emono_is_lfp, simp)
        by (drule_tac x = "n + 1" in spec, simp)

      lemma emono_lfp: "emono f \<Longrightarrow> \<exists> n . Lfp f = (f ^^ n) \<bottom>"
        apply (drule emono_ex_lfp, safe)
        apply (rule_tac x = n in exI)
        by (rule lfp_exists, simp)

      lemma emono_is_lfp: "emono f \<Longrightarrow> is_lfp f (Lfp f)"
        apply (drule emono_ex_lfp, safe)
        by (frule lfp_exists, simp)

      definition "lfp_index (f::'a \<Rightarrow> 'a) = min_set {n . (f ^^ n) \<bottom> = (f ^^ (n + 1)) \<bottom>}"

      lemma lfp_index_aux: "emono f \<Longrightarrow> (\<forall> i < (lfp_index f) . (f ^^ i) \<bottom> < (f ^^ (i + 1)) \<bottom>) \<and> (f ^^ (lfp_index f)) \<bottom> = (f ^^ ((lfp_index f) + 1)) \<bottom>"
        apply (simp add: lfp_index_def)
        apply safe
        apply (simp add: less_le_not_le, safe)
        apply (cut_tac n = i in emono_up, simp_all)
        apply (cut_tac n = i and A = "{n . (f ^^ n) \<bottom> = (f ^^ (n + 1)) \<bottom>}" in min_set_less, simp)
        apply (rule antisym, simp_all)
        apply (cut_tac n = i in emono_up, simp_all)
        apply (cut_tac a = "\<lambda> i . (f ^^ i) \<bottom>" in fin_up_chain, simp, safe)
        apply (drule emono_up, simp)
        apply (cut_tac n = "n" and A = "{n . (f ^^ n) \<bottom> = (f ^^ (n + 1)) \<bottom>}" in min_set_in)
        apply (drule_tac x = "Suc n" in spec, simp)
        by simp

      lemma [simp]: "emono f \<Longrightarrow> i < lfp_index f \<Longrightarrow> (f ^^ i) \<bottom> < f ((f ^^ i) \<bottom>)"
        by (drule lfp_index_aux, simp)

      lemma [simp]: "emono f \<Longrightarrow> f ((f ^^ (lfp_index f)) \<bottom>) = (f ^^ (lfp_index f)) \<bottom>"
        by (drule lfp_index_aux, simp)

      lemma "emono f \<Longrightarrow> Lfp f = (f ^^ lfp_index f) \<bottom>"
        by (rule emono_lfp_bot, simp_all)

      lemma AA_aux: "emono f \<Longrightarrow> (\<And> b . b \<le> a \<Longrightarrow> f b \<le> a) \<Longrightarrow> (f ^^ n) \<bottom> \<le> a"
        by (induction n, simp_all)

      lemma AA: "emono f \<Longrightarrow> (\<And> b . b \<le> a \<Longrightarrow> f b \<le> a) \<Longrightarrow> Lfp f \<le> a"
        apply (cut_tac f = f in  emono_lfp, simp_all, safe, simp)
        by (simp add: AA_aux)

      lemma BB: "emono f \<Longrightarrow> f (Lfp f) = Lfp f"
        using local.emono_is_lfp local.is_lfp_def by blast

      lemma Lfp_mono: "emono f \<Longrightarrow> emono g \<Longrightarrow> (\<And> a . f a \<le> g a) \<Longrightarrow> Lfp f \<le> Lfp g"
        by (metis AA BB local.emono_def local.order_trans)

    end
    declare [[show_types]]

      lemma [simp]: "mono_a f \<Longrightarrow> emono (f a)"
        by (simp add: emono_def mono_a_def)

      lemma [simp]: "mono_a f \<Longrightarrow> emono (\<lambda> a . f a b)"
        by (simp add: emono_def mono_a_def)

      lemma mono_aD: "mono_a f \<Longrightarrow> a \<le> a' \<Longrightarrow> b \<le> b' \<Longrightarrow> f a b \<le> f a' b'"
        by (simp add: mono_a_def)

      lemma [simp]: "mono_a (f::'a::fin_cpo \<Rightarrow> 'b::fin_cpo \<Rightarrow> 'b) \<Longrightarrow> mono_a g \<Longrightarrow> emono (\<lambda>b. f (Lfp (g b)) b)"
        apply (simp add: emono_def, safe)
        apply (rule_tac f = f in mono_aD, simp_all)
        by (rule Lfp_mono, simp_all add: mono_a_def)

      lemma CCC: "mono_a  (f::'a::fin_cpo \<Rightarrow> 'b::fin_cpo \<Rightarrow> 'b) \<Longrightarrow> mono_a g \<Longrightarrow> Lfp (\<lambda>a. g (Lfp (f a)) a) \<le> Lfp (g (Lfp (\<lambda>b. f (Lfp (g b)) b)))"
        apply (rule AA, simp_all)
        apply (subst (2) BB [THEN sym], simp_all)
        apply (rule_tac f = g in mono_aD, simp_all)
        apply (rule AA, simp_all)
        apply (subst BB [THEN sym], simp_all)
        by (rule_tac f = f in mono_aD, simp_all)

    lemma Lfp_commute: "mono_a (f::'a::fin_cpo \<Rightarrow> 'b::fin_cpo \<Rightarrow> 'b::fin_cpo) \<Longrightarrow> mono_a g \<Longrightarrow> Lfp (\<lambda> b . f  (Lfp (\<lambda> a . (g (Lfp (f a))) a)) b) = Lfp (\<lambda> b . f (Lfp (g b)) b)"
      apply (rule antisym)
      apply (rule AA, simp_all)
      apply (subst (3) BB [THEN sym], simp_all)
      apply (rule_tac f = f in mono_aD)
      apply simp_all
      by (simp_all add: CCC)

  instantiation "option" :: (type) fin_cpo
    begin
      lemma fin_up_non_bot: "(\<forall> i . (a::nat \<Rightarrow> 'a option) i \<le> a (Suc i)) \<Longrightarrow> a n \<noteq> \<bottom> \<Longrightarrow> n \<le> i \<Longrightarrow> a i = a n"
        apply (induction i, simp_all)
        apply (case_tac "n \<le> i", simp_all)
        apply (drule_tac x = i in spec)
        apply (simp add: le_option_def bot_option_def, safe, simp_all)
        using le_Suc_eq by blast

     lemma fin_up_chain_option: "(\<forall> i:: nat . (a::nat \<Rightarrow> 'a option) i \<le> a (Suc i)) \<Longrightarrow> \<exists> n . \<forall> i \<ge> n . a i = a n"
      apply (case_tac "\<exists> n .  a n \<noteq> \<bottom>", safe, simp_all)
      apply (rule_tac x = n in exI, safe)
      by (rule fin_up_non_bot, simp_all)

    instance
      proof
        qed (simp add: fin_up_chain_option)
    end

  instantiation "prod" :: (order_bot_max, order_bot_max) order_bot_max
    begin
      definition bot_prod_def: "(\<bottom> :: 'a \<times> 'b) = (\<bottom>, \<bottom>)"
      definition le_prod_def: "(x \<le> y) = (fst x \<le> fst y \<and> snd x \<le> snd y)"
      definition less_prod_def: "((x::'a\<times>'b) < y) = (x \<le> y \<and> \<not> (y \<le> x))"
      definition maximal_prod_def: "maximal (x::'a \<times> 'b) = (\<forall> y . \<not> x < y)"

      instance proof
        qed (auto simp add: le_prod_def less_prod_def bot_prod_def maximal_prod_def)
    end

  instantiation "prod" :: (fin_cpo, fin_cpo) fin_cpo
    begin

      lemma fin_up_chain_prod: "(\<forall> i:: nat . (a::nat \<Rightarrow> 'a \<times> 'b) i \<le> a (Suc i)) \<Longrightarrow> \<exists> n . \<forall> i \<ge> n . a i = a n"
        apply (cut_tac a = "fst o a" in fin_up_chain)
        apply (simp add: le_prod_def)
        apply (cut_tac a = "snd o a" in fin_up_chain)
        apply (simp add: le_prod_def)
        apply safe
        apply (rule_tac x = "max n na" in exI)
        by (metis (no_types, hide_lams) comp_apply max.bounded_iff max.cobounded1 max.cobounded2 prod.collapse)
      instance proof
        qed (auto simp add: fin_up_chain_prod)
    end

end


header {* \isaheader{Example for Foreach-Loops} *}
theory Foreach_Refine
imports
  "../../Refine_Dflt_Only_ICF"
begin

text {*
  This example presents the usage of the foreach loop.
  We define a simple foreach loop that looks for the largest element with
  a given property. Ordered loops are used to be sure to find the largest one.
*}

subsection {* Definition *}

definition find_max_invar where
  "find_max_invar P S it \<sigma> =
     (case \<sigma> of None \<Rightarrow> (\<forall>x \<in> S - it. \<not>(P x))
             | Some y \<Rightarrow> (P y \<and> y \<in> S-it \<and> (\<forall>x \<in> S - it - {y}. \<not>(P x))))"

definition find_max :: "('a::{linorder} \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a option) nres" where
  "find_max P S \<equiv>
   FOREACHoci (op\<ge>) (find_max_invar P S) S
     (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x _. RETURN (if P x then Some x else None)) None"

subsection {* Correctness *}
text {* As simple correctness property, we show:
  If the algorithm returns the maximal element satisfying @{text "P"}.
*}
lemma find_max_correct:
  fixes S:: "'a::{linorder} set"
  assumes "finite S"
  shows "find_max P S \<le> SPEC (\<lambda>\<sigma>. case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not>(P x)
                                          | Some y \<Rightarrow> (P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> y \<ge> x)))"
  unfolding find_max_def
proof (rule FOREACHoci_rule)
  show "finite S" by fact
next
  show "find_max_invar P S S None"
  unfolding find_max_invar_def by simp
next
  fix x it \<sigma>
  assume "\<sigma> = None"
         "x \<in> it"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<forall>y\<in>it - {x}. y \<le> x"
         "\<forall>y\<in>S - it. x \<le> y"

  from `find_max_invar P S it \<sigma>` `\<sigma> = None`
  have not_P_others: "\<forall>x\<in>S - it. \<not> P x"
    by (simp add: find_max_invar_def)

  from `x \<in> it` `it \<subseteq> S` have "x \<in> S" by blast

  show "RETURN (if P x then Some x else None) \<le> SPEC (find_max_invar P S (it - {x}))"
    using not_P_others `x \<in> S`
    by (auto simp add: find_max_invar_def)
next
  fix \<sigma>
  assume "find_max_invar P S {} \<sigma>"
  thus "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
    by (cases \<sigma>, auto simp add: find_max_invar_def)
next
  fix it \<sigma>
  assume "it \<noteq> {}"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<sigma> \<noteq> None"
         "\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y"

  from `\<sigma> \<noteq> None` obtain y where \<sigma>_eq[simp]: "\<sigma> = Some y" by auto
  from `find_max_invar P S it \<sigma>`
    have y_props[simp]: "P y" "y \<in> S" "y \<notin> it" and not_P: "\<forall>x\<in>S - it - {y}. \<not> P x"
    by (simp_all add: find_max_invar_def)

  { fix x
    assume "x \<in> S" "P x"
    with not_P have "x \<in> it \<or> x = y" by auto
    with `\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y` y_props have "x \<le> y" by auto
  } note less_eq_y = this

  show "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
   by (simp add: find_max_invar_def Ball_def less_eq_y)
qed

subsection {* Data Refinement and Determinization *}
text {*
  Next, we use automatic data refinement and transfer to generate an
  executable algorithm using a red-black-tree.
*}
schematic_lemma find_max_impl_refine_aux:
  assumes invar_S: "rs.invar S"
  shows "RETURN (?f) \<le> (find_max P (rs.\<alpha> S))"
  unfolding find_max_def
  by (refine_transfer
    RBTSetImpl.rs.rev_iterateoi_correct[unfolded set_iterator_rev_linord_def,
    OF invar_S])

concrete_definition find_max_impl for P S uses find_max_impl_refine_aux

lemma find_max_impl_refine:
  assumes invar_S: "rs.invar S"
  shows "RETURN (find_max_impl P S) \<le> (find_max P (rs.\<alpha> S))"
  using assms by (rule find_max_impl.refine)

subsubsection {* Executable Code *}

lemma find_max_impl_correct :
assumes invar_S: "rs.invar S"
shows "case find_max_impl P S of None \<Rightarrow> \<forall>x\<in>rs.\<alpha> S. \<not>(P x)
                               | Some y \<Rightarrow> (P y \<and> y \<in> (rs.\<alpha> S)
                                 \<and> (\<forall>x\<in>rs.\<alpha> S. P x \<longrightarrow> y \<ge> x))"
proof -
  note find_max_impl_refine [of S P, OF invar_S]
  also note find_max_correct [OF RBTSetImpl.rs.finite[of S, OF invar_S], of P]
  finally show ?thesis by simp
qed

text {* Finally, we can generate code *}
export_code find_max_impl in SML
export_code find_max_impl in OCaml
export_code find_max_impl in Haskell
export_code find_max_impl in Scala

end


(*
  File: Closure.thy
  Author: Bohua Zhan

  Closure in topological spaces.
*)

theory Closure
  imports ProductTopology
begin

definition interior :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "interior(X,A) = \<Union>{U\<in>open_sets(X). U \<subseteq> A}"
setup {* register_wellform_data ("interior(X,A)", ["A \<subseteq> carrier(X)"]) *}

lemma interior_subset [resolve]: "interior(X,A) \<subseteq> A" by auto2
lemma interior_open [resolve]: "is_top_space(X) \<Longrightarrow> is_open(X,interior(X,A))" by auto2

definition closure :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "closure(X,A) = \<Inter>{C\<in>closed_sets(X). A \<subseteq> C}"
setup {* register_wellform_data ("closure(X,A)", ["A \<subseteq> carrier(X)"]) *}

lemma closure_prop:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> A \<subseteq> closure(X,A) \<and> is_closed(X,closure(X,A))"
@proof @have "carrier(X) \<in> {C\<in>closed_sets(X). A \<subseteq> C}" @qed
setup {* add_forward_prfstep_cond @{thm closure_prop} [with_term "closure(?X,?A)"] *}

lemma closure_subset' [backward2]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> is_closed(X,B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> closure(X,A) \<subseteq> B"
@proof @have "carrier(X) \<in> {C\<in>closed_sets(X). A \<subseteq> C}" @qed

lemma closure_subspace:
  "is_top_space(X) \<Longrightarrow> Y \<subseteq> carrier(X) \<Longrightarrow> A \<subseteq> Y \<Longrightarrow> closure(subspace(X,Y),A) = Y \<inter> closure(X,A)"
@proof
  @let "B = closure(subspace(X,Y), A)"
  @have "B \<subseteq> Y \<inter> closure(X,A)" @with
    @have "is_closed(subspace(X,Y), Y \<inter> closure(X,A))" @end
  @obtain "C\<in>closed_sets(X)" where "B = Y \<inter> C"
  @have "closure(X,A) \<subseteq> C"
  @have "Y \<inter> closure(X,A) \<subseteq> Y \<inter> C"
@qed

lemma closure_mem1 [backward1]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> x \<notin> closure(X,A) \<Longrightarrow> \<exists>U\<in>neighs(X,x). U \<inter> A = \<emptyset>"
@proof @have "carrier(X) \<midarrow> closure(X,A) \<in> neighs(X,x)" @qed

lemma closure_mem2 [forward]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> x \<in> closure(X,A) \<Longrightarrow> U \<in> neighs(X,x) \<Longrightarrow> U \<inter> A \<noteq> \<emptyset>"
@proof
  @contradiction
  @have "is_closed(X, carrier(X) \<midarrow> U)"
  @have "closure(X,A) \<subseteq> carrier(X) \<midarrow> U"
@qed

definition hausdorff :: "i \<Rightarrow> o" where [rewrite]:
  "hausdorff(X) \<longleftrightarrow> (is_top_space(X) \<and> (\<forall>x\<in>.X. \<forall>y\<in>.X. x \<noteq> y \<longrightarrow> (\<exists>U\<in>neighs(X,x). \<exists>V\<in>neighs(X,y). U \<inter> V = \<emptyset>)))"

lemma hausdorffD1 [forward]: "hausdorff(X) \<Longrightarrow> is_top_space(X)" by auto2
lemma hausdorffD2 [backward]: "hausdorff(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>U\<in>neighs(X,x). \<exists>V\<in>neighs(X,y). U \<inter> V = \<emptyset>" by auto2
setup {* del_prfstep_thm_eqforward @{thm hausdorff_def} *}

definition T1_space :: "i \<Rightarrow> o" where [rewrite]:
  "T1_space(X) \<longleftrightarrow> (is_top_space(X) \<and> (\<forall>x\<in>.X. is_closed(X,{x})))"

lemma T1_spaceD1 [forward]: "T1_space(X) \<Longrightarrow> is_top_space(X)" by auto2
lemma T1_spaceD2: "T1_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> is_closed(X,{x})" by auto2
setup {* add_forward_prfstep_cond @{thm T1_spaceD2} [with_term "{?x}"] *}
setup {* del_prfstep_thm_eqforward @{thm T1_space_def} *}

lemma hausdorff_is_T1 [forward]: "hausdorff(X) \<Longrightarrow> T1_space(X)"
@proof
  @have "\<forall>x\<in>.X. is_closed(X,{x})" @with
    @contradiction
    @have "\<forall>y\<in>closure(X,{x}). y \<in> {x}" @with
      @contradiction
      @obtain "U\<in>neighs(X,x)" "V\<in>neighs(X,y)" where "U \<inter> V = \<emptyset>" @end @end
@qed

lemma subspace_hausdorff: "hausdorff(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> hausdorff(subspace(X,A))"
@proof
  @let "Y = subspace(X,A)"
  @have "\<forall>x\<in>.Y. \<forall>y\<in>.Y. x \<noteq> y \<longrightarrow> (\<exists>U\<in>neighs(Y,x). \<exists>V\<in>neighs(Y,y). U \<inter> V = \<emptyset>)" @with
    @obtain "U\<in>neighs(X,x)" "V\<in>neighs(X,y)" where "U \<inter> V = \<emptyset>"
    @have "(A \<inter> U) \<inter> (A \<inter> V) = \<emptyset>" @end
@qed
setup {* add_forward_prfstep_cond @{thm subspace_hausdorff} [with_term "subspace(?X,?A)"] *}

lemma product_hausdorff [forward]: "hausdorff(X) \<Longrightarrow> hausdorff(Y) \<Longrightarrow> hausdorff(X \<times>\<^sub>T Y)"
@proof
  @let "Z = X \<times>\<^sub>T Y"
  @have "\<forall>x\<in>.Z. \<forall>y\<in>.Z. x \<noteq> y \<longrightarrow> (\<exists>U\<in>neighs(Z,x). \<exists>V\<in>neighs(Z,y). U \<inter> V = \<emptyset>)" @with
    @case "fst(x) \<noteq> fst(y)" @with
      @obtain "U\<in>neighs(X,fst(x))" "V\<in>neighs(X,fst(y))" where "U \<inter> V = \<emptyset>"
      @have "(U \<times> carrier(Y)) \<inter> (V \<times> carrier(Y)) = \<emptyset>" @end
    @case "snd(x) \<noteq> snd(y)" @with
      @obtain "U\<in>neighs(Y,snd(x))" "V\<in>neighs(Y,snd(y))" where "U \<inter> V = \<emptyset>"
      @have "(carrier(X) \<times> U) \<inter> (carrier(X) \<times> V) = \<emptyset>" @end
  @end
@qed

end


(*  Title:      HOL/Library/Quotient_Type.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Quotient types\<close>

theory Quotient_Type
imports Main
begin

text \<open>We introduce the notion of quotient types over equivalence relations
  via type classes.\<close>

subsection \<open>Equivalence relations and quotient types\<close>

text \<open>Type class \<open>equiv\<close> models equivalence relations
  \<open>\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>.\<close>

class eqv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infixl "\<sim>" 50)

class equiv = eqv +
  assumes equiv_refl [intro]: "x \<sim> x"
    and equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
    and equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
begin

lemma equiv_not_sym [sym]: "\<not> x \<sim> y \<Longrightarrow> \<not> y \<sim> x"
proof -
  assume "\<not> x \<sim> y"
  then show "\<not> y \<sim> x" by (rule contrapos_nn) (rule equiv_sym)
qed

lemma not_equiv_trans1 [trans]: "\<not> x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> x \<sim> y" and "y \<sim> z"
  show "\<not> x \<sim> z"
  proof
    assume "x \<sim> z"
    also from \<open>y \<sim> z\<close> have "z \<sim> y" ..
    finally have "x \<sim> y" .
    with \<open>\<not> x \<sim> y\<close> show False by contradiction
  qed
qed

lemma not_equiv_trans2 [trans]: "x \<sim> y \<Longrightarrow> \<not> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> y \<sim> z"
  then have "\<not> z \<sim> y" ..
  also
  assume "x \<sim> y"
  then have "y \<sim> x" ..
  finally have "\<not> z \<sim> x" .
  then show "\<not> x \<sim> z" ..
qed

end

text \<open>The quotient type \<open>'a quot\<close> consists of all \emph{equivalence
  classes} over elements of the base type @{typ 'a}.\<close>

definition (in eqv) "quot = {{x. a \<sim> x} | a. True}"

typedef (overloaded) 'a quot = "quot :: 'a::eqv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]:
  assumes "R \<in> quot"
  obtains a where "R = {x. a \<sim> x}"
  using assms unfolding quot_def by blast

text \<open>Abstracted equivalence classes are the canonical representation of
  elements of a quotient type.\<close>

definition "class" :: "'a::equiv \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R
  assume R: "A = Abs_quot R"
  assume "R \<in> quot"
  then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis unfolding class_def .
qed

lemma quot_cases [cases type: quot]:
  obtains a where "A = \<lfloor>a\<rfloor>"
  using quot_exhaust by blast

subsection \<open>Equality on quotients\<close>

text \<open>Equality of canonical quotient elements coincides with the original
  relation.\<close>

theorem quot_equality [iff?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
proof
  assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  show "a \<sim> b"
  proof -
    from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
      by (simp only: class_def Abs_quot_inject quotI)
    moreover have "a \<sim> a" ..
    ultimately have "a \<in> {x. b \<sim> x}" by blast
    then have "b \<sim> a" by blast
    then show ?thesis ..
  qed
next
  assume ab: "a \<sim> b"
  show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  proof -
    have "{x. a \<sim> x} = {x. b \<sim> x}"
    proof (rule Collect_cong)
      fix x show "(a \<sim> x) = (b \<sim> x)"
      proof
        from ab have "b \<sim> a" ..
        also assume "a \<sim> x"
        finally show "b \<sim> x" .
      next
        note ab
        also assume "b \<sim> x"
        finally show "a \<sim> x" .
      qed
    qed
    then show ?thesis by (simp only: class_def)
  qed
qed

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    then have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by (simp only: pick_equiv)
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
  with a show ?thesis by simp
qed

text \<open>The following rules support canonical function definitions on quotient
  types (with up to two arguments). Note that the stripped-down version
  without additional conditions is sufficient most of the time.\<close>

theorem quot_cond_function:
  assumes eq: "\<And>X Y. P X Y \<Longrightarrow> f X Y \<equiv> g (pick X) (pick Y)"
    and cong: "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
      \<Longrightarrow> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> \<Longrightarrow> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
    and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
proof -
  from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
  also have "... = g a b"
  proof (rule cong)
    show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
    moreover
    show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
    moreover
    show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
    ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
  qed
  finally show ?thesis .
qed

theorem quot_function:
  assumes "\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)"
    and "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  using assms and TrueI
  by (rule quot_cond_function)

theorem quot_function':
  "(\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)) \<Longrightarrow>
    (\<And>x x' y y'. x \<sim> x' \<Longrightarrow> y \<sim> y' \<Longrightarrow> g x y = g x' y') \<Longrightarrow>
    f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  by (rule quot_function) (simp_all only: quot_equality)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Functions on Relations\<close>
theory SBinary_Relation_Functions
  imports
    Pairs
    Replacement_Predicates
begin

subsubsection \<open>Inverse\<close>

(*TODO: replace condition with a new is_pair predicate*)
definition "set_rel_inv R \<equiv> {\<langle>y, x\<rangle> | \<langle>x, y\<rangle> \<in> {p \<in> R | \<exists>x y. p = \<langle>x, y\<rangle>}}"

bundle hotg_rel_inv_syntax
begin
notation set_rel_inv ("(_\<inverse>)" [1000])
end
bundle no_hotg_rel_inv_syntax
begin
no_notation set_rel_inv ("(_\<inverse>)" [1000])
end

unbundle no_rel_inv_syntax
unbundle hotg_rel_inv_syntax

lemma mem_set_rel_invI [intro]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  shows "\<langle>y, x\<rangle> \<in> R\<inverse>"
  using assms unfolding set_rel_inv_def by auto

lemma mem_set_rel_invE [elim!]:
  assumes "p \<in> R\<inverse>"
  obtains x y where "p = \<langle>y, x\<rangle>" "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding set_rel_inv_def uncurry_def by (auto)

lemma set_rel_inv_pairs_eq [simp]: "(A \<times> B)\<inverse> = B \<times> A"
  by auto

lemma set_rel_inv_empty_eq [simp]: "{}\<inverse> = {}"
  by auto

lemma set_rel_inv_inv_eq: "R\<inverse>\<inverse> = {p \<in> R | \<exists>x y. p = \<langle>x, y\<rangle>}"
  by auto

lemma mono_set_rel_inv: "mono set_rel_inv"
  by (intro monoI) auto

subsubsection \<open>Extensions and Restricts\<close>

definition "extend x y R \<equiv> insert \<langle>x, y\<rangle> R"

lemma mem_extendI [intro]: "\<langle>x, y\<rangle> \<in> extend x y R"
  unfolding extend_def by blast

lemma mem_extendI':
  assumes "p \<in> R"
  shows "p \<in> extend x y R"
  unfolding extend_def using assms by blast

lemma mem_extendE [elim]:
  assumes "p \<in> extend x y R"
  obtains "p = \<langle>x, y\<rangle>" | "p \<noteq> \<langle>x, y\<rangle>" "p \<in> R"
  using assms unfolding extend_def by blast

lemma extend_eq_self_if_pair_mem [simp]: "\<langle>x, y\<rangle> \<in> R \<Longrightarrow> extend x y R = R"
  by (auto intro: mem_extendI')

lemma insert_pair_eq_extend: "insert \<langle>x, y\<rangle> R = extend x y R"
  by (auto intro: mem_extendI')

lemma mono_extend_set: "mono (extend x y)"
  by (intro monoI) (auto intro: mem_extendI')

definition "glue \<R> \<equiv> \<Union>\<R>"

lemma mem_glueI [intro]:
  assumes "p \<in> R"
  and "R \<in> \<R>"
  shows "p \<in> glue \<R>"
  using assms unfolding glue_def by blast

lemma mem_glueE [elim!]:
  assumes "p \<in> glue \<R>"
  obtains R where "p \<in> R" "R \<in> \<R>"
  using assms unfolding glue_def by blast

lemma glue_empty_eq [simp]: "glue {} = {}" by auto

lemma glue_singleton_eq [simp]: "glue {R} = R" by auto

lemma mono_glue: "mono glue"
  by (intro monoI) auto

consts set_restrict_left :: "set \<Rightarrow> 'a \<Rightarrow> set"

definition "set_restrict_right R P \<equiv> (set_restrict_left R\<inverse> P)\<inverse>"

bundle hotg_restrict_syntax
begin
notation set_restrict_left ("(_)\<restriction>(\<^bsub>_\<^esub>)" [1000])
notation set_restrict_right ("(_)\<upharpoonleft>(\<^bsub>_\<^esub>)" [1000])
end
bundle no_hotg_restrict_syntax
begin
no_notation set_restrict_left ("(_)\<restriction>(\<^bsub>_\<^esub>)" [1000])
no_notation set_restrict_right ("(_)\<upharpoonleft>(\<^bsub>_\<^esub>)" [1000])
end
unbundle no_restrict_syntax
unbundle hotg_restrict_syntax

overloading
  set_restrict_left_pred \<equiv> "set_restrict_left :: set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> set"
  set_restrict_left_set \<equiv> "set_restrict_left :: set \<Rightarrow> set \<Rightarrow> set"
begin
  definition "set_restrict_left_pred R P \<equiv> {p \<in> R | \<exists>x y. P x \<and> p = \<langle>x, y\<rangle>}"
  definition "set_restrict_left_set R A \<equiv> set_restrict_left R (mem_of A)"
end

lemma set_restrict_left_set_eq_set_restrict_left [simp]:
  "R\<restriction>\<^bsub>A\<^esub> = R\<restriction>\<^bsub>mem_of A\<^esub>"
  unfolding set_restrict_left_set_def by simp

lemma mem_set_restrict_leftI [intro!]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  and "P x"
  shows "\<langle>x, y\<rangle> \<in> R\<restriction>\<^bsub>P\<^esub>"
  using assms unfolding set_restrict_left_pred_def by blast

lemma mem_set_restrict_leftE [elim]:
  assumes "p \<in> R\<restriction>\<^bsub>P\<^esub>"
  obtains x y where "p = \<langle>x, y\<rangle>" "P x" "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding set_restrict_left_pred_def by blast

lemma mem_set_restrict_rightI [intro!]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  and "P y"
  shows "\<langle>x, y\<rangle> \<in> R\<upharpoonleft>\<^bsub>P\<^esub>"
  using assms unfolding set_restrict_right_def by blast

lemma mem_set_restrict_rightE [elim]:
  assumes "p \<in> R\<upharpoonleft>\<^bsub>P\<^esub>"
  obtains x y where "p = \<langle>x, y\<rangle>" "P y" "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding set_restrict_right_def by blast

lemma set_restrict_left_empty_eq [simp]: "{}\<restriction>\<^bsub>P :: set \<Rightarrow> bool\<^esub> = {}" by auto

lemma set_restrict_left_empty_eq' [simp]: "R\<restriction>\<^bsub>{}\<^esub> = {}" by auto

lemma set_restrict_left_subset_self [iff]: "R\<restriction>\<^bsub>P :: set \<Rightarrow> bool\<^esub> \<subseteq> R" by auto

lemma set_restrict_left_dep_pairs_eq_dep_pairs_collect [simp]:
  "(\<Sum>x \<in> A. B x)\<restriction>\<^bsub>P\<^esub> = (\<Sum>x \<in> {a \<in> A | P a}. B x)"
  by auto

lemma set_restrict_left_dep_pairs_eq_dep_pairs_bin_inter [simp]:
  "(\<Sum>x \<in> A. B x)\<restriction>\<^bsub>A'\<^esub> = (\<Sum>x \<in> A \<inter> A'. B x)"
  by simp

lemma set_restrict_left_subset_dep_pairs_if_subset_dep_pairs [intro]:
  assumes "R \<subseteq> \<Sum>x \<in> A. B x"
  shows "R\<restriction>\<^bsub>P\<^esub> \<subseteq> \<Sum>x \<in> {x \<in> A | P x}. B x"
  using assms by auto

lemma set_restrict_left_set_restrict_left_eq_set_restrict_left [simp]:
  fixes P P' :: "set \<Rightarrow> bool"
  shows "(R\<restriction>\<^bsub>P\<^esub>)\<restriction>\<^bsub>P\<^esub> = R\<restriction>\<^bsub>P\<^esub>"
  by auto

lemma mono_set_restrict_left_set: "mono (\<lambda>R. R\<restriction>\<^bsub>P :: set \<Rightarrow> bool\<^esub>)"
  by (intro monoI) auto

lemma mono_set_restrict_left_pred: "mono (\<lambda>P. R\<restriction>\<^bsub>P :: set \<Rightarrow> bool\<^esub>)"
  by (intro monoI) auto

definition "agree P \<R> \<equiv> \<forall>R R' \<in> \<R>. R\<restriction>\<^bsub>P\<^esub> = R'\<restriction>\<^bsub>P\<^esub>"

lemma agree_set_iff_agree [iff]: "agree A \<R> \<longleftrightarrow> agree (mem_of A) \<R>"
  unfolding agree_def by simp

lemma agreeI [intro]:
  assumes "\<And>x y R R'. P x \<Longrightarrow> R \<in> \<R> \<Longrightarrow> R' \<in> \<R> \<Longrightarrow> \<langle>x, y\<rangle> \<in> R \<Longrightarrow> \<langle>x, y\<rangle> \<in> R'"
  shows "agree P \<R>"
  using assms unfolding agree_def by blast

lemma agreeD:
  assumes "agree P \<R>"
  and "P x"
  and "R \<in> \<R>" "R' \<in> \<R>"
  and "\<langle>x, y\<rangle> \<in> R"
  shows "\<langle>x, y\<rangle> \<in> R'"
proof -
  from assms(2, 5) have "\<langle>x, y\<rangle> \<in> R\<restriction>\<^bsub>P\<^esub>" by (intro mem_set_restrict_leftI)
  moreover from assms(1, 3-4) have "... = R'\<restriction>\<^bsub>P\<^esub>" unfolding agree_def by blast
  ultimately show ?thesis by auto
qed

lemma antimono_agree_pred: "antimono (\<lambda>P. agree (P :: set \<Rightarrow> bool) \<R>)"
  by (intro antimonoI) (auto dest: agreeD)

lemma antimono_agree_set: "antimono (\<lambda>\<R>. agree (P :: set \<Rightarrow> bool) \<R>)"
  by (intro antimonoI) (auto dest: agreeD)

lemma set_restrict_left_eq_set_restrict_left_if_agree:
  fixes P :: "set \<Rightarrow> bool"
  assumes "agree P \<R>"
  and "R \<in> \<R>" "R' \<in> \<R>"
  shows "R\<restriction>\<^bsub>P\<^esub> = R'\<restriction>\<^bsub>P\<^esub>"
  using assms by (auto dest: agreeD)

lemma eq_if_subset_dep_pairs_if_agree:
  assumes "agree A \<R>"
  and subset_dep_pairs: "\<And>R. R \<in> \<R> \<Longrightarrow> \<exists>B. R \<subseteq> \<Sum>x \<in> A. B x"
  and "R \<in> \<R>"
  and "R' \<in> \<R>"
  shows "R = R'"
proof -
  from subset_dep_pairs[OF \<open>R \<in> \<R>\<close>] have "R = R\<restriction>\<^bsub>A\<^esub>" by auto
  also with assms have "... = R'\<restriction>\<^bsub>A\<^esub>"
    by ((subst set_restrict_left_set_eq_set_restrict_left)+,
      intro set_restrict_left_eq_set_restrict_left_if_agree)
    auto
  also from subset_dep_pairs[OF \<open>R' \<in> \<R>\<close>] have "... = R'" by auto
  finally show ?thesis .
qed

lemma subset_if_agree_if_subset_dep_pairs:
  assumes subset_dep_pairs: "R \<subseteq> \<Sum>x \<in> A. B x"
  and "R \<in> \<R>"
  and "agree A \<R>"
  and "R' \<in> \<R>"
  shows "R \<subseteq> R'"
  using assms by (auto simp: agreeD[where ?R="R"])

subsubsection \<open>Domain and Range\<close>

definition "dom R \<equiv> {x | p \<in> R, \<exists>y. p = \<langle>x, y\<rangle>}"

lemma mem_domI [intro]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  shows "x \<in> dom R"
  using assms unfolding dom_def by fast

lemma mem_domE [elim!]:
  assumes "x \<in> dom R"
  obtains y where "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding dom_def by blast

lemma mono_dom: "mono dom"
  by (intro monoI) auto

lemma dom_empty_eq [simp]: "dom {} = {}"
  by auto

lemma dom_union_eq [simp]: "dom (\<Union>\<R>) = \<Union>{dom R | R \<in> \<R>}"
  by auto

lemma dom_bin_union_eq [simp]: "dom (R \<union> S) = dom R \<union> dom S"
  by auto

lemma dom_collect_eq [simp]: "dom {\<langle>f x, g x\<rangle> | x \<in> A} = {f x | x \<in> A}"
  by auto

lemma dom_extend_eq [simp]: "dom (extend x y R) = insert x (dom R)"
  by (rule eqI) (auto intro: mem_extendI')

lemma dom_dep_pairs_eqI [intro]:
  assumes "\<And>x. B x \<noteq> {}"
  shows "dom (\<Sum>x \<in> A. B x) = A"
  using assms by (intro eqI) auto

lemma dom_restrict_left_eq [simp]: "dom (R\<restriction>\<^bsub>P\<^esub>) = {x \<in> dom R | P x}"
  by auto

lemma dom_restrict_left_set_eq [simp]: "dom (R\<restriction>\<^bsub>A\<^esub>) = dom R \<inter> A" by simp

lemma glue_subset_dep_pairsI:
  fixes \<R> defines "D \<equiv> \<Union>R \<in> \<R>. dom R"
  assumes all_subset_dep_pairs: "\<And>R. R \<in> \<R> \<Longrightarrow> \<exists>A. R \<subseteq> \<Sum>x \<in> A. B x"
  shows "glue \<R> \<subseteq> \<Sum>x \<in> D. (B x)"
proof
  fix p assume "p \<in> glue \<R>"
  with all_subset_dep_pairs obtain R A where "p \<in> R" "R \<in> \<R>" "R \<subseteq> \<Sum>x \<in> A. B x"
    by blast
  then obtain x y where "p = \<langle>x, y\<rangle>" "x \<in> dom R" "y \<in> B x" by blast
  with \<open>R \<in> \<R>\<close> have "x \<in> D" unfolding D_def by auto
  with \<open>p = \<langle>x, y\<rangle>\<close> \<open>y \<in> B x\<close> show "p \<in> \<Sum>x \<in> D. (B x)" by auto
qed

definition "rng R \<equiv> {y | p \<in> R, \<exists>x. p = \<langle>x, y\<rangle>}"

lemma mem_rngI [intro]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  shows "y \<in> rng R"
  using assms unfolding rng_def by fast

lemma mem_rngE [elim!]:
  assumes "y \<in> rng R"
  obtains x where "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding rng_def by blast

lemma mono_rng: "mono rng"
  by (intro monoI) auto

lemma rng_empty_eq [simp]: "rng {} = {}"
  by auto

lemma rng_union_eq [simp]: "rng (\<Union>\<R>) = \<Union>{rng R | R \<in> \<R>}"
  by auto

lemma rng_bin_union_eq [simp]: "rng (R \<union> S) = rng R \<union> rng S"
  by auto

lemma rng_collect_eq [simp]: "rng {\<langle>f x, g x\<rangle> | x \<in> A} = {g x | x \<in> A}"
  by auto

lemma rng_extend_eq [simp]: "rng (extend x y R) = insert y (rng R)"
  by (rule eqI) (auto intro: mem_extendI')

lemma rng_dep_pairs_eq [simp]: "rng (\<Sum>x \<in> A. B x) = (\<Union>x \<in> A. B x)"
  by auto

lemma dom_rel_inv_eq_rng [simp]: "dom R\<inverse> = rng R"
  by auto

lemma rng_rel_inv_eq_dom [simp]: "rng R\<inverse> = dom R"
  by auto

subsubsection \<open>Composition\<close>

definition "set_comp S R \<equiv>
  {p \<in> dom R \<times> rng S | \<exists>z. \<langle>fst p, z\<rangle> \<in> R \<and> \<langle>z, snd p\<rangle> \<in> S}"

bundle hotg_comp_syntax begin notation set_comp (infixr "\<circ>" 60) end
bundle no_hotg_comp_syntax begin no_notation set_comp (infixr "\<circ>" 60) end
unbundle no_comp_syntax
unbundle hotg_comp_syntax

lemma mem_compI [intro!]:
  assumes "\<langle>x, y\<rangle> \<in> R"
  and "\<langle>y, z\<rangle> \<in> S"
  shows "\<langle>x, z\<rangle> \<in> S \<circ> R"
  using assms unfolding set_comp_def by auto

lemma mem_compE [elim!]:
  assumes "p \<in> S \<circ> R"
  obtains x y z where "\<langle>x, y\<rangle> \<in> R" "\<langle>y, z\<rangle> \<in> S" "p = \<langle>x, z\<rangle>"
  using assms unfolding set_comp_def by auto

lemma dep_pairs_comp_pairs_eq:
  "((\<Sum>x \<in> B. (C x)) \<circ> (A \<times> B)) = A \<times> (\<Union>x \<in> B. (C x))"
  by auto

lemma set_comp_assoc: "T \<circ> S \<circ> R = (T \<circ> S) \<circ> R"
  by auto

lemma mono_set_comp_left: "mono (\<lambda>R. R \<circ> S)"
  by (intro monoI) auto

lemma mono_set_comp_right: "mono (\<lambda>S. R \<circ> S)"
  by (intro monoI) auto

subsubsection \<open>Diagonal\<close>

definition "diag A \<equiv> {\<langle>a, a\<rangle> | a \<in> A}"

lemma mem_diagI [intro!]: "a \<in> A \<Longrightarrow> \<langle>a, a\<rangle> \<in> diag A"
  unfolding diag_def by auto

lemma mem_diagE [elim!]:
  assumes "p \<in> diag A"
  obtains a where "a \<in> A" "p = \<langle>a, a\<rangle>"
  using assms unfolding diag_def by auto

lemma mono_diag: "mono diag"
  by (intro monoI) auto

end


theory TreeSum
imports Main
begin

(* exercise 2.6 from Concrete Semantics *)

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

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

fun treesum :: "int tree \<Rightarrow> int" where
   "treesum Tip = 0"
 | "treesum (Node a b c) = (treesum a) + b + (treesum c)"

theorem "treesum xt = listsum (contents xt)"
by (induction; auto)

end


theory PropLogic
  imports Main
begin

datatype 'av formula =
  p "'av"
  | andf "'av formula" "'av formula" (infixr "And" 68)
  | negf "'av formula" ("Neg")
 (* | Falsum *)

lemma and_assoc_example: "(p 1) And (p 2) And (p 3) = (p 1) And ((p 2) And (p 3))"
  by simp

lemma and_assoc_example2: "(p 1) And (p 2) And (p 3) \<noteq> ((p 1) And (p 2)) And (p 3)"
  by auto

abbreviation orf (infixr "Or" 67) where
"(orf f1 f2) \<equiv> Neg ( (Neg f1) And (Neg f2) )"

lemma binding_prior_example: "Neg (p 1) Or (p 2) And (p 1) =  (Neg (p 1) Or ((p 2) And (p 1) ) )"
  by simp

abbreviation implf (infixr "Impl" 68) where
"(implf f1 f2) \<equiv> Neg (f1 And (Neg f2))"

abbreviation biimplf (infixr "IImpl" 69) where
"biimplf f1 f2 \<equiv> (f1 Impl f2) And (f2 Impl f1)"

fun rg::"'a formula \<Rightarrow> nat" where
"rg (p _) = 0" |
"rg (f1 And f2) = max(rg f1)(rg f2) +1" |
"rg (Neg f1) = rg f1 +1"
(* | "rg Falsum = 1" *)

lemma "(rg (andf (p (1::nat)) (orf (p 2) (negf (p 1)) ))) = 5"
  by(simp)

type_synonym 'a model = "('a \<Rightarrow> bool)"

fun ext_mod :: " ('a model) \<Rightarrow> 'a formula \<Rightarrow> bool" where
"ext_mod w (p y) = w y" |
"ext_mod w (f1 And f2) = ( (ext_mod w f1) \<and> (ext_mod w f2) )" |
"ext_mod w (Neg f) = (\<not> (ext_mod w f))"
(* | "ext_mod w Falsum = False" *)

fun w_example ::"nat \<Rightarrow> bool" where
"w_example n = (n=2)"

lemma ext_mod_example: " ext_mod w_example (andf (p (1::nat)) (orf (p 2) (negf (p 1)) )) = False"
  by(simp)

abbreviation sem_equiv (infix "\<equiv>f" 70) where
"sem_equiv (f1::'a formula) (f2:: 'a formula) \<equiv> \<forall> (w :: 'a model). ext_mod w f1 = ext_mod w f2"

lemma sem_equiv_neg_neg: "alpha \<equiv>f ( negf (negf alpha))"
  by(simp)

lemma sem_equiv_assoc_and: "((alpha And beta) And gamma) \<equiv>f (alpha And (beta And gamma))"
  by(simp)

lemma sem_equiv_assoc_or: "((alpha Or beta) Or gamma) \<equiv>f (alpha Or beta Or gamma)"
  by(simp)

lemma sem_equiv_comm_and: "(alpha And beta) \<equiv>f (beta And alpha)"
  by(simp, auto)

lemma sem_equiv_comm_or: "(alpha Or beta) \<equiv>f (beta Or alpha)"
  by(simp, auto)

lemma sem_equiv_diag_and: "(alpha And alpha) \<equiv>f alpha"
  by(simp)

lemma sem_equiv_diag_or: "(alpha Or alpha) \<equiv>f alpha"
  by(simp)

lemma sem_equiv_absorb_and: "(alpha And (alpha Or beta)) \<equiv>f alpha"
  by(simp, auto)

lemma sem_equiv_absorb_or : "(alpha Or (alpha And beta)) \<equiv>f alpha"
  by(simp, auto)

lemma sem_equiv_distr1: "(alpha And (beta Or gamma)) \<equiv>f ((alpha And beta) Or (alpha And gamma))"
  by(simp, auto)

lemma sem_equiv_distr2: "(alpha Or (beta And gamma)) \<equiv>f ((alpha Or beta) And (alpha Or gamma))"
  by(simp, auto)

lemma sem_equiv_demorgan1: "(Neg (alpha And beta)) \<equiv>f (Neg alpha Or Neg beta)"
  by(simp)

lemma sem_equiv_demorgan2: "(Neg (alpha Or beta)) \<equiv>f (Neg alpha And Neg beta)"
  by(simp)

lemma sem_equiv_refl: "alpha \<equiv>f alpha"
  by(simp)

lemma sem_equiv_symm: "sem_equiv alpha beta \<longrightarrow> sem_equiv beta alpha"
  by(simp)

lemma sem_equiv_trans: "sem_equiv alpha beta \<longrightarrow> sem_equiv beta gamma \<longrightarrow> sem_equiv alpha gamma"
  by(simp)

lemma sem_equiv_kongr: "alpha \<equiv>f alpha' \<and> beta \<equiv>f beta'
 \<longrightarrow> (andf alpha beta) \<equiv>f (andf alpha' beta') \<and>
     (orf alpha beta) \<equiv>f (orf alpha' beta') \<and>
     (negf alpha) \<equiv>f (negf alpha')"
  by(simp)

abbreviation fulfills where
"fulfills (w :: 'a model) (alpha :: 'a formula) \<equiv> (ext_mod w alpha = True)"

abbreviation fulfillsS where
"fulfillsS (w :: 'a model) (X :: 'a formula set) \<equiv> (\<forall> alpha \<in> X. fulfills w alpha)"

lemma fulfills_prop_prime: "\<forall> (v:: 'a) (w::'a model). fulfills w (p v) \<longleftrightarrow> w v = True"
  by(simp)

lemma fulfills_prop_and: "fulfills w (alpha And beta) \<longleftrightarrow> fulfills w alpha \<and> fulfills w beta"
  by(simp)

lemma fulfills_prop_or: "fulfills w (alpha Or beta) \<longleftrightarrow> fulfills w alpha \<or> fulfills w beta"
  by(simp)

lemma fulfills_prop_neg: "fulfills w (Neg alpha ) \<longleftrightarrow> \<not> fulfills w alpha"
  by(simp)

lemma fulfills_prop_impl: "fulfills w (alpha Impl beta) \<longleftrightarrow> ( (fulfills w alpha) \<longrightarrow> (fulfills w beta))"
  by(simp)

abbreviation taut where
" taut (alpha :: 'a formula) \<equiv> \<forall> (w :: 'a model). fulfills w alpha"

abbreviation contradiction where
"contradiction (alpha :: 'a formula) \<equiv> \<nexists> (w :: 'a model). fulfills w alpha"

lemma taut_example: "taut (alpha Or Neg alpha)"
  by(simp)

lemma contradiction_example1: "contradiction (alpha And Neg alpha)"
  by(simp)

lemma contradiction_example2: "contradiction (alpha IImpl ( Neg alpha))"
  by(simp)

lemma impl_taut_self: "taut (p1 Impl p1)"
  by(simp)

lemma impl_taut_add_praem: "taut ( p1 Impl (q Impl p1))"
  by(simp)

lemma impl_taut_swap_praem: "taut ( (p1 Impl q Impl r) Impl (q Impl p1 Impl r) )"
  by(simp)

lemma impl_taut_circ: "taut ( (p1 Impl q) Impl (q Impl r) Impl (p1 Impl r) )"
  by(simp)

lemma impl_taut_fregecirc: "taut ( (p1 Impl q Impl r) Impl ( (p1 Impl q) Impl (p1 Impl r)) )"
  by(simp)

lemma impl_taut_pierce: "taut ( ( (p1 Impl q) Impl p1) Impl p1)"
  by(simp, blast)

definition ImplSem (infix "\<Turnstile>" 74) where
" ImplSem (X :: ('a formula) set) (alpha :: 'a formula) \<equiv>
  \<forall> (w:: 'a model). (\<forall> x \<in> X. fulfills w x) \<longrightarrow> fulfills w alpha"

lemma empty_ImplSem_iff_taut: "taut alpha \<longleftrightarrow> {} \<Turnstile> alpha"
  by(simp add: ImplSem_def)

lemma ImplSem_refl: "alpha \<in> X \<longrightarrow> X \<Turnstile> alpha"
  by(simp add:ImplSem_def)

lemma Impl_Sem_mon: " X \<subseteq> X' \<longrightarrow> X \<Turnstile> alpha \<longrightarrow> X' \<Turnstile> alpha"
  by(simp add:ImplSem_def, auto)

lemma Impl_Sem_trans: "(\<forall> y \<in> Y. X \<Turnstile> y) \<and> Y \<Turnstile> alpha \<longrightarrow> X \<Turnstile> alpha"
  by(simp add:ImplSem_def)

lemma Impl_Sem_and_example1: "{alpha, beta} \<Turnstile> (alpha And beta)"
  by(simp add:ImplSem_def)

lemma Impl_Sem_and_example2: "{alpha And beta} \<Turnstile> alpha"
  by(simp add:ImplSem_def)

lemma Impl_Sem_and_example3: "{alpha And beta} \<Turnstile> beta"
  by(simp add:ImplSem_def)

lemma Impl_Sem_and_example4: "(X \<Turnstile> (alpha And beta) ) \<longleftrightarrow> ( X \<Turnstile> alpha \<and> X \<Turnstile> beta )"
  by(simp add:ImplSem_def, auto)

lemma Impl_Sem_impl_example: "{alpha, alpha Impl beta} \<Turnstile> beta"
  by(simp add: ImplSem_def)

lemma Impl_Sem_elim_example:
"(X \<union> {alpha}) \<Turnstile> beta \<and> (X \<union> {Neg alpha}) \<Turnstile> beta \<longrightarrow> X \<Turnstile> beta"
  by(simp add: ImplSem_def, auto)

type_synonym 'a subst = "('a \<Rightarrow> 'a formula)"

fun ext_subst ::"'a subst \<Rightarrow> 'a formula \<Rightarrow> 'a formula" where
"ext_subst sigma (p v) = sigma v" |
"ext_subst sigma (f1 And f2) = (ext_subst sigma f1) And (ext_subst sigma f2)" |
"ext_subst sigma (Neg f) = Neg (ext_subst sigma f)"
(* | "ext_subst sigma Falsum = Falsum" *)

fun app_subst ::"'a subst \<Rightarrow> 'a formula set \<Rightarrow> 'a formula set" where
"app_subst sigma X = ext_subst sigma ` X"

lemma app_subst_demo:
"app_subst (\<lambda> n. (p (n+2) ) And (p (n+1) )) { p (1:: nat), (p (2::nat)) And (p (3::nat))}
= {p 3 And p 2, (p 4 And p 3) And p 5 And p 4} " by(auto)

(*
lemma subst_helper_lemma:
" fulfills (w :: 'a model) (ext_subst sigma alpha)
= fulfills (\<lambda> (a :: 'a). ext_mod w (sigma a)) alpha"
  apply(induction alpha) apply(auto) done
*)

lemma subst_helper_lemma2:
" ext_mod (w :: 'a model) (ext_subst sigma alpha)
= ext_mod (\<lambda> (a :: 'a). ext_mod w (sigma a)) alpha"
  by(induction alpha, auto)

theorem substituion_invariance: "X \<Turnstile> alpha \<longrightarrow> app_subst sigma X \<Turnstile> ext_subst sigma alpha"
  apply(simp add:ImplSem_def) apply(auto)
  apply(simp add:subst_helper_lemma2) done

theorem deduction_theorem: " (X \<union> {alpha}) \<Turnstile> beta \<longleftrightarrow> X \<Turnstile> (alpha Impl beta)"
  apply(simp add:ImplSem_def) apply(auto) done

inductive ImplGen :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<turnstile>" 56) where
AR: "ImplGen {alpha} alpha" |
MR: "\<lbrakk> (X::'a formula set) \<subseteq> (X' ::'a formula set) ; ImplGen X alpha \<rbrakk> \<Longrightarrow> ImplGen X' alpha" |
ANDI: "\<lbrakk> ImplGen X alpha ; ImplGen X beta \<rbrakk> \<Longrightarrow> ImplGen X (alpha And beta)" |
ANDl: "ImplGen X (alpha And beta) \<Longrightarrow> ImplGen X alpha" |
ANDr: "ImplGen X (alpha And beta) \<Longrightarrow> ImplGen X beta" |
NEG1: " \<lbrakk> ImplGen X alpha ; ImplGen X (Neg alpha) \<rbrakk> \<Longrightarrow> ImplGen X beta" |
NEG2: " \<lbrakk> ImplGen (X \<union> {alpha}) beta ; ImplGen (X \<union> { Neg alpha}) beta \<rbrakk>
       \<Longrightarrow> ImplGen X beta"

lemma ImplGen_and_example: "{alpha, beta} \<turnstile> (alpha And beta)"
proof -
  from ImplGen.AR have "{alpha} \<turnstile> alpha" by(auto)
  hence A: "{alpha,beta} \<turnstile> alpha" by(simp add: ImplGen.MR[of "{alpha}" "{alpha,beta}"])
  from ImplGen.AR have "{beta} \<turnstile> beta" by(auto)
  hence B: "{alpha,beta} \<turnstile> beta" by(simp add: ImplGen.MR[of "{beta}" "{alpha,beta}"])
  from A B show "{alpha, beta} \<turnstile> (alpha And beta)" by(rule ImplGen.ANDI)
qed

lemma ImplGen_neg_elim_example: "X \<union> {Neg alpha} \<turnstile> alpha \<longrightarrow> X \<turnstile> alpha"
proof
  assume A: "X \<union> {Neg alpha} \<turnstile> alpha"
  have 0: "{alpha} \<turnstile> alpha" by(rule AR)
  have 1: "{alpha} \<subseteq> X \<union> {alpha}" by(auto)
  from 0 1 MR have 2: "X \<union> {alpha} \<turnstile> alpha" by(blast)
  from A 2 NEG2 show "X \<turnstile> alpha" by(auto)
qed

lemma ImplGen_reductio_example: " (X \<union> {Neg alpha} \<turnstile> beta \<and>
X \<union> {Neg alpha} \<turnstile> Neg beta ) \<longrightarrow> X \<turnstile> alpha"
proof
  assume A: " X \<union> {Neg alpha} \<turnstile> beta \<and> X \<union> {Neg alpha} \<turnstile> Neg beta"
  from A have A1: "X \<union> {Neg alpha} \<turnstile> beta" by(simp)
  from A have A2: "X \<union> {Neg alpha} \<turnstile> Neg beta" by (simp)
  from A1 A2 have 2: "X \<union> {Neg alpha} \<turnstile> alpha" by (rule NEG1)
  from 2 ImplGen_neg_elim_example show "X \<turnstile> alpha" by (auto)
qed

lemma ImplGen_rightarrow_elim_example: " (X \<turnstile> alpha Impl beta) \<longrightarrow> X \<union> {alpha} \<turnstile> beta"
proof
  assume H: "(X \<turnstile> alpha Impl beta)"
  from ImplGen.AR[of "alpha"] ImplGen.MR[of "{alpha}" "X \<union> {alpha, Neg beta}"]
  have A: "X \<union> {alpha, Neg beta} \<turnstile> alpha" by(auto)
  from ImplGen.AR[of "Neg beta"] ImplGen.MR[of "{Neg beta}" "X \<union> {alpha, Neg beta}"]
  have B: "X \<union> {alpha, Neg beta} \<turnstile> Neg beta" by(auto)
  from A B have 2: "X \<union> {alpha, Neg beta} \<turnstile> alpha And (Neg beta)" by(rule ImplGen.ANDI)
  from H have 3: "X \<turnstile> Neg(alpha And Neg beta)" by(simp)
  from ImplGen.MR 3 have 4: "X \<union> {alpha, Neg beta} \<turnstile> Neg(alpha And Neg beta)" by(blast)
  from 2 4 have 5: "X \<union> {alpha, Neg beta} \<turnstile> beta" by(rule ImplGen.NEG1)
  from this ImplGen_neg_elim_example [of "X \<union> {alpha}" "beta"]
  show "X \<union> {alpha} \<turnstile> beta" by (simp add: insert_commute)
qed

(* TODO: Further examples *)

theorem ImplGen_correct:"X \<turnstile> alpha \<longrightarrow> X \<Turnstile> alpha"
proof
  fix alpha
  show "X \<turnstile> alpha \<Longrightarrow> X \<Turnstile> alpha"
  proof(induction alpha rule: ImplGen.induct)
case (AR alpha)
  thus "{alpha} \<Turnstile> alpha" by(simp add:ImplSem_refl)
next
case (MR X X' alpha)
  thus ?case by(simp add:Impl_Sem_mon)
next
case (ANDI X alpha beta)
  thus ?case by(simp add:Impl_Sem_and_example4)
next
  case (ANDl X alpha beta)
  thus ?case by(simp add: Impl_Sem_and_example4)
next
case (ANDr X alpha beta)
  thus ?case by(simp add: Impl_Sem_and_example4)
next
  case (NEG1 X alpha beta)
  thus ?case by(simp add: ImplSem_def, auto)
next
case (NEG2 X alpha beta)
  thus ?case by(simp add: Impl_Sem_elim_example[of "X" "alpha" "beta"])
qed
qed

theorem finiteness_theorem: "((X :: 'a formula set) \<turnstile> (alpha :: 'a formula) ) \<Longrightarrow>
      (\<exists> (X0 :: 'a formula set). X0 \<subseteq> X \<and> finite X0 \<and> X0 \<turnstile> alpha )"
proof(induction rule: ImplGen.induct)
  case (AR alpha)
  show ?case proof
    have 1: "{alpha} \<turnstile> alpha" by(rule AR)
    have 2: "finite {alpha}" by(auto)
    from 1 2 show "{alpha} \<subseteq> {alpha} \<and> finite {alpha} \<and> {alpha} \<turnstile> alpha" by(simp)
  qed
next
  case(MR X X' alpha)
  from MR.IH obtain X0 where pX0: "X0\<subseteq>X \<and> finite X0 \<and> X0 \<turnstile> alpha" by(auto)
  show ?case proof
      from pX0 MR(1) have SP: "X0 \<subseteq> X'" by (auto)
      from SP pX0 show "X0\<subseteq>X' \<and> finite X0 \<and> X0 \<turnstile> alpha" by(simp)
    qed
next
  case (ANDI X alpha beta)
  from ANDI.IH(1) obtain X0a where pX0a: "X0a\<subseteq>X \<and> finite X0a \<and> X0a \<turnstile> alpha" by(auto)
  from ANDI.IH(2) obtain X0b where pX0b: "X0b\<subseteq>X \<and> finite X0b \<and> X0b \<turnstile> beta" by(auto)
  show ?case proof
    from pX0a pX0b have p1: "(X0a \<union> X0b) \<subseteq> X" by(auto)
    from pX0a pX0b have p2: "finite (X0a \<union> X0b)" by(auto)
    from pX0a MR have p3: "(X0a \<union> X0b) \<turnstile> alpha" by(blast)
    from pX0b MR have p4: "(X0a \<union> X0b) \<turnstile> beta" by(blast)
    from p3 p4 have p5: "(X0a \<union> X0b) \<turnstile> (alpha And beta)" by (rule ImplGen.ANDI)
    from p1 p2 p5 show "( X0a \<union> X0b) \<subseteq> X \<and> finite ( X0a \<union> X0b) \<and> ( X0a \<union> X0b) \<turnstile> alpha And beta" by(auto)
  qed
next
  case (ANDl X alpha beta)
  from ANDl.IH obtain X0 where pX0: "X0\<subseteq>X \<and> finite X0 \<and> X0 \<turnstile> (alpha And beta)" by(auto)
  show ?case proof
    from ImplGen.ANDl pX0 show "X0 \<subseteq> X \<and> finite X0 \<and> X0 \<turnstile> alpha" by(auto)
  qed
next
  case (ANDr X alpha beta)
  from ANDr.IH obtain X0 where pX0: "X0\<subseteq>X \<and> finite X0 \<and> X0 \<turnstile> (alpha And beta)" by(auto)
  show ?case proof
    from ImplGen.ANDr pX0 show "X0 \<subseteq> X \<and> finite X0 \<and> X0 \<turnstile> beta" by(auto)
  qed
next
  case (NEG1 X alpha beta)
  from NEG1.IH(1) obtain X0p where pX0p: "X0p\<subseteq>X \<and> finite X0p \<and> X0p \<turnstile> alpha" by(auto)
  from NEG1.IH(2) obtain X0n where pX0n: "X0n\<subseteq>X \<and> finite X0n \<and> X0n \<turnstile> Neg alpha" by(auto)
  show ?case proof
    from pX0p pX0n have p1: "(X0p \<union> X0n) \<subseteq> X" by(auto)
    from pX0p pX0n have p2: "finite (X0p \<union> X0n)" by(auto)
    from pX0p MR have p3: "(X0p \<union> X0n) \<turnstile> alpha" by(blast)
    from pX0n MR have p4: "(X0p \<union> X0n) \<turnstile> Neg alpha" by(blast)
    from p3 p4 have p5: "(X0p \<union> X0n) \<turnstile> beta" by (rule ImplGen.NEG1)
    from p1 p2 p5 show "( X0p \<union> X0n) \<subseteq> X \<and> finite ( X0p \<union> X0n) \<and> ( X0p \<union> X0n) \<turnstile> beta" by(auto)
  qed
next
  case (NEG2 X alpha beta)
  from NEG2.IH(1) obtain X0p where pX0p: "X0p\<subseteq>X\<union> {alpha} \<and> finite X0p \<and> X0p \<turnstile> beta" by(auto)
  from NEG2.IH(2) obtain X0n where pX0n: "X0n\<subseteq>X\<union> {Neg alpha} \<and> finite X0n \<and> X0n \<turnstile> beta" by(auto)
  show ?case proof
    from pX0p pX0n have p1: "((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<subseteq> X" by(auto)
    from pX0p pX0n have p2: "finite ((X0p \<union> X0n)- {alpha, Neg alpha})" by(auto)
    have "X0p \<subseteq> ((X0p - {alpha}) \<union> {alpha})" by (blast)
    from this pX0p have p3: "((X0p - {alpha}) \<union> {alpha}) \<turnstile> beta" by(simp add: ImplGen.MR)
    have "X0n \<subseteq> ((X0n - {Neg alpha}) \<union> {Neg alpha})" by (blast)
    from this pX0n have p4: "((X0n - {Neg alpha}) \<union> {Neg alpha}) \<turnstile> beta" by(simp add: ImplGen.MR)
    have "((X0p - {alpha}) \<union> {alpha}) \<subseteq> ((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<union> {alpha}" by(blast)
    from this p3 have p5: "((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<union> {alpha} \<turnstile> beta" by(rule ImplGen.MR)
    have "((X0n - {Neg alpha}) \<union> {Neg alpha}) \<subseteq> ((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<union> {Neg alpha}" by(blast)
    from this p4 have p6: "((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<union> {Neg alpha} \<turnstile> beta" by(rule ImplGen.MR)
    from p5 p6 have p7: "((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<turnstile> beta" by(rule ImplGen.NEG2)
    from p7 p1 p2 show "((X0p - {alpha}) \<union> (X0n - {Neg alpha}))\<subseteq>X
               \<and> finite ((X0p - {alpha}) \<union> (X0n - {Neg alpha}))
               \<and> ((X0p - {alpha}) \<union> (X0n - {Neg alpha})) \<turnstile> beta" by (auto)
  qed
qed

definition incons_FS ::"'a formula set \<Rightarrow> bool" where
"incons_FS (X:: 'a formula set) \<equiv> \<forall> (alpha::'a formula). X \<turnstile> alpha"

abbreviation cons_FS ::"'a formula set \<Rightarrow> bool" where
"cons_FS X \<equiv> \<not> incons_FS X"

definition max_cons_FS::"'a formula set \<Rightarrow> bool" where
"max_cons_FS (X :: 'a formula set) \<equiv>
   (cons_FS X) \<and> ( \<forall> (Y :: 'a formula set). Y \<supset> X \<longrightarrow> incons_FS Y)"

abbreviation Falsum where
"Falsum (f :: 'a formula) \<equiv> (f) And (Neg f)"

lemma incons_prop: "\<forall> (f :: 'a formula). X \<turnstile> Falsum f \<longleftrightarrow> incons_FS X"
proof
  fix f show "X \<turnstile> Falsum f \<longleftrightarrow> incons_FS X" proof
    assume H: "X \<turnstile> Falsum f"
    have "\<forall> alpha. X \<turnstile> alpha" proof
      fix alpha
      from H ImplGen.ANDl ImplGen.ANDr ImplGen.NEG1 show "X \<turnstile> alpha" by(blast)
    qed
    from this incons_FS_def show "incons_FS X" by(auto)
  next
    assume "incons_FS X"
    hence H:"\<forall> alpha. X \<turnstile> Falsum f" by(simp add: incons_FS_def)
    thus "X \<turnstile> Falsum f" by (auto)
  qed
qed

lemma cons_prop: " \<forall> (f :: 'a formula). \<not> ( X \<turnstile> Falsum f) \<longleftrightarrow> cons_FS X"
  by(simp add: incons_prop)

lemma Cplus_ImplSem_prop: " X \<turnstile> alpha \<longleftrightarrow> incons_FS ( X \<union> { Neg alpha} )"
proof
  assume H: "X \<turnstile> alpha"
  from this ImplGen.MR have 1: "X \<union> {Neg alpha} \<turnstile> alpha" by(blast)
  have 2: "{Neg alpha} \<turnstile> Neg alpha" by(rule ImplGen.AR)
  from this ImplGen.MR have 3: "X \<union> {Neg alpha} \<turnstile> Neg alpha" by(blast)
  from 1 3 ImplGen.NEG1 have "\<forall> beta. X \<union> {Neg alpha} \<turnstile> beta" by(auto)
  thus "incons_FS (X \<union> {Neg alpha}) " by(simp add: incons_FS_def)
next
  assume "incons_FS (X \<union> {Neg alpha})"
  hence 1:"X \<union> {Neg alpha} \<turnstile> alpha" by(simp add:incons_FS_def)
  from ImplGen.MR ImplGen.AR have 2: "X \<union> {alpha} \<turnstile> alpha" by (blast)
  from 1 2 ImplGen.NEG2 show "X \<turnstile> alpha" by(auto)
qed

lemma Cplus_ImplSem_prop2: "\<forall> (f :: 'a formula).
                     X \<turnstile> alpha \<longleftrightarrow> (X \<union> {Neg alpha}) \<turnstile> Falsum f"
proof
  fix f show " X \<turnstile> alpha \<longleftrightarrow> (X \<union> {Neg alpha}) \<turnstile> Falsum f" proof
    assume H: "X \<turnstile> alpha"
    from this Cplus_ImplSem_prop have "incons_FS (X \<union> {Neg alpha})" by(auto)
    from this incons_prop show "(X \<union> {Neg alpha}) \<turnstile> Falsum f" by(auto)
  next
    assume H: "(X \<union> {Neg alpha}) \<turnstile> Falsum f"
    from this incons_prop have "incons_FS (X \<union> {Neg alpha})" by(auto)
    from this Cplus_ImplSem_prop show "X \<turnstile> alpha" by(auto)
  qed
qed

lemma Cminus_ImplSem_prop: " X \<turnstile> Neg alpha \<longleftrightarrow> incons_FS ( X \<union> {alpha} )"
proof
  assume H: "X \<turnstile> Neg alpha"
  from this ImplGen.MR have 1: "X \<union> {alpha} \<turnstile> Neg alpha" by(blast)
  have 2: "{alpha} \<turnstile> alpha" by(rule ImplGen.AR)
  from this ImplGen.MR have 3: "X \<union> {alpha} \<turnstile> alpha" by(blast)
  from 1 3 ImplGen.NEG1 have "\<forall> beta. X \<union> {alpha} \<turnstile> beta" by(auto)
  thus "incons_FS (X \<union> { alpha}) " by(simp add: incons_FS_def)
next
  assume "incons_FS (X \<union> {alpha})"
  hence 1:"X \<union> {alpha} \<turnstile> Neg alpha" by(simp add:incons_FS_def)
  from ImplGen.MR ImplGen.AR have 2: "X \<union> {Neg alpha} \<turnstile> Neg alpha" by (blast)
  from 1 2 ImplGen.NEG2 show "X \<turnstile> Neg alpha" by(auto)
qed

lemma Cminus_ImplSem_prop2: "\<forall> (f :: 'a formula).
                    X \<turnstile> Neg alpha \<longleftrightarrow> (X \<union> {alpha}) \<turnstile> Falsum f"
proof
  fix f show "X \<turnstile> Neg alpha \<longleftrightarrow> (X \<union> {alpha}) \<turnstile> Falsum f" proof
    assume H: "X \<turnstile> Neg alpha"
    from this Cminus_ImplSem_prop have "incons_FS (X \<union> {alpha})" by(auto)
    from this incons_prop show "(X \<union> {alpha}) \<turnstile> Falsum f" by(auto)
  next
    assume H: "(X \<union> {alpha}) \<turnstile> Falsum f"
    from this incons_prop have "incons_FS (X \<union> {alpha})" by(auto)
    from this Cminus_ImplSem_prop show "X \<turnstile> Neg alpha" by(auto)
  qed
qed

definition H::"'a formula set \<Rightarrow> 'a formula set set" where
"H X = { Y. X \<subseteq> Y \<and> cons_FS Y}"

lemma finite_chain_contains_Union:
"finite (F :: 'a set set) \<Longrightarrow> F \<noteq> {} \<Longrightarrow>
 (\<forall> x \<in>F. \<forall> y \<in> F. (x \<subseteq> y) \<or> (y \<subseteq> x) )
 \<Longrightarrow> \<Union> F \<in> F"
proof(induct F rule: finite_induct)
  case empty
  then show ?case by(simp)
next
  case (insert x F)
  then show ?case
    by (metis Sup_insert Un_absorb1 Un_absorb2 ccpo_Sup_singleton insertCI)
qed

lemma empty_set_consistent: "\<not> ( {} \<turnstile> Falsum alpha)"
proof
  assume H: "{} \<turnstile> (alpha :: 'a formula) And (Neg alpha)"
  from H have "{} \<turnstile> alpha" by (simp add: ImplGen.ANDl)
  hence A: "{} \<Turnstile> alpha" by (simp add: ImplGen_correct)
  hence "\<forall> w. fulfills w alpha" by(simp add: ImplSem_def)
  hence "ext_mod (\<lambda> v. True) alpha = True" by(auto)
  hence CON1: "ext_mod (\<lambda> v. True) (Neg alpha) = False" by(auto)
  from H have "{} \<turnstile> Neg alpha" by (simp add: ImplGen.ANDr)
  hence B: "{} \<Turnstile> Neg alpha" by (simp add: ImplGen_correct)
  hence "\<forall> w. fulfills w (Neg alpha)" by(simp add: ImplSem_def[of "{}" "Neg alpha"])
  hence CON2: "ext_mod (\<lambda> v. True) (Neg alpha) = True" by(auto)
  from CON1 CON2 show "False" by(auto)
qed

lemma lindenbaum: "cons_FS (X:: 'a formula set) \<longrightarrow> ( \<exists> X'. X \<subseteq> X' \<and> max_cons_FS X' )"
proof
  assume "cons_FS X"
  from this H_def have 0: "X \<in> H X" by(blast)

  have " \<forall> K . subset.chain (H X) K \<longrightarrow> (\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
    fix K :: "'a formula set set"
    have "K = {} \<or> K \<noteq> {}" by(auto)
    then show "subset.chain (H X) K \<longrightarrow> (\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
    assume A: "K = {}"
    show "subset.chain (H X) K \<longrightarrow> (\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
      assume 1: "subset.chain (H X) K"
      show "(\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
        from A show "\<forall> X' \<in> K. X' \<subseteq> X" by(auto)
        from 0 show "X \<in> H X" by(simp)
      qed
    qed
  next
    assume B: "K \<noteq> {}"
    show "subset.chain (H X) K \<longrightarrow> (\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
      assume 1: "subset.chain (H X) K"
        show "(\<exists> U \<in> (H X). \<forall> X' \<in>K . X' \<subseteq> U)" proof
          show "\<forall> X' \<in> K. X' \<subseteq> \<Union> K" by (auto)
          from 1 subset.chain_def have 2: "K \<subseteq> (H X)" by(auto)
          from this H_def have 3: "\<forall> Y \<in> K. X \<subseteq> Y" by(auto)
          from B 3 have 4: "X \<subseteq> \<Union> K" by(auto)
          have 5: "cons_FS (\<Union> K)" proof(rule ccontr)
            assume "\<not> cons_FS (\<Union> K)"
            hence "incons_FS (\<Union> K)" by(simp)
            hence "\<Union> K \<turnstile> Falsum alpha" by(simp add: incons_prop)
            hence "\<exists> U0 \<subseteq> \<Union> K. finite U0 \<and> U0 \<turnstile> Falsum alpha" by(simp add:finiteness_theorem)
            then obtain U0 where 6: "U0 \<subseteq> \<Union> K \<and> finite U0 \<and> U0 \<turnstile> Falsum alpha" by(auto)
            then have fin: "finite U0" by(auto)
            from 6 have 7: "\<forall> alpha_i \<in> U0. \<exists> Y. Y \<in> K \<and> alpha_i \<in> Y" by(auto)
            from finite_set_choice[OF fin 7] obtain f where fprop: "\<forall> alpha_i \<in> U0. f alpha_i \<in> K \<and> alpha_i \<in> f alpha_i" by(auto)
            from fprop have "U0 \<subseteq> \<Union> (f ` U0)" by(auto) (* Y = \<Union> (f ` U0) *)
            from this 6 ImplGen.MR have CON1: "\<Union> (f ` U0) \<turnstile> Falsum alpha" by(auto)
            from fin have fin': "finite ( (f ` U0) )" by(auto)
            from fprop 1 have "subset.chain (H X) (f ` U0)" by (simp add: subset.chain_def subset_eq)
            from this subset.chain_def[of "H X" "(f ` U0)"] have 8: "\<forall> x \<in> (f` U0). \<forall> y \<in> (f` U0). x \<subseteq> y \<or> y \<subseteq> x" by(auto)
            have U0_nonempty: "U0 \<noteq> {}" proof
              assume "U0 = {}"
              from this 6 have "{} \<turnstile> Falsum alpha" by(auto)
              from this empty_set_consistent show "False" by(auto)
            qed
            from this have "(f ` U0) \<noteq> {}" by(auto)
            from this 8 fin' finite_chain_contains_Union[of "(f ` U0)"] have "\<Union> (f` U0) \<in> (f ` U0)" by(auto)
            from this fprop 2 have "\<Union> (f ` U0) \<in> (H X)" by(auto)
            from this have "cons_FS ( \<Union> (f `U0) )" by(simp add: H_def)
            from this have CON2: "\<not> ( \<Union> (f `U0) \<turnstile> Falsum alpha )" by(simp add: cons_prop)
            from CON1 CON2  show "False"  by(auto)
          qed
          from 4 5 H_def show "\<Union> K \<in> (H X)" by(auto)
        qed
      qed
    qed
  qed
  from this subset_Zorn have "\<exists> M \<in> (H X). \<forall> X' \<in> (H X). M \<subseteq> X' \<longrightarrow> X' = M" by(blast)
  then obtain M where Mprop: "M \<in> (H X) \<and> (\<forall> X' \<in> (H X). M \<subseteq> X' \<longrightarrow> X' = M)" by(auto)
  show " \<exists>X'. X \<subseteq> X' \<and> max_cons_FS X'" proof
    from Mprop have Prop1: "X \<subseteq> M" by(simp add: H_def)
    from Mprop have 2: "cons_FS M" by(simp add:H_def)
    have 3: "\<forall> Y. M \<subset> Y \<longrightarrow> incons_FS Y" proof
      fix Y show "M \<subset> Y \<longrightarrow> incons_FS Y" proof
        assume H1: "M \<subset> Y" show "incons_FS Y" proof(rule ccontr)
          assume H2: "cons_FS Y"
          from H_def[of "X"] H2 Prop1 H1 have "Y \<in> (H X)" by (simp add:H_def)
          from this Mprop H1 have "M = Y" by(blast)
          from this H1 show "False" by(auto)
        qed
      qed
    qed
    from 2 3 max_cons_FS_def have Prop2: "max_cons_FS M" by(auto)
    from Prop1 Prop2 show "X \<subseteq> M \<and> max_cons_FS M " by(auto)
  qed
qed

lemma max_cons_set_prop: "max_cons_FS X \<longrightarrow> (\<forall> alpha. X \<turnstile> Neg alpha \<longleftrightarrow> \<not> (X \<turnstile> alpha))"
proof
  assume H1: "max_cons_FS X" show "(\<forall> alpha. X \<turnstile> Neg alpha \<longleftrightarrow> \<not> (X \<turnstile> alpha))" proof
    fix alpha show "X \<turnstile> Neg alpha \<longleftrightarrow> \<not> (X \<turnstile> alpha)" proof
      assume H2: "X \<turnstile> Neg alpha"
      show "\<not> (X \<turnstile> alpha)" proof(rule ccontr)
        assume "\<not> \<not> X \<turnstile> alpha"
        hence "X \<turnstile> alpha" by(auto)
        from this H2 have "X \<turnstile> (alpha And (Neg alpha) )" by(simp add: ImplGen.ANDI)
        hence "incons_FS X" by (simp add: incons_prop)
        from this H1 show "False" by(simp add: max_cons_FS_def)
      qed
    next
      assume H3: "\<not> (X \<turnstile> alpha)"
      hence "cons_FS (X \<union> {Neg alpha})" by(simp add:Cplus_ImplSem_prop)
      from this H1 max_cons_FS_def[of "X"] have "Neg alpha \<in> X" by(auto)
      from this ImplGen.AR[of"Neg alpha"] ImplGen.MR show "X \<turnstile> Neg alpha" by(blast)
    qed
  qed
qed

lemma max_cons_fullfillable:
" max_cons_FS (X:: 'a formula set) \<longrightarrow> ( \<exists> (w :: 'a model). fulfillsS w X )"
proof
  assume H: "max_cons_FS ( X :: 'a formula set)"
  show " \<exists> (w :: 'a model). fulfillsS w X" proof
    have star: "\<forall> alpha :: 'a formula. fulfills (\<lambda> (a :: 'a). X \<turnstile> p a) alpha \<longleftrightarrow> X \<turnstile> alpha"
    proof fix alpha show "fulfills (\<lambda> (a :: 'a). X \<turnstile> p a) alpha \<longleftrightarrow> X \<turnstile> alpha" proof(induction alpha)
      case (p x)
      then show ?case by(auto)
    next
      case (andf alpha1 alpha2)
      then show ?case using ANDI ANDl ANDr ext_mod.simps(2) by blast
    next
     case (negf alpha)
     then show ?case by (simp add: negf.IH H max_cons_set_prop)
   qed
 qed
  have "\<forall> alpha \<in> X. X \<turnstile> alpha" using ImplGen.AR ImplGen.MR by blast
  from this star show "\<forall> alpha \<in> X. fulfills (\<lambda> (a :: 'a). X \<turnstile> p a) alpha" by(simp)
  qed
qed

theorem completeness_theorem: "\<forall> (X:: 'a formula set) (alpha :: 'a formula).
 X \<turnstile> alpha \<longleftrightarrow> X \<Turnstile> alpha"
proof
  fix X :: "'a formula set"
  show "\<forall> alpha :: 'a formula. X \<turnstile> alpha \<longleftrightarrow> X \<Turnstile> alpha" proof
    fix alpha :: "'a formula"
    show " X \<turnstile> alpha \<longleftrightarrow> X \<Turnstile> alpha" proof
      assume H1: "X \<turnstile> alpha"
      from this ImplGen_correct show "X \<Turnstile> alpha" by(auto)
    next
      assume H2: "X \<Turnstile> alpha"
      show "X \<turnstile> alpha" proof(rule ccontr)
        assume H3: "\<not> X \<turnstile> alpha"
        from this Cplus_ImplSem_prop have "cons_FS ( X \<union> {Neg alpha})" by(auto)
        from this lindenbaum[of "X \<union> {Neg alpha}"] have "\<exists>X'.  (X \<union> {Neg alpha}) \<subseteq> X' \<and> max_cons_FS X'" by(auto)
        then obtain Y where H'prop: "(X \<union> {Neg alpha}) \<subseteq> Y \<and> max_cons_FS Y" by(auto)
        from H'prop max_cons_fullfillable have "\<exists> w. fulfillsS w Y" by(auto)
        from H'prop this have "\<exists> w. fulfillsS w (X \<union> {Neg alpha})" by(blast)
        then obtain w where wprop: "fulfillsS w (X \<union> {Neg alpha})" by(auto)
        from this H2 ImplSem_def have CON1: "fulfills w alpha" by(auto)
        from wprop have "fulfills w (Neg alpha)" by(auto)
        hence CON2: "\<not> fulfills w alpha" by(auto)
        from CON1 CON2 show "False" by(auto)
      qed
    qed
  qed
qed

inductive ImplHil :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "|~" 56) where
AR: "(alpha :: 'a formula) \<in> (X:: 'a formula set) \<Longrightarrow> ImplHil X alpha" |
MP: "\<lbrakk> ImplHil (X::'a formula set) alpha; ImplHil X (alpha Impl beta) \<rbrakk> \<Longrightarrow> ImplHil X beta" |
L1: " ImplHil (X :: 'a formula set) ( ((alpha :: 'a formula) Impl beta Impl gamma) Impl (alpha Impl beta) Impl (alpha Impl gamma) )" |
L2: " ImplHil (X :: 'a formula set) ( (alpha :: 'a formula) Impl beta Impl (alpha And beta))" |
L3a: " ImplHil (X :: 'a formula set) ( ( (alpha :: 'a formula) And beta) Impl alpha )" |
L3b: " ImplHil (X :: 'a formula set) ( ( (alpha :: 'a formula) And beta) Impl beta )" |
L4: " ImplHil (X :: 'a formula set) ( ( (alpha :: 'a formula) Impl Neg beta) Impl (beta Impl Neg alpha) )"

lemma ImplHil_example1: "{(alpha :: 'a formula), beta} |~ (alpha And beta)"
proof -
  from ImplHil.AR have 1: "{alpha, beta} |~ alpha" by (blast)
  from ImplHil.AR have 2: "{alpha, beta} |~ beta" by (blast)
  from ImplHil.L2 have 3: "{alpha, beta} |~ (alpha Impl beta Impl (alpha And beta) )" by(blast)
  from 1 3 ImplHil.MP have 4: "{alpha, beta} |~ (beta Impl (alpha And beta))" by(blast)
  from 4 2 ImplHil.MP show 5: "{alpha, beta} |~ (alpha And beta)" by(blast)
qed

lemma ImplHil_correct: " X |~ alpha \<longrightarrow> X \<Turnstile> alpha"
proof
  fix alpha
  show "X |~ alpha \<Longrightarrow> X \<Turnstile> alpha" proof(induction alpha rule: ImplHil.induct)
    case (AR alpha X)
    then show ?case  by(simp add: ImplSem_def)
next
  case (MP X alpha beta)
  then show ?case by (simp add: ImplSem_def)
next
  case (L1 X alpha beta gamma)
  then show ?case by (simp add: ImplSem_def)
next
  case (L2 X alpha beta)
  then show ?case by (simp add: ImplSem_def)
next
  case (L3a X alpha beta)
  then show ?case by (simp add: ImplSem_def)
next
  case (L3b X alpha beta)
  then show ?case by (simp add: ImplSem_def)
next
  case (L4 X alpha beta)
  then show ?case by (simp add: ImplSem_def)
qed
qed

lemma ImplHil_monot_prop: " X |~ alpha \<Longrightarrow> X \<subseteq> X' \<Longrightarrow> X' |~ alpha"
proof(induct rule: ImplHil.induct)
    case (AR alpha X)
    then show ?case using ImplHil.AR by(auto)
  next
    case (MP X alpha beta)
    then show ?case using ImplHil.MP by(auto)
  next
    case (L1 X alpha beta gamma)
    then show ?case by(simp add: ImplHil.L1)
  next
    case (L2 X alpha beta)
    then show ?case by(simp add: ImplHil.L2)
  next
    case (L3a X alpha beta)
    then show ?case by(simp add: ImplHil.L3a)
  next
    case (L3b X alpha beta)
    then show ?case by(simp add: ImplHil.L3b)
  next
    case (L4 X alpha beta)
    then show ?case by(simp add: ImplHil.L4)
qed

lemma ImplHil_propa: "X |~ alpha Impl Neg beta \<longrightarrow> X |~ beta Impl Neg alpha"
proof
  assume H: "X |~ alpha Impl Neg beta"
  from ImplHil.L4 have "X |~ (alpha Impl Neg beta) Impl (beta Impl Neg alpha)" by(auto)
  from this H ImplHil.MP show "X |~ beta Impl Neg alpha" by(auto)
qed

lemma ImplHil_propb: "{} |~ alpha Impl beta Impl alpha"
proof -
  from ImplHil.L3b have "{} |~ (beta And Neg alpha) Impl (Neg alpha)" by(auto)
  from this ImplHil_propa show "{} |~ alpha Impl Neg(beta And Neg alpha)" by(auto)
qed

lemma ImplHil_propc: "{} |~ alpha Impl alpha"
proof -
  from ImplHil.L1 have "{} |~ (alpha Impl (alpha Impl alpha) Impl alpha) Impl (alpha Impl (alpha Impl alpha)) Impl (alpha Impl alpha)" by(auto)
  from this ImplHil.MP ImplHil_propb have "{} |~ (alpha Impl (alpha Impl alpha)) Impl (alpha Impl alpha)" by(blast)
  from this ImplHil.MP ImplHil_propb show "{} |~ alpha Impl alpha" by(blast)
qed

lemma ImplHil_propd: "{} |~ (alpha Impl (Neg (Neg alpha)) )"
proof -
  from ImplHil_propc have "{} |~ (Neg alpha) Impl (Neg alpha)" by(auto)
  from this ImplHil_propa show "{} |~ alpha Impl (Neg (Neg alpha))" by(auto)
qed

lemma ImplHil_prope: "{} |~ beta Impl (Neg beta Impl alpha)"
proof -
  from ImplHil.L3a have "{} |~ ( (Neg beta) And (Neg alpha)) Impl Neg beta" by(auto)
  from this ImplHil_propa show "{} |~ beta Impl Neg( (Neg beta) And (Neg alpha))" by(auto)
qed

lemma ImplHil_deduction_theorem: " X' |~ gamma \<Longrightarrow> X' = X \<union> {alpha} \<Longrightarrow> X |~ alpha Impl gamma"
proof(induct rule: ImplHil.induct)
  case (AR gamma X')
  then have or_prop: "gamma \<in> X \<or> gamma = alpha" by(auto)
  from this show ?case proof
    assume "gamma \<in> X"
    from this ImplHil.AR have 1: "X |~ gamma" by(auto)
    from ImplHil_propb ImplHil_monot_prop have "X |~ gamma Impl alpha Impl gamma" by(blast)
    from this 1 ImplHil.MP show "X |~ alpha Impl gamma" by(auto)
  next
    assume "gamma = alpha"
    from this ImplHil_propc ImplHil_monot_prop show "X |~ alpha Impl gamma" by(blast)
  qed
next
  case (MP X' beta gamma)
  then have H:"X |~ alpha Impl beta \<and> X |~ alpha Impl beta Impl gamma" by(auto)
  from ImplHil.L1 have "X |~ (alpha Impl beta Impl gamma) Impl (alpha Impl beta) Impl (alpha Impl gamma)" by(auto)
  from this H ImplHil.MP show ?case by(blast)
next
  case (L1 X' beta gamma delta)
  then show ?case using ImplHil.L1
    by (metis ImplHil_monot_prop ImplHil_propb MP sup.orderI sup_bot.right_neutral)
next
  case (L2 X' beta gamma)
  then show ?case
    by (metis ImplHil.L2 ImplHil_monot_prop ImplHil_propb MP sup.orderI sup_bot.right_neutral)
next
  case (L3a X' beta gamma)
  then show ?case
    by (metis ImplHil.L3a ImplHil_monot_prop ImplHil_propb MP sup.orderI sup_bot.right_neutral)
next
  case (L3b X' beta gamma)
  then show ?case
    by (metis ImplHil.L3b ImplHil_monot_prop ImplHil_propb MP sup.orderI sup_bot.right_neutral)
next
  case (L4 X' beta gamma)
  then show ?case
    by (metis ImplHil.L4 ImplHil_monot_prop ImplHil_propb MP sup.orderI sup_bot.right_neutral)
qed

lemma ImplHil_negneg_elim: " {} |~ (Neg (Neg alpha )) Impl alpha"
proof -
  from ImplHil.L3a ImplHil.AR ImplHil.MP have I1: "{ (Neg (Neg alpha)) And Neg alpha } |~ Neg (Neg alpha)" by(blast)
  from ImplHil.L3b ImplHil.AR ImplHil.MP have I2: "{ (Neg (Neg alpha)) And Neg alpha } |~ Neg alpha" by(blast)
  from I1 I2 ImplHil.MP ImplHil_prope[of "Neg alpha" "Neg (alpha Impl alpha)"]
   ImplHil_monot_prop[of "{}" "Neg alpha Impl Neg (Neg alpha) Impl Neg (alpha Impl alpha) " "{Neg (Neg alpha) And Neg alpha}"]
  have 3: "{ (Neg (Neg alpha)) And Neg alpha } |~ Neg (alpha Impl alpha)" by(blast)
  from this ImplHil_deduction_theorem have " {} |~ ((Neg (Neg alpha)) And Neg alpha) Impl Neg( alpha Impl alpha)" by(auto)
  from this ImplHil_propa have " {} |~ (alpha Impl alpha) Impl Neg(((Neg (Neg alpha)) And Neg alpha))" by(auto)
  from this ImplHil_propc ImplHil.MP show "{} |~ Neg(((Neg (Neg alpha)) And Neg alpha))" by(auto)
qed

lemma ImplHil_fulfills_ImplGenNEG1: " X |~ alpha \<Longrightarrow> X |~ (Neg alpha) \<Longrightarrow> X |~ beta"
proof -
  assume H1: "X |~ alpha"
  assume H2: "X |~ Neg alpha"
  from ImplHil_prope ImplHil_monot_prop have "X |~ alpha Impl Neg alpha Impl beta" by(blast)
  from this H1 H2 ImplHil.MP show "X |~ beta" by(blast)
qed

lemma ImplHil_fulfills_ImplGenNEG2:
"\<lbrakk> X \<union> {beta} |~ alpha; X \<union> {Neg beta} |~ alpha \<rbrakk> \<Longrightarrow> X |~ alpha"
proof -
  fix alpha beta
  assume H1: "X \<union> {beta} |~ alpha"
  assume H2: "X \<union> {Neg beta} |~ alpha"
  from ImplHil_propd have T:"{} |~ alpha Impl Neg (Neg alpha)" by(auto)
  from this ImplHil_monot_prop have "X \<union> {beta} |~ alpha Impl Neg (Neg alpha)" by(auto)
  from this H1 ImplHil.MP have "X \<union> {beta} |~ Neg (Neg alpha)" by(auto)
  from this ImplHil_deduction_theorem have "X |~ beta Impl Neg (Neg alpha)" by(auto)
  from this ImplHil_propa have 1: "X |~ Neg alpha Impl Neg beta" by(auto)
  from ImplHil.AR ImplHil_monot_prop have 2: "X \<union> {Neg alpha} |~ Neg alpha" by(blast)
  from this 1 ImplHil.MP ImplHil_monot_prop have 3: "X \<union> {Neg alpha} |~ Neg beta " by(blast)
  from T ImplHil_monot_prop have "X \<union> {Neg beta} |~ alpha Impl Neg (Neg alpha)" by(auto)
  from this H2 ImplHil.MP have "X \<union> {Neg beta} |~ Neg (Neg alpha)" by(auto)
  from this ImplHil_deduction_theorem have "X |~ (Neg beta) Impl Neg (Neg alpha)" by(auto)
  from this ImplHil_propa have "X |~ Neg alpha Impl (Neg (Neg beta))" by(auto)
  from this 2 ImplHil.MP ImplHil_monot_prop have 4: "X \<union> {Neg alpha} |~ Neg (Neg beta) " by(blast)
  from 3 4 ImplHil_fulfills_ImplGenNEG1 have "X \<union> {Neg alpha} |~ Neg (alpha Impl alpha)" by(auto)
  from this ImplHil_deduction_theorem[of "X \<union> {Neg alpha}" _ "X" "Neg alpha"] have "X |~ (Neg alpha) Impl Neg(alpha Impl alpha)" by(auto)
  from this ImplHil_propa have " X |~ (alpha Impl alpha) Impl (Neg (Neg alpha))" by(auto)
  from this ImplHil.MP ImplHil_propc ImplHil_monot_prop have 5: "X |~ Neg (Neg alpha)" by(blast)
  from ImplHil_negneg_elim ImplHil_monot_prop have "X |~ Neg (Neg alpha) Impl alpha" by(auto)
  from this 5 ImplHil.MP show "X |~ alpha" by(auto)
qed

lemma ImplGen_implies_ImpHil: "X \<turnstile> alpha \<Longrightarrow> X |~ alpha"
proof(induct rule: ImplGen.induct)
case (AR alpha)
  then show ?case using ImplHil.AR by(auto)
next
  case (MR X X' alpha)
  then show ?case using ImplHil_monot_prop by(auto)
next
  case (ANDI X alpha beta)
  then show ?case using ImplHil.L2 ImplHil.MP by(blast)
next
  case (ANDl X alpha beta)
  then show ?case using ImplHil.L3a ImplHil.MP by(blast)
next
  case (ANDr X alpha beta)
  then show ?case using ImplHil.L3b ImplHil.MP by(blast)
next
  case (NEG1 X alpha beta)
  then show ?case using ImplHil_fulfills_ImplGenNEG1 by(auto)
next
  case (NEG2 X alpha beta)
  then show ?case using ImplHil_fulfills_ImplGenNEG2 by(auto)
qed

theorem ImplHil_complete: "X |~ alpha \<longleftrightarrow> X \<Turnstile> alpha"
proof
  assume H1: "X |~ alpha"
  from this ImplHil_correct show "X \<Turnstile> alpha" by(auto)
next
  assume H2: "X \<Turnstile> alpha"
  from this have "X \<turnstile> alpha" by (simp add: completeness_theorem)
  from this show "X |~ alpha" by (simp add: ImplGen_implies_ImpHil)
qed

end


section "Base"

theory Base
imports PermutationLemmas
begin

subsection "Integrate with Isabelle libraries?"

    \<comment> \<open>Misc\<close>

  \<comment> \<open>FIXME added by tjr, forms basis of a lot of proofs of existence of inf sets\<close>
  \<comment> \<open>something like this should be in FiniteSet, asserting nats are not finite\<close>
lemma natset_finite_max: assumes a: "finite A"
  shows "Suc (Max A) \<notin> A"
proof (cases "A = {}")
  case True
  thus ?thesis by auto
next
  case False
  with a have "Max A \<in> A \<and> (\<forall>s \<in> A. s \<le> Max A)" by simp
  thus ?thesis by auto
qed

    \<comment> \<open>not used\<close>
lemma not_finite_univ: "~ finite (UNIV::nat set)"
  apply rule
  apply(drule_tac natset_finite_max)
  by force

  \<comment> \<open>FIXME should be in main lib\<close>
lemma LeastI_ex: "(\<exists> x. P (x::'a::wellorder)) \<Longrightarrow> P (LEAST x. P x)"
  by(blast intro: LeastI)

subsection "Summation"

primrec summation :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "summation f 0 = f 0"
| "summation f (Suc n) = f (Suc n) + summation f n"

subsection "Termination Measure"

primrec exp :: "[nat,nat] \<Rightarrow> nat"
where
  "exp x 0       = 1"
| "exp x (Suc m) = x * exp x m"

primrec sumList     :: "nat list \<Rightarrow> nat"
where
  "sumList []     = 0"
| "sumList (x#xs) = x + sumList xs"

subsection "Functions"

definition
  preImage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set" where
  "preImage f A = { x . f x \<in> A}"

definition
  pre :: "('a \<Rightarrow> 'b) => 'b \<Rightarrow> 'a set" where
  "pre f a = { x . f x = a}"

definition
  equalOn :: "['a set,'a => 'b,'a => 'b] => bool" where
  "equalOn A f g = (!x:A. f x = g x)"

lemma preImage_insert: "preImage f (insert a A) = pre f a Un preImage f A"
  by(auto simp add: preImage_def pre_def)

lemma preImageI: "f x : A ==> x : preImage f A"
  by(simp add: preImage_def)

lemma preImageE: "x : preImage f A ==> f x : A"
  by(simp add: preImage_def)

lemma equalOn_Un:  "equalOn (A \<union> B) f g = (equalOn A f g \<and> equalOn B f g)"
  by(auto simp add: equalOn_def)

lemma equalOnD: "equalOn A f g \<Longrightarrow> (\<forall> x \<in> A . f x = g x)"
  by(simp add: equalOn_def)

lemma equalOnI:"(\<forall> x \<in> A . f x = g x) \<Longrightarrow> equalOn A f g"
  by(simp add: equalOn_def)

lemma equalOn_UnD: "equalOn (A Un B) f g ==> equalOn A f g & equalOn B f g"
  by(auto simp: equalOn_def)

    \<comment> \<open>FIXME move following elsewhere?\<close>
lemma inj_inv_singleton[simp]: "\<lbrakk> inj f; f z = y \<rbrakk> \<Longrightarrow> {x. f x = y} = {z}"
  apply rule
  apply(auto simp: inj_on_def) done

lemma finite_pre[simp]: "inj f \<Longrightarrow> finite (pre f x)"
  apply(simp add: pre_def)
  apply (cases "\<exists> y. f y = x", auto) done

lemma finite_preImage[simp]: "\<lbrakk> finite A; inj f \<rbrakk> \<Longrightarrow> finite (preImage f A)"
  apply(induct A rule: finite_induct)
  apply(simp add: preImage_def)
  apply(simp add: preImage_insert) done

end


section {* polynomial functions: extremal behaviour and root counts *}

(*  Author: John Harrison and Valentina Bruno
    Ported from "hol_light/Multivariate/complexes.ml" by L C Paulson
*)

theory PolyRoots
imports Complex_Main

begin

subsection{*Geometric progressions*}

lemma setsum_gp_basic:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  shows "(1 - x) * (\<Sum>i\<le>n. x^i) = 1 - x^Suc n"
  by (simp only: one_diff_power_eq [of "Suc n" x] lessThan_Suc_atMost)

lemma setsum_gp0:
 fixes x :: "'a::{comm_ring,division_ring_inverse_zero}"
 shows   "(\<Sum>i\<le>n. x^i) = (if x = 1 then of_nat(n + 1) else (1 - x^Suc n) / (1 - x))"
using setsum_gp_basic[of x n]
apply (simp add: real_of_nat_def)
by (metis eq_iff_diff_eq_0 mult.commute nonzero_eq_divide_eq)

lemma setsum_power_shift:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  assumes "m \<le> n"
  shows "(\<Sum>i=m..n. x^i) = x^m * (\<Sum>i\<le>n-m. x^i)"
proof -
  have "(\<Sum>i=m..n. x^i) = x^m * (\<Sum>i=m..n. x^(i-m))"
    by (simp add: setsum_right_distrib power_add [symmetric])
  also have "(\<Sum>i=m..n. x^(i-m)) = (\<Sum>i\<le>n-m. x^i)"
    using `m \<le> n` by (intro setsum.reindex_bij_witness[where j="\<lambda>i. i - m" and i="\<lambda>i. i + m"]) auto
  finally show ?thesis .
qed

lemma setsum_gp_multiplied:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  assumes "m \<le> n"
  shows "(1 - x) * (\<Sum>i=m..n. x^i) = x^m - x^Suc n"
proof -
  have  "(1 - x) * (\<Sum>i=m..n. x^i) = x^m * (1 - x) * (\<Sum>i\<le>n-m. x^i)"
    by (metis mult.assoc mult.commute assms setsum_power_shift)
  also have "... =x^m * (1 - x^Suc(n-m))"
    by (metis mult.assoc setsum_gp_basic)
  also have "... = x^m - x^Suc n"
    using assms
    by (simp add: algebra_simps) (metis le_add_diff_inverse power_add)
  finally show ?thesis .
qed

lemma setsum_gp:
  fixes x :: "'a::{comm_ring,division_ring_inverse_zero}"
  shows   "(\<Sum>i=m..n. x^i) =
               (if n < m then 0
                else if x = 1 then of_nat((n + 1) - m)
                else (x^m - x^Suc n) / (1 - x))"
using setsum_gp_multiplied [of m n x]
apply (auto simp: real_of_nat_def)
by (metis eq_iff_diff_eq_0 mult.commute nonzero_divide_eq_eq)

lemma setsum_gp_offset:
  fixes x :: "'a::{comm_ring,division_ring_inverse_zero}"
  shows   "(\<Sum>i=m..m+n. x^i) =
       (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
  using setsum_gp [of x m "m+n"]
  by (auto simp: power_add algebra_simps)

subsection{*Basics about polynomial functions: extremal behaviour and root counts.*}

lemma sub_polyfun:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  shows   "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
           (x - y) * (\<Sum>j<n. \<Sum>k= Suc j..n. a k * y^(k - Suc j) * x^j)"
proof -
  have "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
        (\<Sum>i\<le>n. a i * (x^i - y^i))"
    by (simp add: algebra_simps setsum_subtractf [symmetric])
  also have "... = (\<Sum>i\<le>n. a i * (x - y) * (\<Sum>j<i. y^(i - Suc j) * x^j))"
    by (simp add: power_diff_sumr2 ac_simps)
  also have "... = (x - y) * (\<Sum>i\<le>n. (\<Sum>j<i. a i * y^(i - Suc j) * x^j))"
    by (simp add: setsum_right_distrib ac_simps)
  also have "... = (x - y) * (\<Sum>j<n. (\<Sum>i=Suc j..n. a i * y^(i - Suc j) * x^j))"
    by (simp add: nested_setsum_swap')
  finally show ?thesis .
qed

lemma sub_polyfun_alt:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  shows   "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
           (x - y) * (\<Sum>j<n. \<Sum>k<n-j. a (j+k+1) * y^k * x^j)"
proof -
  { fix j
    have "(\<Sum>k = Suc j..n. a k * y^(k - Suc j) * x^j) =
          (\<Sum>k <n - j. a (Suc (j + k)) * y^k * x^j)"
      by (rule setsum.reindex_bij_witness[where i="\<lambda>i. i + Suc j" and j="\<lambda>i. i - Suc j"]) auto }
  then show ?thesis
    by (simp add: sub_polyfun)
qed

lemma polyfun_linear_factor:
  fixes a :: "'a::{comm_ring,monoid_mult}"
  shows  "\<exists>b. \<forall>z. (\<Sum>i\<le>n. c i * z^i) =
                  (z-a) * (\<Sum>i<n. b i * z^i) + (\<Sum>i\<le>n. c i * a^i)"
proof -
  { fix z
    have "(\<Sum>i\<le>n. c i * z^i) - (\<Sum>i\<le>n. c i * a^i) =
          (z - a) * (\<Sum>j<n. (\<Sum>k = Suc j..n. c k * a^(k - Suc j)) * z^j)"
      by (simp add: sub_polyfun setsum_left_distrib)
    then have "(\<Sum>i\<le>n. c i * z^i) =
          (z - a) * (\<Sum>j<n. (\<Sum>k = Suc j..n. c k * a^(k - Suc j)) * z^j)
          + (\<Sum>i\<le>n. c i * a^i)"
      by (simp add: algebra_simps) }
  then show ?thesis
    by (intro exI allI)
qed

lemma polyfun_linear_factor_root:
  fixes a :: "'a::{comm_ring,monoid_mult}"
  assumes "(\<Sum>i\<le>n. c i * a^i) = 0"
  shows  "\<exists>b. \<forall>z. (\<Sum>i\<le>n. c i * z^i) = (z-a) * (\<Sum>i<n. b i * z^i)"
  using polyfun_linear_factor [of c n a] assms
  by simp

lemma adhoc_norm_triangle: "a + norm(y) \<le> b ==> norm(x) \<le> a ==> norm(x + y) \<le> b"
  by (metis norm_triangle_mono order.trans order_refl)

lemma polyfun_extremal_lemma:
  fixes c :: "nat \<Rightarrow> 'a::real_normed_div_algebra"
  assumes "e > 0"
    shows "\<exists>M. \<forall>z. M \<le> norm z \<longrightarrow> norm(\<Sum>i\<le>n. c i * z^i) \<le> e * norm(z) ^ Suc n"
proof (induction n)
  case 0
  show ?case
    by (rule exI [where x="norm (c 0) / e"]) (auto simp: mult.commute pos_divide_le_eq assms)
next
  case (Suc n)
  then obtain M where M: "\<forall>z. M \<le> norm z \<longrightarrow> norm (\<Sum>i\<le>n. c i * z^i) \<le> e * norm z ^ Suc n" ..
  show ?case
  proof (rule exI [where x="max 1 (max M ((e + norm(c(Suc n))) / e))"], clarify)
    fix z::'a
    assume "max 1 (max M ((e + norm (c (Suc n))) / e)) \<le> norm z"
    then have norm1: "0 < norm z" "M \<le> norm z" "(e + norm (c (Suc n))) / e \<le> norm z"
      by auto
    then have norm2: "(e + norm (c (Suc n))) \<le> e * norm z"  "(norm z * norm z ^ n) > 0"
      apply (metis assms less_divide_eq mult.commute not_le)
      using norm1 apply (metis mult_pos_pos zero_less_power)
      done
    have "e * (norm z * norm z ^ n) + norm (c (Suc n) * (z * z ^ n)) =
          (e + norm (c (Suc n))) * (norm z * norm z ^ n)"
      by (simp add: norm_mult norm_power algebra_simps)
    also have "... \<le> (e * norm z) * (norm z * norm z ^ n)"
      using norm2 by (metis real_mult_le_cancel_iff1)
    also have "... = e * (norm z * (norm z * norm z ^ n))"
      by (simp add: algebra_simps)
    finally have "e * (norm z * norm z ^ n) + norm (c (Suc n) * (z * z ^ n))
                  \<le> e * (norm z * (norm z * norm z ^ n))" .
    then show "norm (\<Sum>i\<le>Suc n. c i * z^i) \<le> e * norm z ^ Suc (Suc n)" using M norm1
      by (drule_tac x=z in spec) (auto simp: intro!: adhoc_norm_triangle)
    qed
qed

lemma norm_lemma_xy: "\<lbrakk>abs b + 1 \<le> norm(y) - a; norm(x) \<le> a\<rbrakk> \<Longrightarrow> b \<le> norm(x + y)"
  by (metis abs_add_one_not_less_self add.commute diff_le_eq dual_order.trans le_less_linear
         norm_diff_ineq)

lemma polyfun_extremal:
  fixes c :: "nat \<Rightarrow> 'a::real_normed_div_algebra"
  assumes "\<exists>k. k \<noteq> 0 \<and> k \<le> n \<and> c k \<noteq> 0"
    shows "eventually (\<lambda>z. norm(\<Sum>i\<le>n. c i * z^i) \<ge> B) at_infinity"
using assms
proof (induction n)
  case 0 then show ?case
    by simp
next
  case (Suc n)
  show ?case
  proof (cases "c (Suc n) = 0")
    case True
    with Suc show ?thesis
      by auto (metis diff_is_0_eq diffs0_imp_equal less_Suc_eq_le not_less_eq)
  next
    case False
    with polyfun_extremal_lemma [of "norm(c (Suc n)) / 2" c n]
    obtain M where M: "\<And>z. M \<le> norm z \<Longrightarrow>
               norm (\<Sum>i\<le>n. c i * z^i) \<le> norm (c (Suc n)) / 2 * norm z ^ Suc n"
      by auto
    show ?thesis
    unfolding eventually_at_infinity
    proof (rule exI [where x="max M (max 1 ((abs B + 1) / (norm (c (Suc n)) / 2)))"], clarsimp)
      fix z::'a
      assume les: "M \<le> norm z"  "1 \<le> norm z"  "(\<bar>B\<bar> * 2 + 2) / norm (c (Suc n)) \<le> norm z"
      then have "\<bar>B\<bar> * 2 + 2 \<le> norm z * norm (c (Suc n))"
        by (metis False pos_divide_le_eq zero_less_norm_iff)
      then have "\<bar>B\<bar> * 2 + 2 \<le> norm z ^ (Suc n) * norm (c (Suc n))"
        by (metis `1 \<le> norm z` order.trans mult_right_mono norm_ge_zero self_le_power zero_less_Suc)
      then show "B \<le> norm ((\<Sum>i\<le>n. c i * z^i) + c (Suc n) * (z * z ^ n))" using M les
        apply auto
        apply (rule norm_lemma_xy [where a = "norm (c (Suc n)) * norm z ^ (Suc n) / 2"])
        apply (simp_all add: norm_mult norm_power)
        done
    qed
  qed
qed

lemma polyfun_rootbound:
 fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
 assumes "\<exists>k. k \<le> n \<and> c k \<noteq> 0"
   shows "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<and> card {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<le> n"
using assms
proof (induction n arbitrary: c)
 case (Suc n) show ?case
 proof (cases "{z. (\<Sum>i\<le>Suc n. c i * z^i) = 0} = {}")
   case False
   then obtain a where a: "(\<Sum>i\<le>Suc n. c i * a^i) = 0"
     by auto
   from polyfun_linear_factor_root [OF this]
   obtain b where "\<And>z. (\<Sum>i\<le>Suc n. c i * z^i) = (z - a) * (\<Sum>i< Suc n. b i * z^i)"
     by auto
   then have b: "\<And>z. (\<Sum>i\<le>Suc n. c i * z^i) = (z - a) * (\<Sum>i\<le>n. b i * z^i)"
     by (metis lessThan_Suc_atMost)
   then have ins_ab: "{z. (\<Sum>i\<le>Suc n. c i * z^i) = 0} = insert a {z. (\<Sum>i\<le>n. b i * z^i) = 0}"
     by auto
   have c0: "c 0 = - (a * b 0)" using  b [of 0]
     by simp
   then have extr_prem: "~ (\<exists>k\<le>n. b k \<noteq> 0) \<Longrightarrow> \<exists>k. k \<noteq> 0 \<and> k \<le> Suc n \<and> c k \<noteq> 0"
     by (metis Suc.prems le0 minus_zero mult_zero_right)
   have "\<exists>k\<le>n. b k \<noteq> 0"
     apply (rule ccontr)
     using polyfun_extremal [OF extr_prem, of 1]
     apply (auto simp: eventually_at_infinity b simp del: setsum_atMost_Suc)
     apply (drule_tac x="of_real ba" in spec, simp)
     done
   then show ?thesis using Suc.IH [of b] ins_ab
     by (auto simp: card_insert_if)
   qed simp
qed simp

corollary
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
  assumes "\<exists>k. k \<le> n \<and> c k \<noteq> 0"
    shows polyfun_rootbound_finite: "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0}"
      and polyfun_rootbound_card:   "card {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<le> n"
using polyfun_rootbound [OF assms] by auto

lemma polyfun_finite_roots:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<longleftrightarrow> (\<exists>k. k \<le> n \<and> c k \<noteq> 0)"
proof (cases " \<exists>k\<le>n. c k \<noteq> 0")
  case True then show ?thesis
    by (blast intro: polyfun_rootbound_finite)
next
  case False then show ?thesis
    by (auto simp: infinite_UNIV_char_0)
qed

lemma polyfun_eq_0:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = 0) \<longleftrightarrow> (\<forall>k. k \<le> n \<longrightarrow> c k = 0)"
proof (cases "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = 0)")
  case True
  then have "~ finite {z. (\<Sum>i\<le>n. c i * z^i) = 0}"
    by (simp add: infinite_UNIV_char_0)
  with True show ?thesis
    by (metis (poly_guards_query) polyfun_rootbound_finite)
next
  case False
  then show ?thesis
    by auto
qed

lemma polyfun_eq_const:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = k) \<longleftrightarrow> c 0 = k \<and> (\<forall>k. k \<noteq> 0 \<and> k \<le> n \<longrightarrow> c k = 0)"
proof -
  {fix z
    have "(\<Sum>i\<le>n. c i * z^i) = (\<Sum>i\<le>n. (if i = 0 then c 0 - k else c i) * z^i) + k"
      by (induct n) auto
  } then
  have "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = k) \<longleftrightarrow> (\<forall>z. (\<Sum>i\<le>n. (if i = 0 then c 0 - k else c i) * z^i) = 0)"
    by auto
  also have "... \<longleftrightarrow>  c 0 = k \<and> (\<forall>k. k \<noteq> 0 \<and> k \<le> n \<longrightarrow> c k = 0)"
    by (auto simp: polyfun_eq_0)
  finally show ?thesis .
qed

end