(*  Title:      ZF/AC/AC_Equiv.thy
    Author:     Krzysztof Grabczewski

Axioms AC1 -- AC19 come from "Equivalents of the Axiom of Choice, II"
by H. Rubin and J.E. Rubin, 1985.

Axiom AC0 comes from "Axiomatic Set Theory" by P. Suppes, 1972.

Some Isabelle proofs of equivalences of these axioms are formalizations of
proofs presented by the Rubins.  The others are based on the Rubins' proofs,
but slightly changed.
*)

theory AC_Equiv
imports ZF
begin (*obviously not ZFC*)

(* Well Ordering Theorems *)

definition
    "WO1 == \<forall>A. \<exists>R. well_ord(A,R)"

definition
    "WO2 == \<forall>A. \<exists>a. Ord(a) & A\<approx>a"

definition
    "WO3 == \<forall>A. \<exists>a. Ord(a) & (\<exists>b. b \<subseteq> a & A\<approx>b)"

definition
    "WO4(m) == \<forall>A. \<exists>a f. Ord(a) & domain(f)=a &
                         (\<Union>b<a. f`b) = A & (\<forall>b<a. f`b \<lesssim> m)"

definition
    "WO5 == \<exists>m \<in> nat. 1\<le>m & WO4(m)"

definition
    "WO6 == \<forall>A. \<exists>m \<in> nat. 1\<le>m & (\<exists>a f. Ord(a) & domain(f)=a
                               & (\<Union>b<a. f`b) = A & (\<forall>b<a. f`b \<lesssim> m))"

definition
    "WO7 == \<forall>A. Finite(A) \<longleftrightarrow> (\<forall>R. well_ord(A,R) \<longrightarrow> well_ord(A,converse(R)))"

definition
    "WO8 == \<forall>A. (\<exists>f. f \<in> (\<Prod>X \<in> A. X)) \<longrightarrow> (\<exists>R. well_ord(A,R))"

definition
(* Auxiliary concepts needed below *)
  pairwise_disjoint :: "i => o"  where
    "pairwise_disjoint(A) == \<forall>A1 \<in> A. \<forall>A2 \<in> A. A1 \<inter> A2 \<noteq> 0 \<longrightarrow> A1=A2"

definition
  sets_of_size_between :: "[i, i, i] => o"  where
    "sets_of_size_between(A,m,n) == \<forall>B \<in> A. m \<lesssim> B & B \<lesssim> n"

(* Axioms of Choice *)
definition
    "AC0 == \<forall>A. \<exists>f. f \<in> (\<Prod>X \<in> Pow(A)-{0}. X)"

definition
    "AC1 == \<forall>A. 0\<notin>A \<longrightarrow> (\<exists>f. f \<in> (\<Prod>X \<in> A. X))"

definition
    "AC2 == \<forall>A. 0\<notin>A & pairwise_disjoint(A)
                   \<longrightarrow> (\<exists>C. \<forall>B \<in> A. \<exists>y. B \<inter> C = {y})"
definition
    "AC3 == \<forall>A B. \<forall>f \<in> A->B. \<exists>g. g \<in> (\<Prod>x \<in> {a \<in> A. f`a\<noteq>0}. f`x)"

definition
    "AC4 == \<forall>R A B. (R \<subseteq> A*B \<longrightarrow> (\<exists>f. f \<in> (\<Prod>x \<in> domain(R). R``{x})))"

definition
    "AC5 == \<forall>A B. \<forall>f \<in> A->B. \<exists>g \<in> range(f)->A. \<forall>x \<in> domain(g). f`(g`x) = x"

definition
    "AC6 == \<forall>A. 0\<notin>A \<longrightarrow> (\<Prod>B \<in> A. B)\<noteq>0"

definition
    "AC7 == \<forall>A. 0\<notin>A & (\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1\<approx>B2) \<longrightarrow> (\<Prod>B \<in> A. B) \<noteq> 0"

definition
    "AC8 == \<forall>A. (\<forall>B \<in> A. \<exists>B1 B2. B=<B1,B2> & B1\<approx>B2)
                   \<longrightarrow> (\<exists>f. \<forall>B \<in> A. f`B \<in> bij(fst(B),snd(B)))"

definition
    "AC9 == \<forall>A. (\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1\<approx>B2) \<longrightarrow>
                   (\<exists>f. \<forall>B1 \<in> A. \<forall>B2 \<in> A. f`<B1,B2> \<in> bij(B1,B2))"

definition
    "AC10(n) ==  \<forall>A. (\<forall>B \<in> A. ~Finite(B)) \<longrightarrow>
                   (\<exists>f. \<forall>B \<in> A. (pairwise_disjoint(f`B) &
                   sets_of_size_between(f`B, 2, succ(n)) & \<Union>(f`B)=B))"

definition
    "AC11 == \<exists>n \<in> nat. 1\<le>n & AC10(n)"

definition
    "AC12 == \<forall>A. (\<forall>B \<in> A. ~Finite(B)) \<longrightarrow>
                 (\<exists>n \<in> nat. 1\<le>n & (\<exists>f. \<forall>B \<in> A. (pairwise_disjoint(f`B) &
                      sets_of_size_between(f`B, 2, succ(n)) & \<Union>(f`B)=B)))"

definition
    "AC13(m) == \<forall>A. 0\<notin>A \<longrightarrow> (\<exists>f. \<forall>B \<in> A. f`B\<noteq>0 & f`B \<subseteq> B & f`B \<lesssim> m)"

definition
    "AC14 == \<exists>m \<in> nat. 1\<le>m & AC13(m)"

definition
    "AC15 == \<forall>A. 0\<notin>A \<longrightarrow>
                 (\<exists>m \<in> nat. 1\<le>m & (\<exists>f. \<forall>B \<in> A. f`B\<noteq>0 & f`B \<subseteq> B & f`B \<lesssim> m))"

definition
    "AC16(n, k)  ==
       \<forall>A. ~Finite(A) \<longrightarrow>
           (\<exists>T. T \<subseteq> {X \<in> Pow(A). X\<approx>succ(n)} &
           (\<forall>X \<in> {X \<in> Pow(A). X\<approx>succ(k)}. \<exists>! Y. Y \<in> T & X \<subseteq> Y))"

definition
    "AC17 == \<forall>A. \<forall>g \<in> (Pow(A)-{0} -> A) -> Pow(A)-{0}.
                   \<exists>f \<in> Pow(A)-{0} -> A. f`(g`f) \<in> g`f"

locale AC18 =
  assumes AC18: "A\<noteq>0 & (\<forall>a \<in> A. B(a) \<noteq> 0) \<longrightarrow>
    ((\<Inter>a \<in> A. \<Union>b \<in> B(a). X(a,b)) =
      (\<Union>f \<in> \<Prod>a \<in> A. B(a). \<Inter>a \<in> A. X(a, f`a)))"
  \<comment> \<open>AC18 cannot be expressed within the object-logic\<close>

definition
    "AC19 == \<forall>A. A\<noteq>0 & 0\<notin>A \<longrightarrow> ((\<Inter>a \<in> A. \<Union>b \<in> a. b) =
                   (\<Union>f \<in> (\<Prod>B \<in> A. B). \<Inter>a \<in> A. f`a))"

(* ********************************************************************** *)
(*                    Theorems concerning ordinals                        *)
(* ********************************************************************** *)

(* lemma for ordertype_Int *)
lemma rvimage_id: "rvimage(A,id(A),r) = r \<inter> A*A"
apply (unfold rvimage_def)
apply (rule equalityI, safe)
apply (drule_tac P = "%a. <id (A) `xb,a>:r" in id_conv [THEN subst],
       assumption)
apply (drule_tac P = "%a. <a,ya>:r" in id_conv [THEN subst], (assumption+))
apply (fast intro: id_conv [THEN ssubst])
done

(* used only in Hartog.ML *)
lemma ordertype_Int:
     "well_ord(A,r) ==> ordertype(A, r \<inter> A*A) = ordertype(A,r)"
apply (rule_tac P = "%a. ordertype (A,a) =ordertype (A,r) " in rvimage_id [THEN subst])
apply (erule id_bij [THEN bij_ordertype_vimage])
done

lemma lam_sing_bij: "(\<lambda>x \<in> A. {x}) \<in> bij(A, {{x}. x \<in> A})"
apply (rule_tac d = "%z. THE x. z={x}" in lam_bijective)
apply (auto simp add: the_equality)
done

lemma inj_strengthen_type:
     "[| f \<in> inj(A, B);  !!a. a \<in> A ==> f`a \<in> C |] ==> f \<in> inj(A,C)"
by (unfold inj_def, blast intro: Pi_type)

(* ********************************************************************** *)
(* Another elimination rule for \<exists>!                                       *)
(* ********************************************************************** *)

lemma ex1_two_eq: "[| \<exists>! x. P(x); P(x); P(y) |] ==> x=y"
by blast

(* ********************************************************************** *)
(* Lemmas used in the proofs like WO? ==> AC?                             *)
(* ********************************************************************** *)

lemma first_in_B:
     "[| well_ord(\<Union>(A),r); 0 \<notin> A; B \<in> A |] ==> (THE b. first(b,B,r)) \<in> B"
by (blast dest!: well_ord_imp_ex1_first
                    [THEN theI, THEN first_def [THEN def_imp_iff, THEN iffD1]])

lemma ex_choice_fun: "[| well_ord(\<Union>(A), R); 0 \<notin> A |] ==> \<exists>f. f \<in> (\<Prod>X \<in> A. X)"
by (fast elim!: first_in_B intro!: lam_type)

lemma ex_choice_fun_Pow: "well_ord(A, R) ==> \<exists>f. f \<in> (\<Prod>X \<in> Pow(A)-{0}. X)"
by (fast elim!: well_ord_subset [THEN ex_choice_fun])

(* ********************************************************************** *)
(* Lemmas needed to state when a finite relation is a function.           *)
(*     The criteria are cardinalities of the relation and its domain.     *)
(*     Used in WO6WO1.ML                                                  *)
(* ********************************************************************** *)

(*Using AC we could trivially prove, for all u, domain(u) \<lesssim> u*)
lemma lepoll_m_imp_domain_lepoll_m:
     "[| m \<in> nat; u \<lesssim> m |] ==> domain(u) \<lesssim> m"
apply (unfold lepoll_def)
apply (erule exE)
apply (rule_tac x = "\<lambda>x \<in> domain(u). \<mu> i. \<exists>y. <x,y> \<in> u & f`<x,y> = i"
       in exI)
apply (rule_tac d = "%y. fst (converse(f) ` y) " in lam_injective)
apply (fast intro: LeastI2 nat_into_Ord [THEN Ord_in_Ord]
                           inj_is_fun [THEN apply_type])
apply (erule domainE)
apply (frule inj_is_fun [THEN apply_type], assumption)
apply (rule LeastI2)
apply (auto elim!: nat_into_Ord [THEN Ord_in_Ord])
done

lemma rel_domain_ex1:
    "[| succ(m) \<lesssim> domain(r); r \<lesssim> succ(m); m \<in> nat |] ==> function(r)"
apply (unfold function_def, safe)
apply (rule ccontr)
apply (fast elim!: lepoll_trans [THEN succ_lepoll_natE]
                   lepoll_m_imp_domain_lepoll_m [OF _ Diff_sing_lepoll]
            elim: domain_Diff_eq [OF _ not_sym, THEN subst])
done

lemma rel_is_fun:
     "[| succ(m) \<lesssim> domain(r);  r \<lesssim> succ(m);  m \<in> nat;
         r \<subseteq> A*B; A=domain(r) |] ==> r \<in> A->B"
by (simp add: Pi_iff rel_domain_ex1)

end


theory Desargues_3D
  imports Main Higher_Projective_Space_Rank_Axioms Matroid_Rank_Properties
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We prove Desargues's theorem: if two triangles ABC and A'B'C' are perspective from a point P (ie.
the lines AA', BB' and CC' are concurrent in P), then they are perspective from a line (ie. the points
\<open>\<alpha> = BC \<inter> B'C'\<close>, \<open>\<beta> = AC \<inter> A'C'\<close> and \<open>\<gamma> = AB \<inter> A'B'\<close> are collinear).
In this file we restrict ourself to the case where the two triangles ABC and A'B'C' are not coplanar.
\<close>

section \<open>Desargues's Theorem: The Non-coplanar Case\<close>

context higher_projective_space_rank
begin

definition desargues_config_3D ::
  "['point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point] => bool"
  where "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma> \<equiv> rk {A, B, C} = 3 \<and> rk {A', B', C'} = 3 \<and>
rk {A, A', P} = 2 \<and> rk {B, B', P} = 2 \<and> rk {C, C', P} = 2 \<and> rk {A, B, C, A', B', C'} \<ge> 4 \<and>
rk {B, C, \<alpha>} = 2 \<and> rk {B', C', \<alpha>} = 2 \<and> rk {A, C, \<beta>} = 2 \<and> rk {A', C', \<beta>} = 2 \<and> rk {A, B, \<gamma>} = 2 \<and>
rk {A', B', \<gamma>} = 2"

lemma coplanar_4 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2"
  shows "rk {A, B, C, \<alpha>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>} \<ge> 3"
    using matroid_ax_2
    by (metis assms(1) empty_subsetI insert_mono)
  have "rk {A, B, C, \<alpha>} + rk {B, C} \<le> rk {A, B, C} + rk {B, C, \<alpha>}"
    using matroid_ax_3_alt
    by (metis Un_insert_right add_One_commute add_mono assms(1) assms(2) matroid_ax_2_alt
        nat_1_add_1 numeral_plus_one rk_singleton semiring_norm(3) sup_bot.right_neutral)
  then have f2:"rk {A, B, C, \<alpha>} \<le> 3"
    by (metis Un_insert_right add_One_commute assms(2) matroid_ax_2_alt numeral_plus_one
        semiring_norm(3) sup_bot.right_neutral)
  from f1 and f2 show "rk {A, B, C, \<alpha>} = 3"
    by auto
qed

lemma desargues_config_3D_coplanar_4 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>} = 3" and "rk {A', B', C', \<alpha>} = 3"
proof-
  show "rk {A, B, C, \<alpha>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4
    by blast
  show "rk {A', B', C', \<alpha>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4
    by blast
qed

lemma coplanar_4_bis :
  assumes "rk {A, B, C} = 3" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<beta>} = 3"
  by (smt assms(1) assms(2) coplanar_4 insert_commute)

lemma desargues_config_3D_coplanar_4_bis :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<beta>} = 3" and "rk {A', B', C', \<beta>} = 3"
proof-
  show "rk {A, B, C, \<beta>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_bis
    by auto
  show "rk {A', B', C', \<beta>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_bis
    by auto
qed

lemma coplanar_4_ter :
  assumes "rk {A, B, C} = 3" and "rk {A, B, \<gamma>} = 2"
  shows "rk {A, B, C, \<gamma>} = 3"
  by (smt assms(1) assms(2) coplanar_4 insert_commute)

lemma desargues_config_3D_coplanar_4_ter :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<gamma>} = 3" and "rk {A', B', C', \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_ter
    by auto
  show "rk {A', B', C', \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_ter
    by auto
qed

lemma coplanar_5 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<alpha>, \<beta>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>} = 3"
    using coplanar_4
    by (smt One_nat_def Un_assoc Un_commute add.commute add_Suc_right assms(1) assms(2) insert_is_Un
        le_antisym matroid_ax_2_alt numeral_2_eq_2 numeral_3_eq_3 one_add_one)
  have f2:"rk {A, B, C, \<beta>} = 3"
    using coplanar_4_bis
    by (smt One_nat_def Un_assoc Un_commute add.commute add_Suc_right assms(1) assms(3) insert_is_Un
        le_antisym matroid_ax_2_alt numeral_2_eq_2 numeral_3_eq_3 one_add_one)
  from f1 and f2 show "rk {A, B, C, \<alpha>, \<beta>} = 3"
    using matroid_ax_3_alt'
    by (metis Un_assoc assms(1) insert_is_Un)
qed

lemma desargues_config_3D_coplanar_5 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<beta>} = 3" and "rk {A', B', C', \<alpha>, \<beta>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<beta>} = 3"
    using assms desargues_config_3D_def coplanar_5
    by auto
  show "rk {A', B', C', \<alpha>, \<beta>} = 3"
    using assms desargues_config_3D_def coplanar_5
    by auto
qed

lemma coplanar_5_bis :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, B, \<gamma>} = 2"
  shows "rk {A, B, C, \<alpha>, \<gamma>} = 3"
  by (smt assms coplanar_5 insert_commute)

lemma desargues_config_3D_coplanar_5_bis :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<gamma>} = 3" and "rk {A', B', C', \<alpha>, \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_5_bis
    by auto
  show "rk {A', B', C', \<alpha>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_5_bis
    by auto
qed

lemma coplanar_6 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, B, \<gamma>} = 2" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>, \<gamma>} = 3"
    using coplanar_5_bis assms(1) assms(2) assms(3)
    by auto
  have f2:"rk {A, B, C, \<alpha>, \<beta>} = 3"
    using coplanar_5 assms(1) assms(2) assms(4)
    by auto
  have f3:"rk {A, B, C, \<alpha>} = 3"
    using coplanar_4 assms(1) assms(2)
    by auto
  from f1 and f2 and f3 show "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
    using matroid_ax_3_alt'[of "{A, B, C, \<alpha>}" "\<beta>" "\<gamma>"]
    by (metis Un_insert_left sup_bot.left_neutral)
qed

lemma desargues_config_3D_coplanar_6 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3" and "rk {A', B', C', \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_6
    by auto
  show "rk {A', B', C', \<alpha>, \<beta>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_6
    by auto
qed

lemma desargues_config_3D_non_coplanar :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>} \<ge> 4"
proof-
  have "rk {A, B, C, A', B', C'} \<le> rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_2
    by auto
  thus "4 \<le> rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_2 assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by linarith
qed

theorem desargues_3D :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>} + rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_3_alt[of "{\<alpha>, \<beta>, \<gamma>}" "{A, B, C, \<alpha>, \<beta>, \<gamma>}" "{A', B', C', \<alpha>, \<beta>, \<gamma>}"]
    by (simp add: insert_commute)
  then have "rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {A', B', C', \<alpha>, \<beta>, \<gamma>} - rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    by linarith
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using assms desargues_config_3D_coplanar_6 desargues_config_3D_non_coplanar
    by fastforce
qed

end

end


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

section \<open>Terms over an alphabet\<close>

theory Term imports ZF begin

text \<open>
  Illustrates the list functor (essentially the same type as in \<open>Trees_Forest\<close>).
\<close>

consts
  "term" :: "i => i"

datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
  monos list_mono
  type_elims list_univ [THEN subsetD, elim_format]

declare Apply [TC]

definition
  term_rec :: "[i, [i, i, i] => i] => i"  where
  "term_rec(t,d) ==
    Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"

definition
  term_map :: "[i => i, i] => i"  where
  "term_map(f,t) == term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"

definition
  term_size :: "i => i"  where
  "term_size(t) == term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"

definition
  reflect :: "i => i"  where
  "reflect(t) == term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"

definition
  preorder :: "i => i"  where
  "preorder(t) == term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"

definition
  postorder :: "i => i"  where
  "postorder(t) == term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"

lemma term_unfold: "term(A) = A * list(term(A))"
  by (fast intro!: term.intros [unfolded term.con_defs]
    elim: term.cases [unfolded term.con_defs])

lemma term_induct2:
  "[| t \<in> term(A);
      !!x.      [| x \<in> A |] ==> P(Apply(x,Nil));
      !!x z zs. [| x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
                |] ==> P(Apply(x, Cons(z,zs)))
     |] ==> P(t)"
  \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> followed by induction on \<^term>\<open>list\<close>.\<close>
  apply (induct_tac t)
  apply (erule list.induct)
   apply (auto dest: list_CollectD)
  done

lemma term_induct_eqn [consumes 1, case_names Apply]:
  "[| t \<in> term(A);
      !!x zs. [| x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs) |] ==>
              f(Apply(x,zs)) = g(Apply(x,zs))
   |] ==> f(t) = g(t)"
  \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> to prove an equation.\<close>
  apply (induct_tac t)
  apply (auto dest: map_list_Collect list_CollectD)
  done

text \<open>
  \medskip Lemmas to justify using \<^term>\<open>term\<close> in other recursive
  type definitions.
\<close>

lemma term_mono: "A \<subseteq> B ==> term(A) \<subseteq> term(B)"
  apply (unfold term.defs)
  apply (rule lfp_mono)
    apply (rule term.bnd_mono)+
  apply (rule univ_mono basic_monos| assumption)+
  done

lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
  apply (unfold term.defs term.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply safe
  apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
  done

lemma term_subset_univ: "A \<subseteq> univ(B) ==> term(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule term_mono)
  apply (rule term_univ)
  done

lemma term_into_univ: "[| t \<in> term(A);  A \<subseteq> univ(B) |] ==> t \<in> univ(B)"
  by (rule term_subset_univ [THEN subsetD])

text \<open>
  \medskip \<open>term_rec\<close> -- by \<open>Vset\<close> recursion.
\<close>

lemma map_lemma: "[| l \<in> list(A);  Ord(i);  rank(l)<i |]
    ==> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
  \<comment> \<open>\<^term>\<open>map\<close> works correctly on the underlying list of terms.\<close>
  apply (induct set: list)
   apply simp
  apply (subgoal_tac "rank (a) <i & rank (l) < i")
   apply (simp add: rank_of_Ord)
  apply (simp add: list.con_defs)
  apply (blast dest: rank_rls [THEN lt_trans])
  done

lemma term_rec [simp]: "ts \<in> list(A) ==>
  term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
  \<comment> \<open>Typing premise is necessary to invoke \<open>map_lemma\<close>.\<close>
  apply (rule term_rec_def [THEN def_Vrec, THEN trans])
  apply (unfold term.con_defs)
  apply (simp add: rank_pair2 map_lemma)
  done

lemma term_rec_type:
  assumes t: "t \<in> term(A)"
    and a: "!!x zs r. [| x \<in> A;  zs: list(term(A));
                   r \<in> list(\<Union>t \<in> term(A). C(t)) |]
                ==> d(x, zs, r): C(Apply(x,zs))"
  shows "term_rec(t,d) \<in> C(t)"
  \<comment> \<open>Slightly odd typing condition on \<open>r\<close> in the second premise!\<close>
  using t
  apply induct
  apply (frule list_CollectD)
  apply (subst term_rec)
   apply (assumption | rule a)+
  apply (erule list.induct)
   apply auto
  done

lemma def_term_rec:
  "[| !!t. j(t)==term_rec(t,d);  ts: list(A) |] ==>
    j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
  apply (simp only:)
  apply (erule term_rec)
  done

lemma term_rec_simple_type [TC]:
  "[| t \<in> term(A);
      !!x zs r. [| x \<in> A;  zs: list(term(A));  r \<in> list(C) |]
                ==> d(x, zs, r): C
   |] ==> term_rec(t,d) \<in> C"
  apply (erule term_rec_type)
  apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
  apply simp
  done

text \<open>
  \medskip \<^term>\<open>term_map\<close>.
\<close>

lemma term_map [simp]:
  "ts \<in> list(A) ==>
    term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
  by (rule term_map_def [THEN def_term_rec])

lemma term_map_type [TC]:
    "[| t \<in> term(A);  !!x. x \<in> A ==> f(x): B |] ==> term_map(f,t) \<in> term(B)"
  apply (unfold term_map_def)
  apply (erule term_rec_simple_type)
  apply fast
  done

lemma term_map_type2 [TC]:
    "t \<in> term(A) ==> term_map(f,t) \<in> term({f(u). u \<in> A})"
  apply (erule term_map_type)
  apply (erule RepFunI)
  done

text \<open>
  \medskip \<^term>\<open>term_size\<close>.
\<close>

lemma term_size [simp]:
    "ts \<in> list(A) ==> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
  by (rule term_size_def [THEN def_term_rec])

lemma term_size_type [TC]: "t \<in> term(A) ==> term_size(t) \<in> nat"
  by (auto simp add: term_size_def)

text \<open>
  \medskip \<open>reflect\<close>.
\<close>

lemma reflect [simp]:
    "ts \<in> list(A) ==> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
  by (rule reflect_def [THEN def_term_rec])

lemma reflect_type [TC]: "t \<in> term(A) ==> reflect(t) \<in> term(A)"
  by (auto simp add: reflect_def)

text \<open>
  \medskip \<open>preorder\<close>.
\<close>

lemma preorder [simp]:
    "ts \<in> list(A) ==> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
  by (rule preorder_def [THEN def_term_rec])

lemma preorder_type [TC]: "t \<in> term(A) ==> preorder(t) \<in> list(A)"
  by (simp add: preorder_def)

text \<open>
  \medskip \<open>postorder\<close>.
\<close>

lemma postorder [simp]:
    "ts \<in> list(A) ==> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
  by (rule postorder_def [THEN def_term_rec])

lemma postorder_type [TC]: "t \<in> term(A) ==> postorder(t) \<in> list(A)"
  by (simp add: postorder_def)

text \<open>
  \medskip Theorems about \<open>term_map\<close>.
\<close>

declare map_compose [simp]

lemma term_map_ident: "t \<in> term(A) ==> term_map(\<lambda>u. u, t) = t"
  by (induct rule: term_induct_eqn) simp

lemma term_map_compose:
    "t \<in> term(A) ==> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
  by (induct rule: term_induct_eqn) simp

lemma term_map_reflect:
    "t \<in> term(A) ==> term_map(f, reflect(t)) = reflect(term_map(f,t))"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])

text \<open>
  \medskip Theorems about \<open>term_size\<close>.
\<close>

lemma term_size_term_map: "t \<in> term(A) ==> term_size(term_map(f,t)) = term_size(t)"
  by (induct rule: term_induct_eqn) simp

lemma term_size_reflect: "t \<in> term(A) ==> term_size(reflect(t)) = term_size(t)"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)

lemma term_size_length: "t \<in> term(A) ==> term_size(t) = length(preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: length_flat)

text \<open>
  \medskip Theorems about \<open>reflect\<close>.
\<close>

lemma reflect_reflect_ident: "t \<in> term(A) ==> reflect(reflect(t)) = t"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)

text \<open>
  \medskip Theorems about preorder.
\<close>

lemma preorder_term_map:
    "t \<in> term(A) ==> preorder(term_map(f,t)) = map(f, preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: map_flat)

lemma preorder_reflect_eq_rev_postorder:
    "t \<in> term(A) ==> preorder(reflect(t)) = rev(postorder(t))"
  by (induct rule: term_induct_eqn)
    (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

header {* Formalizing the IPv4-address allocation in ZeroConf *}

theory Zeroconf_Analysis
  imports "../Discrete_Time_Markov_Chain"
begin

subsection {* Definition of a ZeroConf allocation run *}

datatype zc_state = start
                  | probe nat
                  | ok
                  | error

lemma inj_probe: "inj_on probe X"
  by (simp add: inj_on_def)

instance zc_state :: countable
proof
  have "countable ({start, ok, error} \<union> probe`UNIV)"
    by auto
  also have "{start, ok, error} \<union> probe`UNIV = UNIV"
    using zc_state.nchotomy by auto
  finally show "\<exists>f::zc_state \<Rightarrow> nat. inj f"
    using inj_on_to_nat_on[of "UNIV :: zc_state set"] by auto
qed

locale Zeroconf_Analysis =
  fixes N :: nat and p q r e :: real
  assumes p: "0 < p" "p < 1" and q: "0 < q" "q < 1"
  assumes r: "0 \<le> r" and e: "0 \<le> e"
begin

interpretation pmf_as_function .

abbreviation "states == probe ` {.. N} \<union> ({start} \<union> {ok} \<union> {error})"

lift_definition \<tau> :: "zc_state \<Rightarrow> zc_state pmf" is
  "\<lambda>start   \<Rightarrow> ((\<lambda>_. 0) (probe 0 := q, ok := 1 - q))
  | probe n \<Rightarrow> if n < N then (\<lambda>_. 0) (probe (Suc n) := p, start := 1 - p)
                           else (\<lambda>_. 0) (error := p, start := 1 - p)
  | ok      \<Rightarrow> ((\<lambda>_. 0) (ok := 1))
  | error   \<Rightarrow> ((\<lambda>_. 0) (error := 1))"
  using q p
  by (auto split: zc_state.splits split_if_asm simp: setsum.If_cases
           intro!: nn_integral_count_space'[where A="states", THEN trans])

primrec \<rho> :: "zc_state \<Rightarrow> zc_state \<Rightarrow> real" where
  "\<rho> start     = (\<lambda>_. 0) (probe 0 := r, ok := r * (N + 1))"
| "\<rho> (probe n) = (if n < N then (\<lambda>_. 0) (probe (Suc n) := r) else (\<lambda>_. 0) (error := e))"
| "\<rho> ok        = (\<lambda>_. 0) (ok := 0)"
| "\<rho> error     = (\<lambda>_. 0) (error := 0)"

lemma \<rho>_nonneg'[simp]: "0 \<le> \<rho> s t"
  using r e by (cases s) auto

sublocale MC_with_rewards \<tau> \<rho> "\<lambda>s. 0"
  proof qed (simp_all add: pair_measure_countable)

subsection {* The allocation run is a rewarded DTMC *}

abbreviation "E s \<equiv> set_pmf (\<tau> s)"

lemma E_start_iff[simp]: "E start = {probe 0, ok}"
  using q unfolding set_eq_iff set_pmf_iff by transfer simp

lemma E_probe_iff[simp]:
  "E (probe n) = (if n < N then {start, probe (Suc n)} else {start, error})"
  using p q unfolding set_eq_iff set_pmf_iff by transfer simp

lemma E_ok_iff[simp]: "E ok = {ok}"
  unfolding set_eq_iff set_pmf_iff by transfer simp

lemma enabled_ok: "enabled ok \<omega> \<longleftrightarrow> \<omega> = sconst ok"
  by (simp add: enabled_iff_sconst)

lemma E_error_iff[simp]: "E error = {error}"
  unfolding set_eq_iff set_pmf_iff by transfer simp

lemma finite_E[intro, simp]: "finite (E s)"
  by (cases s) auto

lemma enabled_error: "enabled error \<omega> \<longleftrightarrow> \<omega> = sconst error"
  by (simp add: enabled_iff_sconst)

lemma pos_neg_q_pn: "0 < 1 - q * (1 - p^Suc N)"
proof -
  have "p ^ Suc N \<le> 1 ^ Suc N"
    using p by (intro power_mono) auto
  with p q have "q * (1 - p^Suc N) < 1 * 1"
    by (intro mult_strict_mono) (auto simp: field_simps simp del: power_Suc)
  then show ?thesis by simp
qed

lemma to_error: assumes "n \<le> N" shows "(probe n, error) \<in> (Sigma UNIV E)\<^sup>*"
  using `n \<le> N`
proof (induction rule: inc_induct)
  case (step n') then show ?case
    by (intro rtrancl_trans[OF r_into_rtrancl step.IH]) auto
qed auto

subsection {* Probability of a erroneous allocation *}

definition "P_err s = \<P>(\<omega> in T s. ev (HLD {error}) (s ## \<omega>))"

lemma P_err:
  defines "p_start == (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  defines "p_probe == (\<lambda>n. p ^ Suc (N - n) + (1 - p^Suc (N - n)) * p_start)"
  assumes s: "s \<in> states - {ok, error}"
  shows "P_err s = (case s of ok \<Rightarrow> 0 | error \<Rightarrow> 1 | probe n \<Rightarrow> p_probe n | start \<Rightarrow> p_start)"
    (is "\<dots> = ?E s")
  using s
proof (rule unique_les)
  have [arith]: "0 \<le> p * (q * p ^ N)"
    using p q by simp
  have p_eq: "p_start = p_probe 0 * q"
    "\<And>n. n < N \<Longrightarrow> p_probe n = p_start * (1 - p) + p_probe (Suc n) * p"
    "p_probe N = p + p_start * (1 - p)"
    using p q
    by (auto simp: p_probe_def p_start_def power_Suc[symmetric] Suc_diff_Suc divide_simps
             simp del: power_Suc)
       (auto simp: field_simps)
  fix s assume s: "s \<in> states - {ok, error}"
  then show "?E s = (\<integral>t. ?E t \<partial>\<tau> s) + 0"
    using p q
    by (subst integral_measure_pmf[of states])
       (auto split: zc_state.splits split_if_asm intro: p_eq
             simp: setsum_clauses setsum.reindex inj_probe \<tau>.rep_eq
                   setsum.If_cases if_distrib[where f="\<lambda>x. a * x" for a])
  show "\<exists>t\<in>{ok, error}. (s, t) \<in> (Sigma UNIV E)\<^sup>*"
    using s to_error by auto
  from s show "P_err s = integral\<^sup>L (measure_pmf (\<tau> s)) P_err + 0"
    unfolding P_err_def[abs_def] by (subst prob_T) (auto simp: ev_Stream)
next
  fix s assume "s \<in> {ok, error}" then show "P_err s = ?E s"
    by (auto intro!: T.prob_eq_0_AE T.prob_Collect_eq_1[THEN iffD2]
             simp: P_err_def AE_sconst ev_sconst HLD_iff ev_Stream T.prob_space
             simp del: space_T sets_T )
qed (auto intro!: integrable_measure_pmf_finite split: split_if_asm)

lemma P_err_start: "P_err start = (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
  by (simp add: P_err)

subsection {* An allocation run terminates almost surely *}

lemma states_closed:
  assumes "s \<in> states"
  assumes "(s, t) \<in> (SIGMA s:UNIV. E s - {error, ok})\<^sup>*"
  shows "t \<in> states"
  using assms(2,1) by induction (auto split: split_if_asm)

lemma finite_reached:
  assumes s: "s \<in> states" shows "finite ((SIGMA s:UNIV. E s - {error, ok})\<^sup>* `` {s})"
  using states_closed[OF s]
  by (rule_tac finite_subset[of _ states]) auto

lemma AE_reaches_error_or_ok:
  assumes s: "s \<in> states"
  shows "AE \<omega> in T s. ev (HLD {error, ok}) \<omega>"
proof (rule AE_T_ev_HLD)
  { fix t assume t: "(s, t) \<in> (SIGMA s:UNIV. E s - {error, ok})\<^sup>*"
    with states_closed[OF s t] to_error show "\<exists>t'\<in>{error, ok}. (t, t') \<in> (Sigma UNIV E)\<^sup>*"
      by auto }
qed (rule finite_reached[OF s])

subsection {* Expected runtime of an allocation run *}

definition "R s = (\<integral>\<^sup>+ \<omega>. reward_until {error, ok} s \<omega> \<partial>T s)"

lemma R_finite:
  assumes s: "s \<in> states"
  shows "R s \<noteq> \<infinity>"
  unfolding R_def
proof (rule nn_integral_reward_until_finite)
  { fix t assume "(s, t) \<in> (Sigma (- {error, ok}) E)\<^sup>*" from this s have "t \<in> states"
      by induction (auto split: split_if_asm) }
  then have "(Sigma (- {error, ok}) E)\<^sup>* `` {s} \<subseteq> states"
    by auto
  then show "finite ((Sigma (- {error, ok}) E)\<^sup>* `` {s})"
    by (auto dest: finite_subset)
qed (auto simp: AE_reaches_error_or_ok[OF s])

lemma R_nonneg: "0 \<le> R t"
  by (simp add: R_def nn_integral_nonneg)

lemma cost_from_start:
  "R start =
    (q * (r + p^Suc N * e + r * p * (1 - p^N) / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q + q * p^Suc N)"
proof -
  have "\<forall>s\<in>states. \<exists>r. R s = ereal r"
    using R_nonneg R_finite
    apply (intro ballI exI)
    apply (rule ereal_real'[symmetric])+
    apply simp
    done
  from bchoice[OF this] obtain R' where R': "\<And>s. s\<in>states \<Longrightarrow> R s = ereal (R' s)" by auto

  { fix s have "s \<in> states \<Longrightarrow> s \<noteq> error \<Longrightarrow> s \<noteq> ok \<Longrightarrow>
      R s = (\<Sum>s'\<in>states. pmf (\<tau> s) s' * (\<rho> s s' + R s'))"
      using T.emeasure_space_1 E_closed[of s]
      unfolding R_def
      apply (simp add: nn_integral_T[of _ s] nn_integral_add[of _ "T t" for t] reward_until_nonneg
          nn_integral_measure_pmf_support[of states] nn_integral_nonneg)
      apply (subst nn_integral_measure_pmf_support[of states])
      apply (simp_all add: nn_integral_nonneg subset_eq field_simps)
      done }
  then have R'_sum: "\<And>s. s \<in> states \<Longrightarrow> s \<noteq> error \<Longrightarrow> s \<noteq> ok \<Longrightarrow>
    R' s = (\<Sum>s'\<in>states. pmf (\<tau> s) s' * (\<rho> s s' + R' s'))"
    using R' by simp

  have "R ok = 0 \<and> R error = 0"
    unfolding R_def by (subst (1 2) reward_until_unfold[abs_def]) simp
  with R' have R'_ok: "R' ok = 0" and R'_error: "R' error = 0"
    by simp_all

  then have R'_start: "R' start = q * (r + R' (probe 0)) + (1 - q) * (r * (N + 1))"
    by (subst R'_sum)
       (auto simp: field_simps setsum_clauses setsum.reindex inj_probe setsum.distrib
                   setsum.If_cases if_distrib[of "\<lambda>x. a * x" for a] \<tau>.rep_eq)

  have R'_probe: "\<And>n. n < N \<Longrightarrow> R' (probe n) = p * R' (probe (Suc n)) + p * r + (1 - p) * R' start"
    using R'_error
    by (subst R'_sum)
       (auto simp: field_simps setsum_clauses setsum.reindex inj_probe setsum.distrib
                   setsum.If_cases if_distrib[of "\<lambda>x. a * x" for a] \<tau>.rep_eq)

  have R'_N: "R' (probe N) = p * e + (1 - p) * R' start"
    using R'_error by (subst R'_sum)
       (auto simp: field_simps setsum_clauses setsum.reindex inj_probe setsum.distrib
                   setsum.If_cases if_distrib[of "\<lambda>x. a * x" for a] \<tau>.rep_eq)

  { fix n
    assume "n \<le> N"
    then have "R' (probe (N - n)) =
      p ^ Suc n * e + (1 - p^n) * r * p / (1 - p) + (1 - p^Suc n) * R' start"
    proof (induct n)
      case 0 with R'_N show ?case by simp
    next
      case (Suc n)
      moreover then have "Suc (N - Suc n) = N - n" by simp
      ultimately show ?case
        using R'_probe[of "N - Suc n"] p
        by simp (simp add: field_simps)
    qed }
  from this[of N]
  have "R' (probe 0) = p ^ Suc N * e + (1 - p^N) * r * p / (1 - p) + (1 - p^Suc N) * R' start"
    by simp
  then have "R' start - q * (1 - p^Suc N) * R' start =
    q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * (N + 1))"
    by (subst R'_start) (simp, simp add: field_simps)
  then have "R' start = (q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * Suc N)) /
    (1 - q * (1 - p^Suc N))"
    using pos_neg_q_pn
    by (simp add: field_simps)
  then show ?thesis
    using R' p q by (simp add: field_simps)
qed

end

interpretation ZC!: Zeroconf_Analysis 2 "16 / 65024 :: real" "0.01" "0.002" "3600"
  by default auto

lemma "ZC.P_err start \<le> 1 / 10^12"
  unfolding ZC.P_err_start by (simp add: power_one_over[symmetric])

lemma "ZC.R start \<le> 0.007"
  unfolding ZC.cost_from_start by (simp add: power_one_over[symmetric])

end


section \<open>Cardano's formula for solving cubic equations\<close>

theory Cardanos_Formula
  imports
    Polynomial_Factorization.Explicit_Roots
    Polynomial_Interpolation.Ring_Hom_Poly
    Complex_Geometry.More_Complex
    Algebraic_Numbers.Complex_Roots_Real_Poly
begin

subsection \<open>Translation to depressed case\<close>

text \<open>Solving an arbitrary cubic equation can easily be turned into the depressed case, i.e., where
  there is no quadratic part.\<close>

lemma to_depressed_cubic: fixes a :: "'a :: field_char_0"
  assumes a: "a \<noteq> 0"
  and xy: "x = y - b / (3 * a)"
  and e: "e = (c - b^2 / (3 * a)) / a"
  and f: "f = (d + 2 * b^3 / (27 * a^2) - b * c / (3 * a)) / a"
shows "(a * x ^ 3 + b * x\<^sup>2 + c * x + d = 0) \<longleftrightarrow> y^3 + e * y + f = 0"
proof -
  let ?yexp = "y^3 + e * y + f"
  have "a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow> (a * x^3 + b * x^2 + c * x + d) / a = 0"
    using a by auto
  also have "(a * x^3 + b * x^2 + c * x + d) / a = ?yexp" unfolding xy e f power3_eq_cube power2_eq_square using a
    by (simp add: field_simps)
  finally show ?thesis .
qed

subsection \<open>Solving the depressed case in arbitrary fields\<close>

lemma cubic_depressed: fixes e :: "'a :: field_char_0"
  assumes yz: "e \<noteq> 0 \<Longrightarrow> z^2 - y * z - e / 3 = 0"
  and u: "e \<noteq> 0 \<Longrightarrow> u = z^3"
  and v: "v = - (e ^ 3 / 27)"
shows "y^3 + e * y + f = 0 \<longleftrightarrow> (if e = 0 then y^3 = -f else u\<^sup>2 + f * u + v = 0)"
proof -
  let ?yexp = "y^3 + e * y + f"
  show ?thesis
  proof (cases "e = 0")
    case False
    note yz = yz[OF False]
    from yz have eyz: "e = 3 * (z^2 - y * z)" by auto
    from yz False have z0: "z \<noteq> 0" by auto
    have "?yexp = 0 \<longleftrightarrow> z^3 * ?yexp = 0" using z0 by simp
    also have "z^3 * ?yexp = z^6 + f * z^3 - e^3/27" unfolding eyz by algebra
    also have "\<dots> = u^2 + f * u + v" unfolding u[OF False] v by algebra
    finally show ?thesis using False by auto
  next
    case True
    show ?thesis unfolding True by (auto, algebra)
  qed
qed

subsection \<open>Solving the depressed case for complex numbers\<close>

text \<open>In the complex-numbers-case, the quadratic equation for u is always solvable,
  and the main challenge here is prove that it does not matter which solution of
  the quadratic equation is considered (this is the diff:False case in the proof below.)\<close>
lemma solve_cubic_depressed_Cardano_complex: fixes e :: complex
  assumes e0: "e \<noteq> 0"
  and v: "v = - (e ^ 3 / 27)"
  and u: "u^2 + f * u + v = 0"
shows "y^3 + e * y + f = 0 \<longleftrightarrow> (\<exists> z. z^3 = u \<and> y = z - e / (3 * z))"
proof -
  from v e0 have v0: "v \<noteq> 0" by auto
  from e0 have "(if e = 0 then x else y) = y" for x y :: bool by auto
  note main = cubic_depressed[OF _ _ v, unfolded this]
  show ?thesis (is "?l = ?r")
  proof
    assume ?r
    then obtain z where z: "z^3 = u" and y: "y = z - e / (3 * z)" by auto
    from u v0 have u0: "u \<noteq> 0" by auto
    from z u0 have z0: "z \<noteq> 0" by auto
    show ?l
    proof (subst main)
      show "u\<^sup>2 + f * u + v = 0" by fact
      show "u = z^3" unfolding z by simp
      show "z\<^sup>2 - y * z - e / 3 = 0" unfolding y using z0
        by (auto simp: field_simps power2_eq_square)
    qed
  next
    assume ?l
    let ?yexp = "y^3 + e * y + f"
    have y0: "?yexp = 0" using \<open>?l\<close> by auto
    define p where "p = [: -e/3, -y, 1:]"
    have deg: "degree p = 2" unfolding p_def by auto
    define z where "z = hd (croots2 p)"
    have "z \<in> set (croots2 p)" unfolding croots2_def Let_def z_def by auto
    with croots2[OF deg] have pz: "poly p z = 0" by auto
    from pz e0 have z0: "z \<noteq> 0" unfolding p_def by auto
    from pz have yz: "y * z = z * z - e / 3" unfolding p_def by (auto simp: field_simps)
    from arg_cong[OF this, of "\<lambda> x. x / z"] z0 have "y = z - e / (3 * z)"
      by (auto simp: field_simps)
    have "\<exists> u z. u\<^sup>2 + f * u + v = 0 \<and> z^3 = u \<and> y = z - e / (3 * z)"
    proof (intro exI conjI)
      show "y = z - e / (3 * z)" by fact
      from y0 have "0 = ?yexp * z^3" by auto
      also have "\<dots> = (y * z)^3 + e * (y * z) * z^2 + f * z^3" by algebra
      also have "\<dots> = (z^3)^2 + f * (z^3) + v" unfolding yz v by algebra
      finally show "(z^3)^2 + f * (z^3) + v = 0" by simp
    qed simp
    then obtain uu z where
       *: "uu\<^sup>2 + f * uu + v = 0" "z ^ 3 = uu" "y = z - e / (3 * z)" by blast
        show ?r
    proof (cases "uu = u")
      case True
      thus ?thesis using * by auto
    next
      case diff: False
      define p where "p = [:v,f,1:]"
      have p2: "degree p = 2" unfolding p_def by auto
      have poly: "poly p u = 0" "poly p uu = 0" using u *(1) unfolding p_def
        by (auto simp: field_simps power2_eq_square)
      have u0: "u \<noteq> 0" "uu \<noteq> 0" using poly v0 unfolding p_def by auto
      {
        from poly(1) have "[:-u,1:] dvd p" by (meson poly_eq_0_iff_dvd)
        then obtain q where pq: "p = q * [:-u,1:]" by auto
        from poly(2)[unfolded pq poly_mult] diff have "poly q uu = 0" by auto
        hence "[:-uu,1:] dvd q" by (meson poly_eq_0_iff_dvd)
        then obtain q' where qq': "q = q' * [:-uu,1:]" by auto
        with pq have pq: "p = q' * [:-uu,1:] * [:-u,1:]" by auto
        from pq[unfolded p_def] have q': "q' \<noteq> 0" by auto
        from arg_cong[OF pq, of degree, unfolded p2]
        have "2 = degree (q' * [:- uu, 1:] * [:- u, 1:])" .
        also have "\<dots> = degree q' + degree [:- uu, 1:] + degree [:- u, 1:]"
          apply (subst degree_mult_eq)
          subgoal using q' by (metis mult_eq_0_iff pCons_eq_0_iff zero_neq_one)
          subgoal by force
          by (subst degree_mult_eq[OF q'], auto)
        also have "\<dots> = degree q' + 2" by simp
        finally have dq: "degree q' = 0" by simp
        from dq obtain c where q': "q' = [: c:]" by (metis degree_eq_zeroE)
        from pq[unfolded q' p_def] have "c = 1" by auto
        with q' have "q' = 1" by simp
        with pq have "[: -u, 1:] * [: -uu, 1 :] = p" by simp
      }
      from this[unfolded p_def, simplified] have prod: "uu * u = v" by simp
      hence uu: "u = v / uu" using u0 by (simp add: field_simps)
      define zz where "zz = - e / (3 * z)"
      show ?r using *(2-) uu unfolding v using u0
        by (intro exI[of _ zz], auto simp: zz_def field_simps)
    qed
  qed
qed

subsection \<open>Solving the depressed case for real numbers\<close>

definition discriminant_cubic_depressed :: "'a :: comm_ring_1 \<Rightarrow> 'a \<Rightarrow> 'a" where
  "discriminant_cubic_depressed e f = - (4 * e^3 + 27 * f^2)"

lemma discriminant_cubic_depressed: assumes "[:-x,1:] * [:-y,1:] * [:-z,1:] = [:f,e,0,1:]"
  shows "discriminant_cubic_depressed e f = (x-y)^2 * (x - z)^2 * (y - z)^2"
proof -
  from assms have f: "f = - (z * (y * x))" and e: "e = y * x - z * (- y - x)" and
      z: "z = - y - x" by auto
  show ?thesis unfolding discriminant_cubic_depressed_def e f z
    by (simp add: power2_eq_square power3_eq_cube field_simps)
qed

text \<open>If the discriminant is negative, then there is exactly one real root\<close>

lemma solve_cubic_depressed_Cardano_real: fixes e f v u :: real
  defines "y1 \<equiv> root 3 u - e / (3 * root 3 u)"
    and "\<Delta> \<equiv> discriminant_cubic_depressed e f"
  assumes e0: "e \<noteq> 0"
  and v: "v = - (e ^ 3 / 27)"
  and u: "u\<^sup>2 + f * u + v = 0" (* this implies \<Delta> \<le> 0 *)
shows "y1^3 + e * y1 + f = 0"
  "\<Delta> \<noteq> 0 \<Longrightarrow> y^3 + e * y + f = 0 \<Longrightarrow> y = y1" (* this is the case \<Delta> < 0 *)
proof -
  let ?c = complex_of_real
  let ?y = "?c y"
  let ?e = "?c e"
  let ?u = "?c u"
  let ?v = "?c v"
  let ?f = "?c f"
  {
    fix y :: real
    let ?y = "?c y"
    have "y^3 + e * y + f = 0 \<longleftrightarrow> ?c (y^3 + e * y + f) = ?c 0"
      using of_real_eq_iff by blast
    also have "\<dots> \<longleftrightarrow> ?y^3 + ?e * ?y + ?f = 0" by simp
    also have "\<dots> \<longleftrightarrow> (\<exists> z. z^3 = ?u \<and> ?y = z - ?e / (3 * z))"
    proof (rule solve_cubic_depressed_Cardano_complex)
      show "?e \<noteq> 0" using e0 by auto
      show "?v = - (?e ^ 3 / 27)" unfolding v by simp
      show "?u\<^sup>2 + ?f * ?u + ?v = 0" using arg_cong[OF u, of ?c] by simp
    qed
    finally have "y^3 + e * y + f = 0 \<longleftrightarrow> (\<exists> z. z^3 = ?u \<and> ?y = z - ?e / (3 * z))" .
  } note pre = this
  show y1: "y1^3 + e * y1 + f = 0" unfolding pre y1_def
    by (intro exI[of _ "?c (root 3 u)"], simp only: of_real_power[symmetric],
        simp del: of_real_power add: odd_real_root_pow)
  from u have "{z. poly [:v,f,1:] z = 0} \<noteq> {}"
    by (auto simp add: field_simps power2_eq_square)
  hence "set (rroots2 [:v,f,1:]) \<noteq> {}"
    by (subst rroots2[symmetric], auto)
  hence "rroots2 [:v,f,1:] \<noteq> []" by simp
  from this[unfolded rroots2_def Let_def, simplified]
  have "f^2 - 4 * v \<ge> 0"
    by (auto split: if_splits simp: numeral_2_eq_2 field_simps power2_eq_square)
  hence delta_le_0: "\<Delta> \<le> 0" unfolding \<Delta>_def discriminant_cubic_depressed_def v by auto

  assume Delta_non_0: "\<Delta> \<noteq> 0"
  with delta_le_0 have delta_neg: "\<Delta> < 0" by simp
  let ?p = "[:f,e,0,1:]"
  have poly: "poly ?p y = 0 \<longleftrightarrow> y^3 + e * y + f = 0" for y
    by (simp add: field_simps power2_eq_square power3_eq_cube)
  from y1 have "poly ?p y1 = 0" unfolding poly .
  hence "[:-y1,1:] dvd ?p" using poly_eq_0_iff_dvd by blast
  then obtain q where pq: "?p = [:-y1,1:] * q" by blast
  {
    fix y2
    assume "poly ?p y2 = 0" "y2 \<noteq> y1"
    from this[unfolded pq] poly_mult have "poly q y2 = 0" by auto
    from this[unfolded poly_eq_0_iff_dvd] obtain r where qr: "q = [:-y2,1:] * r" by blast
    {
      have r0: "r \<noteq> 0" using pq unfolding qr poly_mult by auto
      have "3 = degree ?p" by simp
      also have "\<dots> = 2 + degree r" unfolding pq qr
        apply (subst degree_mult_eq, force)
        subgoal using r0 pq qr by force
        by (subst degree_mult_eq[OF _ r0], auto)
      finally have "degree r = 1" by simp
      from degree1_coeffs[OF this] obtain yy a where r: "r = [:yy,a:]" by auto
      define y3 where "y3 = -yy"
      with r have r: "r = [:-y3,a:]" by auto
      from pq[unfolded qr r] have "a = 1" by auto
      with r have "\<exists> y3. r = [:-y3,1:]" by auto
    }
    then obtain y3 where r: "r = [:-y3,1:]" by auto
    have py: "?p = [:-y1,1:] * [:-y2,1:] * [:-y3,1:]" unfolding pq qr r by algebra
    from discriminant_cubic_depressed[OF this[symmetric], folded \<Delta>_def]
    have delta: "\<Delta> = (y1 - y2)\<^sup>2 * (y1 - y3)\<^sup>2 * (y2 - y3)\<^sup>2" .
    have d0: "\<Delta> \<ge> 0" unfolding delta by auto
    with delta_neg have False by auto
  }
  with y1 show "y^3 + e * y + f = 0 \<Longrightarrow> y = y1" unfolding poly by auto
qed

text \<open>If the discriminant is non-negative, then all roots are real\<close>

lemma solve_cubic_depressed_Cardano_all_real_roots: fixes e f v :: real and y :: complex
  defines "\<Delta> \<equiv> discriminant_cubic_depressed e f"
  assumes Delta: "\<Delta> \<ge> 0"
  and rt: "y^3 + e * y + f = 0"
shows "y \<in> \<real>"
proof -
  note powers = field_simps power3_eq_cube power2_eq_square
  let ?c = complex_of_real
  let ?e = "?c e"
  let ?f = "?c f"
  let ?cp = "[:?f,?e,0,1:]"
  let ?p = "[:f,e,0,1:]"
  from odd_degree_imp_real_root[of ?p] obtain x1 where "poly ?p x1 = 0" by auto
  hence "[:-x1,1:] dvd ?p" using poly_eq_0_iff_dvd by blast
  then obtain q where pq: "?p = [:-x1,1:] * q" by auto
  from arg_cong[OF pq, of degree]
  have "3 = degree ([:-x1,1:] * q)" by simp
  also have "\<dots> = 1 + degree q"
    by (subst degree_mult_eq, insert pq, auto)
  finally have dq: "degree q = 2" by auto
  let ?cc = "map_poly ?c"
  let ?q = "?cc q"
  have cpq: "?cc ?p = ?cc [:-x1,1:] * ?q" unfolding pq hom_distribs by simp
  let ?x1 = "?c x1"
  have dq': "degree ?q = 2" using dq by simp
  have "\<not> constant (poly ?q)" using dq by (simp add: constant_degree)
  from fundamental_theorem_of_algebra[OF this] obtain x2 where x2: "poly ?q x2 = 0" by blast
  have "x2 \<in> \<real>"
  proof (rule ccontr)
    assume x2r: "x2 \<notin> \<real>"
    define x3 where "x3 = cnj x2"
    from x2r have x23: "x2 \<noteq> x3" unfolding x3_def using Reals_cnj_iff by force
    have x3: "poly ?q x3 = 0" unfolding x3_def
      by (rule complex_conjugate_root[OF _ x2], auto)
    from x2[unfolded poly_eq_0_iff_dvd] obtain r where qr: "?q = [:-x2,1:] * r" by auto
    from arg_cong[OF this[symmetric], of "\<lambda> x. poly x x3", unfolded poly_mult x3 mult_eq_0_iff] x23
    have x3: "poly r x3 = 0" by auto
    from arg_cong[OF qr, of degree]
    have "2 = degree ([:-x2,1:] * r)" using dq' by simp
    also have "\<dots> = 1 + degree r" by (subst degree_mult_eq, insert pq qr, auto)
    finally have "degree r = 1" by simp
    from degree1_coeffs[OF this] obtain a b where r: "r = [:a,b:]" by auto
    from cpq[unfolded qr r] have b1: "b = 1" by simp
    with x3 r have "a + x3 = 0" by simp
    hence "a = - x3" by algebra
    with b1 r have r: "r = [:-x3,1:]" by auto
    have "?cc ?p = ?cc [:-x1,1:] * [:-x2,1:] * [:-x3,1:]" unfolding cpq qr r by algebra
    also have "?cc [:-x1,1:] = [:-?x1,1:]" by simp
    also have "?cc ?p = ?cp" by simp
    finally have id: "[:-?x1,1:] * [:-x2,1:] * [:-x3,1:] = ?cp" by simp
    define x23 where "x23 = - 4 * (Im x2)^2"
    define x12c where "x12c = ?x1 - x2"
    define x12 where "x12 = (Re x12c) ^ 2 + (Im x12c)^2"
    have x23_0: "x23 < 0" unfolding x23_def using x2r using complex_is_Real_iff by force
    have "Im x12c \<noteq> 0" unfolding x12c_def using x2r using complex_is_Real_iff by force
    hence "(Im x12c)^2 > 0" by simp
    hence x12: "x12 > 0" unfolding x12_def using sum_power2_gt_zero_iff by auto
    from discriminant_cubic_depressed[OF id]
    have "?c \<Delta> = ((?x1 - x2)\<^sup>2 * (?x1 - x3)\<^sup>2) * (x2 - x3)\<^sup>2"
      unfolding \<Delta>_def discriminant_cubic_depressed_def by simp
    also have "(x2 - x3)^2 = ?c x23" unfolding x3_def x23_def by (simp add: complex_eq_iff power2_eq_square)
    also have "(?x1 - x2)\<^sup>2 * (?x1 - x3)\<^sup>2 = ((?x1 - x2) * (?x1 - x3))^2"
      by (simp add: power2_eq_square)
    also have "?x1 - x3 = cnj (?x1 - x2)" unfolding x3_def by simp
    also have "(?x1 - x2) = x12c" unfolding x12c_def ..
    also have "x12c * cnj x12c = ?c x12" by (simp add: x12_def complex_eq_iff power2_eq_square)
    finally have "?c \<Delta> = ?c (x12^2 * x23)" by simp
    hence "\<Delta> = x12^2 * x23" by (rule of_real_hom.injectivity)
    also have "\<dots> < 0" using x12 x23_0 by (meson mult_pos_neg zero_less_power)
    finally show False using Delta by simp
  qed
  with x2 obtain x2 where "poly ?q (?c x2) = 0" unfolding Reals_def by auto
  hence x2: "poly q x2 = 0" by simp
  from x2[unfolded poly_eq_0_iff_dvd] obtain r where qr: "q = [:-x2,1:] * r" by auto
  from arg_cong[OF qr, of degree]
  have "2 = degree ([:-x2,1:] * r)" using dq' by simp
  also have "\<dots> = 1 + degree r" by (subst degree_mult_eq, insert pq qr, auto)
  finally have "degree r = 1" by simp
  from degree1_coeffs[OF this] obtain a b where r: "r = [:a,b:]" by auto
  from pq[unfolded qr r] have b1: "b = 1" by simp
  define x3 where "x3 = -a"
  have r: "r = [:-x3,1:]" unfolding r b1 x3_def by simp
  let ?pp = "[:-x1,1:] * [:-x2,1:] * [:-x3,1:]"
  have id: "?p = ?pp" unfolding pq qr r by linarith
  have "True \<longleftrightarrow> y^3 + e * y + f = 0" using rt by auto
  also have "y^3 + e * y + f = poly (?cc ?p) y" by (simp add: powers)
  also have "\<dots> = poly (?cc ?pp) y" unfolding id by simp
  also have "?cc ?pp = [:-?c x1, 1:] * [:-?c x2, 1:] * [:- ?c x3, 1:]"
    by simp
  also have "poly \<dots> y = 0 \<longleftrightarrow> y = ?c x1 \<or> y = ?c x2 \<or> y = ?c x3"
    unfolding poly_mult mult_eq_0_iff by auto
  finally show "y \<in> \<real>" by auto
qed

end


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

section \<open>The accessible part of a relation\<close>

theory Acc imports ZF begin

text \<open>
  Inductive definition of \<open>acc(r)\<close>; see @{cite "paulin-tlca"}.
\<close>

consts
  acc :: "i => i"

inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "[| r-``{a}: Pow(acc(r)); a \<in> field(r) |] ==> a \<in> acc(r)"
  monos      Pow_mono

text \<open>
  The introduction rule must require \<^prop>\<open>a \<in> field(r)\<close>,
  otherwise \<open>acc(r)\<close> would be a proper class!

  \medskip
  The intended introduction rule:
\<close>

lemma accI: "[| !!b. <b,a>:r ==> b \<in> acc(r);  a \<in> field(r) |] ==> a \<in> acc(r)"
  by (blast intro: acc.intros)

lemma acc_downward: "[| b \<in> acc(r);  <a,b>: r |] ==> a \<in> acc(r)"
  by (erule acc.cases) blast

lemma acc_induct [consumes 1, case_names vimage, induct set: acc]:
    "[| a \<in> acc(r);
        !!x. [| x \<in> acc(r);  \<forall>y. <y,x>:r \<longrightarrow> P(y) |] ==> P(x)
     |] ==> P(a)"
  by (erule acc.induct) (blast intro: acc.intros)

lemma wf_on_acc: "wf[acc(r)](r)"
  apply (rule wf_onI2)
  apply (erule acc_induct)
  apply fast
  done

lemma acc_wfI: "field(r) \<subseteq> acc(r) \<Longrightarrow> wf(r)"
  by (erule wf_on_acc [THEN wf_on_subset_A, THEN wf_on_field_imp_wf])

lemma acc_wfD: "wf(r) ==> field(r) \<subseteq> acc(r)"
  apply (rule subsetI)
  apply (erule wf_induct2, assumption)
   apply (blast intro: accI)+
  done

lemma wf_acc_iff: "wf(r) \<longleftrightarrow> field(r) \<subseteq> acc(r)"
  by (rule iffI, erule acc_wfD, erule acc_wfI)

end


theory Chap2_Theorem5
  imports Main Chap1_Properties
begin

section "commutative monoid"

typedecl m

consts m_mult :: "m \<Rightarrow> m \<Rightarrow> m" (infixr "\<^bold>\<sqdot>\<^sub>m" 55)
consts m_one :: "m" ("\<^bold>1\<^sub>m")
consts m_ord :: "m \<Rightarrow> m \<Rightarrow> bool" (infixr "\<^bold>\<le>\<^sub>m" 50)

axiomatization where
m_assoc: "assoc (\<^bold>\<sqdot>\<^sub>m)" and
m_commu: "commu (\<^bold>\<sqdot>\<^sub>m)" and
m_idemp: "unitE (\<^bold>\<sqdot>\<^sub>m) \<^bold>1\<^sub>m"

section "Downward Closedness"

type_synonym p = "m \<Rightarrow> bool"
type_synonym p_cl = "p \<Rightarrow> p"

definition downwardClosed :: "p \<Rightarrow> bool" where
"downwardClosed P \<equiv> \<forall> x. (P x \<longrightarrow> (\<forall> y. (y \<^bold>\<le>\<^sub>m x) \<longrightarrow> P y ))"
definition downwardClosedOp :: "p_cl \<Rightarrow> bool" where
"downwardClosedOp Cl \<equiv> \<forall> X. (cClosed Cl X \<longrightarrow> downwardClosed X)"

definition downSet :: "m \<Rightarrow> p" (" \<langle>_] ") where
"\<langle> b ] \<equiv> \<lambda> x. (x \<^bold>\<le>\<^sub>m b)"
definition UBase :: "p_cl \<Rightarrow> p" where
"UBase Cl \<equiv> \<lambda> b. cClosed Cl \<langle> b ]"

section "Closure Conditions"

type_synonym p_op = "p \<Rightarrow> p \<Rightarrow> p"
type_synonym p_rel = "p \<Rightarrow> p \<Rightarrow> bool"
type_synonym p_set = "p \<Rightarrow> bool"

consts ClOp :: p_cl
consts p_order :: p_rel (infixr "\<^bold>\<le>\<^sub>p" 55)
consts p_prod :: p_op (infixr "\<^bold>\<star>\<^sub>p" 55)
consts p_impl :: p_op (infixr "\<^bold>\<Rrightarrow>\<^sub>p" 55)

axiomatization where
cl_expan: "cl_expan ClOp (\<^bold>\<le>\<^sub>p)" and
cl_mono: "cl_mono ClOp (\<^bold>\<le>\<^sub>p)" and
cl_idem: "cl_idem ClOp (\<^bold>\<le>\<^sub>p)" and
cl_distr: "cl_distr ClOp (\<^bold>\<le>\<^sub>p) (\<^bold>\<star>\<^sub>p)" and
cl_downClosed: "\<forall> X. cClosed ClOp X \<longrightarrow> downwardClosed X"
(* condition 2 is missing *)

section "Theorem 5"

definition hMap :: "m \<Rightarrow> p" where
"hMap b = \<langle> b ]"
(* is a complete embedding, i.e. an order isomorphism,
which preserves all existing products and residuals in U,
and also all existing (infinite) joins and meets in U,
where U is the base for C in M *)

section "order isomorphism"

definition "preserv Base PConn CConn Map
\<equiv> \<forall> x y. Base x \<and> Base y \<and> Base (PConn x y) \<longrightarrow> CConn (Map x) (Map y)"

axiomatization where
m_ord_refl: "\<forall> x. x \<^bold>\<le>\<^sub>m x" and
m_ord_antisym: "\<forall> x y. x \<^bold>\<le>\<^sub>m y \<and> y \<^bold>\<le>\<^sub>m x \<longrightarrow> x = y" and
m_ord_trans: "\<forall> x y z. x \<^bold>\<le>\<^sub>m y \<longrightarrow> x \<^bold>\<sqdot>\<^sub>m z \<^bold>\<le>\<^sub>m y \<^bold>\<sqdot>\<^sub>m z"and
m_ord_mono: "\<forall> x y z. x \<^bold>\<le>\<^sub>m y \<and> y \<^bold>\<le>\<^sub>m z \<longrightarrow> x \<^bold>\<le>\<^sub>m z"

definition c_mult :: "p \<Rightarrow> p_cl \<Rightarrow> p \<Rightarrow> p" ("_ \<^bold>\<star>[_] _" 55)where
"X \<^bold>\<star>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<star>\<^sub>p Y) m)"

lemma preserve_mult:
  assumes 1: "(UBase ClOp a) \<and> (UBase ClOp b)"
  assumes 2: "UBase ClOp (a \<^bold>\<sqdot>\<^sub>m b)"
  shows "((hMap a) \<^bold>\<star>[ClOp] (hMap b)) = hMap (a \<^bold>\<sqdot>\<^sub>m b)"
proof -
  have "((hMap a) \<^bold>\<star>[ClOp] (hMap b)) = (\<langle> a ] \<^bold>\<star>[ClOp] \<langle> b ])"
    by (simp add: hMap_def)
  also have "... = ClOp (\<langle> a ] \<^bold>\<star>\<^sub>p \<langle> b ])"
    by (simp add: c_mult_def)
  also have "... = \<langle> a \<^bold>\<sqdot>\<^sub>m b ]"
    sorry (* <==== here has to be the least cClosed fixpoint argument*)
  also have "... = hMap (a \<^bold>\<sqdot>\<^sub>m b)"
    by (simp add: hMap_def)
  finally show ?thesis .
qed

definition c_impl :: "p \<Rightarrow> p_cl \<Rightarrow> p \<Rightarrow> p" (" _ \<^bold>\<Rrightarrow>[_] _" 55) where
"X \<^bold>\<Rrightarrow>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<Rrightarrow>\<^sub>p Y) m)"
consts m_impl :: "m \<Rightarrow> m \<Rightarrow> m" (infixr "\<^bold>\<rightarrow>\<^sub>m" 55)

lemma preserve_impl:
  assumes 1: "(UBase ClOp a) \<and> (UBase ClOp b)"
  assumes 2: "UBase ClOp (a \<^bold>\<sqdot>\<^sub>m b)"
  shows "((hMap a) \<^bold>\<Rrightarrow>[ClOp] (hMap b)) = hMap (a \<^bold>\<rightarrow>\<^sub>m b)"
proof -
  have "((hMap a) \<^bold>\<Rrightarrow>[ClOp] (hMap b)) = (\<langle> a ] \<^bold>\<Rrightarrow>[ClOp] \<langle> b ])"
    by (simp add: hMap_def)
  also have "... = ClOp (\<langle> a ] \<^bold>\<Rrightarrow>\<^sub>p \<langle> b ])"
    by (simp add: c_impl_def)
  also have "... = \<langle> a \<^bold>\<rightarrow>\<^sub>m b ]"
    sorry (* <==== here has to be the maximal cClosed set  argument*)
  also have "... = hMap (a \<^bold>\<rightarrow>\<^sub>m b)"
    by (simp add: hMap_def)
  finally show ?thesis .

qed

end


(*  Title:      HOL/Auth/Message.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
*)

section\<open>Theory of Agents and Messages for Security Protocols\<close>

theory Message
imports Main
begin

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

type_synonym
  key = nat

consts
  all_symmetric :: bool        \<comment> \<open>true if all keys are symmetric\<close>
  invKey        :: "key\<Rightarrow>key"  \<comment> \<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric \<longrightarrow> invKey = id"
    by (rule exI [of _ id], auto)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  \<comment> \<open>We allow any number of friendly agents\<close>
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     \<comment> \<open>Agent names\<close>
         | Number nat       \<comment> \<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment> \<open>Unguessable nonces\<close>
         | Key    key       \<comment> \<open>Crypto keys\<close>
         | Hash   msg       \<comment> \<open>Hashing\<close>
         | MPair  msg msg   \<comment> \<open>Compound messages\<close>
         | Crypt  key msg   \<comment> \<open>Encryption, public- or shared-key\<close>

text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>
syntax
  "_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>" \<rightleftharpoons> "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>" \<rightleftharpoons> "CONST MPair x y"

definition HPair :: "[msg,msg] \<Rightarrow> msg" ("(4Hash[_] /_)" [0, 1000]) where
    \<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
    "Hash[X] Y == \<lbrace>Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

definition keysFor :: "msg set \<Rightarrow> key set" where
    \<comment> \<open>Keys useful to decrypt elements of a message set\<close>
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection\<open>Inductive Definition of All Parts" of a Message\<close>

inductive_set
  parts :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro]: "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace> \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace> \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text\<open>Monotonicity\<close>
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text\<open>Equations hold because constructors are injective.\<close>
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x\<in>A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsubsection\<open>Inverse of keys\<close>

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
by (metis invKey)

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text\<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text\<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (metis insert_is_Un parts_Un)

text\<open>TWO inserts to avoid looping.  This rewrite is better than nothing.
  But its behaviour can be strange.\<close>
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]:
  "parts (\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts (H x))"
  by (intro equalityI parts_UN_subset1 parts_UN_subset2)

lemma parts_image [simp]:
  "parts (f ` A) = (\<Union>x\<in>A. parts {f x})"
  apply auto
  apply (metis (mono_tags, opaque_lifting) image_iff parts_singleton)
  apply (metis empty_subsetI image_eqI insert_absorb insert_subset parts_mono)
  done

text\<open>Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!\<close>

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  \<^term>\<open>parts(G\<union>H)\<close> in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (metis parts_subset_iff subsetD)

text\<open>Cut\<close>
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (metis insert_absorb parts_idem parts_insert)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
by auto

text\<open>In any message, there is an upper bound N on its greatest nonce.\<close>
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> parts {msg}"
proof (induct msg)
  case (Nonce n)
    show ?case
      by simp (metis Suc_n_not_le_n)
next
  case (MPair X Y)
    then show ?case \<comment> \<open>metis works out the necessary sum itself!\<close>
      by (simp add: parts_insert2) (metis le_trans nat_le_linear)
qed auto

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro,simp]: "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "\<lbrakk>Crypt K X \<in> analz H; Key(invKey K) \<in> analz H\<rbrakk> \<Longrightarrow> X \<in> analz H"

text\<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other\<close>
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text\<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text\<open>Can pull out enCrypted message if the Key is not known\<close>
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text\<open>Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with \<open>if_split\<close>; apparently
\<open>split_tac\<close> does not cope with patterns such as \<^term>\<open>analz (insert
(Crypt K X) H)\<close>\<close>
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text\<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H \<longrightarrow> Y: analz H"
*)

text\<open>This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated.\<close>
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (metis analz_cut analz_insert_eq_I insert_absorb)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
by (metis Un_mono analz_Un analz_subset_iff subset_trans)

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text\<open>If there are no pairs or encryptions then analz does nothing\<close>
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>These two are obsolete (with a single Spy) but cost little to prove...\<close>
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text\<open>Monotonicity\<close>
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text\<open>NO \<open>Agent_synth\<close>, as any Agent name can be synthesized.
  The same holds for \<^term>\<open>Number\<close>\<close>

inductive_simps synth_simps [iff]:
 "Nonce n \<in> synth H"
 "Key K \<in> synth H"
 "Hash X \<in> synth H"
 "\<lbrace>X,Y\<rbrace> \<in> synth H"
 "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

text\<open>Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.\<close>
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, auto)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
by (metis subset_trans synth_idem synth_increasing synth_mono)

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
by (metis Un_empty_right analz_synth_Un)

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (metis UnCI Un_upper2 insert_subset parts_Un parts_mono)

text\<open>More specifically for Fake. See also \<open>Fake_parts_sing\<close> below\<close>
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
by (metis Un_commute analz_increasing insert_subset parts_analz parts_mono
          parts_synth synth_mono synth_subset_iff)

lemma Fake_parts_insert_in_Un:
     "\<lbrakk>Z \<in> parts (insert X H);  X \<in> synth (analz H)\<rbrakk>
      \<Longrightarrow> Z \<in> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert subsetD)

text\<open>\<^term>\<open>H\<close> is sometimes \<^term>\<open>Key ` KK \<union> spies evs\<close>, so can't put
  \<^term>\<open>G=H\<close>.\<close>
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H)", force)
apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H \<and> X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text\<open>Without this equation, other rules for synth and analz would yield
  redundant cases\<close>
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) \<and> Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
by blast

subsection\<open>HPair: a combination of Hash and MPair\<close>

subsubsection\<open>Freeness\<close>

lemma Agent_neq_HPair: "Agent A \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Nonce_neq_HPair: "Nonce N \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Number_neq_HPair: "Number N \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Key_neq_HPair: "Key K \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Hash_neq_HPair: "Hash Z \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Crypt_neq_HPair: "Crypt K X' \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

declare HPair_neqs [iff]
declare HPair_neqs [symmetric, iff]

lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X \<and> Y'=Y)"
by (simp add: HPair_def)

lemma MPair_eq_HPair [iff]:
     "(\<lbrace>X',Y'\<rbrace> = Hash[X] Y) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (simp add: HPair_def)

lemma HPair_eq_MPair [iff]:
     "(Hash[X] Y = \<lbrace>X',Y'\<rbrace>) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (auto simp add: HPair_def)

subsubsection\<open>Specialized laws, proved in terms of those for Hash and MPair\<close>

lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
by (simp add: HPair_def)

lemma parts_insert_HPair [simp]:
    "parts (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (parts (insert Y H)))"
by (simp add: HPair_def)

lemma analz_insert_HPair [simp]:
    "analz (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (analz (insert Y H)))"
by (simp add: HPair_def)

lemma HPair_synth_analz [simp]:
     "X \<notin> synth (analz H)
    ==> (Hash[X] Y \<in> synth (analz H)) =
        (Hash \<lbrace>X, Y\<rbrace> \<in> analz H \<and> Y \<in> synth (analz H))"
by (auto simp add: HPair_def)

text\<open>We do NOT want Crypt... messages broken up in protocols!!\<close>
declare parts.Body [rule del]

text\<open>Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the \<open>analz_insert\<close> rules\<close>

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text\<open>Cannot be added with \<open>[simp]\<close> -- messages should not always be
  re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts

subsection\<open>The set of key-free messages\<close>

(*Note that even the encryption of a key-free message remains key-free.
  This concept is valuable because of the theorem analz_keyfree_into_Un, proved below. *)

inductive_set
  keyfree :: "msg set"
  where
    Agent:  "Agent A \<in> keyfree"
  | Number: "Number N \<in> keyfree"
  | Nonce:  "Nonce N \<in> keyfree"
  | Hash:   "Hash X \<in> keyfree"
  | MPair:  "[|X \<in> keyfree;  Y \<in> keyfree|] ==> \<lbrace>X,Y\<rbrace> \<in> keyfree"
  | Crypt:  "[|X \<in> keyfree|] ==> Crypt K X \<in> keyfree"

declare keyfree.intros [intro]

inductive_cases keyfree_KeyE: "Key K \<in> keyfree"
inductive_cases keyfree_MPairE: "\<lbrace>X,Y\<rbrace> \<in> keyfree"
inductive_cases keyfree_CryptE: "Crypt K X \<in> keyfree"

lemma parts_keyfree: "parts (keyfree) \<subseteq> keyfree"
  by (clarify, erule parts.induct, auto elim!: keyfree_KeyE keyfree_MPairE keyfree_CryptE)

(*The key-free part of a set of messages can be removed from the scope of the analz operator.*)
lemma analz_keyfree_into_Un: "\<lbrakk>X \<in> analz (G \<union> H); G \<subseteq> keyfree\<rbrakk> \<Longrightarrow> X \<in> parts G \<union> analz H"
apply (erule analz.induct, auto dest: parts.Body)
apply (metis Un_absorb2 keyfree_KeyE parts_Un parts_keyfree UnI2)
done

subsection\<open>Tactics useful for many protocol proofs\<close>
ML
\<open>
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED
      (Blast.depth_tac
        (ctxt addIs [@{thm analz_insertI}, impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
           (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
\<close>

text\<open>By default only \<open>o_apply\<close> is built-in.  But in the presence of
eta-expansion this means that some terms displayed as \<^term>\<open>f o g\<close> will be
rewritten, and others will not!\<close>
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
by (metis Fake_analz_insert Un_absorb Un_absorb1 Un_commute
          subset_insertI synth_analz_mono synth_increasing synth_subset_iff)

text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H \<Longrightarrow> \<forall>G. H \<subseteq> G \<longrightarrow> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      \<Longrightarrow> \<forall>G. H \<subseteq> G \<longrightarrow> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert empty_subsetI insert_mono parts_mono subset_trans)

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac)\<close>
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac)\<close>
    "for debugging spy_analz"

method_setup Fake_insert_simp = \<open>
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac)\<close>
    "for debugging spy_analz"

end


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

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

datatype It = A | B | C

fun removeOne :: "It => (It list) list => (It list) list" where
"removeOne x (nil2) = nil2"
| "removeOne x (cons2 z x2) = cons2 (cons2 x z) (removeOne x x2)"

fun removeOne2 :: "It list => (It list) list" where
"removeOne2 (nil2) = nil2"
| "removeOne2 (cons2 y xs) =
     cons2 xs (removeOne y (removeOne2 xs))"

fun or2 :: "bool list => bool" where
"or2 (nil2) = False"
| "or2 (cons2 y xs) = (y | (or2 xs))"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) y = True"
| "isPrefix (cons2 z x2) (nil2) = False"
| "isPrefix (cons2 z x2) (cons2 x3 x4) =
     ((z = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) y = True"
| "isRelaxedPrefix (cons2 z (nil2)) y = True"
| "isRelaxedPrefix (cons2 z (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

fun spec :: "It list => (It list) list => bool list" where
"spec ys (nil2) = nil2"
| "spec ys (cons2 y z) = cons2 (isPrefix y ys) (spec ys z)"

fun spec2 :: "It list => It list => bool" where
"spec2 x y = or2 (spec y (cons2 x (removeOne2 x)))"

theorem property0 :
  "((isRelaxedPrefix xs ys) = (spec2 xs ys))"
  oops

end


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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p (Plus q r)) s) =
      (recognise (Plus (Plus p q) r) s))"
  oops

end