theory Practical
imports Main
begin

section \<open>Part 1\<close>

(* 1 mark *)
lemma disjunction_idempotence:
  "A \<or> A \<longleftrightarrow> A"
  apply (rule iffI)
  apply (erule disjE)
  apply assumption+
  apply (rule disjI1)
  apply assumption
  done

(* 1 mark *)
lemma conjunction_idempotence:
  "A \<and> A \<longleftrightarrow> A"
  apply (rule iffI)
  apply (erule conjE)
  apply assumption
  apply (rule conjI)
  apply assumption+
  done

(* 1 mark *)
lemma disjunction_to_conditional:
  "(\<not> P \<or> R) \<longrightarrow> (P \<longrightarrow> R)"
  apply (rule impI)+
  apply (erule disjE)
  apply (erule notE)
  apply assumption+
  done

(* 1 mark *)
lemma
  "(\<exists>x. P x \<and> Q x) \<longrightarrow> (\<exists>x. P x) \<and> (\<exists>x. Q x)"
  apply (rule impI)
  apply (erule exE)
  apply (erule conjE)
  apply (rule conjI)
  apply (erule exI)+
  done

(* 1 mark *)
lemma
  "(\<not> (\<exists>x. \<not>P x) \<or> R) \<longrightarrow> ((\<exists>x. \<not> P x) \<longrightarrow> R)"
  apply (rule impI)+
  apply (erule disjE)
  apply (erule notE)
  apply assumption+
  done

(* 2 marks *)
lemma
  "(\<forall>x. P x) \<longrightarrow> \<not> (\<exists>x. \<not> P x)"
  apply (rule impI)

  apply (rule notI)
  apply (erule exE)
  apply (erule notE)
  apply (erule allE)
  apply assumption
  done

(* 3 marks *)
text \<open>Prove using ccontr\<close>
lemma excluded_middle:
  "P \<or> \<not> P"
  apply (rule ccontr)
  apply (rule ccontr)
  apply (rule_tac P = "P \<or> \<not> P" in notE)
  apply assumption
  apply (rule disjI1)
  apply (rule ccontr)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

(* 3 marks *)
text \<open>Prove using excluded middle\<close>
lemma notnotD:
  "\<not>\<not> P \<Longrightarrow> P"
  apply (cut_tac P = "P" in  excluded_middle)
  apply (erule disjE)
  apply assumption
  apply (erule notE)
  apply assumption
  done

(* 3 marks *)
text \<open>Prove using double-negation (rule notnotD)\<close>
lemma classical:
  "(\<not> P \<Longrightarrow> P) \<Longrightarrow> P"
  apply (drule impI)
  apply (rule notnotD)
  apply (rule notI)
  apply (erule impE)
  apply assumption
  apply (erule notE)
  apply assumption
  done

(* 3 marks *)
text \<open>Prove using classical\<close>
lemma ccontr:
  "(\<not> P \<Longrightarrow> False) \<Longrightarrow> P"
  apply (drule impI)
  apply (rule classical)
  apply (erule impE)
  apply assumption
  apply (rule_tac P = "\<not> P" in notE)
  apply (rule notI)
  apply assumption+
  done

(* 3 marks *)
lemma
  "(\<not> (\<forall>x. P x \<or> R x)) = (\<exists>x. \<not> P x \<and> \<not> R x)"
  apply (rule iffI)

  apply (rule classical)
  apply (erule notE)
  apply (rule allI)
  apply (rule classical)
  apply (erule notE)
  apply (rule exI)

  apply(rule conjI)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI1)
  apply assumption
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption

  apply (erule exE)
  apply (rule notI)
  apply (erule allE)
  apply (erule disjE)
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  apply (erule conjE)
  apply (erule notE)
  apply (erule notE)
  apply assumption
  done

(* 3 marks *)
lemma
  "(\<exists>x. P x \<or> R x) = (\<not>((\<forall>x. \<not> P x) \<and> \<not> (\<exists>x. R x)))"
  apply (rule iffI)

  apply (erule exE)
  apply (rule notI)
  apply (erule conjE)
  apply (erule allE)
  apply (erule disjE)
  apply (erule notE)
  apply (erule notE)
  apply assumption
  apply (erule notE)
  apply (rule exI)
  apply assumption

  apply (rule classical)
  apply (erule notE)
  apply (rule conjI)
  apply (rule allI)
  apply (rule notI)
  apply (erule notE)
  apply (rule exI)
  apply (rule disjI1)
  apply assumption
  apply (rule notI)
  apply (erule exE)
  apply (erule notE)
  apply (rule exI)
  apply (rule disjI2)
  apply assumption
  done

section \<open>Part 2.1\<close>

locale partof =
  fixes partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
begin

(* 1 mark *)
definition properpartof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubset>" 100) where
  "x \<sqsubset> y \<equiv>  x \<sqsubseteq> y \<and> x \<noteq> y "

(* 1 mark *)
definition overlaps :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<frown>" 100) where
  "x \<frown> y \<equiv> \<exists>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y"

definition disjoint :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<asymp>" 100) where
  "x \<asymp> y \<equiv> \<not> x \<frown> y"

(* 1 mark *)
definition partialoverlap :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "~\<frown>" 100) where
  "x ~\<frown> y \<equiv> x \<frown> y \<and> \<not>x \<sqsubseteq> y \<and> \<not>y \<sqsubseteq> x"

(* 1 mark *)
definition sumregions :: "'region set \<Rightarrow> 'region \<Rightarrow> bool" ("\<Squnion> _ _" [100, 100] 100) where
  "\<Squnion> \<alpha> x \<equiv> (\<forall>y \<in> \<alpha>. y \<sqsubseteq> x) \<and> (\<forall>y. y \<sqsubseteq> x \<longrightarrow> (\<exists>z \<in> \<alpha>. y \<frown> z))"

end

(* 1+1+1=3 marks *)
locale mereology = partof +
  assumes A1: "\<forall>x y z. x\<sqsubseteq>y \<and> y\<sqsubseteq>z \<longrightarrow> x\<sqsubseteq>z"
      and A2: "\<forall>\<alpha>. \<alpha> \<noteq>  {} \<longrightarrow> (\<exists>x. \<Squnion> \<alpha> x)"
      and A2': "\<forall>\<alpha> x y. \<Squnion> \<alpha> x \<and>  \<Squnion>\<alpha> y \<longrightarrow> (x = y)"
begin

section \<open>Part 2.2\<close>

(* 2 marks *)
theorem overlaps_sym:
  "(x \<frown> y) = (y \<frown> x)"
   apply (unfold overlaps_def)
   apply (rule iffI)

   apply (erule exE)+
   apply (erule conjE)+
   apply (rule exI)+
   apply (rule conjI)+
   apply assumption+

   apply (erule exE)+
   apply (erule conjE)+
   apply (rule exI)+
   apply (rule conjI)+
   apply assumption+

  done

(* 1 mark *)
theorem in_sum_set_partof:
  "\<forall>x. x \<in> \<alpha> \<and>  \<Squnion> \<alpha> y \<longrightarrow>  x \<sqsubseteq> y"
proof-
  show "\<forall>x. x \<in> \<alpha> \<and>  \<Squnion> \<alpha> y \<longrightarrow>  x \<sqsubseteq> y" by (simp add: partof.sumregions_def)
qed

(* 3 marks *)
theorem overlaps_refl:
  "x \<frown> x"
proof-
  have "\<exists>z. \<Squnion> {x} z"
  using A2  by auto
  then obtain z where "\<Squnion> {x} z" by blast
  then show "x \<frown> x"
  using sumregions_def by auto
qed

(* 1 mark *)
theorem all_has_partof:
    "\<forall>x.\<exists>y. y \<sqsubseteq> x"
proof-
  show "\<forall>x.\<exists>y. y \<sqsubseteq> x" using overlaps_def overlaps_refl by auto
qed

(* 2 marks *)
theorem partof_overlaps:
  assumes "x \<sqsubseteq> y"
  shows "x \<frown> y"
proof-
  obtain p where "p \<sqsubseteq> x \<and> p \<sqsubseteq> y"
  using A1 all_has_partof assms by blast
  then show "x \<frown> y"
    using overlaps_def by blast
qed

(* 1 mark *)
theorem sum_parts_eq:
  "\<Squnion> {a. a \<sqsubseteq> x} x"
proof -
   show "\<Squnion> {a. a \<sqsubseteq> x} x" using overlaps_refl sumregions_def by auto
qed

(* 2 marks *)
theorem sum_relation_is_same':
  assumes "\<And>c. r y c \<Longrightarrow> c \<sqsubseteq> y"
      and "\<And>f. y \<frown> f \<Longrightarrow> \<exists>g. r y g \<and> g \<frown> f"
      and "\<Squnion> {y} x"
    shows "\<Squnion> {k. r y k} x"
proof-
  have "\<And>k. r y k \<Longrightarrow> k \<sqsubseteq> y"  by (simp add: assms(1))
  then have "y \<sqsubseteq> x" using assms(3) in_sum_set_partof  by blast
  then have a: "\<forall>k. r y k \<longrightarrow> k \<sqsubseteq> x" using A1 assms(1) by blast
  then have b: "\<forall>q. q \<sqsubseteq> x \<longrightarrow> (\<exists>z \<in> {k. r y k}. q \<frown> z)"
  using assms(2) assms(3) overlaps_sym sumregions_def by auto
  from a and b show "\<Squnion> {k. r y k} x"
  using sumregions_def by auto
qed

(* 1 mark *)
theorem overlap_has_partof_overlap:
  assumes a: "e \<frown> f"
  shows "\<exists>g. g \<sqsubseteq> e \<and> g \<frown> f"
proof-
  from a have b :  "\<exists>g. g \<sqsubseteq> e \<and> g \<sqsubseteq> f" using overlaps_def by blast
  from b show "\<exists>g. g \<sqsubseteq> e \<and> g \<frown> f"   using partof_overlaps by blast
qed

(* 1 marks *)
theorem sum_parts_of_one_eq:
  assumes "\<Squnion> {y} x"
  shows "\<Squnion> {k. k\<sqsubseteq>y} x"
proof-
  note sum_relation_is_same' [where r = "\<lambda>y k. k \<sqsubseteq> y"]
  show ?thesis
    using assms sum_relation_is_same' overlap_has_partof_overlap by fastforce
qed

(* 5 marks *)
theorem both_partof_eq:
  assumes "x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  shows "x = y"
proof-
  have "\<Squnion> {k. k \<sqsubseteq> x} y"
  proof (rule ccontr)
    assume "\<not> \<Squnion> {k. k \<sqsubseteq> x} y"
    then have " (\<exists>p. p \<sqsubseteq> x \<and> \<not>(p \<sqsubseteq> y)) \<or> (\<exists>w. w \<sqsubseteq> y \<and> (\<forall>p. p \<sqsubseteq> x \<longrightarrow> w \<asymp> p))"
      using assms partof_overlaps sumregions_def by auto
     then show "False"
    proof
      assume a1: " (\<exists>p. p \<sqsubseteq> x \<and> \<not>(p \<sqsubseteq> y))"
      then  show "False"
      using A1 assms by blast
    next
      assume a: "\<exists>w. w \<sqsubseteq> y \<and> (\<forall>p. p \<sqsubseteq> x \<longrightarrow> w \<asymp> p)"
      obtain w where b : "w \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<longrightarrow> w \<asymp> z)"
        using a by auto
       have c:" y \<sqsubseteq> x "
         by (simp add: assms)
       then have " y \<asymp> w"
         using b disjoint_def partof_overlaps by blast
      then show "False"
        by (simp add: b disjoint_def overlaps_sym partof_overlaps)
    qed
  qed
  then show  "x = y"
    using A2' sum_parts_eq by blast
qed

(* 4 marks *)
theorem sum_all_with_parts_overlapping:
  assumes "\<Squnion> {z. \<forall>a. a \<sqsubseteq> z \<longrightarrow> a \<frown> y} x"
  shows "\<Squnion> {y} x"
proof-
  show  "\<Squnion> {y} x"
  proof (rule ccontr)
   assume "\<not> \<Squnion> {y} x"
   then have "\<not>(y \<sqsubseteq> x) \<or> (\<exists>w. w \<sqsubseteq> x \<and> w \<asymp> y) "
   by (simp add: disjoint_def partof.sumregions_def)
   then show "False"
   proof
     assume a: "\<not>(y \<sqsubseteq> x)"
     then have b: " y \<in> {k .k\<frown>y} "
       by (simp add: overlaps_refl)
     have "y \<sqsubseteq> x"
       using assms partof_overlaps sumregions_def by auto
     then show "False"
       using a by blast
   next
     assume a: "\<exists>w. w \<sqsubseteq> x \<and> w \<asymp> y"
     obtain w where b:"w \<sqsubseteq> x \<and> w \<asymp> y"
       using a by blast
     obtain a where c: "a \<in> {z. \<forall>p. p \<sqsubseteq> z \<longrightarrow> p\<frown>y} \<and> w \<frown> a"
       using assms b sumregions_def by auto
     obtain wz where d :"wz \<sqsubseteq> w \<and> wz \<sqsubseteq> a"
       using c overlaps_def by auto
     have 0 : "wz \<frown> y"
       using c d by blast
     obtain wzy where 1:"wzy \<sqsubseteq> wz \<and> wzy \<sqsubseteq> y"
       using "0" overlaps_def by blast
     have "wzy \<sqsubseteq> w"
       using "1" A1 d by blast
     then have "w \<frown> y"
       using "0" A1 d overlaps_def by blast
      then show "False"
        using b disjoint_def by blast
    qed
  qed
qed

(* 2 marks *)
theorem sum_one_is_self:
  "\<Squnion> {x} x"
proof-
  obtain y where a: "\<Squnion> {x} y "
    using A2 by blast
  then have b: "\<Squnion> {a. a \<sqsubseteq> x} y"
    using sum_parts_of_one_eq by blast
  have c : "\<Squnion> {a. a \<sqsubseteq> x} x"
    by (simp add: sum_parts_eq)
  from b and c have "x = y"
    using A2' by blast
  then show ?thesis
    using a by blast
qed

(* 2 marks *)
theorem sum_all_with_parts_overlapping_self:
  "\<Squnion> {z. \<forall>a. a \<sqsubseteq> z \<longrightarrow> a \<frown> x} x"
proof-
  have "{z. \<forall>a. a \<sqsubseteq> z \<longrightarrow> a \<frown> x} \<noteq> {}" using partof_overlaps by force
  then have "\<exists>y. \<Squnion> {z. \<forall>a. a \<sqsubseteq> z \<longrightarrow> a \<frown> x} y"
    by (simp add: A2)
  then obtain y where a:"\<Squnion> {z. \<forall>a. a \<sqsubseteq> z \<longrightarrow> a \<frown> x} y"
    by blast
  then have b: "x = y"
    using A2' sum_all_with_parts_overlapping sum_one_is_self by blast
  then show ?thesis
  proof -
    show ?thesis
      using a b by blast
  qed
qed
(* 4 marks *)
theorem proper_have_nonoverlapping_proper:
  assumes "s \<sqsubset> r "
  shows "\<exists>a. a \<sqsubset> r \<and> a \<asymp> s"
proof(rule ccontr)
  assume 0 :"\<nexists>a. a \<sqsubset>r \<and> a \<asymp> s"
  then show "False"
  proof-
    have "\<forall>a. a \<sqsubset> r \<longrightarrow> a \<frown> s"
      using 0 disjoint_def by blast
    then have 1: "\<forall>a. a \<sqsubseteq> r \<longrightarrow> a \<frown> s"
      using assms overlaps_sym partof_overlaps properpartof_def by blast
    have "\<Squnion> {r. \<forall>a. a \<sqsubseteq> r \<longrightarrow> a \<frown> s} s"
      using sum_all_with_parts_overlapping_self by blast
    then have 2 :"r \<sqsubseteq> s"
      by (simp add: "1" partof.sumregions_def)
    have 3: "s \<sqsubseteq> r"
      using assms properpartof_def by blast
    from 2 and 3 have "s = r"
      by (simp add: both_partof_eq)
    then show "False"
      using assms properpartof_def by blast
  qed
qed

(* 1 mark *)
sublocale parthood_partial_order: order "(\<sqsubseteq>)" "(\<sqsubset>)"
proof
  show "\<And>x y. x \<sqsubset> y = (x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x)"
    using both_partof_eq properpartof_def by auto
next
  show "\<And>x. x \<sqsubseteq> x"
    using in_sum_set_partof sum_one_is_self by auto
next
  show "\<And>x y z. \<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
    using A1 by blast
next
  show "\<And>x y. \<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x\<rbrakk> \<Longrightarrow> x = y"
    by (simp add: both_partof_eq)
qed

end

section \<open>Part 2.3\<close>

locale sphere =
  fixes sphere :: "'a \<Rightarrow> bool"
begin

abbreviation AllSpheres :: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<forall>\<degree>" 10) where
  "\<forall>\<degree>x. P x \<equiv> \<forall>x. sphere x \<longrightarrow> P x"

abbreviation ExSpheres :: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<exists>\<degree>" 10) where
  "\<exists>\<degree>x. P x \<equiv> \<exists>x. sphere x \<and> P x"

end

locale mereology_sphere = mereology partof + sphere sphere
  for partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
  and sphere :: "'region \<Rightarrow> bool"
begin

definition exttan :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "exttan a b \<equiv> sphere a \<and> sphere b \<and> a \<asymp> b \<and> (\<forall>\<degree>x y. a \<sqsubseteq> x \<and> a \<sqsubseteq> y \<and> b \<asymp> x \<and> b \<asymp> y
                                                        \<longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x)"

definition inttan :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "inttan a b \<equiv> sphere a \<and> sphere b \<and> a \<sqsubset> b \<and> (\<forall>\<degree>x y. a \<sqsubseteq> x \<and> a \<sqsubseteq> y \<and> x \<sqsubseteq> b \<and> y \<sqsubseteq> b
                                                        \<longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x)"

definition extdiam :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "extdiam a b c \<equiv> exttan a c \<and> exttan b c
                 \<and> (\<forall>\<degree>x y. x \<asymp> c \<and> y \<asymp> c \<and> a \<sqsubseteq> x \<and> b \<sqsubseteq> y \<longrightarrow> x \<asymp> y)"

definition intdiam :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "intdiam a b c \<equiv> inttan a c \<and> inttan b c
                 \<and> (\<forall>\<degree>x y. x \<asymp> c \<and> y \<asymp> c \<and> exttan a x \<and> exttan b y \<longrightarrow> x \<asymp> y)"

abbreviation properconcentric :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "properconcentric a b \<equiv> a \<sqsubset> b
                        \<and> (\<forall>\<degree>x y. extdiam x y a \<and> inttan x b \<and> inttan y b \<longrightarrow> intdiam x y b)"

definition concentric :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<odot>" 100) where
  "a \<odot> b \<equiv> sphere a \<and> sphere b \<and> (a = b \<or> properconcentric a b \<or> properconcentric b a)"

definition onboundary :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "onboundary s r \<equiv> sphere s \<and> (\<forall>s'. s' \<odot> s \<longrightarrow> s' \<frown> r \<and> \<not> s' \<sqsubseteq> r)"

definition equidistant3 :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "equidistant3 x y z \<equiv> \<exists>\<degree>z'. z' \<odot> z \<and> onboundary y z' \<and> onboundary x z'"

definition betw :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("[_ _ _]" [100, 100, 100] 100) where
  "[x y z] \<equiv> sphere x \<and> sphere z
             \<and> (x \<odot> y \<or> y \<odot> z
                \<or> (\<exists>x' y' z' v w. x' \<odot> x \<and> y' \<odot> y \<and> z' \<odot> z
                                  \<and> extdiam x' y' v \<and> extdiam v w y' \<and> extdiam y' z' w))"

definition mid :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "mid x y z \<equiv> [x y z] \<and> (\<exists>\<degree>y'. y' \<odot> y \<and> onboundary x y' \<and> onboundary z y')"

definition equidistant4 :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100) where
  "x y \<doteq> z w \<equiv> \<exists>\<degree>u v. mid w u y \<and> mid x u v \<and> equidistant3 v z y"

definition oninterior :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "oninterior s r \<equiv> \<exists>s'. s' \<odot> s \<and> s' \<sqsubseteq> r"

definition nearer :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "nearer w x y z \<equiv> \<exists>\<degree>x'. [w x x'] \<and> \<not> x \<odot> x' \<and> w x' \<doteq> y z"

end

locale partial_region_geometry = mereology_sphere partof sphere
  for partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
  and sphere :: "'region \<Rightarrow> bool" +
  assumes A4: "\<lbrakk>x \<odot> y; y \<odot> z\<rbrakk> \<Longrightarrow> x \<odot> z"
      and A5: "\<lbrakk>x y \<doteq> z w; x' \<odot> x\<rbrakk> \<Longrightarrow> x' y \<doteq> z w"
      and A6: "\<lbrakk>sphere x; sphere y; \<not> x \<odot> y\<rbrakk>
               \<Longrightarrow> \<exists>\<degree>s. \<forall>\<degree>z. oninterior z s = nearer x z x y"
      and A7: "sphere x \<Longrightarrow> \<exists>\<degree>y. \<not> x \<odot> y \<and> (\<forall>\<degree>z. oninterior z x = nearer x z x y)"
      and A8: "x \<sqsubseteq> y = (\<forall>s. oninterior s x \<longrightarrow> oninterior s y)"
      and A9: "\<exists>\<degree>s. s \<sqsubseteq> r"
begin

(* 2 marks *)
thm equiv_def
theorem conc_equiv:
  "equiv {A. sphere A} {(x,y). x \<odot> y}"
proof-
  have "\<forall>x\<in>{A. sphere A}. x \<odot> x"
    using concentric_def by auto
  then have a:"refl_on {A. sphere A}{(x,y). x \<odot> y}"
    by (simp add: concentric_def refl_on_def')
  have "\<forall> y\<in>{A. sphere A}. x \<odot> y \<longrightarrow> y \<odot> x "
    using concentric_def by auto
  have b: "sym {(x,y). x \<odot> y}"
    using concentric_def sym_def by fastforce
  have "\<forall> z\<in>{A. sphere A}. (x \<odot> y \<and> y \<odot> z) \<longrightarrow> x \<odot> z"
    using A4 by blast
  have c:"trans {(x,y). x \<odot> y}"
    using concentric_def Relation.transp_trans A4 transp_def by blast
  from a and b and c show ?thesis
    using equiv_def by blast
qed

(* 6 marks *)
theorem region_is_spherical_sum:
  "\<Squnion> {A. sphere A \<and> A \<sqsubseteq> x} x"
proof-
    have a: "\<exists>a. \<Squnion>{A. sphere A \<and> A \<sqsubseteq> x} a" using A2 A9 by simp
    then obtain a where a: "\<Squnion>{A. sphere A \<and> A \<sqsubseteq> x} a" by blast
    show ?thesis
proof (rule ccontr)
  assume b: "\<not>\<Squnion> {A. sphere A \<and> A \<sqsubseteq> x} x "
  show "False"
  proof-
   have c: "(\<forall>s. oninterior s x \<longrightarrow> oninterior s a)"
     using a concentric_def oninterior_def sumregions_def by auto
    then have d: "\<forall>s.(oninterior s a \<longleftrightarrow> oninterior s x)"
      using A8 a b sumregions_def by auto
    then have e:" \<forall>s.(oninterior s a \<longrightarrow> oninterior s x)"
      by simp

    then have 0: "x \<sqsubseteq> a"
      using A8 c by blast
    then have 1:"a \<sqsubseteq> x"
      using A8 d by blast
    from 0 and 1 have "a = x"
      by auto
    then show ?thesis
      using a b by blast
  qed
 qed
qed

(* 1 mark *)
theorem region_spherical_interior:
  " sphere s \<and> oninterior s r \<longleftrightarrow> (\<exists>s'. sphere s' \<and> s' \<sqsubseteq> r \<and> oninterior s s')"
proof-
  have "sphere s \<and>oninterior s r \<longleftrightarrow> (\<exists>a. a \<sqsubseteq> r \<and> oninterior s a)"
    using concentric_def oninterior_def by auto
  then obtain a where "\<exists>s. sphere s \<and> oninterior s r \<longleftrightarrow> (a \<sqsubseteq> r \<and> oninterior s a)"
    by auto
  then have "\<exists>\<degree>s'. s' \<sqsubseteq> a"
    by (simp add: A9)
  show ?thesis
    using concentric_def oninterior_def by auto
qed

(* 2 marks *)
(*as we assume x and y have equal interiors, so according to A8, we could get x is part of y
  and y is part of x, so use both_partof_eq leamma, we could know x=y. *)
theorem equal_interiors_equal_regions:
  assumes "\<forall>s. oninterior s x = oninterior s y "
  shows "x = y"
proof-
  show ?thesis
    by (simp add: A8 assms both_partof_eq)
qed

(* 2 marks *)
theorem proper_have_nonoverlapping_proper_sphere:
  assumes "s \<sqsubset> r"
  shows "\<exists>\<degree>a. a \<sqsubset> r \<and> a \<asymp> s"
proof-
  have "\<exists>k.  k \<sqsubset> r \<and> k \<asymp> s"
    using assms proper_have_nonoverlapping_proper by blast
  then obtain k where 0:" k \<sqsubset> r \<and> k \<asymp> s" by blast
  then have 1: "\<exists>\<degree>a. a \<sqsubseteq> k"
    by (simp add: A9)
  then obtain a where "a \<sqsubseteq> k"
    by blast
  then show "\<exists>\<degree>a. a \<sqsubset> r \<and> a \<asymp> s"
    using "0" "1" disjoint_def overlaps_def by auto
  qed

(* 4 marks *)
theorem not_sphere_spherical_parts_gt1:
  assumes "\<not>sphere x"
      and "sphere s \<and>  s \<sqsubseteq> x"
    shows "\<exists>\<degree>a. a \<sqsubset> x \<and> a \<asymp> s"
proof-
  have 1:"s \<sqsubset> x"
  using assms(1) assms(2) parthood_partial_order.le_imp_less_or_eq by blast
  obtain s where "sphere s \<and>  s \<sqsubset> x"
    using "1" assms(2) by blast
  then have "s \<sqsubset> x"
    by blast
  then show ?thesis
    using "1" proper_have_nonoverlapping_proper_sphere by blast
qed

end

section \<open>Part 3\<close>

context mereology_sphere
begin

(* 3 marks *)
lemma
  assumes T4: "\<And>x y. \<lbrakk>sphere x; sphere y\<rbrakk> \<Longrightarrow> x y \<doteq> y x"
      and A9: "\<exists>\<degree>s. s \<sqsubseteq> r"
  shows False
oops

(* 3 marks *)
definition equidistant3' :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "equidistant3' x y z \<equiv> undefined"

no_notation equidistant4 ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100)

definition equidistant4' :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100) where
  "x y \<doteq> z w \<equiv> \<exists>\<degree>u v. mid w u y \<and> mid x u v \<and> equidistant3' v z y"

end

datatype two_reg = Left | Right | Both

(* 2 marks *)
definition tworeg_partof :: "two_reg \<Rightarrow> two_reg \<Rightarrow> bool" (infix "\<sqsubseteq>" 100) where
  "x \<sqsubseteq> y \<equiv> undefined"

(* 12 marks *)
interpretation mereology "(\<sqsubseteq>)"
oops

end


(*  Title:      HOL/Multivariate_Analysis/L2_Norm.thy
    Author:     Brian Huffman, Portland State University
*)

section {* Square root of sum of squares *}

theory L2_Norm
imports NthRoot
begin

definition
  "setL2 f A = sqrt (\<Sum>i\<in>A. (f i)\<^sup>2)"

lemma setL2_cong:
  "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
  unfolding setL2_def by simp

lemma strong_setL2_cong:
  "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
  unfolding setL2_def simp_implies_def by simp

lemma setL2_infinite [simp]: "\<not> finite A \<Longrightarrow> setL2 f A = 0"
  unfolding setL2_def by simp

lemma setL2_empty [simp]: "setL2 f {} = 0"
  unfolding setL2_def by simp

lemma setL2_insert [simp]:
  "\<lbrakk>finite F; a \<notin> F\<rbrakk> \<Longrightarrow>
    setL2 f (insert a F) = sqrt ((f a)\<^sup>2 + (setL2 f F)\<^sup>2)"
  unfolding setL2_def by (simp add: setsum_nonneg)

lemma setL2_nonneg [simp]: "0 \<le> setL2 f A"
  unfolding setL2_def by (simp add: setsum_nonneg)

lemma setL2_0': "\<forall>a\<in>A. f a = 0 \<Longrightarrow> setL2 f A = 0"
  unfolding setL2_def by simp

lemma setL2_constant: "setL2 (\<lambda>x. y) A = sqrt (of_nat (card A)) * \<bar>y\<bar>"
  unfolding setL2_def by (simp add: real_sqrt_mult)

lemma setL2_mono:
  assumes "\<And>i. i \<in> K \<Longrightarrow> f i \<le> g i"
  assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
  shows "setL2 f K \<le> setL2 g K"
  unfolding setL2_def
  by (simp add: setsum_nonneg setsum_mono power_mono assms)

lemma setL2_strict_mono:
  assumes "finite K" and "K \<noteq> {}"
  assumes "\<And>i. i \<in> K \<Longrightarrow> f i < g i"
  assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
  shows "setL2 f K < setL2 g K"
  unfolding setL2_def
  by (simp add: setsum_strict_mono power_strict_mono assms)

lemma setL2_right_distrib:
  "0 \<le> r \<Longrightarrow> r * setL2 f A = setL2 (\<lambda>x. r * f x) A"
  unfolding setL2_def
  apply (simp add: power_mult_distrib)
  apply (simp add: setsum_right_distrib [symmetric])
  apply (simp add: real_sqrt_mult setsum_nonneg)
  done

lemma setL2_left_distrib:
  "0 \<le> r \<Longrightarrow> setL2 f A * r = setL2 (\<lambda>x. f x * r) A"
  unfolding setL2_def
  apply (simp add: power_mult_distrib)
  apply (simp add: setsum_left_distrib [symmetric])
  apply (simp add: real_sqrt_mult setsum_nonneg)
  done

lemma setsum_nonneg_eq_0_iff:
  fixes f :: "'a \<Rightarrow> 'b::ordered_ab_group_add"
  shows "\<lbrakk>finite A; \<forall>x\<in>A. 0 \<le> f x\<rbrakk> \<Longrightarrow> setsum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  apply (induct set: finite, simp)
  apply (simp add: add_nonneg_eq_0_iff setsum_nonneg)
  done

lemma setL2_eq_0_iff: "finite A \<Longrightarrow> setL2 f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  unfolding setL2_def
  by (simp add: setsum_nonneg setsum_nonneg_eq_0_iff)

lemma setL2_triangle_ineq:
  shows "setL2 (\<lambda>i. f i + g i) A \<le> setL2 f A + setL2 g A"
proof (cases "finite A")
  case False
  thus ?thesis by simp
next
  case True
  thus ?thesis
  proof (induct set: finite)
    case empty
    show ?case by simp
  next
    case (insert x F)
    hence "sqrt ((f x + g x)\<^sup>2 + (setL2 (\<lambda>i. f i + g i) F)\<^sup>2) \<le>
           sqrt ((f x + g x)\<^sup>2 + (setL2 f F + setL2 g F)\<^sup>2)"
      by (intro real_sqrt_le_mono add_left_mono power_mono insert
                setL2_nonneg add_increasing zero_le_power2)
    also have
      "\<dots> \<le> sqrt ((f x)\<^sup>2 + (setL2 f F)\<^sup>2) + sqrt ((g x)\<^sup>2 + (setL2 g F)\<^sup>2)"
      by (rule real_sqrt_sum_squares_triangle_ineq)
    finally show ?case
      using insert by simp
  qed
qed

lemma sqrt_sum_squares_le_sum:
  "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> sqrt (x\<^sup>2 + y\<^sup>2) \<le> x + y"
  apply (rule power2_le_imp_le)
  apply (simp add: power2_sum)
  apply simp
  done

lemma setL2_le_setsum [rule_format]:
  "(\<forall>i\<in>A. 0 \<le> f i) \<longrightarrow> setL2 f A \<le> setsum f A"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply clarsimp
  apply (erule order_trans [OF sqrt_sum_squares_le_sum])
  apply simp
  apply simp
  apply simp
  done

lemma sqrt_sum_squares_le_sum_abs: "sqrt (x\<^sup>2 + y\<^sup>2) \<le> \<bar>x\<bar> + \<bar>y\<bar>"
  apply (rule power2_le_imp_le)
  apply (simp add: power2_sum)
  apply simp
  done

lemma setL2_le_setsum_abs: "setL2 f A \<le> (\<Sum>i\<in>A. \<bar>f i\<bar>)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply simp
  apply (rule order_trans [OF sqrt_sum_squares_le_sum_abs])
  apply simp
  apply simp
  done

lemma setL2_mult_ineq_lemma:
  fixes a b c d :: real
  shows "2 * (a * c) * (b * d) \<le> a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2"
proof -
  have "0 \<le> (a * d - b * c)\<^sup>2" by simp
  also have "\<dots> = a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2 - 2 * (a * d) * (b * c)"
    by (simp only: power2_diff power_mult_distrib)
  also have "\<dots> = a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2 - 2 * (a * c) * (b * d)"
    by simp
  finally show "2 * (a * c) * (b * d) \<le> a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2"
    by simp
qed

lemma setL2_mult_ineq: "(\<Sum>i\<in>A. \<bar>f i\<bar> * \<bar>g i\<bar>) \<le> setL2 f A * setL2 g A"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply (rule power2_le_imp_le, simp)
  apply (rule order_trans)
  apply (rule power_mono)
  apply (erule add_left_mono)
  apply (simp add: setsum_nonneg)
  apply (simp add: power2_sum)
  apply (simp add: power_mult_distrib)
  apply (simp add: distrib_left distrib_right)
  apply (rule ord_le_eq_trans)
  apply (rule setL2_mult_ineq_lemma)
  apply simp_all
  done

lemma member_le_setL2: "\<lbrakk>finite A; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le> setL2 f A"
  apply (rule_tac s="insert i (A - {i})" and t="A" in subst)
  apply fast
  apply (subst setL2_insert)
  apply simp
  apply simp
  apply simp
  done

end


theory Peano
  imports Main
begin

section \<open>Natural Numbers\<close>

datatype nat = Zero | Suc nat

fun add :: "nat => nat => nat" where
  "add Zero m = m" |
  "add (Suc n) m = Suc (add n m)"

lemma neutral[simp]: "add m Zero = m"
  apply (induction m)
  apply auto
  done

lemma suc_commutation[simp]: "add m (Suc n) = Suc (add m n)"
  apply (induction m)
   apply auto
  done

lemma commutation[simp]: "add m n = add n m"
  apply (induction m)
   apply auto
  done

lemma preassociation: "nat.Suc (add n (add k m)) = add n (add m (nat.Suc k))"
  apply (induction n)
   apply auto
  done

lemma association[simp]: "add k (add m n) = add (add k m) n"
  apply (induction k)
   apply (auto simp:preassociation)
  done

fun double :: "nat \<Rightarrow> nat" where
  "double Zero = Zero" |
  "double (Suc n) = add (double n) (Suc (Suc Zero))"

lemma double_def: "double n = add n n"
  apply (induction n)
  apply auto

end


theory Multiplicity
  imports Main
begin

section "Linear order of \<M>, which is the set of natural numbers \<union> {\<star>}"

datatype \<M> = Star | Nr nat

notation
  Star ("(\<^emph>)" 1000) and
  Nr ("(\<^bold>_)" [1000] 1000)

instantiation \<M> :: linorder
begin

fun less_eq_\<M> :: "\<M> \<Rightarrow> \<M> \<Rightarrow> bool" where
"less_eq_\<M> _ \<^emph> = True" |
"less_eq_\<M> (\<^bold>a) (\<^bold>b) = (a \<le> b)" |
"less_eq_\<M> _ _ = False"

fun less_\<M> :: "\<M> \<Rightarrow> \<M> \<Rightarrow> bool" where
"less_\<M> (\<^bold>_) \<^emph> = True" |
"less_\<M> (\<^bold>a) (\<^bold>b) = (a < b)" |
"less_\<M> _ _ = False"

instance proof
  fix x y z :: \<M>
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
  proof (induction x arbitrary: y)
    case Star
    then show ?case by simp_all
  next
    case (Nr x)
    then show ?case by (cases y) auto
  qed

  show "x \<le> x" by (induction x) simp_all
  then show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  proof (induction x arbitrary: y)
    case Star
    then show ?case by (cases y) simp_all
  next
    case (Nr x)
    then show ?case by (cases y) simp_all
  qed

  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  proof (induction x arbitrary: y z)
    case Star
    then show ?case by (cases y) simp_all
  next
    case (Nr x)
    then show ?case
    proof (induction y arbitrary: z)
      case Star
      then show ?case by (cases z) simp_all
    next
      case (Nr x)
      then show ?case by (cases z) simp_all
    qed
  qed

  show "x \<le> y \<or> y \<le> x"
  proof (induction x arbitrary: y)
    case Star
    then show ?case by simp
  next
    case (Nr x)
    then show ?case by (cases y) auto
  qed
qed

end

section "Definition of multiplicity"

type_synonym multiplicity = "\<M> \<times> \<M>"

definition lower :: "multiplicity \<Rightarrow> \<M>" where
  "lower m \<equiv> fst m"

declare lower_def[simp add]

definition upper :: "multiplicity \<Rightarrow> \<M>" where
  "upper m \<equiv> snd m"

declare upper_def[simp add]

locale multiplicity = fixes mult :: "multiplicity"
  assumes lower_bound_valid[simp]: "lower mult \<noteq> \<^emph>"
  assumes upper_bound_valid: "upper mult \<noteq> \<^bold>0"
  assumes properly_bounded[simp]: "lower mult \<le> upper mult"

context multiplicity
begin

lemma upper_bound_valid_alt[simp]: "upper mult \<ge> \<^bold>1"
  using less_\<M>.elims not_less upper_bound_valid by fastforce

end

abbreviation multiplicity_notation :: "\<M> \<Rightarrow> \<M> \<Rightarrow> multiplicity" ("(_/.._)" [52, 52] 51) where
  "l..u \<equiv> (l,u)"

definition within_multiplicity :: "nat \<Rightarrow> multiplicity \<Rightarrow> bool" (infixl "in" 50) where
  "n in m \<equiv> lower m \<le> \<^bold>n \<and> \<^bold>n \<le> upper m"

theorem mult_zero_unbounded_valid[simp]: "n in \<^bold>0..\<^emph>"
  unfolding within_multiplicity_def
  by simp

theorem mult_single_value_bound[simp]: "n in \<^bold>m..\<^bold>m \<Longrightarrow> n = m"
  unfolding within_multiplicity_def
  by auto

section "Intersection of multiplicities"

definition mult_intersect :: "multiplicity \<Rightarrow> multiplicity \<Rightarrow> multiplicity" where
  "mult_intersect m1 m2 \<equiv> (max (lower m1) (lower m2))..(min (upper m1) (upper m2))"

abbreviation mult_intersect_notation :: "multiplicity \<Rightarrow> multiplicity \<Rightarrow> multiplicity" ("(_ \<sqinter> _)" [52, 52] 51) where
  "m1 \<sqinter> m2 \<equiv> mult_intersect m1 m2"

lemma mult_intersect_identity[simp]: "m \<sqinter> (\<^bold>0..\<^emph>) = m"
proof
  show "fst (m \<sqinter> (\<^bold>0..\<^emph>)) = fst m"
    unfolding mult_intersect_def
    using less_eq_\<M>.elims(3) max.absorb1
    by fastforce
next
  show "snd (m \<sqinter> (\<^bold>0..\<^emph>)) = snd m"
    unfolding mult_intersect_def
    by (simp add: min_absorb1)
qed

lemma mult_intersect_commute[simp]: "m1 \<sqinter> m2 = m2 \<sqinter> m1"
  by (simp add: max.commute min.commute mult_intersect_def)

lemma mult_intersect_assoc[simp]: "(m1 \<sqinter> m2) \<sqinter> m3 = m1 \<sqinter> (m2 \<sqinter> m3)"
  unfolding mult_intersect_def
  by (simp add: max.assoc min.assoc)

lemma mult_intersect_idemp[simp]: "m \<sqinter> m = m"
  unfolding mult_intersect_def
  by simp

lemma mult_intersect_invalid[simp]: "m \<sqinter> (\<^emph>..\<^bold>0) = (\<^emph>..\<^bold>0)"
proof
  show "fst (m \<sqinter> (\<^emph>..\<^bold>0)) = fst (\<^emph>..\<^bold>0)"
    unfolding mult_intersect_def
    by (simp add: max.absorb2)
next
  show "snd (m \<sqinter> (\<^emph>..\<^bold>0)) = snd (\<^emph>..\<^bold>0)"
    unfolding mult_intersect_def
    using less_eq_\<M>.elims(3) min.absorb2
    by fastforce
qed

theorem mult_intersect_correct[simp]: "multiplicity m1 \<Longrightarrow> multiplicity m2 \<Longrightarrow> max (lower m1) (lower m2) \<le> min (upper m1) (upper m2) \<Longrightarrow> multiplicity (m1 \<sqinter> m2)"
proof
  fix m1 m2
  assume m1_is_multiplicity: "multiplicity m1"
  assume m2_is_multiplicity: "multiplicity m2"
  have lower_bound_m1_valid: "lower m1 \<noteq> \<^emph>"
    using m1_is_multiplicity multiplicity.lower_bound_valid by auto
  have lower_bound_m2_valid: "lower m2 \<noteq> \<^emph>"
    using m2_is_multiplicity multiplicity.lower_bound_valid by auto
  have intersect_lower_def: "lower (m1 \<sqinter> m2) = max (lower m1) (lower m2)"
    by (simp add: mult_intersect_def)
  then show "lower (m1 \<sqinter> m2) \<noteq> \<^emph>"
    using lower_bound_m1_valid lower_bound_m2_valid max_def
    by metis
  have upper_bound_m1_valid: "upper m1 \<noteq> \<^bold>0"
    using m1_is_multiplicity multiplicity.upper_bound_valid by auto
  have upper_bound_m2_valid: "upper m2 \<noteq> \<^bold>0"
    using m2_is_multiplicity multiplicity.upper_bound_valid by auto
  have intersect_upper_def: "upper (m1 \<sqinter> m2) = min (upper m1) (upper m2)"
    by (simp add: mult_intersect_def)
  then show "upper (m1 \<sqinter> m2) \<noteq> \<^bold>0"
    using min_def upper_bound_m1_valid upper_bound_m2_valid
    by metis
  assume "max (lower m1) (lower m2) \<le> min (upper m1) (upper m2)"
  then show "lower (m1 \<sqinter> m2) \<le> upper (m1 \<sqinter> m2)"
    using intersect_lower_def intersect_upper_def by auto
qed

lemma mult_intersect_eq[simp]: "m = m \<sqinter> m"
  by (simp add: mult_intersect_def)

end


theory Test_Code_Generation
imports
  Environment_Executable
begin

section "Code generation for segment intersection"

type_synonym segment = "(real*real)*real*real"
definition segment1::segment where
  "segment1 = ((0.0,0.0), (5.0,0.0))"
definition segment2::segment where
  "segment2 = ((0.0,0.0), (5.0,1.0))"
definition "reoi x = (real_of_int (int_of_integer x))"
definition "raoi i j = reoi i / reoi j"

ML \<open>
val segment_intersection = @{code segment_intersection}
val segment1 = @{code segment1}
val segment2 = @{code segment2}
val reoi = @{code reoi}
val raoi = @{code raoi}
fun mk_segment a b c d = ((reoi a, reoi b), (reoi c, reoi d))
val segment3 = mk_segment 0 1 2 3
\<close>
ML \<open>segment_intersection segment1 segment2\<close>
ML \<open>segment_intersection segment1 segment3\<close>

section "Code generation for point in drivable area"

fun polychain2 :: "('a \<times> 'a) list \<Rightarrow> bool" where
  "polychain2 [] = True" |
  "polychain2 [x] = True" |
  "polychain2 (x # y # zs) = (if snd x = fst y then polychain2 (y # zs) else False)"

theorem univ_unfold_at_0:
  assumes "1 < m"
  shows "(\<forall>i::nat. Suc i < m \<longrightarrow> P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i::nat. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i))"
proof
  assume 0: "\<forall>i. Suc i < m \<longrightarrow> P i"
  with assms have c1: "P 0" by auto
  with assms 0 have c2: "(\<forall>i::nat. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i)" by auto
  with c1 show " P 0 \<and> (\<forall>i. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i)" by auto
next
  show "P 0 \<and> (\<forall>i. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i) \<Longrightarrow> \<forall>i. Suc i < m \<longrightarrow> P i" using assms
      by (metis One_nat_def le_add2 le_add_same_cancel2 le_eq_less_or_eq le_simps(3))
qed

lemma polychain_polychain2[code]:
  "polychain xs = polychain2 xs"
proof (induction xs rule:polychain2.induct)
  case 1
  then show ?case by auto
next
  case (2 x)
  then show ?case by auto
next
  case (3 x y zs)
  note case3 = this
  have "1 < length (x # y # zs)" by auto
  have "polychain (x # y # zs) = (snd ((x # y # zs) ! 0) = fst ((x # y # zs) ! Suc 0) \<and>
                                 (\<forall>i. 1 \<le> i \<and> Suc i < length (x # y # zs) \<longrightarrow> snd ((x # y # zs) ! i) = fst ((x # y # zs) ! Suc i)))"
    unfolding polychain_def univ_unfold_at_0[OF `1 < length (x # y # zs)`, where P="\<lambda>i. snd ((x # y # zs) ! i) = (fst ((x # y # zs) ! Suc i))"]
    by auto
  also have "... = (snd x = fst y \<and> polychain (y # zs))" unfolding polychain_def by auto
  finally have "polychain (x # y # zs) = (snd x = fst y \<and> polychain (y # zs))" by auto
  with case3 show ?case  by auto
qed

definition points_le :: "segment list" where
  "points_le = [((0,0), (1,0)), ((1,0), (2,0)), ((2,0), (3,0))]"

theorem pple: "polychain points_le" unfolding points_le_def by eval

theorem univ_unfold_at_0':
  assumes "0 < m"
  shows "(\<forall>i::nat. i < m \<longrightarrow> P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i::nat. 1 \<le> i \<and> i < m \<longrightarrow> P i))"
proof
  assume 0: "\<forall>i<m. P i"
  with assms have "P 0" by auto
  from 0 have "(\<forall>i::nat. 1 \<le> i \<and> i < m \<longrightarrow> P i)" by auto
  with `P 0` show "P 0 \<and> (\<forall>i. 1 \<le> i \<and> i < m \<longrightarrow> P i)" by auto
next
  assume " P 0 \<and> (\<forall>i. 1 \<le> i \<and> i < m \<longrightarrow> P i)"
  with assms show "\<forall>i<m. P i"
    by (metis less_one not_less)
qed

fun monotone_polychain2 :: "((real \<times> real) \<times> real \<times> real) list \<Rightarrow> bool" where
  "monotone_polychain2 [] = True" |
  "monotone_polychain2 (x # xs) = (if fst (fst x) < fst (snd x) then monotone_polychain2 xs else False)"

lemma monotone_polychain2:
  "(\<forall>i<length xs. fst (fst (xs ! i)) < fst (snd (xs ! i))) = monotone_polychain2 xs"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  note case_cons = this
  have "0 < length (a # xs)" by auto
  have "(\<forall>i<length (a # xs). fst (fst ((a # xs) ! i)) < fst (snd ((a # xs) ! i))) =
    (fst (fst a) < fst (snd a) \<and> (\<forall>i < length xs. fst (fst (xs ! i)) < fst (snd (xs ! i))))"
    unfolding univ_unfold_at_0'[OF `0 < length (a #xs)`, where P="\<lambda>x. fst (fst ((a # xs) ! x)) < fst (snd ((a # xs) ! x))"]
    by auto
  with case_cons show ?case by auto
qed

lemma monotone_polychain_monotone_polychain2 [code]:
  "monotone_polychain xs = (polychain2 xs \<and> monotone_polychain2 xs)"
  unfolding monotone_polychain_def polychain_polychain2 monotone_polychain2 by auto

theorem mple: "monotone_polychain points_le" unfolding points_le_def by eval

global_interpretation llsb: lanelet_simple_boundary points_le
  using points_le_def by (unfold_locales) (auto simp add:pple mple)

definition points_ri :: "segment list" where
  "points_ri = [((0,1), (1,1)), ((1,1), (2,1)), ((2,1), (3,1))]"

theorem ppri: "polychain points_ri" unfolding points_ri_def by eval
theorem mpri: "monotone_polychain points_ri" unfolding points_ri_def by eval

global_interpretation rlsb: lanelet_simple_boundary points_ri
  using points_ri_def by (unfold_locales) (auto simp add:ppri mpri)

theorem pathstart_boundary [code]:
  "pathstart_boundary [x] = fst x"
  "pathstart_boundary (x # y # zs) = fst x"
  unfolding pathstart_boundary_def points_path2_def by auto

theorem pathfinish_boundary [code]:
  "pathfinish_boundary [x] = snd x"
  "pathfinish_boundary (x # y # zs) = pathfinish_boundary (y # zs)"
  unfolding pathfinish_boundary_def points_path2_def by auto

theorem "pathfinish_boundary points_ri = (3,1)" by eval

value [code] "above_and_inside_polychains points_le (3,1)"

global_interpretation l: lanelet points_ri points_le
  defines right = l.direction_right and pida = l.point_in_drivable_area
  by (unfold_locales) (eval+)

value [code] "right"
value [code] "pida (1,0.5)"

term "rotation_matrix'"

end


(*  Title:      Util_Nat.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

header {* Results for natural arithmetics *}

theory Util_Nat
imports Main
begin

subsection {* Some convenience arithmetic lemmata *}

thm Nat.add_Suc_right
lemma add_1_Suc_conv: "m + 1 = Suc m" by simp
lemma sub_Suc0_sub_Suc_conv: "b - a - Suc 0 = b - Suc a" by simp
thm Nat.Suc_pred
lemma Suc_diff_Suc: "m < n \<Longrightarrow> Suc (n - Suc m) = n - m"
apply (rule subst[OF sub_Suc0_sub_Suc_conv])
apply (rule Suc_pred)
apply (simp only: zero_less_diff)
done

lemma nat_grSuc0_conv: "(Suc 0 < n) = (n \<noteq> 0 \<and> n \<noteq> Suc 0)"
by fastforce
lemma nat_geSucSuc0_conv: "(Suc (Suc 0) \<le> n) = (n \<noteq> 0 \<and> n \<noteq> Suc 0)"
by fastforce

lemma nat_lessSucSuc0_conv: "(n < Suc (Suc 0)) = (n = 0 \<or> n = Suc 0)"
by fastforce
lemma nat_leSuc0_conv: "(n \<le> Suc 0) = (n = 0 \<or> n = Suc 0)"
by fastforce

thm Nat.mult_Suc
lemma mult_pred: "(m - Suc 0) * n = m * n - n"
by (simp add: diff_mult_distrib)
thm Nat.mult_Suc_right
lemma mult_pred_right: "m * (n - Suc 0) = m * n - m"
by (simp add: diff_mult_distrib2)

lemma gr_implies_gr0: "m < (n::nat) \<Longrightarrow> 0 < n" by simp

thm
  Nat.mult_cancel1
  Nat.mult_cancel1
corollary mult_cancel1_gr0: "
  (0::nat) < k \<Longrightarrow> (k * m = k * n) = (m = n)" by simp
corollary mult_cancel2_gr0: "
  (0::nat) < k \<Longrightarrow> (m * k = n * k) = (m = n)" by simp

thm
  Nat.mult_le_cancel1
  Nat.mult_le_cancel2
corollary mult_le_cancel1_gr0: "
  (0::nat) < k \<Longrightarrow> (k * m \<le> k * n) = (m \<le> n)" by simp
corollary mult_le_cancel2_gr0: "
  (0::nat) < k \<Longrightarrow> (m * k \<le> n * k) = (m \<le> n)" by simp

thm mult_le_mono
lemma gr0_imp_self_le_mult1: "0 < (k::nat) \<Longrightarrow> m \<le> m * k"
by (drule Suc_leI, drule mult_le_mono[OF order_refl], simp)

lemma gr0_imp_self_le_mult2: "0 < (k::nat) \<Longrightarrow> m \<le> k * m"
by (subst mult.commute, rule gr0_imp_self_le_mult1)

lemma less_imp_Suc_mult_le: "m < n \<Longrightarrow> Suc m * k \<le> n * k"
by (rule mult_le_mono1, simp)

lemma less_imp_Suc_mult_pred_less: "\<lbrakk> m < n; 0 < k \<rbrakk> \<Longrightarrow> Suc m * k - Suc 0 < n * k"
apply (rule Suc_le_lessD)
apply (simp only: Suc_pred[OF nat_0_less_mult_iff[THEN iffD2, OF conjI, OF zero_less_Suc]])
apply (rule less_imp_Suc_mult_le, assumption)
done

thm Nat.zero_less_diff
lemma ord_zero_less_diff: "(0 < (b::'a::ordered_ab_group_add) - a) = (a < b)"
by (simp add: less_diff_eq)

lemma ord_zero_le_diff: "(0 \<le> (b::'a::ordered_ab_group_add) - a) = (a \<le> b)"
by (simp add: le_diff_eq)

text {* @{text diff_diff_right} in rule format *}
lemmas diff_diff_right = Nat.diff_diff_right[rule_format]

thm Nat.le_add1 Nat.le_add2
lemma less_add1: "(0::nat) < j \<Longrightarrow> i < i + j" by simp
lemma less_add2: "(0::nat) < j \<Longrightarrow> i < j + i" by simp

thm Nat.add_leD1 Nat.add_leD2
thm Nat.add_lessD1
lemma add_lessD2: "i + j < (k::nat) \<Longrightarrow> j < k" by simp

thm Nat.add_le_mono1
lemma add_le_mono2: "i \<le> (j::nat) \<Longrightarrow> k + i \<le> k + j" by simp
thm Nat.add_less_mono1
lemma add_less_mono2: "i < (j::nat) \<Longrightarrow> k + i < k + j" by simp

thm Nat.diff_le_self
lemma diff_less_self: "\<lbrakk> (0::nat) < i;  0 < j \<rbrakk> \<Longrightarrow> i - j < i" by simp

lemma
  ge_less_neq_conv: "((a::'a::linorder) \<le> n) = (\<forall>x. x < a \<longrightarrow> n \<noteq> x)" and
  le_greater_neq_conv: "(n \<le> (a::'a::linorder)) = (\<forall>x. a < x \<longrightarrow> n \<noteq> x)"
by (subst linorder_not_less[symmetric], blast)+
lemma
  greater_le_neq_conv: "((a::'a::linorder) < n) = (\<forall>x. x \<le> a \<longrightarrow> n \<noteq> x)" and
  less_ge_neq_conv: "(n < (a::'a::linorder)) = (\<forall>x. a \<le> x \<longrightarrow> n \<noteq> x)"
by (subst linorder_not_le[symmetric], blast)+

text {* Lemmas for @term{abs} function *}

lemma leq_pos_imp_abs_leq: "\<lbrakk> 0 \<le> (a::'a::ordered_ab_group_add_abs); a \<le> b \<rbrakk> \<Longrightarrow> \<bar>a\<bar> \<le> \<bar>b\<bar>"
by simp
lemma leq_neg_imp_abs_geq: "\<lbrakk> (a::'a::ordered_ab_group_add_abs) \<le> 0; b \<le> a \<rbrakk> \<Longrightarrow> \<bar>a\<bar> \<le> \<bar>b\<bar>"
by simp
lemma abs_range: "\<lbrakk> 0 \<le> (a::'a::{ordered_ab_group_add_abs,abs_if}); -a \<le> x; x \<le> a \<rbrakk> \<Longrightarrow> \<bar>x\<bar> \<le> a"
apply (clarsimp simp: abs_if)
thm neg_le_iff_le[THEN iffD1]
apply (rule neg_le_iff_le[THEN iffD1], simp)
done

text {* Lemmas for @term{sgn} function *}

lemma sgn_abs:"(x::'a::linordered_idom) \<noteq> 0 \<Longrightarrow> \<bar>sgn x\<bar> = 1"
by (case_tac "x < 0", simp+)
lemma sgn_mult_abs:"\<bar>x\<bar> * \<bar>sgn (a::'a::linordered_idom)\<bar> = \<bar>x * sgn a\<bar>"
by (fastforce simp add: sgn_if abs_if)
lemma abs_imp_sgn_abs: "\<bar>a\<bar> = \<bar>b\<bar> \<Longrightarrow> \<bar>sgn (a::'a::linordered_idom)\<bar> = \<bar>sgn b\<bar>"
by (fastforce simp add: abs_if)
lemma sgn_mono: "a \<le> b \<Longrightarrow> sgn (a::'a::{linordered_idom,linordered_semidom}) \<le> sgn b"
by (auto simp add: sgn_if)

subsection {* Additional facts about inequalities *}

thm Nat.le_add_diff
lemma add_diff_le: "k \<le> n \<Longrightarrow> m + k - n \<le> (m::nat)"
by (case_tac "m + k < n", simp_all)
thm
  Nat.le_add_diff
  add_diff_le

lemma less_add_diff: "k < (n::nat) \<Longrightarrow> m < n + m - k"
thm add_less_imp_less_right[of _ k]
by (rule add_less_imp_less_right[of _ k], simp)
thm add_diff_le
lemma add_diff_less: "\<lbrakk> k < n; 0 < m \<rbrakk> \<Longrightarrow> m + k - n < (m::nat)"
by (case_tac "m + k < n", simp_all)
thm
  Nat.le_add_diff
  add_diff_le
  less_add_diff
  add_diff_less

thm Nat.less_diff_conv
lemma add_le_imp_le_diff1: "i + k \<le> j \<Longrightarrow> i \<le> j - (k::nat)"
by (case_tac "k \<le> j", simp_all)
lemma add_le_imp_le_diff2: "k + i \<le> j \<Longrightarrow> i \<le> j - (k::nat)" by simp
thm
  Nat.less_diff_conv[symmetric]
  Nat.le_diff_conv2[symmetric]
  add_le_imp_le_diff1
  add_le_imp_le_diff2

thm
  Nat.le_diff_conv Nat.le_diff_conv2
  Nat.less_diff_conv
lemma diff_less_imp_less_add: "j - (k::nat) < i \<Longrightarrow> j < i + k" by simp
thm Nat.le_diff_conv
lemma diff_less_conv: "0 < i \<Longrightarrow> (j - (k::nat) < i) = (j < i + k)"
by (safe, simp_all)

lemma diff_less_imp_swap: "\<lbrakk> 0 < (i::nat); k - i < j \<rbrakk> \<Longrightarrow> (k - j < i)" by simp
lemma diff_less_swap: "\<lbrakk> 0 < (i::nat); 0 < j \<rbrakk> \<Longrightarrow> (k - j < i) = (k - i < j)"
by (blast intro: diff_less_imp_swap)

lemma less_diff_imp_less: "(i::nat) < j - m \<Longrightarrow> i < j" by simp
lemma le_diff_imp_le: "(i::nat) \<le> j - m \<Longrightarrow> i \<le> j" by simp

lemma less_diff_le_imp_less: "\<lbrakk> (i::nat) < j - m; n \<le> m \<rbrakk> \<Longrightarrow> i < j - n" by simp
lemma le_diff_le_imp_le: "\<lbrakk> (i::nat) \<le> j - m; n \<le> m \<rbrakk> \<Longrightarrow> i \<le> j - n" by simp

thm Nat.less_imp_diff_less
lemma le_imp_diff_le: "(j::nat) \<le> k \<Longrightarrow> j - n \<le> k" by simp

subsection {* Inequalities for Suc and pred *}

thm Nat.less_Suc_eq_le
corollary less_eq_le_pred: "0 < (n::nat) \<Longrightarrow> (m < n) = (m \<le> n - Suc 0)"
by (safe, simp_all)
corollary less_imp_le_pred: "m < n \<Longrightarrow> m \<le> n - Suc 0" by simp
corollary le_pred_imp_less: "\<lbrakk> 0 < n; m \<le> n - Suc 0 \<rbrakk> \<Longrightarrow> m < n" by simp

thm Nat.Suc_le_eq
corollary pred_less_eq_le: "0 < m \<Longrightarrow> (m - Suc 0 < n) = (m \<le> n)"
by (safe, simp_all)
corollary pred_less_imp_le: "m - Suc 0 < n \<Longrightarrow> m \<le> n" by simp
corollary le_imp_pred_less: "\<lbrakk> 0 < m; m \<le> n \<rbrakk> \<Longrightarrow> m - Suc 0 < n" by simp

thm Nat.diff_add_inverse
lemma diff_add_inverse_Suc: "n < m \<Longrightarrow> n + (m - Suc n) = m - Suc 0" by simp

thm Nat.Suc_mono
lemma pred_mono: "\<lbrakk> m < n; 0 < m \<rbrakk> \<Longrightarrow> m - Suc 0 < n - Suc 0" by simp
corollary pred_Suc_mono: "\<lbrakk> m < Suc n; 0 < m \<rbrakk> \<Longrightarrow> m - Suc 0 < n" by simp

lemma Suc_less_pred_conv: "(Suc m < n) = (m < n - Suc 0)" by (safe, simp_all)
lemma Suc_le_pred_conv: "0 < n \<Longrightarrow> (Suc m \<le> n) = (m \<le> n - Suc 0)" by (safe, simp_all)
lemma Suc_le_imp_le_pred: "Suc m \<le> n \<Longrightarrow> m \<le> n - Suc 0" by simp

subsection {* Additional facts about cancellation in (in-)equalities *}

lemma diff_cancel_imp_eq: "\<lbrakk> 0 < (n::nat);  n + i - j = n \<rbrakk> \<Longrightarrow> i = j" by simp

thm
  Nat.nat_add_left_cancel_less
  Nat.nat_add_left_cancel_le
  Nat.nat_add_right_cancel
  Nat.nat_add_left_cancel
  Nat.diff_diff_eq
  Nat.eq_diff_iff
  Nat.less_diff_iff
  Nat.le_diff_iff
lemma nat_diff_left_cancel_less: "k - m < k - (n::nat) \<Longrightarrow> n < m" by simp
lemma nat_diff_right_cancel_less: "n - k < (m::nat) - k \<Longrightarrow> n < m" by simp

lemma nat_diff_left_cancel_le1: "\<lbrakk> k - m \<le> k - (n::nat); m < k \<rbrakk> \<Longrightarrow> n \<le> m" by simp
lemma nat_diff_left_cancel_le2: "\<lbrakk> k - m \<le> k - (n::nat); n \<le> k \<rbrakk> \<Longrightarrow> n \<le> m" by simp

lemma nat_diff_right_cancel_le1: "\<lbrakk> m - k \<le> n - (k::nat); k < m \<rbrakk> \<Longrightarrow> m \<le> n" by simp
lemma nat_diff_right_cancel_le2: "\<lbrakk> m - k \<le> n - (k::nat); k \<le> n \<rbrakk> \<Longrightarrow> m \<le> n" by simp

lemma nat_diff_left_cancel_eq1: "\<lbrakk> k - m = k - (n::nat); m < k \<rbrakk> \<Longrightarrow> m = n" by simp
lemma nat_diff_left_cancel_eq2: "\<lbrakk> k - m = k - (n::nat); n < k \<rbrakk> \<Longrightarrow> m = n" by simp

lemma nat_diff_right_cancel_eq1: "\<lbrakk> m - k = n - (k::nat); k < m \<rbrakk> \<Longrightarrow> m = n" by simp
lemma nat_diff_right_cancel_eq2: "\<lbrakk> m - k = n - (k::nat); k < n \<rbrakk> \<Longrightarrow> m = n" by simp

thm eq_diff_iff
lemma eq_diff_left_iff: "\<lbrakk> (m::nat) \<le> k; n \<le> k\<rbrakk> \<Longrightarrow> (k - m = k - n) = (m = n)"
by (safe, simp_all)

thm Nat.nat_add_right_cancel Nat.nat_add_left_cancel
thm Nat.diff_le_mono
lemma eq_imp_diff_eq: "m = (n::nat) \<Longrightarrow> m - k = n - k" by simp

text {* List of definitions and lemmas *}

thm
  Nat.add_Suc_right
  add_1_Suc_conv
  sub_Suc0_sub_Suc_conv

thm
  Nat.mult_cancel1
  Nat.mult_cancel2
  mult_cancel1_gr0
  mult_cancel2_gr0

thm
  Nat.add_lessD1
  add_lessD2

thm
  Nat.zero_less_diff
  ord_zero_less_diff
  ord_zero_le_diff

thm
  Nat.le_add_diff
  add_diff_le
  less_add_diff
  add_diff_less

thm
  Nat.le_diff_conv Nat.le_diff_conv2
  Nat.less_diff_conv
  diff_less_imp_less_add
  diff_less_conv

thm
  le_diff_swap
  diff_less_imp_swap
  diff_less_swap

thm
  less_diff_imp_less
  le_diff_imp_le

thm
  less_diff_le_imp_less
  le_diff_le_imp_le

thm
  Nat.less_imp_diff_less
  le_imp_diff_le

thm
  Nat.less_Suc_eq_le
  less_eq_le_pred
  less_imp_le_pred
  le_pred_imp_less

thm
  Nat.Suc_le_eq
  pred_less_eq_le
  pred_less_imp_le
  le_imp_pred_less

thm
  diff_cancel_imp_eq
thm
  diff_add_inverse_Suc
thm
  Nat.nat_add_left_cancel_less
  Nat.nat_add_left_cancel_le
  Nat.nat_add_right_cancel
  Nat.nat_add_left_cancel
  Nat.eq_diff_iff
  Nat.less_diff_iff
  Nat.le_diff_iff
thm
  nat_diff_left_cancel_less
  nat_diff_right_cancel_less
thm
  nat_diff_left_cancel_le1
  nat_diff_left_cancel_le2
  nat_diff_right_cancel_le1
  nat_diff_right_cancel_le2
thm
  nat_diff_left_cancel_eq1
  nat_diff_left_cancel_eq2
  nat_diff_right_cancel_eq1
  nat_diff_right_cancel_eq2

thm
  Nat.eq_diff_iff
  eq_diff_left_iff

thm
  Nat.nat_add_right_cancel Nat.nat_add_left_cancel
  Nat.diff_le_mono
  eq_imp_diff_eq

end


theory Quasi_Order
imports Main
begin

locale quasi_order =
fixes qle :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 60)
assumes qle_refl[iff]: "x \<preceq> x"
and qle_trans: "x \<preceq> y \<Longrightarrow> y \<preceq> z \<Longrightarrow> x \<preceq> z"
begin

definition in_qle :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "\<in>\<^sub>\<preceq>" 60) where
 "x \<in>\<^sub>\<preceq> M \<equiv> \<exists>y \<in> M. x \<preceq> y"

definition subseteq_qle :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<subseteq>\<^sub>\<preceq>" 60) where
 "M \<subseteq>\<^sub>\<preceq> N \<equiv> \<forall>x \<in> M. x \<in>\<^sub>\<preceq> N"

definition seteq_qle :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "=\<^sub>\<preceq>" 60) where
 "M =\<^sub>\<preceq> N  \<equiv>  M \<subseteq>\<^sub>\<preceq> N \<and> N \<subseteq>\<^sub>\<preceq> M"

lemmas "defs" = in_qle_def subseteq_qle_def seteq_qle_def

lemma subseteq_qle_refl[simp]: "M \<subseteq>\<^sub>\<preceq> M"
by(auto simp add: subseteq_qle_def in_qle_def)

lemma subseteq_qle_trans: "A \<subseteq>\<^sub>\<preceq> B \<Longrightarrow> B \<subseteq>\<^sub>\<preceq> C \<Longrightarrow> A \<subseteq>\<^sub>\<preceq> C"
by (simp add: subseteq_qle_def in_qle_def) (metis qle_trans)

lemma empty_subseteq_qle[simp]: "{} \<subseteq>\<^sub>\<preceq> A"
by (simp add: subseteq_qle_def)

lemma subseteq_qleI2: "(!!x. x \<in> M \<Longrightarrow> EX y : N. x \<preceq> y) \<Longrightarrow> M \<subseteq>\<^sub>\<preceq> N"
by (auto simp add: subseteq_qle_def in_qle_def)

lemma subseteq_qleD2: "M \<subseteq>\<^sub>\<preceq> N \<Longrightarrow> x \<in> M \<Longrightarrow> EX y : N. x \<preceq> y"
by (auto simp add: subseteq_qle_def in_qle_def)

lemma seteq_qle_refl[iff]: "A =\<^sub>\<preceq> A"
by (simp add: seteq_qle_def)

lemma seteq_qle_trans: "A =\<^sub>\<preceq> B \<Longrightarrow> B =\<^sub>\<preceq> C \<Longrightarrow> A =\<^sub>\<preceq> C"
by (simp add: seteq_qle_def) (metis subseteq_qle_trans)

end

end


header {* Partition iteration algorithm *}

(*<*)
theory Partition_iterate imports Helpers
begin
(*>*)

text {*
The partition iteration algorithm @{text partition_iterate} takes four parameters:
\begin{itemize}
\item a predicate $P$,
\item an accumulator update function $f$,
\item an accumulator $a$,
\item and finally a list $l$.
\end{itemize}
In each iteration of the algorithm, it splits the input list $l$
into two lists $yes$ and $no$, which contain the list elements satisfying
$P\, a$ respectively those which do not. Then, we calculate a new
accumulator $a'$ using the accumulator update function $f$, i.e.
$a'=f\, a\, yes$, and call the algorithm again with the updated accumulator
$a'$ and those list elements which did not satisfy the predicate
$P\, a$, namely $no$. We continue this process as long as there
are list elements which satisfy the predicate; when this is no longer
the case, we return the last accumulator and those list elements which
never satisfied the predicate.
*}

function partition_iterate ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow>
    'a \<times> 'b list" where
  "partition_iterate P f a l = (case partition (P a) l of
       ([] , no) \<Rightarrow> (a, no)
     | (yes, no) \<Rightarrow> partition_iterate P f (f a yes) no)"
by auto

termination partition_iterate
by (relation "measure (\<lambda>(p, f, a, l). length l)")
   (auto simp add: filter_length_smaller)

(*<*)
lemma pi_induct [case_names Base Step]:
  assumes B: "P (a, l)"
      and S: "\<And>a l yes no. P (a, l) \<Longrightarrow> partition (p a) l = (yes, no) \<Longrightarrow> P (f a yes, no)"
  shows "P (partition_iterate p f a l)" using B
proof (induct l arbitrary: a rule: length_induct)
  case (1 l a) then show ?case
  proof (cases "filter (p a) l")
    case Nil show ?thesis using 1(2) filter_one_empty_other_full[of "p a"] Nil by auto
  next
    case (Cons yesh yest)
    def no \<equiv> "filter (Not \<circ> p a) l"
    have "(\<forall>x. P (x, no) \<longrightarrow> P (partition_iterate p f x no))"
      using spec[OF 1(1), of no] filter_length_smaller[of _ _ p, OF Cons[symmetric]] no_def by auto
    then have "P (partition_iterate p f (f a (yesh#yest)) no)"
      using S[OF 1(2), of "yesh#yest"] Cons no_def by auto
    then show ?thesis using Cons no_def[symmetric] by simp
  qed
qed

lemma pi_termination_condition:
  assumes "partition_iterate P f a l = (ac, no)"
  shows "filter (P ac) no = []"
proof -
  have "(ac, no) = (case partition (P a) l of ([], no) \<Rightarrow>
    (a, no) | (x # l, no) \<Rightarrow> partition_iterate P f (f a (x # l)) no)" using assms by simp
  then show ?thesis proof (induct l arbitrary: ac no a rule: length_induct)
    case (1 l)
    def yes \<equiv> "filter (P a) l"
    def noa \<equiv> "filter (Not \<circ> P a) l"
    then show ?case proof (cases yes)
      case Nil then show ?thesis using 1 yes_def by simp
    next
      case Cons
      then have E: "(ac, no) = (partition_iterate P f (f a yes) noa)" using 1(2)
        unfolding yes_def partition_filter_conv noa_def by (metis list.simps(5) split_conv)

      have S: "length noa < length l" using Cons filter_length_smaller[of _ _ P a l]
        unfolding yes_def noa_def by auto
      then show ?thesis using 1 E by (metis (mono_tags) partition_iterate.simps)
    qed
  qed
qed

lemma pi_invariant:
  assumes "\<And>a. f a [] = a"
    shows "partition_iterate P f a l =
           (\<lambda>(acc, no). (f acc (filter (P acc) no), no)) (partition_iterate P f a l)"
proof -
  def pi \<equiv> "partition_iterate P f a l"
  def ac \<equiv> "fst pi"
  def no \<equiv> "snd pi"
  have PI: "partition_iterate P f a l = (ac, no)" using pi_def ac_def no_def by auto

  have "filter (P ac) no = []" using pi_termination_condition PI .
  then have "f ac (filter (P ac) no) = ac" using assms by auto
  then show ?thesis unfolding ac_def no_def pi_def by (case_tac "partition_iterate P f a l") auto
qed
(*>*)

end


(* -------------------------------------------------------------------------- *)
subsection \<open>Canonical angle\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Canonize any angle to $(-\pi, \pi]$ (taking account of $2\pi$ periodicity of @{term sin} and
@{term cos}). With this function, for example, multiplicative properties of @{term arg} for complex
numbers can easily be expressed and proved.\<close>

theory Canonical_Angle
imports More_Transcendental
begin

abbreviation canon_ang_P where
 "canon_ang_P \<alpha> \<alpha>' \<equiv> (-pi < \<alpha>' \<and> \<alpha>' \<le> pi) \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2*k*pi)"

definition canon_ang :: "real \<Rightarrow> real" ("\<downharpoonright>_\<downharpoonleft>") where
  "\<downharpoonright>\<alpha>\<downharpoonleft> = (THE \<alpha>'. canon_ang_P \<alpha> \<alpha>')"

text \<open>There is a canonical angle for every angle.\<close>
lemma canon_ang_ex:
  shows "\<exists> \<alpha>'. canon_ang_P \<alpha> \<alpha>'"
proof-
  have ***: "\<forall> \<alpha>::real. \<exists> \<alpha>'. 0 < \<alpha>' \<and> \<alpha>' \<le> 1 \<and> (\<exists> k::int. \<alpha>' = \<alpha> - k)"
  proof
    fix \<alpha>::real
    show "\<exists>\<alpha>'>0. \<alpha>' \<le> 1 \<and> (\<exists>k::int. \<alpha>' = \<alpha> - k)"
    proof (cases "\<alpha> = floor \<alpha>")
      case True
      thus ?thesis
        by (rule_tac x="\<alpha> - floor \<alpha> + 1" in exI, auto) (rule_tac x="floor \<alpha> - 1" in exI, auto)
    next
      case False
      thus ?thesis
        using real_of_int_floor_ge_diff_one[of "\<alpha>"]
        using of_int_floor_le[of "\<alpha>"]
        by (rule_tac x="\<alpha> - floor \<alpha>" in exI) smt
    qed
  qed

  have **: "\<forall> \<alpha>::real. \<exists> \<alpha>'. 0 < \<alpha>' \<and> \<alpha>' \<le> 2 \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2*k - 1)"
  proof
    fix \<alpha>::real
    from ***[rule_format, of "(\<alpha> + 1) /2"]
    obtain \<alpha>' and k::int where "0 < \<alpha>'" "\<alpha>' \<le> 1" "\<alpha>' = (\<alpha> + 1)/2 - k"
      by force
    hence "0 < \<alpha>'" "\<alpha>' \<le> 1" "\<alpha>' = \<alpha>/2 - k + 1/2"
      by auto
    thus "\<exists>\<alpha>'>0. \<alpha>' \<le> 2 \<and> (\<exists>k::int. \<alpha> - \<alpha>' = real_of_int (2 * k - 1))"
      by (rule_tac x="2*\<alpha>'" in exI) auto
  qed
  have *: "\<forall> \<alpha>::real. \<exists> \<alpha>'. -1 < \<alpha>' \<and> \<alpha>' \<le> 1 \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2*k)"
  proof
    fix \<alpha>::real
    from ** obtain \<alpha>' and k :: int where
      "0 < \<alpha>' \<and> \<alpha>' \<le> 2 \<and> \<alpha> - \<alpha>' = 2*k - 1"
      by force
    thus "\<exists>\<alpha>'>-1. \<alpha>' \<le> 1 \<and> (\<exists>k. \<alpha> - \<alpha>' = real_of_int (2 * (k::int)))"
      by (rule_tac x="\<alpha>' - 1" in exI) (auto simp add: field_simps)
  qed
  obtain \<alpha>' k where 1: "\<alpha>' >- 1 \<and> \<alpha>' \<le> 1" and 2: "\<alpha> / pi - \<alpha>' = real_of_int (2 * k)"
    using *[rule_format, of "\<alpha> / pi"]
    by auto
  have "\<alpha>'*pi > -pi \<and> \<alpha>'*pi \<le> pi"
    using 1
    by (smt mult.commute mult_le_cancel_left1 mult_minus_right pi_gt_zero)
  moreover
  have "\<alpha> - \<alpha>'*pi = 2 * real_of_int k * pi"
    using 2
    by (auto simp add: field_simps)
  ultimately
  show ?thesis
    by auto
qed

text \<open>Canonical angle of any angle is unique.\<close>
lemma canon_ang_unique:
  assumes "canon_ang_P \<alpha> \<alpha>\<^sub>1" and "canon_ang_P \<alpha> \<alpha>\<^sub>2"
  shows "\<alpha>\<^sub>1 = \<alpha>\<^sub>2"
proof-
  obtain k1::int where "\<alpha> - \<alpha>\<^sub>1 = 2*k1*pi"
    using assms(1)
    by auto
  obtain k2::int where "\<alpha> - \<alpha>\<^sub>2 = 2*k2*pi"
    using assms(2)
    by auto
  hence *: "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 = 2*(k1 - k2)*pi"
    using \<open>\<alpha> - \<alpha>\<^sub>1 = 2*k1*pi\<close>
    by (simp add:field_simps)
  moreover
  have "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 < 2 * pi" "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 > -2*pi"
    using assms
    by auto
  ultimately
  have "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 = 0"
    using mult_less_cancel_right[of "-2" pi "real_of_int(2 * (k1 - k2))"]
    by auto
  thus ?thesis
    by auto
qed

text \<open>Canonical angle is always in $(-\pi, \pi]$ and differs from the starting angle by $2k\pi$.\<close>
lemma canon_ang:
  shows "-pi < \<downharpoonright>\<alpha>\<downharpoonleft>" and "\<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi" and "\<exists> k::int. \<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2*k*pi"
proof-
  obtain \<alpha>' where "canon_ang_P \<alpha> \<alpha>'"
    using canon_ang_ex[of \<alpha>]
    by auto
  have "canon_ang_P \<alpha> \<downharpoonright>\<alpha>\<downharpoonleft>"
    unfolding canon_ang_def
  proof (rule theI[where a="\<alpha>'"])
    show "canon_ang_P \<alpha> \<alpha>'"
      by fact
  next
    fix \<alpha>''
    assume "canon_ang_P \<alpha> \<alpha>''"
    thus "\<alpha>'' = \<alpha>'"
      using \<open>canon_ang_P \<alpha> \<alpha>'\<close>
      using canon_ang_unique[of \<alpha>' \<alpha> \<alpha>'']
      by simp
  qed
  thus "-pi < \<downharpoonright>\<alpha>\<downharpoonleft>" "\<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi" "\<exists> k::int. \<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2*k*pi"
    by auto
qed

text \<open>Angles in $(-\pi, \pi]$ are already canonical.\<close>
lemma canon_ang_id:
  assumes  "-pi < \<alpha> \<and> \<alpha> \<le> pi"
  shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha>"
  using assms
  using canon_ang_unique[of "canon_ang \<alpha>" \<alpha> \<alpha>] canon_ang[of \<alpha>]
  by auto

text \<open>Angles that differ by $2k\pi$ have equal canonical angles.\<close>
lemma canon_ang_eq:
  assumes "\<exists> k::int. \<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2*k*pi"
  shows "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"
proof-
  obtain k'::int where *: "- pi < \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft>" "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> \<le> pi" "\<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = 2 * k' * pi"
    using canon_ang[of \<alpha>\<^sub>1]
    by auto

  obtain k''::int where **: "- pi < \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>" "\<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> \<le> pi" "\<alpha>\<^sub>2 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 * k'' * pi"
    using canon_ang[of \<alpha>\<^sub>2]
    by auto

  obtain k::int where ***: "\<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2*k*pi"
    using assms
    by auto

  have "\<exists>m::int. \<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 * m * pi"
    using **(3) ***
    by (rule_tac x="k+k''" in exI) (auto simp add: field_simps)

  thus ?thesis
    using canon_ang_unique[of "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft>" \<alpha>\<^sub>1 "\<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"] * **
    by auto
qed

text \<open>Introduction and elimination rules\<close>
lemma canon_ang_eqI:
  assumes "\<exists>k::int. \<alpha>' - \<alpha> = 2 * k * pi" and "- pi < \<alpha>' \<and> \<alpha>' \<le> pi"
  shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha>'"
  using assms
  using canon_ang_eq[of \<alpha>' \<alpha>]
  using canon_ang_id[of \<alpha>']
  by auto

lemma canon_ang_eqE:
  assumes "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"
  shows "\<exists> (k::int). \<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2 *k * pi"
proof-
  obtain k1 k2 :: int where
    "\<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = 2 * k1 * pi"
    "\<alpha>\<^sub>2 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 * k2 * pi"
    using canon_ang[of \<alpha>\<^sub>1] canon_ang[of \<alpha>\<^sub>2]
    by auto
  thus ?thesis
    using assms
    by (rule_tac x="k1 - k2" in exI) (auto simp add: field_simps)
qed

text \<open>Canonical angle of opposite angle\<close>

lemma canon_ang_uminus:
  assumes "\<downharpoonright>\<alpha>\<downharpoonleft> \<noteq> pi"
  shows "\<downharpoonright>-\<alpha>\<downharpoonleft> = -\<downharpoonright>\<alpha>\<downharpoonleft>"
proof (rule canon_ang_eqI)
  show "\<exists>x::int. - \<downharpoonright>\<alpha>\<downharpoonleft> - - \<alpha> = 2 * x * pi"
    using canon_ang(3)[of \<alpha>]
    by (metis minus_diff_eq minus_diff_minus)
next
  show "- pi < - \<downharpoonright>\<alpha>\<downharpoonleft> \<and> - \<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi"
    using canon_ang(1)[of \<alpha>] canon_ang(2)[of \<alpha>] assms
    by auto
qed

lemma canon_ang_uminus_pi:
  assumes "\<downharpoonright>\<alpha>\<downharpoonleft> = pi"
  shows "\<downharpoonright>-\<alpha>\<downharpoonleft> = \<downharpoonright>\<alpha>\<downharpoonleft>"
proof (rule canon_ang_eqI)
  obtain k::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2 * k * pi"
    using canon_ang(3)[of \<alpha>]
    by auto
  thus "\<exists>x::int. \<downharpoonright>\<alpha>\<downharpoonleft> - - \<alpha> = 2 * x * pi"
    using assms
    by (rule_tac x="k+(1::int)" in exI) (auto simp add: field_simps)
next
  show "- pi < \<downharpoonright>\<alpha>\<downharpoonleft> \<and> \<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi"
    using assms
    by auto
qed

text \<open>Canonical angle of difference of two angles\<close>
lemma canon_ang_diff:
  shows "\<downharpoonright>\<alpha> - \<beta>\<downharpoonleft> = \<downharpoonright>\<downharpoonright>\<alpha>\<downharpoonleft> - \<downharpoonright>\<beta>\<downharpoonleft>\<downharpoonleft>"
proof (rule canon_ang_eq)
  show "\<exists>x::int. \<alpha> - \<beta> - (\<downharpoonright>\<alpha>\<downharpoonleft> - \<downharpoonright>\<beta>\<downharpoonleft>) = 2 * x * pi"
  proof-
    obtain k1::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2*k1*pi"
      using canon_ang(3)
      by auto
    moreover
    obtain k2::int where "\<beta> - \<downharpoonright>\<beta>\<downharpoonleft> = 2*k2*pi"
      using canon_ang(3)
      by auto
    ultimately
    show ?thesis
      by (rule_tac x="k1 - k2" in exI) (auto simp add: field_simps)
  qed
qed

text \<open>Canonical angle of sum of two angles\<close>
lemma canon_ang_sum:
  shows "\<downharpoonright>\<alpha> + \<beta>\<downharpoonleft> = \<downharpoonright>\<downharpoonright>\<alpha>\<downharpoonleft> + \<downharpoonright>\<beta>\<downharpoonleft>\<downharpoonleft>"
proof (rule canon_ang_eq)
  show "\<exists>x::int. \<alpha> + \<beta> - (\<downharpoonright>\<alpha>\<downharpoonleft> + \<downharpoonright>\<beta>\<downharpoonleft>) = 2 * x * pi"
  proof-
    obtain k1::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2*k1*pi"
      using canon_ang(3)
      by auto
    moreover
    obtain k2::int where "\<beta> - \<downharpoonright>\<beta>\<downharpoonleft> = 2*k2*pi"
      using canon_ang(3)
      by auto
    ultimately
    show ?thesis
      by (rule_tac x="k1 + k2" in exI) (auto simp add: field_simps)
  qed
qed

text \<open>Canonical angle of angle from $(0, 2\pi]$ shifted by $\pi$\<close>

lemma canon_ang_plus_pi1:
  assumes "0 < \<alpha>" and "\<alpha> \<le> 2*pi"
  shows "\<downharpoonright>\<alpha> + pi\<downharpoonleft> = \<alpha> - pi"
proof (rule canon_ang_eqI)
  show "\<exists> x::int. \<alpha> - pi - (\<alpha> + pi) = 2 * x * pi"
    by (rule_tac x="-1" in exI) auto
next
  show "- pi < \<alpha> - pi \<and> \<alpha> - pi \<le> pi"
    using assms
    by auto
qed

lemma canon_ang_minus_pi1:
  assumes "0 < \<alpha>" and "\<alpha> \<le> 2*pi"
  shows "\<downharpoonright>\<alpha> - pi\<downharpoonleft> = \<alpha> - pi"
proof (rule canon_ang_id)
  show "- pi < \<alpha> - pi \<and> \<alpha> - pi \<le> pi"
    using assms
    by auto
qed

text \<open>Canonical angle of angles from $(-2\pi, 0]$ shifted by $\pi$\<close>

lemma canon_ang_plus_pi2:
  assumes "-2*pi < \<alpha>" and "\<alpha> \<le> 0"
  shows "\<downharpoonright>\<alpha> + pi\<downharpoonleft> = \<alpha> + pi"
proof (rule canon_ang_id)
  show "- pi < \<alpha> + pi \<and> \<alpha> + pi \<le> pi"
    using assms
    by auto
qed

lemma canon_ang_minus_pi2:
  assumes "-2*pi < \<alpha>" and "\<alpha> \<le> 0"
  shows "\<downharpoonright>\<alpha> - pi\<downharpoonleft> = \<alpha> + pi"
proof (rule canon_ang_eqI)
  show "\<exists> x::int. \<alpha> + pi - (\<alpha> - pi) = 2 * x * pi"
    by (rule_tac x="1" in exI) auto
next
  show "- pi < \<alpha> + pi \<and> \<alpha> + pi \<le> pi"
    using assms
    by auto
qed

text \<open>Canonical angle of angle in $(\pi, 3\pi]$.\<close>
lemma canon_ang_pi_3pi:
  assumes "pi < \<alpha>" and "\<alpha> \<le> 3 * pi"
  shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha> - 2*pi"
proof-
  have "\<exists>x. - pi = pi * real_of_int x"
    by (rule_tac x="-1" in exI, simp)
  thus ?thesis
    using assms canon_ang_eqI[of "\<alpha> - 2*pi" "\<alpha>"]
    by auto
qed

text \<open>Canonical angle of angle in $(-3\pi, -\pi]$.\<close>
lemma canon_ang_minus_3pi_minus_pi:
  assumes "-3*pi < \<alpha>" and "\<alpha> \<le> -pi"
  shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha> + 2*pi"
proof-
  have "\<exists>x. pi = pi * real_of_int x"
    by (rule_tac x="1" in exI, simp)
  thus ?thesis
    using assms canon_ang_eqI[of "\<alpha> + 2*pi" "\<alpha>"]
    by auto
qed

text \<open>Canonical angles for some special angles\<close>

lemma zero_canonical [simp]:
  shows "\<downharpoonright>0\<downharpoonleft> = 0"
  using canon_ang_eqI[of 0 0]
  by simp

lemma pi_canonical [simp]:
  shows "\<downharpoonright>pi\<downharpoonleft> = pi"
  by (simp add: canon_ang_id)

lemma two_pi_canonical [simp]:
  shows "\<downharpoonright>2 * pi\<downharpoonleft> = 0"
  using canon_ang_plus_pi1[of "pi"]
  by simp

text \<open>Canonization preserves sine and cosine\<close>
lemma canon_ang_sin [simp]:
  shows "sin \<downharpoonright>\<alpha>\<downharpoonleft> = sin \<alpha>"
proof-
  obtain x::int where "\<alpha> = \<downharpoonright>\<alpha>\<downharpoonleft> + pi * (x * 2)"
    using canon_ang(3)[of \<alpha>]
    by (auto simp add: field_simps)
  thus ?thesis
    using sin_periodic_int[of "\<downharpoonright>\<alpha>\<downharpoonleft>" x]
    by (simp add: field_simps)
qed

lemma canon_ang_cos [simp]:
  shows "cos \<downharpoonright>\<alpha>\<downharpoonleft> = cos \<alpha>"
proof-
  obtain x::int where "\<alpha> = \<downharpoonright>\<alpha>\<downharpoonleft> + pi * (x * 2)"
    using canon_ang(3)[of \<alpha>]
    by (auto simp add: field_simps)
  thus ?thesis
    using cos_periodic_int[of "\<downharpoonright>\<alpha>\<downharpoonleft>" x]
    by (simp add: field_simps)
qed

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_29
  imports "../../Test_Base"
begin

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (nil2) z = z"
| "qrev (cons2 z2 xs) z = qrev xs (cons2 z2 z)"

lemma app_assoc: "x (x y z) w = x y (x z w)" by (induction y, auto)
lemma qrev_rev: "qrev y z = x (rev y) z"
  apply(induction y arbitrary: z, auto)
  apply(simp add: app_assoc)
  done
lemma app_nil: "x y nil2 = y" by(induction y, auto)
lemma rev_app: "rev (x y z) = x (rev z) (rev y)"
  apply(induction y, auto)
   apply(simp add: app_nil)
  using app_assoc apply(auto)
  done
theorem property0 :
  "((rev (qrev y (nil2))) = y)"
  apply(induction y, auto)
  apply(simp add: qrev_rev)
  apply(simp add: rev_app)
  done
end


(*
  File: FixedPt.thy
  Author: Bohua Zhan

  Fixed point theorems, roughly following FixedPt in Isabelle/ZF.
*)

theory FixedPt
  imports OrderRel
begin

(* h is a function from Pow(D) to itself, and is monotone in the sense that
   given two subsets W and X of D such that W \<subseteq> X, then h(W) \<subseteq> h(X). *)
definition bnd_mono :: "i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> o" where [rewrite]:
  "bnd_mono(D,h) \<longleftrightarrow> (h(D) \<subseteq> D \<and> (\<forall>W X. W \<subseteq> X \<longrightarrow> X \<subseteq> D \<longrightarrow> h(W) \<subseteq> h(X)))"

(* Least fixed point of h. *)
definition lfp :: "i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> i" where [rewrite]:
  "lfp(D,h) = \<Inter>({X \<in> Pow(D). h(X) \<subseteq> X})"
setup {* add_prfstep_check_req ("lfp(D,h)", "bnd_mono(D,h)") *}

(* Greatest fixed point of h. *)
definition gfp :: "i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> i" where [rewrite]:
  "gfp(D,h) = \<Union>({X \<in> Pow(D). X \<subseteq> h(X)})"

section \<open>Monotone operators\<close>

lemma bnd_monoD1 [forward]: "bnd_mono(D,h) \<Longrightarrow> h(D) \<subseteq> D" by auto2
lemma bnd_monoD2 [backward2]: "bnd_mono(D,h) \<Longrightarrow> W \<subseteq> X \<Longrightarrow> X \<subseteq> D \<Longrightarrow> h(W) \<subseteq> h(X)" by auto2
setup {* del_prfstep_thm_eqforward @{thm bnd_mono_def} *}

lemma bnd_mono_subset: "bnd_mono(D,h) \<Longrightarrow> X \<subseteq> D \<Longrightarrow> h(X) \<subseteq> D" by auto2
lemma bnd_mono_Un: "bnd_mono(D,h) \<Longrightarrow> A \<subseteq> D \<Longrightarrow> B \<subseteq> D \<Longrightarrow> h(A) \<union> h(B) \<subseteq> h(A \<union> B)" by auto2

section \<open>Knaster-Tarski Theorem using lfp\<close>

lemma lfp_set_nonempty [backward2]:
  "h(A) \<subseteq> A \<Longrightarrow> A \<subseteq> D \<Longrightarrow> {X \<in> Pow(D). h(X) \<subseteq> X} \<noteq> \<emptyset>"
@proof @have "A \<in> {X \<in> Pow(D). h(X) \<subseteq> X}" @qed

(* lfp(D,h) is a subset of any fixed point of h. *)
lemma lfp_lowerbound [backward]:
  "h(A) \<subseteq> A \<Longrightarrow> A \<subseteq> D \<Longrightarrow> lfp(D,h) \<subseteq> A" by auto2

(* If A is a subset of any fixed point of h, then A is a subset of lfp(D,h). *)
lemma lfp_greatest [backward2]:
  "h(D) \<subseteq> D \<Longrightarrow> \<forall>X. h(X) \<subseteq> X \<longrightarrow> X \<subseteq> D \<longrightarrow> A \<subseteq> X \<Longrightarrow> A \<subseteq> lfp(D,h)" by auto2

(* lfp is indeed a fixed point of h. *)
lemma lfp_unfold [rewrite]:
  "bnd_mono(D,h) \<Longrightarrow> h(lfp(D,h)) = lfp(D,h)"
@proof @have  "h(lfp(D,h)) \<subseteq> lfp(D,h)" @qed

section \<open>General induction rule for least fixed points\<close>

(* Induction rule: given predicate P and let A be the subset of lfp that satisfies P.
   If everything in h(A) also satisfies P, then in fact A = lfp. *)
lemma lfp_induct [script_induct]:
  "a \<in> lfp(D,h) \<Longrightarrow> bnd_mono(D,h) \<Longrightarrow> \<forall>x\<in>h(Collect(lfp(D,h),P)). P(x) \<Longrightarrow> P(a)"
@proof @have "h(Collect(lfp(D,h),P)) \<subseteq> lfp(D,h)" @qed

lemma lfp_Int_lowerbound [backward1]:
  "bnd_mono(D,h) \<Longrightarrow> h(D \<inter> A) \<subseteq> A \<Longrightarrow> lfp(D,h) \<subseteq> A" by auto2

lemma lfp_mono:
  "bnd_mono(D,h) \<Longrightarrow> bnd_mono(E,i) \<Longrightarrow> \<forall>X. X \<subseteq> D \<longrightarrow> h(X) \<subseteq> i(X) \<Longrightarrow>
   lfp(D,h) \<subseteq> lfp(E,i)"
@proof
  @have "\<forall>X. i(X) \<subseteq> X \<longrightarrow> X \<subseteq> E \<longrightarrow> lfp(D,h) \<subseteq> X" @with
    @have "h(D \<inter> X) \<subseteq> X" @with @have "h(D \<inter> X) \<subseteq> i(D \<inter> X)" @end @end
@qed

lemma lfp_cong:
  "\<forall>X. X \<subseteq> D \<longrightarrow> h(X) = h'(X) \<Longrightarrow> lfp(D,h) = lfp(D,h')" by auto2
setup {* del_prfstep_thm @{thm lfp_def} *}

section \<open>Knaster-Tarski Theorem using gfp\<close>

(* Any fixed point of h is contained in gfp(D,h). *)
lemma gfp_upperbound [backward]:
  "A \<subseteq> h(A) \<Longrightarrow> A \<subseteq> D \<Longrightarrow> A \<subseteq> gfp(D,h)" by auto2

(* If A contains any fixed point of h, then A contains gfp(D,h). *)
lemma gfp_least [backward2]:
  "h(D) \<subseteq> D \<Longrightarrow> \<forall>X. X \<subseteq> h(X) \<longrightarrow> X \<subseteq> D \<longrightarrow> X \<subseteq> A \<Longrightarrow> gfp(D,h) \<subseteq> A" by auto2

(* gfp is indeed a fixed point of h. *)
lemma gfp_unfold [rewrite]:
  "bnd_mono(D,h) \<Longrightarrow> h(gfp(D,h)) = gfp(D,h)"
@proof @have "gfp(D,h) \<subseteq> h(gfp(D,h))" @qed

section \<open>General induction rule for greatest fixed points\<close>

lemma gfp_weak_coinduct:
  "a \<in> X \<Longrightarrow> X \<subseteq> h(X) \<Longrightarrow> X \<subseteq> D \<Longrightarrow> a \<in> gfp(D,h)" by auto2

lemma gfp_coinduct_lemma [backward1]:
  "X \<subseteq> D \<Longrightarrow> bnd_mono(D,h) \<Longrightarrow> X \<subseteq> h(X \<union> gfp(D,h)) \<Longrightarrow> X \<union> gfp(D,h) \<subseteq> h(X \<union> gfp(D,h))" by auto2

lemma gfp_coinduct:
  "bnd_mono(D,h) \<Longrightarrow> a \<in> X \<Longrightarrow> X \<subseteq> h(X \<union> gfp(D,h)) \<Longrightarrow> X \<subseteq> D \<Longrightarrow> a \<in> gfp(D,h)" by auto2

lemma gfp_mono:
  "bnd_mono(D,h) \<Longrightarrow> D \<subseteq> E \<Longrightarrow> \<forall>X. X \<subseteq> D \<longrightarrow> h(X) \<subseteq> i(X) \<Longrightarrow> gfp(D,h) \<subseteq> gfp(E,i)" by auto2
setup {* del_prfstep_thm @{thm gfp_def} *}

section \<open>Transitive closure\<close>

definition rtrans_cl :: "i \<Rightarrow> i" where [rewrite]:
  "rtrans_cl(r) = lfp(gr_field(r)\<times>gr_field(r), \<lambda>s. gr_id(gr_field(r)) \<union> (r \<circ>\<^sub>g s))"

lemma rtrans_cl_bnd_mono [resolve]:
  "bnd_mono(gr_field(r)\<times>gr_field(r), \<lambda>s. gr_id(gr_field(r)) \<union> (r \<circ>\<^sub>g s))" by auto2

lemma rtrans_cl_eq [rewrite]:
  "rtrans_cl(r) = gr_id(gr_field(r)) \<union> (r \<circ>\<^sub>g rtrans_cl(r))" by auto2

lemma rtrans_cl_is_graph [forward]: "is_graph(r) \<Longrightarrow> is_graph(rtrans_cl(r))" by auto2
lemma rtrans_clI1 [typing2]: "a \<in> gr_field(r) \<Longrightarrow> \<langle>a,a\<rangle>\<in>rtrans_cl(r)" by auto2
lemma rtrans_clI2 [typing2]: "\<langle>a,b\<rangle> \<in> r \<Longrightarrow> \<langle>a,b\<rangle> \<in> rtrans_cl(r)" by auto2
lemma rtrans_clI3 [forward]: "\<langle>a,b\<rangle>\<in>rtrans_cl(r) \<Longrightarrow> \<langle>b,c\<rangle>\<in>r \<Longrightarrow> \<langle>a,c\<rangle>\<in>rtrans_cl(r)" by auto2

lemma rtrans_cl_full_induct [script_induct]:
  "x \<in> rtrans_cl(r) \<Longrightarrow> \<forall>x\<in>gr_field(r). P(\<langle>x,x\<rangle>) \<Longrightarrow>
   \<forall>x y z. P(\<langle>x,y\<rangle>) \<longrightarrow> \<langle>x,y\<rangle>\<in>rtrans_cl(r) \<longrightarrow> \<langle>y,z\<rangle>\<in>r \<longrightarrow> P(\<langle>x,z\<rangle>) \<Longrightarrow> P(x)"
@proof
  @induct "x \<in> lfp(gr_field(r)\<times>gr_field(r), \<lambda>s. gr_id(gr_field(r)) \<union> (r \<circ>\<^sub>g s))" "P(x)"
@qed
setup {* del_prfstep_thm @{thm rtrans_cl_def} *}

lemma rtrans_cl_induct [script_induct]:
  "\<langle>a,b\<rangle> \<in> rtrans_cl(r) \<Longrightarrow>
   \<forall>y z. \<langle>a,y\<rangle>\<in>rtrans_cl(r) \<longrightarrow> \<langle>y,z\<rangle>\<in>r \<longrightarrow> y \<noteq> z \<longrightarrow> P(y) \<longrightarrow> P(z) \<Longrightarrow>
   P(a) \<Longrightarrow> P(b)"
@proof
  @induct "\<langle>a,b\<rangle> \<in> rtrans_cl(r)" "fst(\<langle>a,b\<rangle>) = a \<longrightarrow> P(snd(\<langle>a,b\<rangle>))"
@qed
setup {* delete_script_induct_data @{thm rtrans_cl_full_induct} *}

lemma rtrans_cl_trans [forward]:
  "\<langle>c,a\<rangle>\<in>rtrans_cl(r) \<Longrightarrow> \<langle>a,b\<rangle>\<in>rtrans_cl(r) \<Longrightarrow> \<langle>c,b\<rangle>\<in>rtrans_cl(r)"
@proof
  @induct "\<langle>a,b\<rangle> \<in> rtrans_cl(r)" "\<langle>c,b\<rangle>\<in>rtrans_cl(r)"
@qed
setup {* del_prfstep_thm @{thm rtrans_cl_eq} *}

definition rel_rtrans_cl :: "i \<Rightarrow> i" where [rewrite]:
  "rel_rtrans_cl(R) = Order(carrier(R), \<lambda>x y. \<langle>x,y\<rangle> \<in> rtrans_cl(order_graph(R)))"

lemma rel_rtrans_cl_is_rel [typing]:
  "raworder(R) \<Longrightarrow> rel_rtrans_cl(R) \<in> raworder_space(carrier(R))" by auto2

lemma rel_rtrans_clI1:
  "raworder(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> le(rel_rtrans_cl(R),x,y)"
@proof @have "\<langle>x,y\<rangle> \<in> order_graph(R)" @qed
setup {* add_forward_prfstep_cond @{thm rel_rtrans_clI1} [with_term "rel_rtrans_cl(?R)"] *}

lemma rel_rtrans_clI2 [forward]: "raworder(R) \<Longrightarrow> trans(rel_rtrans_cl(R))" by auto2
lemma rel_rtrans_clI3 [forward]: "refl_order(R) \<Longrightarrow> preorder(rel_rtrans_cl(R))"
@proof
  @let "S = rel_rtrans_cl(R)"
  @have "\<forall>x\<in>.S. x \<le>\<^sub>S x" @with @have "\<langle>x,x\<rangle> \<in> order_graph(R)" @end
@qed

lemma rel_rtrans_cl_induct [script_induct]:
  "le(rel_rtrans_cl(R),a,b) \<Longrightarrow> raworder(R) \<Longrightarrow>
   \<forall>y z. le(rel_rtrans_cl(R),a,y) \<longrightarrow> y <\<^sub>R z \<longrightarrow> P(y) \<longrightarrow> P(z) \<Longrightarrow> P(a) \<Longrightarrow> P(b)"
@proof
  @induct "\<langle>a,b\<rangle>\<in>rtrans_cl(order_graph(R))" "P(b)"
@qed

setup {* del_prfstep_thm @{thm rel_rtrans_cl_def} *}

end