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

section\<open>Basic Equalities and Inclusions\<close>

theory equalities imports pair begin

text\<open>These cover union, intersection, converse, domain, range, etc.  Philippe
de Groote proved many of the inclusions.\<close>

lemma in_mono: "A\<subseteq>B ==> x\<in>A \<longrightarrow> x\<in>B"
by blast

lemma the_eq_0 [simp]: "(THE x. False) = 0"
by (blast intro: the_0)

subsection\<open>Bounded Quantifiers\<close>
text \<open>\medskip

  The following are not added to the default simpset because
  (a) they duplicate the body and (b) there are no similar rules for \<open>Int\<close>.\<close>

lemma ball_Un: "(\<forall>x \<in> A\<union>B. P(x)) \<longleftrightarrow> (\<forall>x \<in> A. P(x)) & (\<forall>x \<in> B. P(x))"
  by blast

lemma bex_Un: "(\<exists>x \<in> A\<union>B. P(x)) \<longleftrightarrow> (\<exists>x \<in> A. P(x)) | (\<exists>x \<in> B. P(x))"
  by blast

lemma ball_UN: "(\<forall>z \<in> (\<Union>x\<in>A. B(x)). P(z)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>z \<in> B(x). P(z))"
  by blast

lemma bex_UN: "(\<exists>z \<in> (\<Union>x\<in>A. B(x)). P(z)) \<longleftrightarrow> (\<exists>x\<in>A. \<exists>z\<in>B(x). P(z))"
  by blast

subsection\<open>Converse of a Relation\<close>

lemma converse_iff [simp]: "<a,b>\<in> converse(r) \<longleftrightarrow> <b,a>\<in>r"
by (unfold converse_def, blast)

lemma converseI [intro!]: "<a,b>\<in>r ==> <b,a>\<in>converse(r)"
by (unfold converse_def, blast)

lemma converseD: "<a,b> \<in> converse(r) ==> <b,a> \<in> r"
by (unfold converse_def, blast)

lemma converseE [elim!]:
    "[| yx \<in> converse(r);
        !!x y. [| yx=<y,x>;  <x,y>\<in>r |] ==> P |]
     ==> P"
by (unfold converse_def, blast)

lemma converse_converse: "r\<subseteq>Sigma(A,B) ==> converse(converse(r)) = r"
by blast

lemma converse_type: "r\<subseteq>A*B ==> converse(r)\<subseteq>B*A"
by blast

lemma converse_prod [simp]: "converse(A*B) = B*A"
by blast

lemma converse_empty [simp]: "converse(0) = 0"
by blast

lemma converse_subset_iff:
     "A \<subseteq> Sigma(X,Y) ==> converse(A) \<subseteq> converse(B) \<longleftrightarrow> A \<subseteq> B"
by blast

subsection\<open>Finite Set Constructions Using @{term cons}\<close>

lemma cons_subsetI: "[| a\<in>C; B\<subseteq>C |] ==> cons(a,B) \<subseteq> C"
by blast

lemma subset_consI: "B \<subseteq> cons(a,B)"
by blast

lemma cons_subset_iff [iff]: "cons(a,B)\<subseteq>C \<longleftrightarrow> a\<in>C & B\<subseteq>C"
by blast

(*A safe special case of subset elimination, adding no new variables
  [| cons(a,B) \<subseteq> C; [| a \<in> C; B \<subseteq> C |] ==> R |] ==> R *)
lemmas cons_subsetE = cons_subset_iff [THEN iffD1, THEN conjE]

lemma subset_empty_iff: "A\<subseteq>0 \<longleftrightarrow> A=0"
by blast

lemma subset_cons_iff: "C\<subseteq>cons(a,B) \<longleftrightarrow> C\<subseteq>B | (a\<in>C & C-{a} \<subseteq> B)"
by blast

(* cons_def refers to Upair; reversing the equality LOOPS in rewriting!*)
lemma cons_eq: "{a} \<union> B = cons(a,B)"
by blast

lemma cons_commute: "cons(a, cons(b, C)) = cons(b, cons(a, C))"
by blast

lemma cons_absorb: "a: B ==> cons(a,B) = B"
by blast

lemma cons_Diff: "a: B ==> cons(a, B-{a}) = B"
by blast

lemma Diff_cons_eq: "cons(a,B) - C = (if a\<in>C then B-C else cons(a,B-C))"
by auto

lemma equal_singleton [rule_format]: "[| a: C;  \<forall>y\<in>C. y=b |] ==> C = {b}"
by blast

(** singletons **)

lemma singleton_subsetI: "a\<in>C ==> {a} \<subseteq> C"
by blast

lemma singleton_subsetD: "{a} \<subseteq> C  ==>  a\<in>C"
by blast

(** succ **)

lemma subset_succI: "i \<subseteq> succ(i)"
by blast

(*But if j is an ordinal or is transitive, then @{term"i\<in>j"} implies @{term"i\<subseteq>j"}!
  See @{text"Ord_succ_subsetI}*)
lemma succ_subsetI: "[| i\<in>j;  i\<subseteq>j |] ==> succ(i)\<subseteq>j"
by (unfold succ_def, blast)

lemma succ_subsetE:
    "[| succ(i) \<subseteq> j;  [| i\<in>j;  i\<subseteq>j |] ==> P |] ==> P"
by (unfold succ_def, blast)

lemma succ_subset_iff: "succ(a) \<subseteq> B \<longleftrightarrow> (a \<subseteq> B & a \<in> B)"
by (unfold succ_def, blast)

subsection\<open>Binary Intersection\<close>

(** Intersection is the greatest lower bound of two sets **)

lemma Int_subset_iff: "C \<subseteq> A \<inter> B \<longleftrightarrow> C \<subseteq> A & C \<subseteq> B"
by blast

lemma Int_lower1: "A \<inter> B \<subseteq> A"
by blast

lemma Int_lower2: "A \<inter> B \<subseteq> B"
by blast

lemma Int_greatest: "[| C\<subseteq>A;  C\<subseteq>B |] ==> C \<subseteq> A \<inter> B"
by blast

lemma Int_cons: "cons(a,B) \<inter> C \<subseteq> cons(a, B \<inter> C)"
by blast

lemma Int_absorb [simp]: "A \<inter> A = A"
by blast

lemma Int_left_absorb: "A \<inter> (A \<inter> B) = A \<inter> B"
by blast

lemma Int_commute: "A \<inter> B = B \<inter> A"
by blast

lemma Int_left_commute: "A \<inter> (B \<inter> C) = B \<inter> (A \<inter> C)"
by blast

lemma Int_assoc: "(A \<inter> B) \<inter> C  =  A \<inter> (B \<inter> C)"
by blast

(*Intersection is an AC-operator*)
lemmas Int_ac= Int_assoc Int_left_absorb Int_commute Int_left_commute

lemma Int_absorb1: "B \<subseteq> A ==> A \<inter> B = B"
  by blast

lemma Int_absorb2: "A \<subseteq> B ==> A \<inter> B = A"
  by blast

lemma Int_Un_distrib: "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
by blast

lemma Int_Un_distrib2: "(B \<union> C) \<inter> A = (B \<inter> A) \<union> (C \<inter> A)"
by blast

lemma subset_Int_iff: "A\<subseteq>B \<longleftrightarrow> A \<inter> B = A"
by (blast elim!: equalityE)

lemma subset_Int_iff2: "A\<subseteq>B \<longleftrightarrow> B \<inter> A = A"
by (blast elim!: equalityE)

lemma Int_Diff_eq: "C\<subseteq>A ==> (A-B) \<inter> C = C-B"
by blast

lemma Int_cons_left:
     "cons(a,A) \<inter> B = (if a \<in> B then cons(a, A \<inter> B) else A \<inter> B)"
by auto

lemma Int_cons_right:
     "A \<inter> cons(a, B) = (if a \<in> A then cons(a, A \<inter> B) else A \<inter> B)"
by auto

lemma cons_Int_distrib: "cons(x, A \<inter> B) = cons(x, A) \<inter> cons(x, B)"
by auto

subsection\<open>Binary Union\<close>

(** Union is the least upper bound of two sets *)

lemma Un_subset_iff: "A \<union> B \<subseteq> C \<longleftrightarrow> A \<subseteq> C & B \<subseteq> C"
by blast

lemma Un_upper1: "A \<subseteq> A \<union> B"
by blast

lemma Un_upper2: "B \<subseteq> A \<union> B"
by blast

lemma Un_least: "[| A\<subseteq>C;  B\<subseteq>C |] ==> A \<union> B \<subseteq> C"
by blast

lemma Un_cons: "cons(a,B) \<union> C = cons(a, B \<union> C)"
by blast

lemma Un_absorb [simp]: "A \<union> A = A"
by blast

lemma Un_left_absorb: "A \<union> (A \<union> B) = A \<union> B"
by blast

lemma Un_commute: "A \<union> B = B \<union> A"
by blast

lemma Un_left_commute: "A \<union> (B \<union> C) = B \<union> (A \<union> C)"
by blast

lemma Un_assoc: "(A \<union> B) \<union> C  =  A \<union> (B \<union> C)"
by blast

(*Union is an AC-operator*)
lemmas Un_ac = Un_assoc Un_left_absorb Un_commute Un_left_commute

lemma Un_absorb1: "A \<subseteq> B ==> A \<union> B = B"
  by blast

lemma Un_absorb2: "B \<subseteq> A ==> A \<union> B = A"
  by blast

lemma Un_Int_distrib: "(A \<inter> B) \<union> C  =  (A \<union> C) \<inter> (B \<union> C)"
by blast

lemma subset_Un_iff: "A\<subseteq>B \<longleftrightarrow> A \<union> B = B"
by (blast elim!: equalityE)

lemma subset_Un_iff2: "A\<subseteq>B \<longleftrightarrow> B \<union> A = B"
by (blast elim!: equalityE)

lemma Un_empty [iff]: "(A \<union> B = 0) \<longleftrightarrow> (A = 0 & B = 0)"
by blast

lemma Un_eq_Union: "A \<union> B = \<Union>({A, B})"
by blast

subsection\<open>Set Difference\<close>

lemma Diff_subset: "A-B \<subseteq> A"
by blast

lemma Diff_contains: "[| C\<subseteq>A;  C \<inter> B = 0 |] ==> C \<subseteq> A-B"
by blast

lemma subset_Diff_cons_iff: "B \<subseteq> A - cons(c,C)  \<longleftrightarrow>  B\<subseteq>A-C & c \<notin> B"
by blast

lemma Diff_cancel: "A - A = 0"
by blast

lemma Diff_triv: "A  \<inter> B = 0 ==> A - B = A"
by blast

lemma empty_Diff [simp]: "0 - A = 0"
by blast

lemma Diff_0 [simp]: "A - 0 = A"
by blast

lemma Diff_eq_0_iff: "A - B = 0 \<longleftrightarrow> A \<subseteq> B"
by (blast elim: equalityE)

(*NOT SUITABLE FOR REWRITING since {a} == cons(a,0)*)
lemma Diff_cons: "A - cons(a,B) = A - B - {a}"
by blast

(*NOT SUITABLE FOR REWRITING since {a} == cons(a,0)*)
lemma Diff_cons2: "A - cons(a,B) = A - {a} - B"
by blast

lemma Diff_disjoint: "A \<inter> (B-A) = 0"
by blast

lemma Diff_partition: "A\<subseteq>B ==> A \<union> (B-A) = B"
by blast

lemma subset_Un_Diff: "A \<subseteq> B \<union> (A - B)"
by blast

lemma double_complement: "[| A\<subseteq>B; B\<subseteq>C |] ==> B-(C-A) = A"
by blast

lemma double_complement_Un: "(A \<union> B) - (B-A) = A"
by blast

lemma Un_Int_crazy:
 "(A \<inter> B) \<union> (B \<inter> C) \<union> (C \<inter> A) = (A \<union> B) \<inter> (B \<union> C) \<inter> (C \<union> A)"
apply blast
done

lemma Diff_Un: "A - (B \<union> C) = (A-B) \<inter> (A-C)"
by blast

lemma Diff_Int: "A - (B \<inter> C) = (A-B) \<union> (A-C)"
by blast

lemma Un_Diff: "(A \<union> B) - C = (A - C) \<union> (B - C)"
by blast

lemma Int_Diff: "(A \<inter> B) - C = A \<inter> (B - C)"
by blast

lemma Diff_Int_distrib: "C \<inter> (A-B) = (C \<inter> A) - (C \<inter> B)"
by blast

lemma Diff_Int_distrib2: "(A-B) \<inter> C = (A \<inter> C) - (B \<inter> C)"
by blast

(*Halmos, Naive Set Theory, page 16.*)
lemma Un_Int_assoc_iff: "(A \<inter> B) \<union> C = A \<inter> (B \<union> C)  \<longleftrightarrow>  C\<subseteq>A"
by (blast elim!: equalityE)

subsection\<open>Big Union and Intersection\<close>

(** Big Union is the least upper bound of a set  **)

lemma Union_subset_iff: "\<Union>(A) \<subseteq> C \<longleftrightarrow> (\<forall>x\<in>A. x \<subseteq> C)"
by blast

lemma Union_upper: "B\<in>A ==> B \<subseteq> \<Union>(A)"
by blast

lemma Union_least: "[| !!x. x\<in>A ==> x\<subseteq>C |] ==> \<Union>(A) \<subseteq> C"
by blast

lemma Union_cons [simp]: "\<Union>(cons(a,B)) = a \<union> \<Union>(B)"
by blast

lemma Union_Un_distrib: "\<Union>(A \<union> B) = \<Union>(A) \<union> \<Union>(B)"
by blast

lemma Union_Int_subset: "\<Union>(A \<inter> B) \<subseteq> \<Union>(A) \<inter> \<Union>(B)"
by blast

lemma Union_disjoint: "\<Union>(C) \<inter> A = 0 \<longleftrightarrow> (\<forall>B\<in>C. B \<inter> A = 0)"
by (blast elim!: equalityE)

lemma Union_empty_iff: "\<Union>(A) = 0 \<longleftrightarrow> (\<forall>B\<in>A. B=0)"
by blast

lemma Int_Union2: "\<Union>(B) \<inter> A = (\<Union>C\<in>B. C \<inter> A)"
by blast

(** Big Intersection is the greatest lower bound of a nonempty set **)

lemma Inter_subset_iff: "A\<noteq>0  ==>  C \<subseteq> \<Inter>(A) \<longleftrightarrow> (\<forall>x\<in>A. C \<subseteq> x)"
by blast

lemma Inter_lower: "B\<in>A ==> \<Inter>(A) \<subseteq> B"
by blast

lemma Inter_greatest: "[| A\<noteq>0;  !!x. x\<in>A ==> C\<subseteq>x |] ==> C \<subseteq> \<Inter>(A)"
by blast

(** Intersection of a family of sets  **)

lemma INT_lower: "x\<in>A ==> (\<Inter>x\<in>A. B(x)) \<subseteq> B(x)"
by blast

lemma INT_greatest: "[| A\<noteq>0;  !!x. x\<in>A ==> C\<subseteq>B(x) |] ==> C \<subseteq> (\<Inter>x\<in>A. B(x))"
by force

lemma Inter_0 [simp]: "\<Inter>(0) = 0"
by (unfold Inter_def, blast)

lemma Inter_Un_subset:
     "[| z\<in>A; z\<in>B |] ==> \<Inter>(A) \<union> \<Inter>(B) \<subseteq> \<Inter>(A \<inter> B)"
by blast

(* A good challenge: Inter is ill-behaved on the empty set *)
lemma Inter_Un_distrib:
     "[| A\<noteq>0;  B\<noteq>0 |] ==> \<Inter>(A \<union> B) = \<Inter>(A) \<inter> \<Inter>(B)"
by blast

lemma Union_singleton: "\<Union>({b}) = b"
by blast

lemma Inter_singleton: "\<Inter>({b}) = b"
by blast

lemma Inter_cons [simp]:
     "\<Inter>(cons(a,B)) = (if B=0 then a else a \<inter> \<Inter>(B))"
by force

subsection\<open>Unions and Intersections of Families\<close>

lemma subset_UN_iff_eq: "A \<subseteq> (\<Union>i\<in>I. B(i)) \<longleftrightarrow> A = (\<Union>i\<in>I. A \<inter> B(i))"
by (blast elim!: equalityE)

lemma UN_subset_iff: "(\<Union>x\<in>A. B(x)) \<subseteq> C \<longleftrightarrow> (\<forall>x\<in>A. B(x) \<subseteq> C)"
by blast

lemma UN_upper: "x\<in>A ==> B(x) \<subseteq> (\<Union>x\<in>A. B(x))"
by (erule RepFunI [THEN Union_upper])

lemma UN_least: "[| !!x. x\<in>A ==> B(x)\<subseteq>C |] ==> (\<Union>x\<in>A. B(x)) \<subseteq> C"
by blast

lemma Union_eq_UN: "\<Union>(A) = (\<Union>x\<in>A. x)"
by blast

lemma Inter_eq_INT: "\<Inter>(A) = (\<Inter>x\<in>A. x)"
by (unfold Inter_def, blast)

lemma UN_0 [simp]: "(\<Union>i\<in>0. A(i)) = 0"
by blast

lemma UN_singleton: "(\<Union>x\<in>A. {x}) = A"
by blast

lemma UN_Un: "(\<Union>i\<in> A \<union> B. C(i)) = (\<Union>i\<in> A. C(i)) \<union> (\<Union>i\<in>B. C(i))"
by blast

lemma INT_Un: "(\<Inter>i\<in>I \<union> J. A(i)) =
               (if I=0 then \<Inter>j\<in>J. A(j)
                       else if J=0 then \<Inter>i\<in>I. A(i)
                       else ((\<Inter>i\<in>I. A(i)) \<inter>  (\<Inter>j\<in>J. A(j))))"
by (simp, blast intro!: equalityI)

lemma UN_UN_flatten: "(\<Union>x \<in> (\<Union>y\<in>A. B(y)). C(x)) = (\<Union>y\<in>A. \<Union>x\<in> B(y). C(x))"
by blast

(*Halmos, Naive Set Theory, page 35.*)
lemma Int_UN_distrib: "B \<inter> (\<Union>i\<in>I. A(i)) = (\<Union>i\<in>I. B \<inter> A(i))"
by blast

lemma Un_INT_distrib: "I\<noteq>0 ==> B \<union> (\<Inter>i\<in>I. A(i)) = (\<Inter>i\<in>I. B \<union> A(i))"
by auto

lemma Int_UN_distrib2:
     "(\<Union>i\<in>I. A(i)) \<inter> (\<Union>j\<in>J. B(j)) = (\<Union>i\<in>I. \<Union>j\<in>J. A(i) \<inter> B(j))"
by blast

lemma Un_INT_distrib2: "[| I\<noteq>0;  J\<noteq>0 |] ==>
      (\<Inter>i\<in>I. A(i)) \<union> (\<Inter>j\<in>J. B(j)) = (\<Inter>i\<in>I. \<Inter>j\<in>J. A(i) \<union> B(j))"
by auto

lemma UN_constant [simp]: "(\<Union>y\<in>A. c) = (if A=0 then 0 else c)"
by force

lemma INT_constant [simp]: "(\<Inter>y\<in>A. c) = (if A=0 then 0 else c)"
by force

lemma UN_RepFun [simp]: "(\<Union>y\<in> RepFun(A,f). B(y)) = (\<Union>x\<in>A. B(f(x)))"
by blast

lemma INT_RepFun [simp]: "(\<Inter>x\<in>RepFun(A,f). B(x))    = (\<Inter>a\<in>A. B(f(a)))"
by (auto simp add: Inter_def)

lemma INT_Union_eq:
     "0 \<notin> A ==> (\<Inter>x\<in> \<Union>(A). B(x)) = (\<Inter>y\<in>A. \<Inter>x\<in>y. B(x))"
apply (subgoal_tac "\<forall>x\<in>A. x\<noteq>0")
 prefer 2 apply blast
apply (force simp add: Inter_def ball_conj_distrib)
done

lemma INT_UN_eq:
     "(\<forall>x\<in>A. B(x) \<noteq> 0)
      ==> (\<Inter>z\<in> (\<Union>x\<in>A. B(x)). C(z)) = (\<Inter>x\<in>A. \<Inter>z\<in> B(x). C(z))"
apply (subst INT_Union_eq, blast)
apply (simp add: Inter_def)
done

(** Devlin, Fundamentals of Contemporary Set Theory, page 12, exercise 5:
    Union of a family of unions **)

lemma UN_Un_distrib:
     "(\<Union>i\<in>I. A(i) \<union> B(i)) = (\<Union>i\<in>I. A(i))  \<union>  (\<Union>i\<in>I. B(i))"
by blast

lemma INT_Int_distrib:
     "I\<noteq>0 ==> (\<Inter>i\<in>I. A(i) \<inter> B(i)) = (\<Inter>i\<in>I. A(i)) \<inter> (\<Inter>i\<in>I. B(i))"
by (blast elim!: not_emptyE)

lemma UN_Int_subset:
     "(\<Union>z\<in>I \<inter> J. A(z)) \<subseteq> (\<Union>z\<in>I. A(z)) \<inter> (\<Union>z\<in>J. A(z))"
by blast

(** Devlin, page 12, exercise 5: Complements **)

lemma Diff_UN: "I\<noteq>0 ==> B - (\<Union>i\<in>I. A(i)) = (\<Inter>i\<in>I. B - A(i))"
by (blast elim!: not_emptyE)

lemma Diff_INT: "I\<noteq>0 ==> B - (\<Inter>i\<in>I. A(i)) = (\<Union>i\<in>I. B - A(i))"
by (blast elim!: not_emptyE)

(** Unions and Intersections with General Sum **)

(*Not suitable for rewriting: LOOPS!*)
lemma Sigma_cons1: "Sigma(cons(a,B), C) = ({a}*C(a)) \<union> Sigma(B,C)"
by blast

(*Not suitable for rewriting: LOOPS!*)
lemma Sigma_cons2: "A * cons(b,B) = A*{b} \<union> A*B"
by blast

lemma Sigma_succ1: "Sigma(succ(A), B) = ({A}*B(A)) \<union> Sigma(A,B)"
by blast

lemma Sigma_succ2: "A * succ(B) = A*{B} \<union> A*B"
by blast

lemma SUM_UN_distrib1:
     "(\<Sum>x \<in> (\<Union>y\<in>A. C(y)). B(x)) = (\<Union>y\<in>A. \<Sum>x\<in>C(y). B(x))"
by blast

lemma SUM_UN_distrib2:
     "(\<Sum>i\<in>I. \<Union>j\<in>J. C(i,j)) = (\<Union>j\<in>J. \<Sum>i\<in>I. C(i,j))"
by blast

lemma SUM_Un_distrib1:
     "(\<Sum>i\<in>I \<union> J. C(i)) = (\<Sum>i\<in>I. C(i)) \<union> (\<Sum>j\<in>J. C(j))"
by blast

lemma SUM_Un_distrib2:
     "(\<Sum>i\<in>I. A(i) \<union> B(i)) = (\<Sum>i\<in>I. A(i)) \<union> (\<Sum>i\<in>I. B(i))"
by blast

(*First-order version of the above, for rewriting*)
lemma prod_Un_distrib2: "I * (A \<union> B) = I*A \<union> I*B"
by (rule SUM_Un_distrib2)

lemma SUM_Int_distrib1:
     "(\<Sum>i\<in>I \<inter> J. C(i)) = (\<Sum>i\<in>I. C(i)) \<inter> (\<Sum>j\<in>J. C(j))"
by blast

lemma SUM_Int_distrib2:
     "(\<Sum>i\<in>I. A(i) \<inter> B(i)) = (\<Sum>i\<in>I. A(i)) \<inter> (\<Sum>i\<in>I. B(i))"
by blast

(*First-order version of the above, for rewriting*)
lemma prod_Int_distrib2: "I * (A \<inter> B) = I*A \<inter> I*B"
by (rule SUM_Int_distrib2)

(*Cf Aczel, Non-Well-Founded Sets, page 115*)
lemma SUM_eq_UN: "(\<Sum>i\<in>I. A(i)) = (\<Union>i\<in>I. {i} * A(i))"
by blast

lemma times_subset_iff:
     "(A'*B' \<subseteq> A*B) \<longleftrightarrow> (A' = 0 | B' = 0 | (A'\<subseteq>A) & (B'\<subseteq>B))"
by blast

lemma Int_Sigma_eq:
     "(\<Sum>x \<in> A'. B'(x)) \<inter> (\<Sum>x \<in> A. B(x)) = (\<Sum>x \<in> A' \<inter> A. B'(x) \<inter> B(x))"
by blast

(** Domain **)

lemma domain_iff: "a: domain(r) \<longleftrightarrow> (\<exists>y. <a,y>\<in> r)"
by (unfold domain_def, blast)

lemma domainI [intro]: "<a,b>\<in> r ==> a: domain(r)"
by (unfold domain_def, blast)

lemma domainE [elim!]:
    "[| a \<in> domain(r);  !!y. <a,y>\<in> r ==> P |] ==> P"
by (unfold domain_def, blast)

lemma domain_subset: "domain(Sigma(A,B)) \<subseteq> A"
by blast

lemma domain_of_prod: "b\<in>B ==> domain(A*B) = A"
by blast

lemma domain_0 [simp]: "domain(0) = 0"
by blast

lemma domain_cons [simp]: "domain(cons(<a,b>,r)) = cons(a, domain(r))"
by blast

lemma domain_Un_eq [simp]: "domain(A \<union> B) = domain(A) \<union> domain(B)"
by blast

lemma domain_Int_subset: "domain(A \<inter> B) \<subseteq> domain(A) \<inter> domain(B)"
by blast

lemma domain_Diff_subset: "domain(A) - domain(B) \<subseteq> domain(A - B)"
by blast

lemma domain_UN: "domain(\<Union>x\<in>A. B(x)) = (\<Union>x\<in>A. domain(B(x)))"
by blast

lemma domain_Union: "domain(\<Union>(A)) = (\<Union>x\<in>A. domain(x))"
by blast

(** Range **)

lemma rangeI [intro]: "<a,b>\<in> r ==> b \<in> range(r)"
apply (unfold range_def)
apply (erule converseI [THEN domainI])
done

lemma rangeE [elim!]: "[| b \<in> range(r);  !!x. <x,b>\<in> r ==> P |] ==> P"
by (unfold range_def, blast)

lemma range_subset: "range(A*B) \<subseteq> B"
apply (unfold range_def)
apply (subst converse_prod)
apply (rule domain_subset)
done

lemma range_of_prod: "a\<in>A ==> range(A*B) = B"
by blast

lemma range_0 [simp]: "range(0) = 0"
by blast

lemma range_cons [simp]: "range(cons(<a,b>,r)) = cons(b, range(r))"
by blast

lemma range_Un_eq [simp]: "range(A \<union> B) = range(A) \<union> range(B)"
by blast

lemma range_Int_subset: "range(A \<inter> B) \<subseteq> range(A) \<inter> range(B)"
by blast

lemma range_Diff_subset: "range(A) - range(B) \<subseteq> range(A - B)"
by blast

lemma domain_converse [simp]: "domain(converse(r)) = range(r)"
by blast

lemma range_converse [simp]: "range(converse(r)) = domain(r)"
by blast

(** Field **)

lemma fieldI1: "<a,b>\<in> r ==> a \<in> field(r)"
by (unfold field_def, blast)

lemma fieldI2: "<a,b>\<in> r ==> b \<in> field(r)"
by (unfold field_def, blast)

lemma fieldCI [intro]:
    "(~ <c,a>\<in>r ==> <a,b>\<in> r) ==> a \<in> field(r)"
apply (unfold field_def, blast)
done

lemma fieldE [elim!]:
     "[| a \<in> field(r);
         !!x. <a,x>\<in> r ==> P;
         !!x. <x,a>\<in> r ==> P        |] ==> P"
by (unfold field_def, blast)

lemma field_subset: "field(A*B) \<subseteq> A \<union> B"
by blast

lemma domain_subset_field: "domain(r) \<subseteq> field(r)"
apply (unfold field_def)
apply (rule Un_upper1)
done

lemma range_subset_field: "range(r) \<subseteq> field(r)"
apply (unfold field_def)
apply (rule Un_upper2)
done

lemma domain_times_range: "r \<subseteq> Sigma(A,B) ==> r \<subseteq> domain(r)*range(r)"
by blast

lemma field_times_field: "r \<subseteq> Sigma(A,B) ==> r \<subseteq> field(r)*field(r)"
by blast

lemma relation_field_times_field: "relation(r) ==> r \<subseteq> field(r)*field(r)"
by (simp add: relation_def, blast)

lemma field_of_prod: "field(A*A) = A"
by blast

lemma field_0 [simp]: "field(0) = 0"
by blast

lemma field_cons [simp]: "field(cons(<a,b>,r)) = cons(a, cons(b, field(r)))"
by blast

lemma field_Un_eq [simp]: "field(A \<union> B) = field(A) \<union> field(B)"
by blast

lemma field_Int_subset: "field(A \<inter> B) \<subseteq> field(A) \<inter> field(B)"
by blast

lemma field_Diff_subset: "field(A) - field(B) \<subseteq> field(A - B)"
by blast

lemma field_converse [simp]: "field(converse(r)) = field(r)"
by blast

(** The Union of a set of relations is a relation -- Lemma for fun_Union **)
lemma rel_Union: "(\<forall>x\<in>S. \<exists>A B. x \<subseteq> A*B) ==>
                  \<Union>(S) \<subseteq> domain(\<Union>(S)) * range(\<Union>(S))"
by blast

(** The Union of 2 relations is a relation (Lemma for fun_Un)  **)
lemma rel_Un: "[| r \<subseteq> A*B;  s \<subseteq> C*D |] ==> (r \<union> s) \<subseteq> (A \<union> C) * (B \<union> D)"
by blast

lemma domain_Diff_eq: "[| <a,c> \<in> r; c\<noteq>b |] ==> domain(r-{<a,b>}) = domain(r)"
by blast

lemma range_Diff_eq: "[| <c,b> \<in> r; c\<noteq>a |] ==> range(r-{<a,b>}) = range(r)"
by blast

subsection\<open>Image of a Set under a Function or Relation\<close>

lemma image_iff: "b \<in> r``A \<longleftrightarrow> (\<exists>x\<in>A. <x,b>\<in>r)"
by (unfold image_def, blast)

lemma image_singleton_iff: "b \<in> r``{a} \<longleftrightarrow> <a,b>\<in>r"
by (rule image_iff [THEN iff_trans], blast)

lemma imageI [intro]: "[| <a,b>\<in> r;  a\<in>A |] ==> b \<in> r``A"
by (unfold image_def, blast)

lemma imageE [elim!]:
    "[| b: r``A;  !!x.[| <x,b>\<in> r;  x\<in>A |] ==> P |] ==> P"
by (unfold image_def, blast)

lemma image_subset: "r \<subseteq> A*B ==> r``C \<subseteq> B"
by blast

lemma image_0 [simp]: "r``0 = 0"
by blast

lemma image_Un [simp]: "r``(A \<union> B) = (r``A) \<union> (r``B)"
by blast

lemma image_UN: "r `` (\<Union>x\<in>A. B(x)) = (\<Union>x\<in>A. r `` B(x))"
by blast

lemma Collect_image_eq:
     "{z \<in> Sigma(A,B). P(z)} `` C = (\<Union>x \<in> A. {y \<in> B(x). x \<in> C & P(<x,y>)})"
by blast

lemma image_Int_subset: "r``(A \<inter> B) \<subseteq> (r``A) \<inter> (r``B)"
by blast

lemma image_Int_square_subset: "(r \<inter> A*A)``B \<subseteq> (r``B) \<inter> A"
by blast

lemma image_Int_square: "B\<subseteq>A ==> (r \<inter> A*A)``B = (r``B) \<inter> A"
by blast

(*Image laws for special relations*)
lemma image_0_left [simp]: "0``A = 0"
by blast

lemma image_Un_left: "(r \<union> s)``A = (r``A) \<union> (s``A)"
by blast

lemma image_Int_subset_left: "(r \<inter> s)``A \<subseteq> (r``A) \<inter> (s``A)"
by blast

subsection\<open>Inverse Image of a Set under a Function or Relation\<close>

lemma vimage_iff:
    "a \<in> r-``B \<longleftrightarrow> (\<exists>y\<in>B. <a,y>\<in>r)"
by (unfold vimage_def image_def converse_def, blast)

lemma vimage_singleton_iff: "a \<in> r-``{b} \<longleftrightarrow> <a,b>\<in>r"
by (rule vimage_iff [THEN iff_trans], blast)

lemma vimageI [intro]: "[| <a,b>\<in> r;  b\<in>B |] ==> a \<in> r-``B"
by (unfold vimage_def, blast)

lemma vimageE [elim!]:
    "[| a: r-``B;  !!x.[| <a,x>\<in> r;  x\<in>B |] ==> P |] ==> P"
apply (unfold vimage_def, blast)
done

lemma vimage_subset: "r \<subseteq> A*B ==> r-``C \<subseteq> A"
apply (unfold vimage_def)
apply (erule converse_type [THEN image_subset])
done

lemma vimage_0 [simp]: "r-``0 = 0"
by blast

lemma vimage_Un [simp]: "r-``(A \<union> B) = (r-``A) \<union> (r-``B)"
by blast

lemma vimage_Int_subset: "r-``(A \<inter> B) \<subseteq> (r-``A) \<inter> (r-``B)"
by blast

(*NOT suitable for rewriting*)
lemma vimage_eq_UN: "f -``B = (\<Union>y\<in>B. f-``{y})"
by blast

lemma function_vimage_Int:
     "function(f) ==> f-``(A \<inter> B) = (f-``A)  \<inter>  (f-``B)"
by (unfold function_def, blast)

lemma function_vimage_Diff: "function(f) ==> f-``(A-B) = (f-``A) - (f-``B)"
by (unfold function_def, blast)

lemma function_image_vimage: "function(f) ==> f `` (f-`` A) \<subseteq> A"
by (unfold function_def, blast)

lemma vimage_Int_square_subset: "(r \<inter> A*A)-``B \<subseteq> (r-``B) \<inter> A"
by blast

lemma vimage_Int_square: "B\<subseteq>A ==> (r \<inter> A*A)-``B = (r-``B) \<inter> A"
by blast

(*Invese image laws for special relations*)
lemma vimage_0_left [simp]: "0-``A = 0"
by blast

lemma vimage_Un_left: "(r \<union> s)-``A = (r-``A) \<union> (s-``A)"
by blast

lemma vimage_Int_subset_left: "(r \<inter> s)-``A \<subseteq> (r-``A) \<inter> (s-``A)"
by blast

(** Converse **)

lemma converse_Un [simp]: "converse(A \<union> B) = converse(A) \<union> converse(B)"
by blast

lemma converse_Int [simp]: "converse(A \<inter> B) = converse(A) \<inter> converse(B)"
by blast

lemma converse_Diff [simp]: "converse(A - B) = converse(A) - converse(B)"
by blast

lemma converse_UN [simp]: "converse(\<Union>x\<in>A. B(x)) = (\<Union>x\<in>A. converse(B(x)))"
by blast

(*Unfolding Inter avoids using excluded middle on A=0*)
lemma converse_INT [simp]:
     "converse(\<Inter>x\<in>A. B(x)) = (\<Inter>x\<in>A. converse(B(x)))"
apply (unfold Inter_def, blast)
done

subsection\<open>Powerset Operator\<close>

lemma Pow_0 [simp]: "Pow(0) = {0}"
by blast

lemma Pow_insert: "Pow (cons(a,A)) = Pow(A) \<union> {cons(a,X) . X: Pow(A)}"
apply (rule equalityI, safe)
apply (erule swap)
apply (rule_tac a = "x-{a}" in RepFun_eqI, auto)
done

lemma Un_Pow_subset: "Pow(A) \<union> Pow(B) \<subseteq> Pow(A \<union> B)"
by blast

lemma UN_Pow_subset: "(\<Union>x\<in>A. Pow(B(x))) \<subseteq> Pow(\<Union>x\<in>A. B(x))"
by blast

lemma subset_Pow_Union: "A \<subseteq> Pow(\<Union>(A))"
by blast

lemma Union_Pow_eq [simp]: "\<Union>(Pow(A)) = A"
by blast

lemma Union_Pow_iff: "\<Union>(A) \<in> Pow(B) \<longleftrightarrow> A \<in> Pow(Pow(B))"
by blast

lemma Pow_Int_eq [simp]: "Pow(A \<inter> B) = Pow(A) \<inter> Pow(B)"
by blast

lemma Pow_INT_eq: "A\<noteq>0 ==> Pow(\<Inter>x\<in>A. B(x)) = (\<Inter>x\<in>A. Pow(B(x)))"
by (blast elim!: not_emptyE)

subsection\<open>RepFun\<close>

lemma RepFun_subset: "[| !!x. x\<in>A ==> f(x) \<in> B |] ==> {f(x). x\<in>A} \<subseteq> B"
by blast

lemma RepFun_eq_0_iff [simp]: "{f(x).x\<in>A}=0 \<longleftrightarrow> A=0"
by blast

lemma RepFun_constant [simp]: "{c. x\<in>A} = (if A=0 then 0 else {c})"
by force

subsection\<open>Collect\<close>

lemma Collect_subset: "Collect(A,P) \<subseteq> A"
by blast

lemma Collect_Un: "Collect(A \<union> B, P) = Collect(A,P) \<union> Collect(B,P)"
by blast

lemma Collect_Int: "Collect(A \<inter> B, P) = Collect(A,P) \<inter> Collect(B,P)"
by blast

lemma Collect_Diff: "Collect(A - B, P) = Collect(A,P) - Collect(B,P)"
by blast

lemma Collect_cons: "{x\<in>cons(a,B). P(x)} =
      (if P(a) then cons(a, {x\<in>B. P(x)}) else {x\<in>B. P(x)})"
by (simp, blast)

lemma Int_Collect_self_eq: "A \<inter> Collect(A,P) = Collect(A,P)"
by blast

lemma Collect_Collect_eq [simp]:
     "Collect(Collect(A,P), Q) = Collect(A, %x. P(x) & Q(x))"
by blast

lemma Collect_Int_Collect_eq:
     "Collect(A,P) \<inter> Collect(A,Q) = Collect(A, %x. P(x) & Q(x))"
by blast

lemma Collect_Union_eq [simp]:
     "Collect(\<Union>x\<in>A. B(x), P) = (\<Union>x\<in>A. Collect(B(x), P))"
by blast

lemma Collect_Int_left: "{x\<in>A. P(x)} \<inter> B = {x \<in> A \<inter> B. P(x)}"
by blast

lemma Collect_Int_right: "A \<inter> {x\<in>B. P(x)} = {x \<in> A \<inter> B. P(x)}"
by blast

lemma Collect_disj_eq: "{x\<in>A. P(x) | Q(x)} = Collect(A, P) \<union> Collect(A, Q)"
by blast

lemma Collect_conj_eq: "{x\<in>A. P(x) & Q(x)} = Collect(A, P) \<inter> Collect(A, Q)"
by blast

lemmas subset_SIs = subset_refl cons_subsetI subset_consI
                    Union_least UN_least Un_least
                    Inter_greatest Int_greatest RepFun_subset
                    Un_upper1 Un_upper2 Int_lower1 Int_lower2

ML \<open>
val subset_cs =
  claset_of (@{context}
    delrules [@{thm subsetI}, @{thm subsetCE}]
    addSIs @{thms subset_SIs}
    addIs  [@{thm Union_upper}, @{thm Inter_lower}]
    addSEs [@{thm cons_subsetE}]);

val ZF_cs = claset_of (@{context} delrules [@{thm equalityI}]);
\<close>

end


section \<open> thy \<close>

theory Poset
imports Main Function

begin

(* Poset type *)

record 'a Poset =
  el :: "'a set"
  le_rel :: "('a \<times> 'a) set"

definition "Poset_le_undefined_arg_not_in_domain a a' \<equiv> undefined"

abbreviation le :: "'a Poset \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
"le P a a' \<equiv>
  if a \<in> el P \<and> a' \<in> el P
  then (a, a') \<in> le_rel P
  else Poset_le_undefined_arg_not_in_domain a a'"

(*
abbreviation le_P :: "'a \<Rightarrow> 'a Poset \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<sqsubseteq>\<langle>_\<rangle> _") where
"le_P a P a' \<equiv> (a, a') \<in> le_rel P"
*)

definition valid :: "'a Poset \<Rightarrow> bool" where
  "valid P \<equiv>
    let
      welldefined = \<forall>x y. (x,y) \<in> le_rel P \<longrightarrow> x \<in> el P \<and> y \<in> el P;
      reflexivity = \<forall>x. x \<in> el P \<longrightarrow> (x,x) \<in> le_rel P;
      antisymmetry = \<forall>x y. x \<in> el P \<longrightarrow> y \<in> el P  \<longrightarrow>  (x,y) \<in> le_rel P \<longrightarrow> (y,x) \<in> le_rel P  \<longrightarrow> x = y;
      transitivity = \<forall>x y z. x \<in> el P \<longrightarrow> y \<in> el P \<longrightarrow> z \<in> el P \<longrightarrow> (x,y) \<in> le_rel P \<longrightarrow> (y,z) \<in> le_rel P\<longrightarrow> (x,z) \<in> le_rel P
    in
      welldefined \<and> reflexivity \<and> antisymmetry \<and> transitivity"

(* PosetMap type (monotone function *)

record ('a, 'b) PosetMap =
  dom :: "'a Poset"
  cod :: "'b Poset"
  func ::"('a \<times>'b) set"

definition "Poset_app_undefined_arg_not_in_domain a \<equiv> undefined"

(* Map application *)

definition app :: "('a, 'b) PosetMap \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "\<star>" 997) where
"app f a \<equiv>
  if a \<in> el (dom f)
  then (THE b. (a, b) \<in> func f)
  else Poset_app_undefined_arg_not_in_domain a"

definition valid_map :: "('a, 'b) PosetMap \<Rightarrow> bool" where
"valid_map f \<equiv>
  let
      le_dom = le (dom f);
      le_cod = le (cod f);
      e_dom = el (dom f);
      e_cod = el (cod f);
      welldefined = valid (dom f) \<and> valid (cod f) \<and> (\<forall>a b. (a, b) \<in> func f \<longrightarrow> a \<in> e_dom \<and> b \<in> e_cod);
      deterministic = (\<forall>a b b'. (a, b) \<in> func f \<and> (a, b') \<in> func f \<longrightarrow> b = b');
      total = (\<forall>a. a \<in> e_dom \<longrightarrow> (\<exists>b. (a, b) \<in> func f));
      monotone = (\<forall>a a'. a \<in> e_dom \<and> a' \<in> e_dom \<and> le_dom a a' \<longrightarrow> le_cod (f \<star> a) (f \<star> a'))

  in welldefined \<and> deterministic \<and> total \<and> monotone"

(* Validity *)

lemma validI [intro]:
  fixes P :: "'a Poset"
  assumes welldefined : "(\<And>x y. (x,y) \<in> le_rel P \<Longrightarrow> x \<in> el P \<and> y \<in> el P)"
  and reflexivity : "(\<And>x. x \<in> el P \<Longrightarrow> le P x x)"
  and antisymmetry : "(\<And>x y. x \<in> el P \<Longrightarrow> y \<in> el P \<Longrightarrow>  le P x y \<Longrightarrow> le P y x \<Longrightarrow> x = y)"
  and transitivity : "(\<And>x y z. x \<in> el P \<Longrightarrow> y \<in> el P \<Longrightarrow> z \<in> el P \<Longrightarrow> le P x y \<Longrightarrow> le P y z \<Longrightarrow> le P x z)"
    shows "valid P"
  by (smt (verit, best) antisymmetry reflexivity transitivity valid_def welldefined)

lemma valid_welldefined : "valid P \<Longrightarrow> (x,y) \<in> le_rel P \<Longrightarrow> x \<in> el P \<and> y \<in> el P"
  by (smt (verit) valid_def)

lemma valid_reflexivity : "valid P \<Longrightarrow> x \<in> el P \<Longrightarrow> le P x x"
  by (smt (verit) valid_def)

lemma valid_transitivity : "valid P \<Longrightarrow> x \<in> el P \<Longrightarrow> y \<in> el P \<Longrightarrow> z \<in> el P \<Longrightarrow> le P x y \<Longrightarrow> le P y z \<Longrightarrow> le P x z"
  by (smt (verit, ccfv_threshold) valid_def)

lemma valid_antisymmetry : "valid P \<Longrightarrow> x \<in> el P\<Longrightarrow> y \<in> el P\<Longrightarrow> le P x y \<Longrightarrow> le P y x \<Longrightarrow> x = y"
  by (smt (verit, ccfv_threshold) valid_def)

lemma valid_mapI [intro] : "valid (dom f) \<Longrightarrow> valid (cod f)  \<Longrightarrow> (\<And>a b. (a, b) \<in> func f \<Longrightarrow>  a \<in> el (dom f) \<and> b \<in> el (cod f)) \<Longrightarrow>
                   (\<And>a b b'. (a, b) \<in> func f \<Longrightarrow> (a, b') \<in> func f \<Longrightarrow> b = b') \<Longrightarrow>
                   (\<And>a. a \<in> el (dom f) \<Longrightarrow> (\<exists>b. (a, b) \<in> func f)) \<Longrightarrow>
                   (\<And>a a'. a \<in> el (dom f) \<Longrightarrow> a' \<in> el (dom f) \<Longrightarrow> le (dom f) a a' \<Longrightarrow> le (cod f) (f \<star> a) (f \<star> a'))
  \<Longrightarrow> valid_map f " unfolding valid_map_def
  by auto

lemma valid_map_welldefined_dom : "valid_map f \<Longrightarrow> valid (dom f)"
  apply (subst (asm) valid_map_def)
  by (clarsimp simp: Let_unfold)

lemma valid_map_welldefined_cod : "valid_map f \<Longrightarrow> valid (cod f)"
  apply (subst (asm) valid_map_def)
  by (clarsimp simp: Let_unfold)

lemma valid_map_welldefined_func : "valid_map f \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> a \<in> el (dom f) \<and> b \<in> el (cod f)"
  unfolding valid_map_def
  by (simp add: Let_def)

lemma valid_map_welldefined : "valid_map f \<Longrightarrow> valid (dom f) \<and> valid (cod f) \<and> (\<forall>a b. (a, b) \<in> func f \<longrightarrow> a \<in>
 el (dom f) \<and> b \<in> el (cod f))"
  by (simp add: valid_map_welldefined_cod valid_map_welldefined_dom valid_map_welldefined_func)

lemma valid_map_dom: "valid_map f \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> a \<in> el (dom f)"
  by (meson valid_map_welldefined)

lemma valid_map_cod: "valid_map f \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> b \<in> el (cod f)"
  by (meson valid_map_welldefined)

lemma valid_map_deterministic : "valid_map f \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> (a, b') \<in> func f \<Longrightarrow> b = b'"
  unfolding valid_map_def
  by (simp add: Let_def)

lemma valid_map_total : "valid_map f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> \<exists>b. (a, b) \<in> func f"
  unfolding valid_map_def
  by (simp add: Let_def)

lemma valid_map_monotone : "valid_map f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> a' \<in> el (dom f) \<Longrightarrow> le (dom f) a a' \<Longrightarrow> le (cod f) (f \<star> a) (f \<star> a')"
unfolding valid_map_def
  by metis

lemma valid_map_eqI: "cod f = cod g \<Longrightarrow> dom f = dom g \<Longrightarrow> func f = func g \<Longrightarrow> (f :: ('a, 'b) PosetMap) = g"
  by simp

(* Map application *)

lemma fun_app : "valid_map f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> (a, f \<star> a) \<in> func f"
  by (metis app_def the_equality valid_map_deterministic valid_map_total)

lemma fun_app2 : "valid_map f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> f \<star> a \<in> el (cod f)"
  by (meson fun_app valid_map_welldefined)

lemma fun_app3 [simp] : "valid_map f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> f \<star> a = (THE b. (a, b) \<in> func f) "
  by (simp add: app_def)

lemma fun_ext_raw : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And>a. a \<in> el (dom f) \<Longrightarrow> f \<star> a = g \<star> a) \<Longrightarrow> func f = func g"
  by (metis Poset.fun_app pred_equals_eq2 valid_map_deterministic valid_map_welldefined_func)

lemma fun_ext : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And> a . a \<in> el (dom f) \<Longrightarrow> f \<star> a = g \<star> a) \<Longrightarrow> f = g"
  by (meson Poset.fun_ext_raw valid_map_eqI)

lemma fun_app_iff  : "valid_map f \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> (f \<star> a) = b"
  by (meson fun_app valid_map_deterministic valid_map_welldefined)

(* Map composition *)

definition "Poset_compose_undefined_incomposable g f \<equiv> undefined"

definition compose :: "('b, 'c) PosetMap \<Rightarrow> ('a, 'b) PosetMap \<Rightarrow> ('a, 'c) PosetMap" (infixl "\<diamondop>" 55) where
  "compose g f \<equiv>
  if dom g = cod f
  then \<lparr> dom = dom f, cod = cod g, func = relcomp (func f) (func g) \<rparr>
  else Poset_compose_undefined_incomposable g f"

lemma compose_welldefined_cod : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (a, b) \<in> func (g \<diamondop> f) \<Longrightarrow> b \<in> el (cod g)"
  unfolding compose_def
  using Poset.valid_map_welldefined by auto

lemma compose_welldefined_dom : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (a, b) \<in> func (g \<diamondop> f) \<Longrightarrow> a \<in> el (dom f)"
  unfolding compose_def
  using Poset.valid_map_welldefined by auto

lemma compose_welldefined : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> (a, b) \<in> func (g \<diamondop> f) \<Longrightarrow> a \<in> el (dom f) \<and> b \<in> el (cod g)"
  by (metis Poset.valid_map_welldefined PosetMap.select_convs(3) compose_def relcomp.cases)

lemma compose_deterministic : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> (a, b) \<in> func (g \<diamondop> f) \<Longrightarrow> (a, b') \<in> func (g \<diamondop> f) \<Longrightarrow> b = b'"
  by (metis (no_types, opaque_lifting) Poset.valid_map_deterministic PosetMap.select_convs(3) compose_def relcomp.cases)

lemma compose_total : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> \<exists>b. (a, b) \<in> func (g \<diamondop> f)"
  unfolding compose_def
  by (smt (z3) Poset.fun_app Poset.fun_app2 PosetMap.select_convs(3) relcomp.relcompI)

lemma dom_compose [simp] : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> dom (g \<diamondop> f) = dom f"
  unfolding compose_def
  by (simp add: Let_def)

lemma cod_compose [simp] : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> cod (g \<diamondop> f) = cod g"
  unfolding compose_def
  by (simp add: Let_def)

lemma compose_app_assoc: "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> a \<in> el (dom f) \<Longrightarrow> dom g = cod f \<Longrightarrow> (g \<diamondop> f) \<star> a = g \<star> (f \<star> a)"
  apply (clarsimp simp: app_def, safe; clarsimp?)
  apply (smt (z3) Poset.fun_app PosetMap.select_convs(3) compose_def compose_deterministic fun_app_iff relcomp.relcompI theI')
  by (metis app_def fun_app2)

lemma compose_monotone :
  fixes f :: "('a,'b) PosetMap" and g :: "('b,'c) PosetMap" and a a' :: "'a"
  assumes f_valid : "valid_map f" and g_valid : "valid_map g"
  and a_elem : "a \<in> el (dom f)" and a'_elem : "a' \<in> el (dom f)"
  and le_aa' : "le (dom f) a a'"
  and dom_cod : "dom g = cod f"
shows "le (cod g) ((g \<diamondop> f) \<star> a) ((g \<diamondop> f) \<star> a')"
proof -
  have "le (cod f) (f \<star> a) (f \<star> a')" using valid_map_monotone
    by (metis a'_elem a_elem f_valid le_aa')
  moreover have  "le (cod g) (g \<star> (f \<star> a)) (g \<star> (f \<star> a'))" using valid_map_monotone
    by (metis a'_elem a_elem calculation dom_cod f_valid fun_app2 g_valid)
  ultimately show ?thesis using compose_app_assoc
    by (metis a'_elem a_elem dom_cod f_valid g_valid)
qed

lemma compose_valid : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom g = cod f \<Longrightarrow> valid_map (g \<diamondop> f)"
proof (intro valid_mapI, safe, goal_cases)
  case 1
  then show ?case
    by (simp add: Poset.valid_map_welldefined_dom)
next
  case 2
  then show ?case
    by (simp add: Poset.valid_map_welldefined_cod)
next
  case (3 a b)
  then show ?case
    by (simp add: Poset.compose_welldefined_dom)
next
  case (4 a b)
  then show ?case
    by (simp add: Poset.compose_welldefined_cod)
next
  case (5 a b b')
  then show ?case
    by (meson Poset.compose_deterministic)
next
  case (6 a)
  then show ?case
    by (simp add: Poset.compose_total)
next
  case (7 a a')
  then show ?case
    by (simp add: compose_monotone)
qed

lemma compose_app [simp] : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> (a, b) \<in> func f \<Longrightarrow> dom g = cod f \<Longrightarrow>
                (b, c) \<in> func g \<Longrightarrow> (g \<diamondop> f) \<star> a = c"
  apply (rule fun_app_iff)
  using compose_valid apply blast
  by (simp add: compose_def relcomp.relcompI)

lemma compose_assoc : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> valid_map h \<Longrightarrow> dom g = cod f \<Longrightarrow> dom h = cod g
\<Longrightarrow> (h \<diamondop> g) \<diamondop> f = h \<diamondop> (g \<diamondop> f)"
  by (smt (verit) Poset.cod_compose Poset.compose_app_assoc Poset.compose_valid Poset.dom_compose Poset.fun_app2 Poset.fun_ext)

(* Properties *)

abbreviation is_surjective :: "('a, 'b) PosetMap \<Rightarrow> bool" where
"is_surjective f \<equiv> \<forall> b . b \<in> el (cod f) \<longrightarrow> (\<exists> a . a \<in> el (dom f) \<and> f \<star> a = b)"

abbreviation is_injective :: "('a, 'b) PosetMap \<Rightarrow> bool" where
"is_injective f \<equiv> \<forall>a a' . a \<in> el (dom f) \<longrightarrow> a' \<in> el (dom f) \<longrightarrow> f \<star> a = f \<star> a' \<longrightarrow> a = a'"

abbreviation is_bijective :: "('a, 'b) PosetMap \<Rightarrow> bool" where
"is_bijective f \<equiv> is_surjective f \<and> is_injective f"

lemma surjection_is_right_cancellative : "valid_map f \<Longrightarrow> is_surjective f \<Longrightarrow>
  valid_map g \<Longrightarrow> valid_map h \<Longrightarrow> cod f = dom g \<Longrightarrow> cod f = dom h \<Longrightarrow>  g \<diamondop> f = h \<diamondop> f \<Longrightarrow> g = h"
  by (metis cod_compose compose_app_assoc fun_ext )

lemma injection_is_left_cancellative : "valid_map f \<Longrightarrow> is_injective f \<Longrightarrow>
  valid_map g \<Longrightarrow> valid_map h \<Longrightarrow> cod g = dom f \<Longrightarrow> cod h = dom f \<Longrightarrow>  f \<diamondop> g = f \<diamondop> h \<Longrightarrow> g = h"
  by (smt (verit, best) compose_app_assoc dom_compose fun_app2 fun_ext)

(* Identity maps *)

definition ident :: "'a Poset \<Rightarrow> ('a, 'a) PosetMap" where
"ident P \<equiv> \<lparr> dom = P, cod = P, func = Id_on (el P) \<rparr>"

lemma ident_valid  : "valid P \<Longrightarrow> valid_map (ident P)"
  unfolding valid_map_def  ident_def app_def
  apply ( simp add: Let_unfold Id_on_def )
  by blast

lemma ident_dom [simp] : "dom (ident P) = P"
  by (simp add: Poset.ident_def)

lemma ident_cod [simp] : "cod (ident P) = P"
  by (simp add: Poset.ident_def)

lemma ident_app [simp] :
  fixes a :: "'a" and P :: "'a Poset"
  assumes "valid P" and "a \<in> el P"
  shows "ident P \<star> a = a"
  by (metis Id_onI Poset.fun_app_iff Poset.ident_def Poset.ident_valid PosetMap.select_convs(3) assms(1) assms(2))

lemma compose_ident_left [simp]  : "valid_map f \<Longrightarrow> ident (cod f) \<diamondop> f = f"
  by (smt (verit, best) Poset.cod_compose Poset.compose_app_assoc Poset.compose_valid Poset.dom_compose Poset.fun_app2 Poset.fun_ext Poset.ident_app Poset.ident_cod Poset.ident_dom Poset.ident_valid valid_map_welldefined_cod)

lemma compose_ident_right [simp] : "valid_map f  \<Longrightarrow> f \<diamondop> ident (dom f) = f"
  by (smt (verit, ccfv_SIG) Poset.cod_compose Poset.compose_app_assoc Poset.compose_valid Poset.dom_compose Poset.fun_ext Poset.ident_app Poset.ident_cod Poset.ident_dom Poset.ident_valid valid_map_welldefined_dom)

(* Constant maps *)

definition "PosetMap_const_undefined_arg_not_in_codomain b \<equiv> undefined"

definition const :: "'a Poset \<Rightarrow>  'b Poset  \<Rightarrow> 'b \<Rightarrow>  ('a, 'b) PosetMap" where
"const P Q q \<equiv>
  if q \<in> el Q
  then  \<lparr> dom = P, cod = Q,  func = { (p, q) | p . p \<in> el P } \<rparr>
  else PosetMap_const_undefined_arg_not_in_codomain q"

lemma const_dom [simp] : "q \<in> el Q \<Longrightarrow> dom (const P Q q) = P"
  by (simp add: const_def)

lemma const_cod [simp] : "q \<in> el Q \<Longrightarrow> cod (const P Q q) = Q"
  by (simp add: const_def)

lemma const_app [simp] : "valid P \<Longrightarrow> valid Q \<Longrightarrow> p \<in> el P \<Longrightarrow> q \<in> el Q \<Longrightarrow> ((const P Q q) \<star> p) = q"
  unfolding const_def app_def
  by auto

lemma const_valid : "valid P \<Longrightarrow> valid Q \<Longrightarrow> q \<in> el Q \<Longrightarrow> valid_map (const P Q q)"
proof (intro valid_mapI,goal_cases)
  case 1
  then show ?case
    by simp
next
  case 2
  then show ?case
    by simp
next
  case (3 a b)
  then show ?case
    by (simp add: Poset.const_def)
next
  case (4 a b b')
  then show ?case
    by (simp add: Poset.const_def)
next
  case (5 a)
  then show ?case by (simp add: const_def)
next
  case (6 a a')
  then show ?case
    by (simp add: valid_reflexivity)
qed

(* Cartesian product of posets *)

definition product :: "'a Poset \<Rightarrow> 'b Poset \<Rightarrow> ('a \<times> 'b) Poset" (infixl "\<times>\<times>" 55) where
"product P Q \<equiv> \<lparr> el = el P \<times> el Q, le_rel =
 {(x, y). fst x \<in> el P \<and> snd x \<in> el Q \<and> fst y \<in> el P \<and> snd y \<in> el Q \<and> (fst x, fst y) \<in> le_rel P \<and> (snd x, snd y) \<in> le_rel Q} \<rparr>"

lemma product_valid : "valid P \<Longrightarrow> valid Q \<Longrightarrow> valid (P \<times>\<times> Q)"
  unfolding valid_def product_def
  by (smt (verit) Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD SigmaE SigmaI case_prodI fst_conv mem_Collect_eq prod.collapse snd_conv)

lemma product_el_1 : "(a,b) \<in> el (P \<times>\<times> Q) \<Longrightarrow> a \<in> el P"
  by (simp add: Poset.product_def)

lemma product_el_2 : "(a,b) \<in> el (P \<times>\<times> Q) \<Longrightarrow> b \<in> el Q"
  by (simp add: Poset.product_def)

lemma product_le_1 : "valid P \<Longrightarrow> valid Q \<Longrightarrow> ((a, b),(a', b')) \<in> le_rel (P \<times>\<times> Q) \<Longrightarrow> (a,a') \<in> le_rel P"
  by (simp add: Poset.product_def)

lemma product_le_2 : "valid P \<Longrightarrow> valid Q \<Longrightarrow> ((a, b),(a', b')) \<in> le_rel (P \<times>\<times> Q) \<Longrightarrow> (b,b') \<in> le_rel Q"
  by (simp add: Poset.product_def)

(* Discrete poset *)

definition discrete :: "'a Poset" where
  "discrete \<equiv> \<lparr>  el = UNIV , le_rel = {x. fst x = snd x} \<rparr>"

lemma discrete_valid : "valid discrete"
  by (simp add: discrete_def valid_def)

(* Infima and suprema *)

definition is_inf :: "'a Poset \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_inf P U i \<equiv>  U \<subseteq> el P \<and> i \<in> el P \<and>  ((\<forall>u\<in>U. le P i u) \<and> (\<forall>z \<in> el P. (\<forall>u\<in>U. le P z u) \<longrightarrow> le P z i))"

definition is_sup :: "'a Poset \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_sup P U s \<equiv> U \<subseteq> el P \<and> s \<in> el P \<and>  (s \<in> el P \<and> (\<forall>u\<in>U. le P u s) \<and> (\<forall>z \<in> el P. (\<forall>u\<in>U. le P u z) \<longrightarrow> le P s z))"

abbreviation is_bot :: "'a Poset \<Rightarrow> 'a \<Rightarrow> bool" where
"is_bot P b \<equiv> b \<in> el P \<and> (\<forall>p \<in> el P. le P b p)"

abbreviation is_top :: "'a Poset \<Rightarrow> 'a \<Rightarrow> bool" where
"is_top P t \<equiv> t \<in> el P \<and> (\<forall>p \<in> el P. le P p t)"

definition inf :: "'a Poset \<Rightarrow> 'a set \<Rightarrow> 'a option" where
"inf P U \<equiv> if (\<exists>i. i \<in> el P \<and> is_inf P U i) then Some (SOME i. i \<in> el P \<and> is_inf P U i) else None"

definition sup :: "'a Poset \<Rightarrow> 'a set \<Rightarrow> 'a option" where
"sup P U \<equiv> if (\<exists>s. s \<in> el P \<and> is_sup P U s) then Some (SOME s. s \<in> el P \<and> is_sup P U s) else None"

abbreviation is_complete :: "'a Poset \<Rightarrow> bool" where
"is_complete P \<equiv> valid P \<and> (\<forall>U. U \<subseteq> el P \<longrightarrow> (\<exists>i. is_inf P U i))"

abbreviation is_cocomplete :: "'a Poset \<Rightarrow> bool" where
"is_cocomplete P \<equiv> valid P \<and> (\<forall>U. U \<subseteq> el P \<longrightarrow> (\<exists>s. is_sup P U s))"

lemma inf_unique : "valid P \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> i \<in> el P\<Longrightarrow> i' \<in> el P \<Longrightarrow> is_inf P U i \<Longrightarrow> is_inf P U i' \<Longrightarrow> i = i'"
  unfolding is_inf_def
  by (metis valid_antisymmetry)

lemma sup_unique : "valid P  \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> s \<in> el P\<Longrightarrow> s' \<in> el P \<Longrightarrow> is_sup P U s \<Longrightarrow> is_sup P U s' \<Longrightarrow> s = s'"
  unfolding is_sup_def
  by (metis valid_antisymmetry)

lemma inf_is_glb : "valid P  \<Longrightarrow> U \<subseteq> el P  \<Longrightarrow> z \<in> el P \<Longrightarrow> i \<in> el P \<Longrightarrow> is_inf P U i
\<Longrightarrow> \<forall>u\<in>U. le P z u \<Longrightarrow> le P z i"
  by (simp add: is_inf_def)

lemma sup_is_lub : "valid P  \<Longrightarrow> U \<subseteq> el P  \<Longrightarrow> z \<in> el P \<Longrightarrow> s \<in> el P \<Longrightarrow> is_sup P U s
\<Longrightarrow> \<forall>u\<in>U. le P u z \<Longrightarrow> le P s z"
  by (simp add: is_sup_def)

lemma inf_smaller : "valid P  \<Longrightarrow> U \<subseteq> el P  \<Longrightarrow> i \<in> el P \<Longrightarrow> is_inf P U i \<Longrightarrow> \<forall> u \<in> U. le P i u"
  unfolding is_inf_def
  by blast

lemma sup_greater : "valid P  \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> s \<in> el P  \<Longrightarrow> is_sup P U s \<Longrightarrow> \<forall> u \<in> U. le P u s"
  unfolding is_sup_def
  by blast

lemma some_inf_is_inf : "valid P \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> i \<in> el P \<Longrightarrow> inf P U = Some i \<Longrightarrow> is_inf P U i"
  unfolding inf_def
  by (metis (no_types, lifting) option.distinct(1) option.inject someI_ex)

lemma some_sup_is_sup : "valid P\<Longrightarrow> U \<subseteq> el P \<Longrightarrow> sup P U = Some s \<Longrightarrow> is_sup P U s"
  unfolding sup_def
  by (metis (no_types, lifting) sup_unique option.distinct(1) option.inject some_equality)

lemma complete_inf_not_none : "valid P \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> is_complete P \<Longrightarrow> inf P U \<noteq> None"
  by (simp add: inf_def is_inf_def)

lemma cocomplete_sup_not_none : "valid P \<Longrightarrow> U \<subseteq> el P \<Longrightarrow> is_cocomplete P \<Longrightarrow> sup P U \<noteq> None"
  by (simp add: is_sup_def sup_def)

lemma complete_equiv_cocomplete : "is_complete P \<longleftrightarrow> is_cocomplete P"
proof
  assume "is_complete P"
  fix U
  define "s" where "s = inf P {a \<in> el P . (\<forall> u \<in> U . le P u a)}"
  have "s = sup P U"
    oops

(* Powerset and direct image *)

definition powerset :: "'a set \<Rightarrow> ('a set) Poset" where
"powerset X \<equiv> \<lparr> el = Pow X, le_rel = {(U, V). U \<in> Pow X \<and> V \<in> Pow X \<and> U \<subseteq> V} \<rparr>"

definition direct_image :: "('a, 'b) Function \<Rightarrow> ('a set, 'b set) PosetMap" where
"direct_image f \<equiv> \<lparr>
        dom = powerset (Function.dom f),
        cod = powerset (Function.cod f),
        func = {(p, {f \<cdot> x | x . x \<in> p}) | p . p \<subseteq> Function.dom f}
 \<rparr>"

lemma powerset_valid : "valid (powerset A)"
  by (smt (verit) Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD case_prodI dual_order.refl fst_conv mem_Collect_eq order_trans powerset_def snd_conv subset_antisym valid_def)

lemma powerset_le : "a \<in> el (powerset A) \<Longrightarrow> a' \<in> el (powerset A) \<Longrightarrow> le (powerset A) a a' = (a \<subseteq> a')"
  by (simp add: powerset_def)

lemma powerset_el : "(a \<in> el (powerset A)) = (a \<subseteq> A)"
  by (simp add: powerset_def)

lemma direct_image_dom : "dom (direct_image f) = powerset (Function.dom f)"
  by (simp add: direct_image_def)

lemma direct_image_cod : "cod (direct_image f) = powerset (Function.cod f)"
  by (simp add: direct_image_def)

lemma direct_image_app : "Function.valid_map f \<Longrightarrow> a \<subseteq> Function.dom f \<Longrightarrow> (direct_image f) \<star> a = {f \<cdot> x | x . x \<in> a}"
  unfolding Function.valid_map_def app_def direct_image_def
  apply (simp add: Let_def)
  by (simp add: powerset_def)

lemma direct_image_mono_raw: "Function.valid_map f \<Longrightarrow> a \<subseteq> Function.dom f \<Longrightarrow> a' \<subseteq> Function.dom f
 \<Longrightarrow> a \<subseteq> a' \<Longrightarrow> (direct_image f) \<star> a \<subseteq> (direct_image f) \<star> a'"
  unfolding Function.valid_map_def app_def direct_image_def
  apply (simp add: Let_def)
  by (smt (verit, del_insts) Collect_mono_iff Poset.Poset.select_convs(1) PowI powerset_def subset_eq)

lemma direct_image_valid :
  fixes f :: "('a,'b) Function"
  assumes f_valid : "Function.valid_map f"
  defines "X \<equiv> Function.dom f" and "Y \<equiv> Function.cod f"
  shows "valid_map (direct_image f)"
proof (intro valid_mapI, safe, goal_cases)
  case 1
  then show ?case
    by (simp add: direct_image_dom powerset_valid)
next
  case 2
  then show ?case
    by (simp add: direct_image_cod powerset_valid)
next
  case (3 a b)
  then show ?case
    by (simp add: direct_image_def powerset_def)
next
  case (4 a b)
  then show ?case
    by (smt (verit) Function.fun_app2 Poset.Poset.select_convs(1) PosetMap.select_convs(3) PowI direct_image_cod direct_image_def f_valid mem_Collect_eq powerset_def snd_conv subset_eq)
next
  case (5 a b b' x)
  then show ?case
    by (simp add: direct_image_def)
next
  case (6 a b b' x)
  then show ?case
    by (smt (z3) CollectD PosetMap.select_convs(3) direct_image_def fst_conv snd_conv)
next
  case (7 a)
  then show ?case
    by (simp add: direct_image_def powerset_def)
next
  case (8 a a')
  then show ?case
  proof -
    fix a a'
    assume "a \<in> el (PosetMap.dom (direct_image f))"
    assume "a'\<in> el (PosetMap.dom (direct_image f))"
    assume "le (PosetMap.dom (direct_image f)) a a'"

    have "(direct_image f) \<star> a = {f \<cdot> x | x . x \<in> a}" using direct_image_def [where ?f=f] app_def
        [where ?f="direct_image f" and ?a=a]
      by (metis (mono_tags, lifting) Poset.Poset.select_convs(1) PowD \<open>a \<in> el (PosetMap.dom (direct_image f))\<close> direct_image_app direct_image_dom f_valid powerset_def)
    moreover have "(direct_image f) \<star> a' = {f \<cdot> x | x . x \<in> a'}" using direct_image_def [where ?f=f] app_def
        [where ?f="direct_image f" and ?a=a']
      by (metis (mono_tags, lifting) Poset.Poset.select_convs(1) PosetMap.select_convs(1) Pow_iff \<open>a' \<in> el (PosetMap.dom (direct_image f))\<close> direct_image_app f_valid powerset_def)
    moreover have "{f \<cdot> x | x . x \<in> a} \<subseteq> {f \<cdot> x | x . x \<in> a'}" using direct_image_def [where ?f=f]
        calculation
      by (smt (verit) Poset.Poset.select_convs(2) Pow_iff \<open>a \<in> el (PosetMap.dom (direct_image f))\<close> \<open>a' \<in> el (PosetMap.dom (direct_image f))\<close> \<open>le (PosetMap.dom (direct_image f)) a a'\<close> case_prod_unfold direct_image_dom direct_image_mono_raw f_valid fst_conv mem_Collect_eq powerset_def snd_conv)

    ultimately show "le (PosetMap.cod (direct_image f)) (direct_image f \<star> a) (direct_image f \<star>
      a')" using direct_image_def [where ?f=f] powerset_def [where ?X="Function.cod f"]
      by (smt (verit) Function.fun_app2 Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) PosetMap.select_convs(1) PosetMap.select_convs(2) Pow_iff \<open>a' \<in> el (PosetMap.dom (direct_image f))\<close> case_prodI f_valid mem_Collect_eq powerset_def subsetD subsetI)
  qed
qed

lemma direct_image_mono:
  fixes f :: "('a, 'b) Function" and a a' :: "'a set"
  defines "pf \<equiv> direct_image f"
  assumes f_valid : "Function.valid_map f"
  and a_el : "a \<in> el (dom pf)" and a'_el : "a' \<in> el (dom pf)" and a_le_a' : "le (dom pf) a a'"
shows "le (cod pf) (pf \<star> a) (pf \<star> a')"
  by (metis a'_el a_el a_le_a' direct_image_valid f_valid pf_def valid_map_monotone)

lemma direct_image_ident : "direct_image (Function.ident X) = ident (powerset X)"
proof -
  fix X :: "'a set"
  have " {(p, p) |p . p \<subseteq> X} =  Id_on (Pow X)" using Id_on_def [where ?A="Pow X"]   Pow_def
      [where ?A=X] set_eqI [where ?A="Id_on (Pow X)" and ?B="{(p, p) |p. p \<subseteq> X}"]
    by blast

  moreover have "func (ident (powerset X)) = {(p, p) |p . p \<subseteq> X}"
    by (simp add: Poset.ident_def calculation powerset_def)
  moreover have "dom (direct_image (Function.ident X)) = powerset X"
    by (simp add: direct_image_dom)
  moreover have "cod (direct_image (Function.ident X)) = powerset X"
    by (simp add: Function.ident_def direct_image_cod)

  moreover have "\<forall> p . p \<subseteq> X \<longrightarrow> {Function.ident X \<cdot> x |x. x \<in> p} = p" using Function.ident_app [where
        ?X=X]
    by (smt (verit, ccfv_threshold) Collect_cong Collect_mem_eq in_mono)
  moreover have "func (direct_image (Function.ident X)) = {(p, p) |p . p \<subseteq> X}" using calculation
      direct_image_def
    [where ?f="Function.ident X"] Function.ident_app [where ?X=X]
    by force
   ultimately show "direct_image (Function.ident X) = ident (powerset X)"
     by (simp add: Poset.ident_def)
 qed

lemma direct_image_trans :
  fixes g :: "('b, 'c) Function" and f :: "('a , 'b) Function"
  assumes f_valid : "Function.valid_map f"
  and g_valid : "Function.valid_map g"
  and "Function.cod f = Function.dom g"
shows "direct_image g \<diamondop> direct_image f = direct_image (g \<bullet> f)"
proof (rule fun_ext, goal_cases)
  case 1
  then show ?case
    by (simp add: Poset.compose_valid assms(3) direct_image_cod direct_image_dom direct_image_valid f_valid g_valid)
next
  case 2
  then show ?case
    using Function.compose_valid assms(3) direct_image_valid f_valid g_valid by blast
next
  case 3
  then show ?case
    by (simp add: assms(3) direct_image_cod direct_image_dom direct_image_valid f_valid g_valid)
next
  case 4
  then show ?case
    by (simp add: assms(3) direct_image_cod direct_image_dom direct_image_valid f_valid g_valid)
next
  case (5 a)
  then show ?case
    proof -
    fix a
    assume "a \<in> el (PosetMap.dom (direct_image g \<diamondop> direct_image f))"
    have "a \<subseteq> Function.dom f"
      by (metis (no_types, lifting) Poset.Poset.select_convs(1) Poset.dom_compose PowD \<open>a \<in> el (PosetMap.dom (direct_image g \<diamondop> direct_image f))\<close> assms(3) direct_image_cod direct_image_dom direct_image_valid f_valid g_valid powerset_def)
    have "(a, {f \<cdot> x |x. x \<in> a}) \<in> {(b, {f \<cdot> x |x. x \<in> b}) |b. b \<subseteq> Function.dom f} "
      using \<open>a \<subseteq> Function.dom f\<close> by blast
    moreover have "{f \<cdot> x |x. x \<in> a} \<subseteq> Function.cod f"
      using Function.fun_app2 \<open>a \<subseteq> Function.dom f\<close> f_valid by fastforce
    moreover have "({f \<cdot> x |x. x \<in> a}, {g \<cdot> (f \<cdot> x) |x. x \<in> a}) \<in> {(b, {g \<cdot> x |x. x \<in> b}) |b. b \<subseteq>
      Function.cod f}"
      using calculation(2) by blast
    moreover have "(a, {g \<cdot> (f \<cdot> x) |x. x \<in> a}) \<in>
  {(p, {f \<cdot> x |x. x \<in> p}) |p. p \<subseteq> Function.dom f} O {(p, {g \<cdot> x |x. x \<in> p}) |p. p  \<subseteq> Function.cod f}"
      using calculation(1) calculation(3) by auto
    ultimately show "(direct_image g \<diamondop> direct_image f) \<star> a = direct_image (g \<bullet> f) \<star> a"
      by (smt (verit) CollectD Collect_cong Function.compose_app_assoc Function.compose_valid Function.dom_compose Poset.compose_app_assoc Poset.dom_compose \<open>a \<in> el (PosetMap.dom (direct_image g \<diamondop> direct_image f))\<close> assms(3) direct_image_app direct_image_cod direct_image_dom direct_image_valid f_valid fst_conv g_valid snd_conv subset_eq)
  qed
qed

lemma surj_imp_direct_image_surj :
  fixes f :: "('a, 'b) Function"
  assumes f_valid : "Function.valid_map f"
  and f_surj : "Function.is_surjective f"
  shows "Poset.is_surjective (direct_image f)"
proof safe
  fix b
  define "X" where "X = Function.dom f"
  define "Y" where "Y = Function.cod f"

  assume "b \<in> el (PosetMap.cod (direct_image f))"
  have "b \<subseteq> Y"
    by (metis (no_types, lifting) Poset.Poset.select_convs(1) PowD Y_def \<open>b \<in> el (PosetMap.cod (direct_image f))\<close> direct_image_cod powerset_def)
  moreover have "\<forall> y \<in> b . (\<exists> x . x \<in> X \<and> f \<cdot> x = y)"
    using X_def Y_def calculation f_surj by auto
  define "pre" where "pre = (\<lambda> y. (SOME x. (y \<in> b) \<longrightarrow> (f \<cdot> x = y \<and> x \<in> X) ))"
  moreover have "\<forall> y . (y \<in> b \<longrightarrow> f \<cdot> (pre y) = y)"
    by (smt (verit, best) \<open>\<forall>y\<in>b. \<exists>x. x \<in> X \<and> f \<cdot> x = y\<close> pre_def someI_ex)
  moreover have "\<forall> y . y \<in> b \<longrightarrow> pre y \<in> X"
    by (smt (verit) \<open>\<forall>y\<in>b. \<exists>x. x \<in> X \<and> f \<cdot> x = y\<close> pre_def someI)
  define "a" where "a = { pre y | y . y \<in> b }"
  moreover have "a \<subseteq> X"
    using \<open>\<forall>y. y \<in> b \<longrightarrow> pre y \<in> X\<close> a_def by fastforce
  moreover have "a \<in> el (PosetMap.dom (direct_image f))"
    by (metis (no_types, lifting) Poset.Poset.select_convs(1) PowI X_def calculation(5) direct_image_dom powerset_def)
  moreover have "\<forall> y . (y \<in> b \<longrightarrow> ( y = f \<cdot>  (pre y)))" using calculation
  by presburger
  moreover have "\<forall> y . (y \<in> b \<longrightarrow> (\<exists> x \<in> a . y = f \<cdot> x))" using calculation
    by blast
  moreover have "((\<cdot>) f) ` a = b" using a_def pre_def using calculation
    by (smt (verit, ccfv_threshold) image_Collect_subsetI image_iff subsetI subset_antisym)
  show "\<exists>a. a \<in> el (PosetMap.dom (direct_image f)) \<and> direct_image f \<star> a = b"
    by (metis Setcompr_eq_image X_def \<open>(\<cdot>) f ` a = b\<close> calculation(5) calculation(6) direct_image_app f_valid)
  qed

lemma fibre_from_image :
  fixes f :: "('a, 'b) Function" and a :: "'a set"
  assumes f_valid : "Function.valid_map f"
  and a_el : "a \<subseteq> Function.dom f"
  and t_el : "t \<in> (direct_image f) \<star> a"
  shows "\<exists> t' . t' \<in> a \<and> f \<cdot> t' = t"
  using a_el direct_image_app f_valid t_el by fastforce

(* Forgetful functor from Pos to Set *)

definition forget_map ::  "('a, 'b) PosetMap \<Rightarrow> ('a, 'b) Function" where
"forget_map f \<equiv> \<lparr> Function.cod = el (cod f), func = func f \<rparr>"

lemma forget_map_valid : "valid_map f \<Longrightarrow> Function.valid_map (forget_map f)"
  unfolding valid_map_def forget_map_def
  apply (simp add:Let_def)
  by (smt (verit) CollectD Function.dom_def Function.select_convs(1) Function.select_convs(2) Function.valid_map_def)

(* Examples *)

definition naturals :: "nat Poset" where
  "naturals \<equiv> \<lparr>  el = UNIV , le_rel = {(x,y). x \<le> y}  \<rparr>"

lemma naturals_valid : "valid naturals"
  by (smt (verit, best) Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD UNIV_I case_prodI naturals_def fst_conv linorder_linear mem_Collect_eq order_antisym order_trans snd_conv validI)

definition divisibility :: "nat Poset" where
  "divisibility \<equiv> \<lparr>  el = UNIV , le_rel = {(x,y). x dvd y }  \<rparr>"

lemma divisibility_valid : "valid divisibility"
  by (smt (verit, del_insts) Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD UNIV_I case_prodI dvd_antisym divisibility_def fst_conv gcd_nat.refl gcd_nat.trans mem_Collect_eq snd_conv valid_def)

end


theory Part_1 imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N a) s = a" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x.0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V n) = V n" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N (n1 + n2) |
    (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus[simp] : "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction a1 a2 rule: plus.induct)
    apply auto
  done

(* 3.1 *)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N a) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus a b) = ((optimal a) \<and> (optimal b))"

lemma is_optimal : "optimal (asimp_const a)"
  apply(induction a)
    apply(auto simp add: aexp.split)
  done

(* 3.2 *)

fun sumN :: "aexp \<Rightarrow> int" where
"sumN (N a) = a" |
"sumN (V x) = 0" |
"sumN (Plus a b) = sumN a + sumN b"

fun zeroN :: "aexp \<Rightarrow> aexp" where
"zeroN (N a) = N 0" |
"zeroN (V x) = V x" |
"zeroN (Plus a b) = Plus (zeroN a) (zeroN b)"

fun sepN :: "aexp \<Rightarrow> aexp" where
"sepN a = Plus (N (sumN a)) (zeroN a)"

lemma aval_sepN : "aval (sepN t) s = aval t s"
  apply(induction t)
    apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2 ) = plus (asimp a1) (asimp a2)"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = asimp (sepN a)"

lemma aval_full_asimp : "aval (full_asimp t) s = aval t s"
  apply(induction t)
    apply(auto)
  done

(* 3.3 *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (V v) = (if x = v then a else (V v))" |
"subst x a (Plus m n) = Plus (subst x a m) (subst x a n)" |
"subst _ _ (N v) = N v"

lemma subst_lemma [simp] : "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e arbitrary: a)
    apply(auto simp add: aexp.split)
  done

lemma "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(auto)
  done

(* 3.4 *)

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | Times aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> val" where
"aval2 (N2 a) s = a" |
"aval2 (V2 x) s = s x" |
"aval2 (Plus2 a b) s = (aval2 a s) + (aval2 b s)" |
"aval2 (Times a b) s = (aval2 a s) * (aval2 b s)"

fun plus2 :: "aexp2 \<Rightarrow> aexp2 \<Rightarrow> aexp2" where
"plus2 (N2 i\<^sub>1) (N2 i\<^sub>2) = N2 (i\<^sub>1 + i\<^sub>2)" |
"plus2 (N2 i) a = (if i = 0 then a else Plus2 (N2 i) a)" |
"plus2 a (N2 i) = (if i = 0 then a else Plus2 a (N2 i))" |
"plus2 a\<^sub>1 a\<^sub>2 = Plus2 a\<^sub>1 a\<^sub>2"

fun mult :: "aexp2 \<Rightarrow> aexp2 \<Rightarrow> aexp2" where
"mult (N2 i\<^sub>1) (N2 i\<^sub>2) = N2 (i\<^sub>1*i\<^sub>2)" |
"mult (N2 i) a =
  (if i=1 then a else if i=0 then (N2 0) else Times (N2 i) a)" |
"mult a (N2 i) = (if i=0 then (N2 0) else if i = 1 then a else Times a (N2 i))" |
"mult a\<^sub>1 a\<^sub>2 = Times a\<^sub>1 a\<^sub>2"

fun asimp2 :: "aexp2 \<Rightarrow> aexp2" where
"asimp2 (N2 n) = N2 n" |
"asimp2 (V2 x) = V2 x" |
"asimp2 (Plus2 a\<^sub>1 a\<^sub>2) = plus2 (asimp2 a\<^sub>1) (asimp2 a\<^sub>2)" |
"asimp2 (Times a\<^sub>1 a\<^sub>2) = mult (asimp2 a\<^sub>1) (asimp2 a\<^sub>2)"

lemma aval2_plus [simp] : "aval2 (plus2 a\<^sub>1 a\<^sub>2) s = aval2 a\<^sub>1 s + aval2 a\<^sub>2 s"
  apply(induction a\<^sub>1 a\<^sub>2 rule: plus2.induct)
    apply(auto)
  done

lemma aval2_mult [simp] : "aval2 (mult a\<^sub>1 a\<^sub>2) s = (aval2 a\<^sub>1) s * (aval2 a\<^sub>2) s"
  apply(induction a\<^sub>1 a\<^sub>2 rule: mult.induct)
    apply(auto)
  done

lemma aval2_asimp [simp] : "aval2 (asimp2 a) s = aval2 a s"
  apply(induction a)
     apply(auto simp add: aexp2.split)
  done

(* 3.6 *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl a) _ = a" |
"lval (Vl x) s = s x" |
"lval (Plusl a\<^sub>1 a\<^sub>2) s = (lval a\<^sub>1 s) + (lval a\<^sub>2 s)" |
"lval (LET x a\<^sub>1 a\<^sub>2) s = lval a\<^sub>2 (s(x := lval a\<^sub>1 s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl a) = N a" |
"inline (Vl x) = V x" |
"inline (Plusl a b) = Plus (inline a) (inline b)" |
"inline (LET x a b) = subst x (inline a) (inline b)"

lemma "aval (inline a) s = lval a s"
  apply(induction a arbitrary: s)
     apply(auto)
  done

(* 3.7 *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N a) (N b) = Bc (a < b)" |
"less a b = Less a b"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a b = And (Not (less a b)) (Not (less b a))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a b = Not (And (Not (less a b)) (Not (Eq a b)))"

lemma "bval (Eq a b) s = (aval a s =  aval b s)"
  apply(induction a)
    apply(induction b)
      apply(auto)
  done

lemma "bval (Le a b) s = (aval a s \<le> aval b s)"
  apply(induction a)
    apply(induction b)
      apply(auto)
  done

(* 3.8 *)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 v) s = v" |
"ifval (If a b c) s = (if (ifval a s) then (ifval b s) else (ifval c s))" |
"ifval (Less2 a b) s = (aval a s < aval b s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc a) = Bc2 a" |
"b2ifexp (Less a b) = Less2 a b" |
"b2ifexp (Not a) = If (b2ifexp a) (Bc2 False) (Bc2 True)" |
"b2ifexp (And a b) = If (b2ifexp a) (b2ifexp b) (Bc2 False)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = Bc v" |
"if2bexp (If a b c) = Not (And (Not (And (if2bexp a) (if2bexp b))) (Not (And (Not (if2bexp a)) (if2bexp c))))" |
"if2bexp (Less2 a b) = Less a b"

lemma "bval (if2bexp exp) s = ifval exp s"
  apply(induction rule: if2bexp.induct)
    apply(auto)
  done

lemma "ifval (b2ifexp exp) s = bval exp s"
  apply(induction rule: b2ifexp.induct)
     apply(auto)
  done

(* 3.9 *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x ) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (NOT (VAR _)) = True" |
"is_nnf (NOT _) = False" |
"is_nnf (VAR x) = True" |
"is_nnf (AND a b) = (is_nnf a \<and> is_nnf b)" |
"is_nnf (OR a b) = (is_nnf a \<and> is_nnf b)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (NOT (AND a b)) = OR (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (OR a b)) = AND (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (NOT a)) = nnf a" |
"nnf (AND a b) = AND (nnf a) (nnf b)" |
"nnf (OR a b) = OR (nnf a) (nnf b)" |
"nnf (NOT (VAR x)) = NOT (VAR x)" |
"nnf (VAR x) = VAR x"

lemma pbval_nnf : "pbval (nnf b) s = pbval b s"
  apply(induction rule: nnf.induct)
    apply(auto)
  done

lemma is_nnf_nnf : "is_nnf (nnf b)"
  apply(induction b rule: nnf.induct)
        apply(auto)
  done

fun or_below_and :: "pbexp \<Rightarrow> bool" where
"or_below_and (VAR x) = True" |
"or_below_and (NOT a) = or_below_and a" |
"or_below_and (OR a b) = (or_below_and a \<and> or_below_and b)" |
"or_below_and (AND (OR _ _) _) = False" |
"or_below_and (AND _ (OR _ _)) = False" |
"or_below_and (AND a b) = (or_below_and a \<and> or_below_and b)"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf a = (is_nnf a \<and> or_below_and a)"

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"dist_AND (OR a\<^sub>1 a\<^sub>2) b = OR (dist_AND a\<^sub>1 b) (dist_AND a\<^sub>2 b)" |
"dist_AND a (OR b\<^sub>1 b\<^sub>2) = OR (dist_AND a b\<^sub>1) (dist_AND a b\<^sub>2)" |
"dist_AND a b = AND a b"

lemma pbval_dist [simp] : "pbval (dist_AND b\<^sub>1 b\<^sub>2) s = pbval (AND b\<^sub>1 b\<^sub>2) s"
  apply(induction b\<^sub>1 b\<^sub>2 rule: dist_AND.induct)
     apply(auto)
  done

lemma is_dnf_dist [simp] : "is_dnf a \<Longrightarrow> is_dnf b \<Longrightarrow> is_dnf (dist_AND a b)"
  apply(induction a b rule: dist_AND.induct)
    apply(auto)
  done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (AND a b) = dist_AND (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (OR a b) = OR (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT a) = NOT (dnf_of_nnf a)"

lemma "pbval (dnf_of_nnf b) s = pbval b s"
  apply(induction b arbitrary: s)
     apply(auto)
  done

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply(induction b)
     apply simp
    apply (metis dnf_of_nnf.simps(3) dnf_of_nnf.simps(4) is_dnf.simps is_nnf.elims(2) nnf.simps(3) nnf.simps(7) or_below_and.simps(1) or_below_and.simps(2) pbexp.distinct(1) pbexp.distinct(10) pbexp.distinct(8))
  using is_dnf_dist apply auto[1]
  apply (simp add: is_nnf.simps(7) or_below_and.simps(3))
  done

(* 3.10 *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 ADD _ [] = None" |
"exec1 ADD _ [a] = None" |
"exec1 (LOAD x) s stk = Some (s(x) # stk)" |
"exec1 ADD _ (j # i # stk) = Some ((i + j) # stk)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (case (exec1 i s stk) of
                      Some a \<Rightarrow> exec is s a |
                      None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x ) = [LOAD x ]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

lemma [simp] : "exec is\<^sub>1 s stk = Some a \<Longrightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s a"
  apply(induction is\<^sub>1 arbitrary: stk)
   apply(auto simp add: option.split)
  apply (metis option.case_eq_if option.simps(3))
  done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
  apply(induction a arbitrary: stk)
    apply(auto)
  done

(* 3.11 *)

type_synonym reg = nat

datatype instr2 = LDI val reg | LD vname reg | ADD reg reg

(* TODO *)


(* Title:  Weighted_Graph.thy
   Author: Lars Noschinski, TU München
*)

theory Weighted_Graph
imports
  Digraph
  Arc_Walk
  Complex_Main
begin

section {* Weighted Graphs *}

type_synonym 'b weight_fun = "'b \<Rightarrow> real"

context wf_digraph begin

definition awalk_cost :: "'b weight_fun \<Rightarrow> 'b awalk \<Rightarrow> real" where
  "awalk_cost f es = listsum (map f es)"

lemma awalk_cost_Nil[simp]: "awalk_cost f [] = 0"
  unfolding awalk_cost_def by simp

lemma awalk_cost_Cons[simp]: "awalk_cost f (x # xs) = f x + awalk_cost  f xs"
  unfolding awalk_cost_def by simp

lemma awalk_cost_append[simp]:
  "awalk_cost f (xs @ ys) = awalk_cost f xs + awalk_cost f ys"
  unfolding awalk_cost_def by simp

end

end


theory Ex4_4
  imports Main
begin

(*
By: Vadim Zaliva <vzaliva@cmu.edu>
From: T. Nipkow and G. Klein, Concrete Semantics with Isabelle/HOL. Springer, 2014.
Exercise 4.4:
*)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "star r x x" |
  step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  zero: "iter r 0 x x" |
  step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "star r x y \<Longrightarrow>  (\<exists> n. iter r n x y)"
  apply(induction rule: star.induct)
  apply(metis iter.zero)
  apply(metis iter.step)
done

end