theory conditions_negative_infinitary
  imports conditions_negative conditions_positive_infinitary
begin

(**We define and interrelate infinitary variants for some previously introduced
 axiomatic conditions on operators.*)

(**anti-distribution over infinite joins (suprema) or infinite anti-additivity (inADDI).*)
definition inADDI::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inADDI")
  where "inADDI \<phi>  \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<approx> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"
definition inADDI_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inADDI\<^sup>a")
  where "inADDI\<^sup>a \<phi> \<equiv> \<forall>S. \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<Or>S)  "
definition inADDI_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inADDI\<^sup>b")
  where "inADDI\<^sup>b \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"

(**anti-distribution over infinite meets (infima) or infinite anti-multiplicativity (inMULT).*)
definition inMULT::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inMULT")
  where "inMULT \<phi>  \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<approx> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"
definition inMULT_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inMULT\<^sup>a")
  where "inMULT\<^sup>a \<phi> \<equiv> \<forall>S. \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>S)"
definition inMULT_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("inMULT\<^sup>b")
  where "inMULT\<^sup>b \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"

declare inADDI_def[cond] inADDI_a_def[cond] inADDI_b_def[cond]
        inMULT_def[cond] inMULT_a_def[cond] inMULT_b_def[cond]

lemma inADDI_char: "inADDI \<phi> = (inADDI\<^sup>a \<phi> \<and> inADDI\<^sup>b \<phi>)" unfolding cond using setequ_char by blast
lemma inMULT_char: "inMULT \<phi> = (inMULT\<^sup>a \<phi> \<and> inMULT\<^sup>b \<phi>)" unfolding cond using setequ_char by blast

(**nADDI-b and inADDI-b are in fact equivalent.*)
lemma inADDIb_equ: "inADDI\<^sup>b \<phi> = nADDI\<^sup>b \<phi>" proof -
  have lr: "inADDI\<^sup>b \<phi> \<Longrightarrow> nADDI\<^sup>b \<phi>" proof - (*prove as a one-liner by instantiating inADDI_b_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume inaddib: "inADDI\<^sup>b \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>" (* for some reason Isabelle doesn't like other letters as type variable. Why?*)
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<Or>?S = A \<^bold>\<or> B" unfolding supremum_def join_def by blast
    hence p1: "\<phi>(\<^bold>\<Or>?S) = \<phi>(A \<^bold>\<or> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding image_def by metis
    hence p2: "\<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<and> (\<phi> B)" unfolding infimum_def meet_def by auto
    have "\<phi>(\<^bold>\<Or>?S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk>" using inaddib inADDI_b_def by blast
    hence "\<phi>(A \<^bold>\<or> B) \<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: nADDI_b_def) qed
  have rl: "nADDI\<^sup>b \<phi> \<Longrightarrow> inADDI\<^sup>b \<phi>" unfolding inADDI_b_def ANTI_nADDIb ANTI_def image_def
    by (smt (verit) glb_def inf_glb lower_bounds_def lub_def sup_lub upper_bounds_def)
  from lr rl show ?thesis by auto
qed
(**nMULT-a and inMULT-a are also equivalent.*)
lemma inMULTa_equ: "inMULT\<^sup>a \<phi> = nMULT\<^sup>a \<phi>" proof -
  have lr: "inMULT\<^sup>a \<phi> \<Longrightarrow> nMULT\<^sup>a \<phi>" proof - (*prove as a one-liner by instantiating inMULT_a_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume inmulta: "inMULT\<^sup>a \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>"
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<And>?S = A \<^bold>\<and> B" unfolding infimum_def meet_def by blast
    hence p1: "\<phi>(\<^bold>\<And>?S) = \<phi>(A \<^bold>\<and> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding image_def by metis
    hence p2: "\<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<or> (\<phi> B)" unfolding supremum_def join_def by auto
    have "\<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>?S)" using inmulta inMULT_a_def by blast
    hence "(\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq> \<phi>(A \<^bold>\<and> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: nMULT_a_def) qed
  have rl: "nMULT\<^sup>a \<phi> \<Longrightarrow> inMULT\<^sup>a \<phi>" unfolding inMULT_a_def ANTI_nMULTa ANTI_def image_def
    by (smt (verit) glb_def inf_glb lower_bounds_def lub_def sup_lub upper_bounds_def)
  from lr rl show ?thesis by blast
qed

(**Thus we have that ANTI, nADDI-b/inADDI-b and nMULT-a/inMULT-a are all equivalent.*)
lemma ANTI_inADDIb: "inADDI\<^sup>b \<phi> = ANTI \<phi>" unfolding ANTI_nADDIb inADDIb_equ by simp
lemma ANTI_inMULTa: "inMULT\<^sup>a \<phi> = ANTI \<phi>" unfolding ANTI_nMULTa inMULTa_equ by simp

(**Below we prove several duality relationships between inADDI(a/b) and inMULT(a/b).*)

(**Duality between inMULT-a and inADDI-b (an easy corollary from the previous equivalence).*)
lemma inMULTa_inADDIb_dual1: "inMULT\<^sup>a \<phi> = inADDI\<^sup>b \<phi>\<^sup>d" by (simp add: nMULTa_nADDIb_dual1 inADDIb_equ inMULTa_equ)
lemma inMULTa_inADDIb_dual2: "inADDI\<^sup>b \<phi> = inMULT\<^sup>a \<phi>\<^sup>d" by (simp add: nMULTa_nADDIb_dual2 inADDIb_equ inMULTa_equ)
(**Duality between inADDI-a and inMULT-b.*)
lemma inADDIa_inMULTb_dual1: "inADDI\<^sup>a \<phi> = inMULT\<^sup>b \<phi>\<^sup>d" by (smt (z3) BA_cmpl_equ BA_cp dualcompl_invol inADDI_a_def iDM_a inMULT_b_def im_prop1 op_dual_def setequ_ext)
lemma inADDIa_inMULTb_dual2: "inMULT\<^sup>b \<phi> = inADDI\<^sup>a \<phi>\<^sup>d" by (simp add: dual_invol inADDIa_inMULTb_dual1)
(**Duality between inADDI and inMULT.*)
lemma inADDI_inMULT_dual1: "inADDI \<phi> = inMULT \<phi>\<^sup>d" using inADDI_char inADDIa_inMULTb_dual1 inMULT_char inMULTa_inADDIb_dual2 by blast
lemma inADDI_inMULT_dual2: "inMULT \<phi> = inADDI \<phi>\<^sup>d" by (simp add: dual_invol inADDI_inMULT_dual1)

(**inADDI and inMULT are the 'complements' of iADDI and iMULT respectively*)
lemma inADDIa_compl: "iADDI\<^sup>a \<phi> = inADDI\<^sup>a \<phi>\<^sup>c" by (metis BA_cmpl_equ BA_cp iADDI_a_def iDM_a im_prop2 inADDI_a_def setequ_ext svfun_compl_def)
lemma inADDIb_compl: "iADDI\<^sup>b \<phi> = inADDI\<^sup>b \<phi>\<^sup>c" by (simp add: ANTI_MONO ANTI_inADDIb MONO_iADDIb)
lemma inADDI_compl: "iADDI \<phi> = inADDI \<phi>\<^sup>c" by (simp add: iADDI_char inADDI_char inADDIa_compl inADDIb_compl)
lemma inMULTa_compl: "iMULT\<^sup>a \<phi> = inMULT\<^sup>a \<phi>\<^sup>c" by (simp add: ANTI_MONO ANTI_inMULTa MONO_iMULTa)
lemma inMULTb_compl: "iMULT\<^sup>b \<phi> = inMULT\<^sup>b \<phi>\<^sup>c" by (metis dual_compl_char1 dual_compl_char2 iADDIa_iMULTb_dual2 inADDIa_compl inADDIa_inMULTb_dual2)
lemma inMULT_compl: "iMULT \<phi> = inMULT \<phi>\<^sup>c" by (simp add: iMULT_char inMULT_char inMULTa_compl inMULTb_compl)

(**In fact, infinite anti-additivity (anti-multiplicativity) entails (dual) anti-normality:*)
lemma inADDI_nNORM: "inADDI \<phi> \<longrightarrow> nNORM \<phi>" by (metis bottom_def inADDI_def inf_empty image_def nNORM_def setequ_ext sup_empty)
lemma inMULT_nDNRM: "inMULT \<phi> \<longrightarrow> nDNRM \<phi>" by (simp add: inADDI_inMULT_dual2 inADDI_nNORM nNOR_dual2)

end


theory SINVAR_BLPstrict
imports "../TopoS_Helper"
begin

subsection \<open>Stricter Bell LaPadula SecurityInvariant\<close>
text\<open>All unclassified data sources must be labeled, default assumption: all is secret.

Warning: This is considered here an access control strategy.
By default, everything is secret and one explicitly prohibits sending to non-secret hosts.\<close>

datatype security_level = Unclassified | Confidential | Secret

(*total order*)
instantiation security_level :: linorder
  begin
  fun less_eq_security_level :: "security_level \<Rightarrow> security_level \<Rightarrow> bool" where
    "(Unclassified \<le> Unclassified) = True" |
    "(Confidential \<le> Confidential) = True" |
    "(Secret \<le> Secret) = True" |
    "(Unclassified \<le> Confidential) = True" |
    "(Confidential \<le> Secret) = True"  |
    "(Unclassified \<le> Secret) = True"  |
    "(Secret \<le> Confidential) = False"  |
    "(Confidential \<le> Unclassified) = False"  |
    "(Secret \<le> Unclassified) = False"

  fun less_security_level :: "security_level \<Rightarrow> security_level \<Rightarrow> bool" where
    "(Unclassified < Unclassified) = False" |
    "(Confidential < Confidential) = False" |
    "(Secret < Secret) = False" |
    "(Unclassified < Confidential) = True" |
    "(Confidential < Secret) = True"  |
    "(Unclassified < Secret) = True"  |
    "(Secret < Confidential) = False"  |
    "(Confidential < Unclassified) = False"  |
    "(Secret < Unclassified) = False"
  instance
    apply(intro_classes)
    apply(case_tac [!] x)
    apply(simp_all)
    apply(case_tac  [!] y)
    apply(simp_all)
    apply(case_tac  [!] z)
    apply(simp_all)
    done
  end

definition default_node_properties :: "security_level"
  where  "default_node_properties \<equiv> Secret"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (nP e1) \<le> (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation \<equiv> False"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

subsection \<open>ENF\<close>
  lemma secret_default_candidate: "\<And> (nP::('v \<Rightarrow> security_level)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> Secret \<le> (nP e2)"
    apply(case_tac "nP e1")
    apply(simp_all)
    apply(case_tac [!] "nP e2")
    apply(simp_all)
    done
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (\<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (\<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPstrict: SecurityInvariant_ACS sinvar default_node_properties
  (*TODO: why is there a where and no "rewrites" in the afp?*)
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
      apply(simp add: secret_default_candidate; fail)
     apply(erule default_uniqueness_by_counterexample_ACS)
     apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
     apply(simp add: BLP_offending_set graph_ops wf_graph_def)
     apply(rule_tac x="(\<lambda> x. Secret)(vertex_1 := Secret, vertex_2 := Confidential)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
     apply(simp add: BLP_offending_set_def)
     apply(rule conjI)
      apply fastforce
     apply (case_tac otherbot, simp_all)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPstrict: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono

hide_const (open) sinvar receiver_violation default_node_properties

end


(*  Author:     Tobias Nipkow, 2007  *)

section "Arrow's Theorem for Strict Linear Orders"

theory Arrow_Order imports Main "HOL-Library.FuncSet"
begin

text\<open>This theory formalizes the third proof due to
Geanakoplos~\<^cite>\<open>"Geanakoplos05"\<close>.  Preferences are modeled as strict
linear orderings. The set of alternatives need not be finite.

Individuals are assumed to be finite but are not a priori identified with an
initial segment of the naturals. In retrospect this generality appears
gratuitous and complicates some of the low-level reasoning where we use a
bijection with such an initial segment.\<close>

typedecl alt
typedecl indi

abbreviation "I == (UNIV::indi set)"

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_indi: "finite I"

abbreviation "N == card I"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "(alt * alt)set"

definition "Lin == {L::pref. strict_linear_order L}"

lemmas slo_defs = Lin_def strict_linear_order_on_def total_on_def irrefl_def

lemma notin_Lin_iff: "L : Lin \<Longrightarrow> x\<noteq>y \<Longrightarrow> (x,y) \<notin> L \<longleftrightarrow> (y,x) : L"
apply(auto simp add: slo_defs)
apply(metis trans_def)
done

lemma converse_in_Lin[simp]: "L\<inverse> : Lin \<longleftrightarrow> L : Lin"
apply (simp add: slo_defs)
apply blast
done

lemma Lin_irrefl: "L:Lin \<Longrightarrow> (a,b):L \<Longrightarrow> (b,a):L \<Longrightarrow> False"
by(simp add:slo_defs)(metis trans_def)

corollary linear_alt: "\<exists>L::pref. L : Lin"
using well_order_on[where 'a = "alt", of UNIV]
apply (auto simp:well_order_on_def Lin_def)
apply (metis strict_linear_order_on_diff_Id)
done

abbreviation
 rem :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"rem L a \<equiv> {(x,y). (x,y) \<in> L \<and> x\<noteq>a \<and> y\<noteq>a}"
definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop L b \<equiv> rem L b \<union> {(x,b)|x. x\<noteq>b}"
definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot L b \<equiv> rem L b \<union> {(b,y)|y. y\<noteq>b}"
definition
 below :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"below L a b \<equiv> rem L a \<union>
  {(a,b)} \<union> {(x,a)|x. (x,b) : L \<and> x\<noteq>a} \<union> {(a,y)|y. (b,y) : L \<and> y\<noteq>a}"
definition
 above :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"above L a b \<equiv> rem L b \<union>
  {(a,b)} \<union> {(x,b)|x. (x,a) : L \<and> x\<noteq>b} \<union> {(b,y)|y. (a,y) : L \<and> y\<noteq>b}"

lemma in_mktop: "(x,y) \<in> mktop L z \<longleftrightarrow> x\<noteq>z \<and> (if y=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mktop_def)

lemma in_mkbot: "(x,y) \<in> mkbot L z \<longleftrightarrow> y\<noteq>z \<and> (if x=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mkbot_def)

lemma in_above: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : above L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if x=b then (a,y) : L else
   if y=b then x=a | (x,a) : L else (x,y) : L)"
by(auto simp:above_def slo_defs)

lemma in_below: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : below L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if y=a then (x,b) : L else
   if x=a then y=b | (b,y) : L else (x,y) : L)"
by(auto simp:below_def slo_defs)

declare [[simp_depth_limit = 2]]

lemma mktop_Lin: "L : Lin \<Longrightarrow> mktop L x : Lin"
by(auto simp add:slo_defs mktop_def trans_def)
lemma mkbot_Lin: "L : Lin \<Longrightarrow> mkbot L x : Lin"
by(auto simp add:slo_defs trans_def mkbot_def)

lemma below_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> below L x y : Lin"
unfolding slo_defs below_def trans_def
apply(simp)
apply blast
done

lemma above_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> above L x y : Lin"
unfolding slo_defs above_def trans_def
apply(simp)
apply blast
done

declare [[simp_depth_limit = 50]]

abbreviation lessLin :: "alt \<Rightarrow> pref \<Rightarrow> alt \<Rightarrow> bool" ("(_ <\<^bsub>_\<^esub> _)" [51, 51] 50)
where "a <\<^bsub>L\<^esub> b == (a,b) : L"

definition "Prof = I \<rightarrow> Lin"

abbreviation "SWF == Prof \<rightarrow> Lin"

definition "unanimity F == \<forall>P\<in>Prof.\<forall>a b. (\<forall>i. a <\<^bsub>P i\<^esub> b) \<longrightarrow>  a <\<^bsub>F P\<^esub> b"

definition "IIA F == \<forall>P\<in>Prof.\<forall>P'\<in>Prof.\<forall>a b.
   (\<forall>i. a <\<^bsub>P i\<^esub> b \<longleftrightarrow> a <\<^bsub>P' i\<^esub> b) \<longrightarrow> (a <\<^bsub>F P\<^esub> b \<longleftrightarrow> a <\<^bsub>F P'\<^esub> b)"

definition "dictator F i == \<forall>P\<in>Prof. F P = P i"

lemma dictatorI: "F : SWF \<Longrightarrow>
  \<forall>P\<in>Prof. \<forall>a b. a \<noteq> b \<longrightarrow> (a,b) : P i \<longrightarrow> (a,b) : F P \<Longrightarrow> dictator F i"
apply(simp add:dictator_def Prof_def Pi_def Lin_def strict_linear_order_on_def)
apply safe
 apply(erule_tac x=P in allE)
 apply(erule_tac x=P in allE)
 apply(simp add:total_on_def irrefl_def)
 apply (metis trans_def)
apply (metis irrefl_def)
done

lemma const_Lin_Prof: "L:Lin \<Longrightarrow> (%p. L) : Prof"
by(simp add:Prof_def Pi_def)

lemma complete_Lin: assumes "a\<noteq>b" shows "\<exists>L\<in>Lin. (a,b) : L"
proof -
  from linear_alt obtain R where "R:Lin" by auto
  thus ?thesis by (metis assms in_mkbot mkbot_Lin)
qed

declare Let_def[simp]

theorem Arrow: assumes "F : SWF" and u: "unanimity F" and "IIA F"
shows "\<exists>i. dictator F i"
proof -
  { fix a b a' b' and P P'
    assume d1: "a\<noteq>b" "a'\<noteq>b'" and d2: "a\<noteq>b'" "b\<noteq>a'" and
      "P : Prof" "P' : Prof" and 1: "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    assume "(a,b) : F P"
    define Q where
      "Q i = (let L = (if a=a' then P i else below (P i) a' a)
              in if b=b' then L else above L b b')" for i
    have "Q : Prof" using \<open>P : Prof\<close>
      by(simp add:Q_def Prof_def Pi_def above_Lin below_Lin)
    hence "F Q : Lin" using \<open>F : SWF\<close> by(simp add:Pi_def)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,b) : Q i" using d1 d2 \<open>P : Prof\<close>
      by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
    hence "(a,b) : F Q" using \<open>(a,b) : F P\<close> \<open>IIA F\<close> \<open>P:Prof\<close> \<open>Q : Prof\<close>
      unfolding IIA_def by blast
    moreover
    { assume "a\<noteq>a'"
      hence "!!i. (a',a) : Q i" using d1 d2 \<open>P : Prof\<close>
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(a',a) : F Q" using u \<open>Q : Prof\<close> by(simp add:unanimity_def)
    } moreover
    { assume "b\<noteq>b'"
      hence "!!i. (b,b') : Q i" using d1 d2 \<open>P : Prof\<close>
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(b,b') : F Q" using u \<open>Q : Prof\<close> by(simp add:unanimity_def)
    }
    ultimately have "(a',b') : F Q" using \<open>F Q : Lin\<close>
      unfolding slo_defs trans_def
      by safe metis
    moreover
    have "\<forall>i. (a',b') : Q i \<longleftrightarrow> (a',b') : P' i" using d1 d2 \<open>P : Prof\<close> 1
      by(simp add:Q_def in_below in_above Prof_def Pi_def below_Lin) blast
    ultimately have "(a',b') : F P'"
      using \<open>IIA F\<close> \<open>P' : Prof\<close> \<open>Q : Prof\<close> unfolding IIA_def by blast
  } note 1 = this
  { fix a b a' b' and P P'
    assume "a\<noteq>b" "a'\<noteq>b'" "a\<noteq>b'" "b\<noteq>a'" "P : Prof" "P' : Prof"
           "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    hence "(a,b) : F P \<longleftrightarrow> (a',b') : F P'" using 1 by blast
  } note 2 = this
  { fix a b P P'
    assume "a\<noteq>b" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,a) : P' i"
    from \<open>a\<noteq>b\<close> obtain c where dist: "distinct[a,b,c]" using third_alt by metis
    let ?Q = "%p. below (P p) c b"
    let ?R = "%p. below (?Q p) b a"
    let ?S = "%p. below (?R p) a c"
    have "?Q : Prof" using \<open>P : Prof\<close> dist
      by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?R : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?S : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,c) : ?Q i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def)
    hence ab: "(a,b) : F P \<longleftrightarrow> (a,c) : F ?Q"
      using 2 \<open>P : Prof\<close> \<open>?Q : Prof\<close> dist[simplified] by (blast)
    have "\<forall>i. (a,c) : ?Q i \<longleftrightarrow> (b,c) : ?R i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence ac: "(a,c) : F ?Q \<longleftrightarrow> (b,c) : F ?R"
      using 2 \<open>?Q : Prof\<close> \<open>?R : Prof\<close> dist[simplified] by (blast)
    have "\<forall>i. (b,c) : ?R i \<longleftrightarrow> (b,a) : ?S i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence bc: "(b,c) : F ?R \<longleftrightarrow> (b,a) : F ?S"
      using \<open>?R : Prof\<close> \<open>?S : Prof\<close> dist[simplified] 2
      apply -
      apply(rule 2)
      by fast+
    have "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (a,b) : P i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (b,a) : P' i" using iff by blast
    hence ba: "(b,a) : F ?S \<longleftrightarrow> (b,a) : F P'"
      using \<open>IIA F\<close> \<open>P' : Prof\<close> \<open>?S : Prof\<close> unfolding IIA_def by fast
    from ab ac bc ba have "(a,b) : F P \<longleftrightarrow> (b,a) : F P'" by simp
  } note 3 = this
  { fix a b c P P'
    assume A: "a\<noteq>b" "b\<noteq>c" "a\<noteq>c" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,c) : P' i"
    hence "\<forall>i. (b,a) : (converse o P)i \<longleftrightarrow> (b,c) : P' i" by simp
    moreover have cP: "converse o P : Prof"
      using \<open>P:Prof\<close> by(simp add:Prof_def Pi_def)
    ultimately have "(b,a) : F(converse o P) \<longleftrightarrow> (b,c) : F P'" using A 2
      by metis
    moreover have "(a,b) : F P \<longleftrightarrow> (b,a) : F(converse o P)"
      by (rule 3[OF \<open>a\<noteq>b\<close> \<open>P:Prof\<close> cP]) simp
    ultimately have "(a,b) : F P \<longleftrightarrow> (b,c) : F P'" by blast
  } note 4 = this
  { fix a b a' b' :: alt and P P'
    assume A: "a\<noteq>b" "a'\<noteq>b'" "P : Prof" "P' : Prof"
      "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    have "(a,b) : F P \<longleftrightarrow> (a',b') : F P'"
    proof-
      { assume "a\<noteq>b' & b\<noteq>a'" hence ?thesis using 2 A by blast }
      moreover
      { assume "a=b' & b\<noteq>a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a\<noteq>b' & b=a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a=b' & b=a'" hence ?thesis using 3 A by blast }
      ultimately show ?thesis by blast
    qed
  } note pairwise_neutrality = this
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  obtain a b :: alt where "a \<noteq> b" using alt3 by auto
  obtain Lab where "(a,b) : Lab" "Lab:Lin" using \<open>a\<noteq>b\<close> by (metis complete_Lin)
  hence "(b,a) \<notin> Lab" by(simp add:slo_defs trans_def) metis
  obtain Lba where "(b,a) : Lba" "Lba:Lin" using \<open>a\<noteq>b\<close> by (metis complete_Lin)
  hence "(a,b) \<notin> Lba" by(simp add:slo_defs trans_def) metis
  let ?Pi = "%n. %i. if h i < n then Lab else Lba"
  have PiProf: "!!n. ?Pi n : Prof" using \<open>Lab:Lin\<close> \<open>Lba:Lin\<close>
    unfolding Prof_def Pi_def by simp
  have "\<exists>n<N. (\<forall>m\<le>n. (b,a) : F(?Pi m)) & (a,b) : F(?Pi(n+1))"
  proof -
    have 0: "!!n. F(?Pi n) : Lin" using \<open>F : SWF\<close> PiProf by(simp add:Pi_def)
    have "F(%i. Lba):Lin" using \<open>F:SWF\<close> \<open>Lba:Lin\<close> by(simp add:Prof_def Pi_def)
    hence 1: "(a,b) \<notin> F(?Pi 0)" using u \<open>(a,b) \<notin> Lba\<close> \<open>Lba:Lin\<close> \<open>Lba:Lin\<close> \<open>a\<noteq>b\<close>
      by(simp add:unanimity_def notin_Lin_iff const_Lin_Prof)
    have "?Pi N = (%p. Lab)" using surjh [THEN equalityD1]
      by(auto simp: subset_eq)
    moreover
    have "F(%i. Lab):Lin" using \<open>F:SWF\<close> \<open>Lab:Lin\<close> by(simp add:Prof_def Pi_def)
    ultimately have 2: "(a,b) \<in> F(?Pi N)" using u \<open>(a,b) : Lab\<close> \<open>Lab:Lin\<close>
      by(simp add:unanimity_def const_Lin_Prof)
    with ex_least_nat_less[of "%n. (a,b) : F(?Pi n)"] 1 2 notin_Lin_iff[OF 0 \<open>a\<noteq>b\<close>]
    show ?thesis by simp
  qed
  then obtain n where n: "n<N" "\<forall>m\<le>n. (b,a) : F(?Pi m)" "(a,b) : F(?Pi(n+1))"
    by blast
  have "dictator F (inv h n)"
  proof (rule dictatorI [OF \<open>F : SWF\<close>], auto)
    fix P c d assume "P \<in> Prof" "c\<noteq>d" "(c,d) \<in> P(inv h n)"
    then obtain e where dist: "distinct[c,d,e]" using third_alt by metis
    let ?W = "%i. if h i < n then mktop (P i) e else
                  if h i = n then above (P i) c e else mkbot (P i) e"
    have "?W : Prof" using \<open>P : Prof\<close> dist
      by(simp add:Pi_def Prof_def mkbot_Lin mktop_Lin above_Lin)
    have "\<forall>i. (c,d) : P i \<longleftrightarrow> (c,d) : ?W i" using dist \<open>P : Prof\<close>
      by(auto simp: in_above in_mkbot in_mktop Prof_def Pi_def)
    hence PW: "(c,d) : F P \<longleftrightarrow> (c,d) : F ?W"
      using \<open>IIA F\<close>[unfolded IIA_def] \<open>P:Prof\<close> \<open>?W:Prof\<close> by fast
    have "\<forall>i. (c,e) : ?W i \<longleftrightarrow> (a,b) : ?Pi (n+1) i" using dist \<open>P : Prof\<close>
      by (auto simp: \<open>(a,b):Lab\<close> \<open>(a,b)\<notin>Lba\<close>
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(c,e) : F ?W \<longleftrightarrow> (a,b) : F(?Pi(n+1))"
      using pairwise_neutrality[of c e a b ?W "?Pi(n+1)"]
        \<open>a\<noteq>b\<close> dist \<open>?W : Prof\<close> PiProf by simp
    hence "(c,e) : F ?W" using n(3) by blast
    have "\<forall>i. (e,d) : ?W i \<longleftrightarrow> (b,a) : ?Pi n i"
      using dist \<open>P : Prof\<close> \<open>(c,d) \<in> P(inv h n)\<close> \<open>inj h\<close>
      by(auto simp: \<open>(b,a):Lba\<close> \<open>(b,a)\<notin>Lab\<close>
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(e,d) : F ?W \<longleftrightarrow> (b,a) : F(?Pi n)"
      using pairwise_neutrality[of e d b a ?W "?Pi n"]
        \<open>a\<noteq>b\<close> dist \<open>?W : Prof\<close> PiProf by simp blast
    hence "(e,d) : F ?W" using n(2) by auto
    with \<open>(c,e) : F ?W\<close> \<open>?W : Prof\<close> \<open>F:SWF\<close>
    have "(c,d) \<in> F ?W" unfolding Pi_def slo_defs trans_def by blast
    thus "(c,d) \<in> F P" using PW by blast
  qed
  thus ?thesis ..
qed

end


(* ----------------------------------------------------------------- *)
subsection \<open>Quadratic equations\<close>
(* ----------------------------------------------------------------- *)

text \<open>In this section some simple properties of quadratic equations and their roots are derived.
Quadratic equations over reals and over complex numbers, but also systems of quadratic equations and
systems of quadratic and linear equations are analysed.\<close>

theory Quadratic
  imports More_Complex "HOL-Library.Quadratic_Discriminant"
begin

(* ----------------------------------------------------------------- *)
subsubsection \<open>Real quadratic equations, Viette rules\<close>
(* ----------------------------------------------------------------- *)

lemma viette2_monic:
  fixes b c \<xi>1 \<xi>2 :: real
  assumes "b\<^sup>2 - 4*c \<ge> 0" and "\<xi>1\<^sup>2 + b*\<xi>1 + c = 0" and "\<xi>2\<^sup>2 + b*\<xi>2 + c = 0" and "\<xi>1 \<noteq> \<xi>2"
  shows "\<xi>1*\<xi>2 = c"
  using assms
  by algebra

lemma viette2:
  fixes a b c \<xi>1 \<xi>2 :: real
  assumes "a \<noteq> 0" and "b\<^sup>2 - 4*a*c \<ge> 0" and "a*\<xi>1\<^sup>2 + b*\<xi>1 + c = 0" and "a*\<xi>2\<^sup>2 + b*\<xi>2 + c = 0" and "\<xi>1 \<noteq> \<xi>2"
  shows "\<xi>1*\<xi>2 = c/a"
proof (rule viette2_monic[of "b/a" "c/a" \<xi>1 \<xi>2])
  have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4*a*c) / a\<^sup>2"
    using \<open>a \<noteq> 0\<close>
    by (auto simp add: power2_eq_square field_simps)
  thus "0 \<le> (b / a)\<^sup>2 - 4 * (c / a)"
    using \<open>b\<^sup>2 - 4*a*c \<ge> 0\<close>
    by simp
next
  show "\<xi>1\<^sup>2 + b / a * \<xi>1 + c / a = 0" "\<xi>2\<^sup>2 + b / a * \<xi>2 + c / a = 0"
    using assms
    by (auto simp add: power2_eq_square field_simps)
next
  show "\<xi>1 \<noteq> \<xi>2"
    by fact
qed

lemma viette2'_monic:
  fixes b c \<xi> :: real
  assumes "b\<^sup>2 - 4*c = 0" and "\<xi>\<^sup>2 + b*\<xi> + c = 0"
  shows "\<xi>*\<xi> = c"
  using assms
  by algebra

lemma viette2':
  fixes a b c \<xi> :: real
  assumes "a \<noteq> 0" and "b\<^sup>2 - 4*a*c = 0" and "a*\<xi>\<^sup>2 + b*\<xi> + c = 0"
  shows "\<xi>*\<xi> = c/a"
proof (rule viette2'_monic)
  have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4*a*c) / a\<^sup>2"
    using \<open>a \<noteq> 0\<close>
    by (auto simp add: power2_eq_square field_simps)
  thus "(b / a)\<^sup>2 - 4 * (c / a) = 0"
    using \<open>b\<^sup>2 - 4*a*c = 0\<close>
    by simp
next
  show "\<xi>\<^sup>2 + b / a * \<xi> + c / a = 0"
    using assms
    by (auto simp add: power2_eq_square field_simps)
qed

(* ----------------------------------------------------------------- *)
subsubsection \<open>Complex quadratic equations\<close>
(* ----------------------------------------------------------------- *)

lemma complex_quadratic_equation_monic_only_two_roots:
  fixes \<xi> :: complex
  assumes "\<xi>\<^sup>2 + b * \<xi> + c = 0"
  shows "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4*c)) / 2 \<or> \<xi> = (-b - ccsqrt(b\<^sup>2 - 4*c)) / 2"
using assms
proof-
  from assms have "(2 * (\<xi> + b/2))\<^sup>2 = b\<^sup>2 - 4*c"
    by (simp add: power2_eq_square field_simps)
       (metis (no_types, lifting) distrib_right_numeral mult.assoc mult_zero_left)
  hence "2 * (\<xi> + b/2) = ccsqrt (b\<^sup>2 - 4*c) \<or> 2 * (\<xi> + b/2) = - ccsqrt (b\<^sup>2 - 4*c)"
    using ccsqrt[of "(2 * (\<xi> + b / 2))" "b\<^sup>2 - 4 * c"]
    by (simp add: power2_eq_square)
  thus ?thesis
    using mult_cancel_right[of "b + \<xi> * 2" 2 "ccsqrt (b\<^sup>2 - 4*c)"]
    using mult_cancel_right[of "b + \<xi> * 2" 2 "-ccsqrt (b\<^sup>2 - 4*c)"]
    by (auto simp add: field_simps) (metis add_diff_cancel diff_minus_eq_add minus_diff_eq)
qed

lemma complex_quadratic_equation_monic_roots:
  fixes \<xi> :: complex
  assumes "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4*c)) / 2 \<or>
           \<xi> = (-b - ccsqrt(b\<^sup>2 - 4*c)) / 2"
  shows  "\<xi>\<^sup>2 + b * \<xi> + c = 0"
using assms
proof
  assume *: "\<xi> = (- b + ccsqrt (b\<^sup>2 - 4 * c)) / 2"
  show ?thesis
    by ((subst *)+) (subst power_divide, subst power2_sum, simp add: field_simps, simp add: power2_eq_square)
next
  assume *: "\<xi> = (- b - ccsqrt (b\<^sup>2 - 4 * c)) / 2"
  show ?thesis
    by ((subst *)+, subst power_divide, subst power2_diff, simp add: field_simps, simp add: power2_eq_square)
qed

lemma complex_quadratic_equation_monic_distinct_roots:
  fixes b c :: complex
  assumes "b\<^sup>2 - 4*c \<noteq> 0"
  shows "\<exists> k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> k\<^sub>1\<^sup>2 + b*k\<^sub>1 + c = 0 \<and> k\<^sub>2\<^sup>2 + b*k\<^sub>2 + c = 0"
proof-
  let ?\<xi>1 = "(-b + ccsqrt(b\<^sup>2 - 4*c)) / 2"
  let ?\<xi>2 = "(-b - ccsqrt(b\<^sup>2 - 4*c)) / 2"
  show ?thesis
    apply (rule_tac x="?\<xi>1" in exI)
    apply (rule_tac x="?\<xi>2" in exI)
    using assms
    using complex_quadratic_equation_monic_roots[of ?\<xi>1 b c]
    using complex_quadratic_equation_monic_roots[of ?\<xi>2 b c]
    by simp
qed

lemma complex_quadratic_equation_two_roots:
  fixes \<xi> :: complex
  assumes "a \<noteq> 0" and "a*\<xi>\<^sup>2 + b * \<xi> + c = 0"
  shows "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4*a*c)) / (2*a) \<or>
         \<xi> = (-b - ccsqrt(b\<^sup>2 - 4*a*c)) / (2*a)"
proof-
  from assms have "\<xi>\<^sup>2 + (b/a) * \<xi> + (c/a) = 0"
    by (simp add: field_simps)
  hence "\<xi> = (-(b/a) + ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2 \<or> \<xi> = (-(b/a) - ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2"
    using complex_quadratic_equation_monic_only_two_roots[of \<xi> "b/a" "c/a"]
    by simp
  hence "\<exists> k. \<xi> = (-(b/a) + (-1)^k * ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2"
    by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
  then obtain k1 where "\<xi> = (-(b/a) + (-1)^k1 * ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2"
    by auto
  moreover
  have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4 * a * c) * (1 / a\<^sup>2)"
    using \<open>a \<noteq> 0\<close>
    by (simp add: field_simps power2_eq_square)
  hence "ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1/a\<^sup>2) \<or>
         ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = - ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1/a\<^sup>2)"
    using ccsqrt_mult[of "b\<^sup>2 - 4 * a * c" "1/a\<^sup>2"]
    by auto
  hence "\<exists> k.  ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = (-1)^k * ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1 / a\<^sup>2)"
    by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
  then obtain k2 where "ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = (-1)^k2 * ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1 / a\<^sup>2)"
    by auto
  moreover
  have "ccsqrt (1 / a\<^sup>2) = 1/a \<or> ccsqrt (1 / a\<^sup>2) = -1/a"
    using ccsqrt[of "1/a" "1 / a\<^sup>2"]
    by (auto simp add: power2_eq_square)
  hence "\<exists> k. ccsqrt (1 / a\<^sup>2) = (-1)^k * 1/a"
    by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
  then obtain k3 where "ccsqrt (1 / a\<^sup>2) = (-1)^k3 * 1/a"
    by auto
  ultimately
  have "\<xi> = (- (b / a) + ((-1) ^ k1 * (-1) ^ k2 * (-1) ^ k3) * ccsqrt (b\<^sup>2 - 4 * a * c) * 1/a) / 2"
    by simp
  moreover
  have "(-(1::complex)) ^ k1 * (-1) ^ k2 * (-1) ^ k3 = 1 \<or> (-(1::complex)) ^ k1 * (-1) ^ k2 * (-1) ^ k3 = -1"
    using neg_one_even_power[of "k1 + k2 + k3"]
    using neg_one_odd_power[of "k1 + k2 + k3"]
    by (smt power_add)
  ultimately
  have "\<xi> = (- (b / a) + ccsqrt (b\<^sup>2 - 4 * a * c) * 1 / a) / 2 \<or> \<xi> = (- (b / a) - ccsqrt (b\<^sup>2 - 4 * a * c) * 1 / a) / 2"
    by auto
  thus ?thesis
    using \<open>a \<noteq> 0\<close>
    by (simp add: field_simps)
qed

lemma complex_quadratic_equation_only_two_roots:
  fixes x :: complex
  assumes "a \<noteq> 0"
  assumes "qf = (\<lambda> x. a*x\<^sup>2 + b*x + c)"
          "qf x1 = 0" and "qf x2 = 0" and "x1 \<noteq> x2"
          "qf x = 0"
  shows "x = x1 \<or> x = x2"
  using assms
  using complex_quadratic_equation_two_roots
  by blast

(* ----------------------------------------------------------------- *)
subsubsection \<open>Intersections of linear and quadratic forms\<close>
(* ----------------------------------------------------------------- *)
(* These lemmas are not used *)

lemma quadratic_linear_at_most_2_intersections_help:
  fixes x y :: complex
  assumes "(a11, a12, a22) \<noteq> (0, 0, 0)" and "k2 \<noteq> 0"
          "qf = (\<lambda> x y. a11*x\<^sup>2 + 2*a12*x*y + a22*y\<^sup>2 + b1*x + b2*y + c)" and "lf = (\<lambda> x y. k1*x + k2*y + n)"
          "qf x y = 0" and "lf x y = 0"
          "pf = (\<lambda> x. (a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2)*x\<^sup>2 + (-2*a12*n/k2  + b1 + a22*2*n*k1/k2\<^sup>2 - b2*k1/k2)*x + a22*n\<^sup>2/k2\<^sup>2 - b2*n/k2 + c)"
          "yf = (\<lambda> x. (-n - k1*x) / k2)"
  shows "pf x = 0" and "y = yf x"
proof -
  show "y = yf x"
    using assms
    by (simp add:field_simps eq_neg_iff_add_eq_0)
next
  have "2*a12*x*(-n - k1*x)/k2 = (-2*a12*n/k2)*x - (2*a12*k1/k2)*x\<^sup>2"
    by algebra
  have "a22*((-n - k1*x)/k2)\<^sup>2 = a22*n\<^sup>2/k2\<^sup>2 + (a22*2*n*k1/k2\<^sup>2)*x + (a22*k1\<^sup>2/k2\<^sup>2)*x\<^sup>2"
    by (simp add: power_divide) algebra
  have "2*a12*x*(-n - k1*x)/k2 = (-2*a12*n/k2)*x - (2*a12*k1/k2)*x\<^sup>2"
    by algebra
  have "b2*(-n - k1*x)/k2 = -b2*n/k2 - (b2*k1/k2)*x"
    by algebra

  have *: "y = (-n - k1*x)/k2"
    using assms(2, 4, 6)
    by (simp add:field_simps eq_neg_iff_add_eq_0)

  have "0 = a11*x\<^sup>2 + 2*a12*x*y + a22*y\<^sup>2 + b1*x + b2*y + c"
    using assms
    by simp
  hence "0 = a11*x\<^sup>2 + 2*a12*x*(-n - k1*x)/k2 + a22*((-n - k1*x)/k2)\<^sup>2 + b1*x + b2*(-n - k1*x)/k2 + c"
    by (subst (asm) *, subst (asm) *, subst (asm) *) auto
  also have "... = (a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2)*x\<^sup>2 + (-2*a12*n/k2  + b1 + a22*2*n*k1/k2\<^sup>2 - b2*k1/k2)*x + a22*n\<^sup>2/k2\<^sup>2 -b2*n/k2 + c"
    using \<open>2*a12*x*(-n - k1*x)/k2 = (-2*a12*n/k2)*x - (2*a12*k1/k2)*x\<^sup>2\<close>
    using \<open>a22*((-n - k1*x)/k2)\<^sup>2 = a22*n\<^sup>2/k2\<^sup>2 + (a22*2*n*k1/k2\<^sup>2)*x + (a22*k1\<^sup>2/k2\<^sup>2)*x\<^sup>2\<close>
    using \<open>b2*(-n - k1*x)/k2 = -b2*n/k2 - (b2*k1/k2)*x\<close>
    by (simp add:field_simps)
  finally show "pf x = 0"
    using assms(7)
    by auto
qed

lemma quadratic_linear_at_most_2_intersections_help':
  fixes x y :: complex
  assumes "qf = (\<lambda> x y. a11*x\<^sup>2 + 2*a12*x*y + a22*y\<^sup>2 + b1*x + b2*y + c)"
          "x = -n/k1" and "k1 \<noteq> 0" and "qf x y = 0"
          "yf = (\<lambda> y. k1\<^sup>2*a22*y\<^sup>2 + (-2*a12*n*k1 + b2*k1\<^sup>2)*y + a11*n\<^sup>2 - b1*n*k1 + c*k1\<^sup>2)"
  shows "yf y = 0"
proof-
  have "0 = a11*n\<^sup>2/k1\<^sup>2 - 2*a12*n*y/k1 + a22*y\<^sup>2 - b1*n/k1 + b2*y + c"
    using assms(1, 2, 4)
    by (simp add: power_divide)
  hence "0 = a11*n\<^sup>2 - 2*a12*n*k1*y + a22*y\<^sup>2*k1\<^sup>2 - b1*n*k1 + b2*y*k1\<^sup>2 + c*k1\<^sup>2"
    using assms(3)
    apply (simp add:field_simps power2_eq_square)
    by algebra
  thus ?thesis
    using assms(1, 4, 5)
    by (simp add:field_simps)
qed

lemma quadratic_linear_at_most_2_intersections:
  fixes x y x1 y1 x2 y2 :: complex
  assumes "(a11, a12, a22) \<noteq> (0, 0, 0)" and "(k1, k2) \<noteq> (0, 0)"
  assumes "a11*k2\<^sup>2 - 2*a12*k1*k2 + a22*k1\<^sup>2 \<noteq> 0"
  assumes "qf = (\<lambda> x y. a11*x\<^sup>2 + 2*a12*x*y + a22*y\<^sup>2 + b1*x + b2*y + c)" and "lf = (\<lambda> x y. k1*x + k2*y + n)"
          "qf x1 y1 = 0" and "lf x1 y1 = 0"
          "qf x2 y2 = 0" and "lf x2 y2 = 0"
          "(x1, y1) \<noteq> (x2, y2)"
          "qf x y = 0" and "lf x y = 0"
  shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
proof(cases "k2 = 0")
  case True
  hence "k1 \<noteq> 0"
    using assms(2)
    by simp

  have "a22*k1\<^sup>2 \<noteq> 0"
    using assms(3) True
    by auto

  have "x1 = -n/k1"
    using \<open>k1 \<noteq> 0\<close> assms(5, 7) True
    by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)
  have "x2 = -n/k1"
    using \<open>k1 \<noteq> 0\<close> assms(5, 9) True
    by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)
  have "x = -n/k1"
    using \<open>k1 \<noteq> 0\<close> assms(5, 12) True
    by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)

  let ?yf =  "(\<lambda> y. k1\<^sup>2*a22*y\<^sup>2 + (-2*a12*n*k1 + b2*k1\<^sup>2)*y + a11*n\<^sup>2 - b1*n*k1 + c*k1\<^sup>2)"

  have "?yf y = 0"
    using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x n k1 y ?yf]
    using assms(4, 11) \<open>k1 \<noteq> 0\<close> \<open>x = -n/k1\<close>
    by auto
  have "?yf y1 = 0"
    using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x1 n k1 y1 ?yf]
    using assms(4, 6) \<open>k1 \<noteq> 0\<close> \<open>x1 = -n/k1\<close>
    by auto
  have "?yf y2 = 0"
    using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x2 n k1 y2 ?yf]
    using assms(4, 8) \<open>k1 \<noteq> 0\<close> \<open>x2 = -n/k1\<close>
    by auto

  have "y1 \<noteq> y2"
    using assms(10) \<open>x1 = -n/k1\<close> \<open>x2 = -n/k1\<close>
    by blast

  have "y = y1 \<or> y = y2"
    using complex_quadratic_equation_only_two_roots[of "a22*k1\<^sup>2" ?yf "-2*a12*n*k1 + b2*k1\<^sup>2" "a11*n\<^sup>2 - b1*n*k1 + c*k1\<^sup>2"
                                                        y1 y2 y]
    using \<open>a22*k1\<^sup>2 \<noteq> 0\<close> \<open>?yf y1 = 0\<close> \<open>y1 \<noteq> y2\<close> \<open>?yf y2 = 0\<close> \<open>?yf y = 0\<close>
    by fastforce

  thus ?thesis
    using \<open>x1 = -n/k1\<close> \<open>x2 = -n/k1\<close>  \<open>x = -n/k1\<close>
    by auto
next
  case False

  let ?py = "(\<lambda> x. (-n - k1*x)/k2)"
  let ?pf = "(\<lambda> x. (a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2)*x\<^sup>2 + (-2*a12*n/k2  + b1 + a22*2*n*k1/k2\<^sup>2 - b2*k1/k2)*x + a22*n\<^sup>2/k2\<^sup>2 -b2*n/k2 + c)"
  have "?pf x1 = 0" "y1 = ?py x1"
    using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x1 y1]
    using assms(1, 4, 5, 6, 7) False
    by auto
  have "?pf x2 = 0" "y2 = ?py x2"
    using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x2 y2]
    using assms(1, 4, 5, 8, 9) False
    by auto
  have "?pf x = 0" "y = ?py x"
    using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x y]
    using assms(1, 4, 5, 11, 12) False
    by auto

  have "x1 \<noteq> x2"
    using assms(10) \<open>y1 = ?py x1\<close> \<open>y2 = ?py x2\<close>
    by auto

  have "a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2 = (a11 * k2\<^sup>2 - 2 * a12 * k1 * k2 + a22 * k1\<^sup>2)/k2\<^sup>2"
    by (simp add: False power2_eq_square add_divide_distrib diff_divide_distrib)
  also have "...  \<noteq> 0"
    using False assms(3)
    by simp
  finally have "a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2 \<noteq> 0"
    .

  have "x = x1 \<or> x = x2"
    using complex_quadratic_equation_only_two_roots[of "a11 - 2*a12*k1/k2 + a22*k1\<^sup>2/k2\<^sup>2" ?pf
                                                       "(- 2 * a12 * n / k2 + b1 + a22 * 2 * n * k1 / k2\<^sup>2 - b2 * k1 / k2)"
                                                       "a22 * n\<^sup>2 / k2\<^sup>2 - b2 * n / k2 + c" x1 x2 x]
    using \<open>?pf x2 = 0\<close> \<open>?pf x1 = 0\<close> \<open>?pf x = 0\<close>
    using \<open>a11 - 2 * a12 * k1 / k2 + a22 * k1\<^sup>2 / k2\<^sup>2 \<noteq> 0\<close>
    using \<open>x1 \<noteq> x2\<close>
    by fastforce

  thus ?thesis
    using \<open>y = ?py x\<close> \<open>y1 = ?py x1\<close> \<open>y2 = ?py x2\<close>
    by (cases "x = x1", auto)
qed

lemma quadratic_quadratic_at_most_2_intersections':
  fixes x y x1 y1 x2 y2 :: complex
  assumes "b2 \<noteq> B2 \<or> b1 \<noteq> B1"
          "(b2 - B2)\<^sup>2 + (b1 - B1)\<^sup>2 \<noteq> 0"
  assumes "qf1 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + b1*x + b2*y + c)"
          "qf2 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + B1*x + B2*y + C)"
          "qf1 x1 y1 = 0" "qf2 x1 y1 = 0"
          "qf1 x2 y2 = 0" "qf2 x2 y2 = 0"
          "(x1, y1) \<noteq> (x2, y2)"
          "qf1 x y = 0" "qf2 x y = 0"
  shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
proof-
  have "x\<^sup>2 + y\<^sup>2 + b1*x + b2*y + c = 0"
    using assms by auto
  have "x\<^sup>2 + y\<^sup>2 + B1*x + B2*y + C = 0"
    using assms by auto
  hence "0 = x\<^sup>2 + y\<^sup>2 + b1*x + b2*y + c - (x\<^sup>2 + y\<^sup>2 + B1*x + B2*y + C)"
    using \<open>x\<^sup>2 + y\<^sup>2 + b1*x + b2*y + c = 0\<close>
    by auto
  hence "0 = (b1 - B1)*x + (b2 - B2)*y + c - C"
    by (simp  add:field_simps)

  have "x1\<^sup>2 + y1\<^sup>2 + b1*x1 + b2*y1 + c = 0"
    using assms  by auto
  have "x1\<^sup>2 + y1\<^sup>2 + B1*x1 + B2*y1 + C = 0"
    using assms by auto
  hence "0 = x1\<^sup>2 + y1\<^sup>2 + b1*x1 + b2*y1 + c - (x1\<^sup>2 + y1\<^sup>2 + B1*x1 + B2*y1 + C)"
    using \<open>x1\<^sup>2 + y1\<^sup>2 + b1*x1 + b2*y1 + c = 0\<close>
    by auto
  hence "0 = (b1 - B1)*x1 + (b2 - B2)*y1 + c - C"
    by (simp  add:field_simps)

  have "x2\<^sup>2 + y2\<^sup>2 + b1*x2 + b2*y2 + c = 0"
    using assms  by auto
  have "x2\<^sup>2 + y2\<^sup>2 + B1*x2 + B2*y2 + C = 0"
    using assms  by auto
  hence "0 = x2\<^sup>2 + y2\<^sup>2 + b1*x2 + b2*y2 + c - (x2\<^sup>2 + y2\<^sup>2 + B1*x2 + B2*y2 + C)"
    using \<open>x2\<^sup>2 + y2\<^sup>2 + b1*x2 + b2*y2 + c = 0\<close>
    by auto
  hence "0 = (b1 - B1)*x2 + (b2 - B2)*y2 + c - C"
    by (simp  add:field_simps)

  have "(b1 - B1, b2 - B2) \<noteq> (0, 0)"
    using assms(1) by auto

  let ?lf = "(\<lambda> x y. (b1 - B1)*x + (b2 - B2)*y + c - C)"

  have "?lf x y = 0" "?lf x1 y1 = 0" "?lf x2 y2 = 0"
    using \<open>0 = (b1 - B1)*x2 + (b2 - B2)*y2 + c - C\<close>
          \<open>0 = (b1 - B1)*x1 + (b2 - B2)*y1 + c - C\<close>
          \<open>0 = (b1 - B1)*x + (b2 - B2)*y + c - C\<close>
    by auto

  thus ?thesis
    using quadratic_linear_at_most_2_intersections[of 1 0 1 "b1 - B1" "b2 - B2" qf1 b1 b2 c ?lf "c - C" x1 y1 x2 y2 x y]
    using \<open>(b1 - B1, b2 - B2) \<noteq> (0, 0)\<close>
    using assms \<open>(b1 - B1, b2 - B2) \<noteq> (0, 0)\<close>
    using \<open>(b1 - B1) * x + (b2 - B2) * y + c - C = 0\<close> \<open>(b1 - B1) * x1 + (b2 - B2) * y1 + c - C = 0\<close>
    by (simp add: add_diff_eq)
qed

lemma quadratic_change_coefficients:
  fixes x y :: complex
  assumes "A1 \<noteq> 0"
  assumes "qf = (\<lambda> x y. A1*x\<^sup>2 + A1*y\<^sup>2 + b1*x + b2*y + c)"
          "qf x y = 0"
          "qf_1 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (b1/A1)*x + (b2/A1)*y + c/A1)"
  shows "qf_1 x y = 0"
proof-
  have "0 = A1*x\<^sup>2 + A1*y\<^sup>2 + b1*x + b2*y + c"
    using assms by auto
  hence "0/A1 = (A1*x\<^sup>2 + A1*y\<^sup>2 + b1*x + b2*y + c)/A1"
    using assms(1) by auto
  also have "... = A1*x\<^sup>2/A1 + A1*y\<^sup>2/A1 + b1*x/A1 + b2*y/A1 + c/A1"
    by (simp add: add_divide_distrib)
  also have "... = x\<^sup>2 + y\<^sup>2 + (b1/A1)*x + (b2/A1)*y + c/A1"
    using assms(1)
    by (simp add:field_simps)
  finally have "0 = x\<^sup>2 + y\<^sup>2 + (b1/A1)*x + (b2/A1)*y + c/A1"
    by simp
  thus ?thesis
    using assms
    by simp
qed

lemma quadratic_quadratic_at_most_2_intersections:
  fixes x y x1 y1 x2 y2 :: complex
  assumes "A1 \<noteq> 0" and "A2 \<noteq> 0"
  assumes "qf1 = (\<lambda> x y. A1*x\<^sup>2 + A1*y\<^sup>2 + b1*x + b2*y + c)" and
          "qf2 = (\<lambda> x y. A2*x\<^sup>2 + A2*y\<^sup>2 + B1*x + B2*y + C)" and
          "qf1 x1 y1 = 0" and "qf2 x1 y1 = 0" and
          "qf1 x2 y2 = 0" and "qf2 x2 y2 = 0" and
          "(x1, y1) \<noteq> (x2, y2)" and
          "qf1 x y = 0" and "qf2 x y = 0"
  assumes "(b2*A2 - B2*A1)\<^sup>2 + (b1*A2 - B1*A1)\<^sup>2 \<noteq> 0" and
          "b2*A2 \<noteq> B2*A1 \<or> b1*A2 \<noteq> B1*A1"
  shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
proof-
  have *: "b2 / A1 \<noteq> B2 / A2 \<or> b1 / A1 \<noteq> B1 / A2"
    using assms(1, 2) assms(13)
    by (simp add:field_simps)
  have **: "(b2 / A1 - B2 / A2)\<^sup>2 + (b1 / A1 - B1 / A2)\<^sup>2 \<noteq> 0"
    using assms(1, 2) assms(12)
    by (simp add:field_simps)

  let ?qf_1 = "(\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (b1/A1)*x + (b2/A1)*y + c/A1)"
  let ?qf_2 = "(\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (B1/A2)*x + (B2/A2)*y + C/A2)"

  have "?qf_1 x1 y1 = 0" "?qf_1 x2 y2 = 0" "?qf_1 x y = 0"
       "?qf_2 x1 y1 = 0" "?qf_2 x2 y2 = 0" "?qf_2 x y = 0"
    using assms quadratic_change_coefficients[of A1 qf1 b1 b2 c x2 y2 ?qf_1]
          quadratic_change_coefficients[of A1 qf1 b1 b2 c x1 y1 ?qf_1]
          quadratic_change_coefficients[of A2 qf2 B1 B2 C x1 y1 ?qf_2]
          quadratic_change_coefficients[of A2 qf2 B1 B2 C x2 y2 ?qf_2]
          quadratic_change_coefficients[of A1 qf1 b1 b2 c x y ?qf_1]
          quadratic_change_coefficients[of A2 qf2 B1 B2 C x y ?qf_2]
    by auto

  thus ?thesis
    using quadratic_quadratic_at_most_2_intersections'
              [of "b2 / A1" "B2 / A2" "b1 / A1" "B1 / A2" ?qf_1 "c / A1" ?qf_2 "C / A2" x1 y1 x2 y2 x y]
    using * ** \<open>(x1, y1) \<noteq> (x2, y2)\<close>
    by fastforce
qed

end