(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Surjections from A to B up to a Permutation on B\<close>

theory Twelvefold_Way_Entry9
imports Twelvefold_Way_Entry7
begin

subsection \<open>Properties for Bijections\<close>

lemma surjective_on_implies_card_eq:
  assumes "f ` A = B"
  shows "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card B"
proof -
  from \<open>f ` A = B\<close> have "{} \<notin> (\<lambda>b. {x \<in> A. f x = b}) ` B" by auto
  from \<open>f ` A = B\<close> have "inj_on (\<lambda>b. {x \<in> A. f x = b}) B" by (fastforce intro: inj_onI)
  have "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card ((\<lambda>b. {x \<in> A. f x = b}) ` B)"
    using \<open>{} \<notin> (\<lambda>b. {x \<in> A. f x = b}) ` B\<close> by simp
  also have "\<dots> = card B"
    using \<open>inj_on (\<lambda>b. {x \<in> A. f x = b}) B\<close> by (rule card_image)
  finally show ?thesis .
qed

lemma card_eq_implies_surjective_on:
  assumes "finite B" "f \<in> A \<rightarrow>\<^sub>E B"
  assumes card_eq: "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card B"
  shows "f ` A = B"
proof
  from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show "f ` A \<subseteq> B" by auto
next
  show "B \<subseteq> f ` A"
  proof
    fix x
    assume "x \<in> B"
    have "{} \<notin> (\<lambda>b. {x \<in> A. f x = b}) ` B"
    proof (cases "card B \<ge> 1")
      assume "\<not> card B \<ge> 1"
      from this have "card B = 0" by simp
      from this \<open>finite B\<close> have "B = {}" by simp
      from this show ?thesis by simp
    next
      assume "card B \<ge> 1"
      show ?thesis
      proof (rule ccontr)
        assume "\<not> {} \<notin> (\<lambda>b. {x \<in> A. f x = b}) ` B"
        from this have "{} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B" by simp
        moreover have "card ((\<lambda>b. {x \<in> A. f x = b}) ` B) \<le> card B"
          using \<open>finite B\<close> card_image_le by blast
        moreover have "finite ((\<lambda>b. {x \<in> A. f x = b}) ` B)"
          using \<open>finite B\<close> by auto
        ultimately have "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) \<le> card B - 1"
          by (auto simp add: card_Diff_singleton)
        from this card_eq \<open>card B \<ge> 1\<close> show False by auto
      qed
    qed
    from this \<open>x \<in> B\<close> show "x \<in> f ` A" by force
  qed
qed

lemma functions_of_is_surj_on:
  assumes "finite A" "finite B"
  assumes "partition_on A P" "card P = card B"
  shows "univ (\<lambda>f. f ` A = B) (functions_of P A B)"
proof -
  have "functions_of P A B \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
    using functions_of \<open>finite A\<close> \<open>finite B\<close> \<open>partition_on A P\<close> \<open>card P = card B\<close> by fastforce
  from this obtain f where eq_f: "functions_of P A B = range_permutation A B `` {f}" and "f \<in> A \<rightarrow>\<^sub>E B"
    using quotientE by blast
  from eq_f have "f \<in> functions_of P A B"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> equiv_range_permutation equiv_class_self by fastforce
  from \<open>f \<in> functions_of P A B\<close> have eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
    unfolding functions_of_def by auto
  from this have "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card B"
    using \<open>card P = card B\<close> by simp
  from \<open>finite B\<close> \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> this have "f ` A = B"
    using card_eq_implies_surjective_on by blast
  from this show ?thesis
    unfolding eq_f using equiv_range_permutation surj_on_respects_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') assumption+
qed

subsection \<open>Bijections\<close>

lemma bij_betw_partitions_of:
  assumes "finite A" "finite B"
  shows "bij_betw (partitions_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B) {P. partition_on A P \<and> card P = card B}"
proof (rule bij_betw_byWitness[where f'="\<lambda>P. functions_of P A B"])
  have quotient_eq: "{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // range_permutation A B). univ (\<lambda>f. f ` A = B) F}"
  using equiv_range_permutation[of A B] surj_on_respects_range_permutation[of A B] by (simp only: univ_preserves_predicate)
  show "\<forall>F\<in>{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B. functions_of (partitions_of A B F) A B = F"
    using \<open>finite B\<close> by (simp add: functions_of_partitions_of quotient_eq)
  show "\<forall>P\<in>{P. partition_on A P \<and> card P = card B}. partitions_of A B (functions_of P A B) = P"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: partitions_of_functions_of)
  show "partitions_of A B ` ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B) \<subseteq> {P. partition_on A P \<and> card P = card B}"
    using \<open>finite B\<close> quotient_eq card_partitions_of partitions_of by fastforce
  show "(\<lambda>P. functions_of P A B) ` {P. partition_on A P \<and> card P = card B} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_surj_on)
qed

subsection \<open>Cardinality\<close>

lemma card_surjective_functions_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B) = Stirling (card A) (card B)"
proof -
  have "bij_betw (partitions_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B) {P. partition_on A P \<and> card P = card B}"
    using \<open>finite A\<close> \<open>finite B\<close> by (rule bij_betw_partitions_of)
  from this have "card ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B) = card {P. partition_on A P \<and> card P = card B}"
    by (rule bij_betw_same_card)
  also have "card {P. partition_on A P \<and> card P = card B} = Stirling (card A) (card B)"
    using \<open>finite A\<close> by (rule card_partition_on)
  finally show ?thesis .
qed

end


(*<*)
theory Nested imports ABexpr begin
(*>*)

text\<open>
\index{datatypes!and nested recursion}%
So far, all datatypes had the property that on the right-hand side of their
definition they occurred only at the top-level: directly below a
constructor. Now we consider \emph{nested recursion}, where the recursive
datatype occurs nested in some other datatype (but not inside itself!).
Consider the following model of terms
where function symbols can be applied to a list of arguments:
\<close>
(*<*)hide_const Var(*>*)
datatype ('v,'f)"term" = Var 'v | App 'f "('v,'f)term list"

text\<open>\noindent
Note that we need to quote \<open>term\<close> on the left to avoid confusion with
the Isabelle command \isacommand{term}.
Parameter \<^typ>\<open>'v\<close> is the type of variables and \<^typ>\<open>'f\<close> the type of
function symbols.
A mathematical term like $f(x,g(y))$ becomes \<^term>\<open>App f [Var x, App g
  [Var y]]\<close>, where \<^term>\<open>f\<close>, \<^term>\<open>g\<close>, \<^term>\<open>x\<close>, \<^term>\<open>y\<close> are
suitable values, e.g.\ numbers or strings.

What complicates the definition of \<open>term\<close> is the nested occurrence of
\<open>term\<close> inside \<open>list\<close> on the right-hand side. In principle,
nested recursion can be eliminated in favour of mutual recursion by unfolding
the offending datatypes, here \<open>list\<close>. The result for \<open>term\<close>
would be something like
\medskip

\input{unfoldnested.tex}
\medskip

\noindent
Although we do not recommend this unfolding to the user, it shows how to
simulate nested recursion by mutual recursion.
Now we return to the initial definition of \<open>term\<close> using
nested recursion.

Let us define a substitution function on terms. Because terms involve term
lists, we need to define two substitution functions simultaneously:
\<close>

primrec
subst :: "('v\<Rightarrow>('v,'f)term) \<Rightarrow> ('v,'f)term      \<Rightarrow> ('v,'f)term" and
substs:: "('v\<Rightarrow>('v,'f)term) \<Rightarrow> ('v,'f)term list \<Rightarrow> ('v,'f)term list"
where
"subst s (Var x) = s x" |
  subst_App:
"subst s (App f ts) = App f (substs s ts)" |

"substs s [] = []" |
"substs s (t # ts) = subst s t # substs s ts"

text\<open>\noindent
Individual equations in a \commdx{primrec} definition may be
named as shown for @{thm[source]subst_App}.
The significance of this device will become apparent below.

Similarly, when proving a statement about terms inductively, we need
to prove a related statement about term lists simultaneously. For example,
the fact that the identity substitution does not change a term needs to be
strengthened and proved as follows:
\<close>

lemma subst_id(*<*)(*referred to from ABexpr*)(*>*): "subst  Var t  = (t ::('v,'f)term)  \<and>
                  substs Var ts = (ts::('v,'f)term list)"
apply(induct_tac t and ts rule: subst.induct substs.induct, simp_all)
done

text\<open>\noindent
Note that \<^term>\<open>Var\<close> is the identity substitution because by definition it
leaves variables unchanged: \<^prop>\<open>subst Var (Var x) = Var x\<close>. Note also
that the type annotations are necessary because otherwise there is nothing in
the goal to enforce that both halves of the goal talk about the same type
parameters \<open>('v,'f)\<close>. As a result, induction would fail
because the two halves of the goal would be unrelated.

\begin{exercise}
The fact that substitution distributes over composition can be expressed
roughly as follows:
@{text[display]"subst (f \<circ> g) t = subst f (subst g t)"}
Correct this statement (you will find that it does not type-check),
strengthen it, and prove it. (Note: \<open>\<circ>\<close> is function composition;
its definition is found in theorem @{thm[source]o_def}).
\end{exercise}
\begin{exercise}\label{ex:trev-trev}
  Define a function \<^term>\<open>trev\<close> of type \<^typ>\<open>('v,'f)term => ('v,'f)term\<close>
that recursively reverses the order of arguments of all function symbols in a
  term. Prove that \<^prop>\<open>trev(trev t) = t\<close>.
\end{exercise}

The experienced functional programmer may feel that our definition of
\<^term>\<open>subst\<close> is too complicated in that \<^const>\<open>substs\<close> is
unnecessary. The \<^term>\<open>App\<close>-case can be defined directly as
@{term[display]"subst s (App f ts) = App f (map (subst s) ts)"}
where \<^term>\<open>map\<close> is the standard list function such that
\<open>map f [x1,...,xn] = [f x1,...,f xn]\<close>. This is true, but Isabelle
insists on the conjunctive format. Fortunately, we can easily \emph{prove}
that the suggested equation holds:
\<close>
(*<*)
(* Exercise 1: *)
lemma "subst  ((subst f) \<circ> g) t  = subst  f (subst g t) \<and>
       substs ((subst f) \<circ> g) ts = substs f (substs g ts)"
apply (induct_tac t and ts rule: subst.induct substs.induct)
apply (simp_all)
done

(* Exercise 2: *)

primrec trev :: "('v,'f) term \<Rightarrow> ('v,'f) term"
  and trevs:: "('v,'f) term list \<Rightarrow> ('v,'f) term list"
where
  "trev (Var v)    = Var v"
| "trev (App f ts) = App f (trevs ts)"
| "trevs [] = []"
| "trevs (t#ts) = (trevs ts) @ [(trev t)]"

lemma "trev (trev t) = (t::('v,'f)term) \<and>
       trevs (trevs ts) = (ts::('v,'f)term list)"
apply (induct_tac t and ts rule: trev.induct trevs.induct, simp_all)
done
(*>*)

lemma [simp]: "subst s (App f ts) = App f (map (subst s) ts)"
apply(induct_tac ts, simp_all)
done

text\<open>\noindent
What is more, we can now disable the old defining equation as a
simplification rule:
\<close>

declare subst_App [simp del]

text\<open>\noindent The advantage is that now we have replaced \<^const>\<open>substs\<close> by \<^const>\<open>map\<close>, we can profit from the large number of
pre-proved lemmas about \<^const>\<open>map\<close>.  Unfortunately, inductive proofs
about type \<open>term\<close> are still awkward because they expect a
conjunction. One could derive a new induction principle as well (see
\S\ref{sec:derive-ind}), but simpler is to stop using
\isacommand{primrec} and to define functions with \isacommand{fun}
instead.  Simple uses of \isacommand{fun} are described in
\S\ref{sec:fun} below.  Advanced applications, including functions
over nested datatypes like \<open>term\<close>, are discussed in a
separate tutorial~\<^cite>\<open>"isabelle-function"\<close>.

Of course, you may also combine mutual and nested recursion of datatypes. For example,
constructor \<open>Sum\<close> in \S\ref{sec:datatype-mut-rec} could take a list of
expressions as its argument: \<open>Sum\<close>~@{typ[quotes]"'a aexp list"}.
\<close>
(*<*)end(*>*)


(* Author: Tobias Nipkow, TU Muenchen *)

section \<open>Sum and product over lists\<close>

theory Groups_List
imports List
begin

locale monoid_list = monoid
begin

definition F :: "'a list \<Rightarrow> 'a"
where
  eq_foldr [code]: "F xs = foldr f xs \<^bold>1"

lemma Nil [simp]:
  "F [] = \<^bold>1"
  by (simp add: eq_foldr)

lemma Cons [simp]:
  "F (x # xs) = x \<^bold>* F xs"
  by (simp add: eq_foldr)

lemma append [simp]:
  "F (xs @ ys) = F xs \<^bold>* F ys"
  by (induct xs) (simp_all add: assoc)

end

locale comm_monoid_list = comm_monoid + monoid_list
begin

lemma rev [simp]:
  "F (rev xs) = F xs"
  by (simp add: eq_foldr foldr_fold  fold_rev fun_eq_iff assoc left_commute)

end

locale comm_monoid_list_set = list: comm_monoid_list + set: comm_monoid_set
begin

lemma distinct_set_conv_list:
  "distinct xs \<Longrightarrow> set.F g (set xs) = list.F (map g xs)"
  by (induct xs) simp_all

lemma set_conv_list [code]:
  "set.F g (set xs) = list.F (map g (remdups xs))"
  by (simp add: distinct_set_conv_list [symmetric])

end

subsection \<open>List summation\<close>

context monoid_add
begin

sublocale sum_list: monoid_list plus 0
defines
  sum_list = sum_list.F ..

end

context comm_monoid_add
begin

sublocale sum_list: comm_monoid_list plus 0
rewrites
  "monoid_list.F plus 0 = sum_list"
proof -
  show "comm_monoid_list plus 0" ..
  then interpret sum_list: comm_monoid_list plus 0 .
  from sum_list_def show "monoid_list.F plus 0 = sum_list" by simp
qed

sublocale sum: comm_monoid_list_set plus 0
rewrites
  "monoid_list.F plus 0 = sum_list"
  and "comm_monoid_set.F plus 0 = sum"
proof -
  show "comm_monoid_list_set plus 0" ..
  then interpret sum: comm_monoid_list_set plus 0 .
  from sum_list_def show "monoid_list.F plus 0 = sum_list" by simp
  from sum_def show "comm_monoid_set.F plus 0 = sum" by (auto intro: sym)
qed

end

text \<open>Some syntactic sugar for summing a function over a list:\<close>
syntax (ASCII)
  "_sum_list" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)
syntax
  "_sum_list" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Sum>x\<leftarrow>xs. b" == "CONST sum_list (CONST map (\<lambda>x. b) xs)"

text \<open>TODO duplicates\<close>
lemmas sum_list_simps = sum_list.Nil sum_list.Cons
lemmas sum_list_append = sum_list.append
lemmas sum_list_rev = sum_list.rev

lemma (in monoid_add) fold_plus_sum_list_rev:
  "fold plus xs = plus (sum_list (rev xs))"
proof
  fix x
  have "fold plus xs x = sum_list (rev xs @ [x])"
    by (simp add: foldr_conv_fold sum_list.eq_foldr)
  also have "\<dots> = sum_list (rev xs) + x"
    by simp
  finally show "fold plus xs x = sum_list (rev xs) + x"
    .
qed

lemma (in comm_monoid_add) sum_list_map_remove1:
  "x \<in> set xs \<Longrightarrow> sum_list (map f xs) = f x + sum_list (map f (remove1 x xs))"
  by (induct xs) (auto simp add: ac_simps)

lemma (in monoid_add) size_list_conv_sum_list:
  "size_list f xs = sum_list (map f xs) + size xs"
  by (induct xs) auto

lemma (in monoid_add) length_concat:
  "length (concat xss) = sum_list (map length xss)"
  by (induct xss) simp_all

lemma (in monoid_add) length_product_lists:
  "length (product_lists xss) = foldr op * (map length xss) 1"
proof (induct xss)
  case (Cons xs xss) then show ?case by (induct xs) (auto simp: length_concat o_def)
qed simp

lemma (in monoid_add) sum_list_map_filter:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"
  shows "sum_list (map f (filter P xs)) = sum_list (map f xs)"
  using assms by (induct xs) auto

lemma (in comm_monoid_add) distinct_sum_list_conv_Sum:
  "distinct xs \<Longrightarrow> sum_list xs = Sum (set xs)"
  by (induct xs) simp_all

lemma sum_list_upt[simp]:
  "m \<le> n \<Longrightarrow> sum_list [m..<n] = \<Sum> {m..<n}"
by(simp add: distinct_sum_list_conv_Sum)

lemma sum_list_eq_0_nat_iff_nat [simp]:
  "sum_list ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"
  by (induct ns) simp_all

lemma member_le_sum_list_nat:
  "(n :: nat) \<in> set ns \<Longrightarrow> n \<le> sum_list ns"
  by (induct ns) auto

lemma elem_le_sum_list_nat:
  "k < size ns \<Longrightarrow> ns ! k \<le> sum_list (ns::nat list)"
  by (rule member_le_sum_list_nat) simp

lemma sum_list_update_nat:
  "k < size ns \<Longrightarrow> sum_list (ns[k := (n::nat)]) = sum_list ns + n - ns ! k"
apply(induct ns arbitrary:k)
 apply (auto split:nat.split)
apply(drule elem_le_sum_list_nat)
apply arith
done

lemma (in monoid_add) sum_list_triv:
  "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"
  by (induct xs) (simp_all add: distrib_right)

lemma (in monoid_add) sum_list_0 [simp]:
  "(\<Sum>x\<leftarrow>xs. 0) = 0"
  by (induct xs) (simp_all add: distrib_right)

text\<open>For non-Abelian groups \<open>xs\<close> needs to be reversed on one side:\<close>
lemma (in ab_group_add) uminus_sum_list_map:
  "- sum_list (map f xs) = sum_list (map (uminus \<circ> f) xs)"
  by (induct xs) simp_all

lemma (in comm_monoid_add) sum_list_addf:
  "(\<Sum>x\<leftarrow>xs. f x + g x) = sum_list (map f xs) + sum_list (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ab_group_add) sum_list_subtractf:
  "(\<Sum>x\<leftarrow>xs. f x - g x) = sum_list (map f xs) - sum_list (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) sum_list_const_mult:
  "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) sum_list_mult_const:
  "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ordered_ab_group_add_abs) sum_list_abs:
  "\<bar>sum_list xs\<bar> \<le> sum_list (map abs xs)"
  by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

lemma sum_list_mono:
  fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"
  shows "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sum>x\<leftarrow>xs. f x) \<le> (\<Sum>x\<leftarrow>xs. g x)"
  by (induct xs) (simp, simp add: add_mono)

lemma (in monoid_add) sum_list_distinct_conv_sum_set:
  "distinct xs \<Longrightarrow> sum_list (map f xs) = sum f (set xs)"
  by (induct xs) simp_all

lemma (in monoid_add) interv_sum_list_conv_sum_set_nat:
  "sum_list (map f [m..<n]) = sum f (set [m..<n])"
  by (simp add: sum_list_distinct_conv_sum_set)

lemma (in monoid_add) interv_sum_list_conv_sum_set_int:
  "sum_list (map f [k..l]) = sum f (set [k..l])"
  by (simp add: sum_list_distinct_conv_sum_set)

text \<open>General equivalence between @{const sum_list} and @{const sum}\<close>
lemma (in monoid_add) sum_list_sum_nth:
  "sum_list xs = (\<Sum> i = 0 ..< length xs. xs ! i)"
  using interv_sum_list_conv_sum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)

lemma sum_list_map_eq_sum_count:
  "sum_list (map f xs) = sum (\<lambda>x. count_list xs x * f x) (set xs)"
proof(induction xs)
  case (Cons x xs)
  show ?case (is "?l = ?r")
  proof cases
    assume "x \<in> set xs"
    have "?l = f x + (\<Sum>x\<in>set xs. count_list xs x * f x)" by (simp add: Cons.IH)
    also have "set xs = insert x (set xs - {x})" using \<open>x \<in> set xs\<close>by blast
    also have "f x + (\<Sum>x\<in>insert x (set xs - {x}). count_list xs x * f x) = ?r"
      by (simp add: sum.insert_remove eq_commute)
    finally show ?thesis .
  next
    assume "x \<notin> set xs"
    hence "\<And>xa. xa \<in> set xs \<Longrightarrow> x \<noteq> xa" by blast
    thus ?thesis by (simp add: Cons.IH \<open>x \<notin> set xs\<close>)
  qed
qed simp

lemma sum_list_map_eq_sum_count2:
assumes "set xs \<subseteq> X" "finite X"
shows "sum_list (map f xs) = sum (\<lambda>x. count_list xs x * f x) X"
proof-
  let ?F = "\<lambda>x. count_list xs x * f x"
  have "sum ?F X = sum ?F (set xs \<union> (X - set xs))"
    using Un_absorb1[OF assms(1)] by(simp)
  also have "\<dots> = sum ?F (set xs)"
    using assms(2)
    by(simp add: sum.union_disjoint[OF _ _ Diff_disjoint] del: Un_Diff_cancel)
  finally show ?thesis by(simp add:sum_list_map_eq_sum_count)
qed

lemma sum_list_nonneg:
    "(\<And>x. x \<in> set xs \<Longrightarrow> (x :: 'a :: ordered_comm_monoid_add) \<ge> 0) \<Longrightarrow> sum_list xs \<ge> 0"
  by (induction xs) simp_all

lemma (in monoid_add) sum_list_map_filter':
  "sum_list (map f (filter P xs)) = sum_list (map (\<lambda>x. if P x then f x else 0) xs)"
  by (induction xs) simp_all

lemma sum_list_cong [fundef_cong]:
  assumes "xs = ys"
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = g x"
  shows    "sum_list (map f xs) = sum_list (map g ys)"
proof -
  from assms(2) have "sum_list (map f xs) = sum_list (map g xs)"
    by (induction xs) simp_all
  with assms(1) show ?thesis by simp
qed

subsection \<open>Further facts about @{const List.n_lists}\<close>

lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"
  by (induct n) (auto simp add: comp_def length_concat sum_list_triv)

lemma distinct_n_lists:
  assumes "distinct xs"
  shows "distinct (List.n_lists n xs)"
proof (rule card_distinct)
  from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)
  have "card (set (List.n_lists n xs)) = card (set xs) ^ n"
  proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)
    moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys) ` set xs)
      = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys) ` set xs))"
      by (rule card_UN_disjoint) auto
    moreover have "\<And>ys. card ((\<lambda>y. y # ys) ` set xs) = card (set xs)"
      by (rule card_image) (simp add: inj_on_def)
    ultimately show ?case by auto
  qed
  also have "\<dots> = length xs ^ n" by (simp add: card_length)
  finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"
    by (simp add: length_n_lists)
qed

subsection \<open>Tools setup\<close>

lemmas sum_code = sum.set_conv_list

lemma sum_set_upto_conv_sum_list_int [code_unfold]:
  "sum f (set [i..j::int]) = sum_list (map f [i..j])"
  by (simp add: interv_sum_list_conv_sum_set_int)

lemma sum_set_upt_conv_sum_list_nat [code_unfold]:
  "sum f (set [m..<n]) = sum_list (map f [m..<n])"
  by (simp add: interv_sum_list_conv_sum_set_nat)

lemma sum_list_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "A 0 0"
  assumes [transfer_rule]: "(A ===> A ===> A) op + op +"
  shows "(list_all2 A ===> A) sum_list sum_list"
  unfolding sum_list.eq_foldr [abs_def]
  by transfer_prover

subsection \<open>List product\<close>

context monoid_mult
begin

sublocale prod_list: monoid_list times 1
defines
  prod_list = prod_list.F ..

end

context comm_monoid_mult
begin

sublocale prod_list: comm_monoid_list times 1
rewrites
  "monoid_list.F times 1 = prod_list"
proof -
  show "comm_monoid_list times 1" ..
  then interpret prod_list: comm_monoid_list times 1 .
  from prod_list_def show "monoid_list.F times 1 = prod_list" by simp
qed

sublocale prod: comm_monoid_list_set times 1
rewrites
  "monoid_list.F times 1 = prod_list"
  and "comm_monoid_set.F times 1 = prod"
proof -
  show "comm_monoid_list_set times 1" ..
  then interpret prod: comm_monoid_list_set times 1 .
  from prod_list_def show "monoid_list.F times 1 = prod_list" by simp
  from prod_def show "comm_monoid_set.F times 1 = prod" by (auto intro: sym)
qed

end

lemma prod_list_cong [fundef_cong]:
  assumes "xs = ys"
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = g x"
  shows    "prod_list (map f xs) = prod_list (map g ys)"
proof -
  from assms(2) have "prod_list (map f xs) = prod_list (map g xs)"
    by (induction xs) simp_all
  with assms(1) show ?thesis by simp
qed

lemma prod_list_zero_iff:
  "prod_list xs = 0 \<longleftrightarrow> (0 :: 'a :: {semiring_no_zero_divisors, semiring_1}) \<in> set xs"
  by (induction xs) simp_all

text \<open>Some syntactic sugar:\<close>

syntax (ASCII)
  "_prod_list" :: "pttrn => 'a list => 'b => 'b"    ("(3PROD _<-_. _)" [0, 51, 10] 10)
syntax
  "_prod_list" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Prod>_\<leftarrow>_. _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Prod>x\<leftarrow>xs. b" \<rightleftharpoons> "CONST prod_list (CONST map (\<lambda>x. b) xs)"

end


theory Boolean_functions
  imports
    Main
    "Jordan_Normal_Form.Matrix"
begin

section\<open>Boolean functions\<close>

text\<open>Definition of monotonicity\<close>

text\<open>We consider (monotone) Boolean
  functions over vectors of length $n$, so that we can later
  prove that those are isomorphic to
  simplicial complexes of dimension $n$ (in $n$ vertexes).\<close>

locale boolean_functions
  = fixes n::"nat"
begin

definition bool_fun_dim_n :: "(bool vec => bool) set"
  where "bool_fun_dim_n = {f. f \<in> carrier_vec n \<rightarrow> (UNIV::bool set)}"

definition monotone_bool_fun :: "(bool vec => bool) => bool"
  where "monotone_bool_fun \<equiv> (mono_on (carrier_vec n))"

definition monotone_bool_fun_set :: "(bool vec => bool) set"
  where "monotone_bool_fun_set = (Collect monotone_bool_fun)"

text\<open>Some examples of Boolean functions\<close>

definition bool_fun_top :: "bool vec => bool"
  where "bool_fun_top f = True"

definition bool_fun_bot :: "bool vec => bool"
  where "bool_fun_bot f = False"

end

section\<open>Threshold function\<close>

definition count_true :: "bool vec => nat"
  where "count_true v = sum (\<lambda>i. if vec_index v i then 1 else 0::nat) {0..<dim_vec v}"

lemma "vec_index (vec (5::nat) (\<lambda>i. False)) 2 = False"
  by simp

lemma "vec_index (vec (5::nat) (\<lambda>i. True)) 3 = True"
  by simp

lemma "count_true (vec (1::nat) (\<lambda>i. True)) = 1"
  unfolding count_true_def by simp

lemma "count_true (vec (2::nat) (\<lambda>i. True)) = 2"
  unfolding count_true_def by simp

lemma "count_true (vec (5::nat) (\<lambda>i. True)) = 5"
  unfolding count_true_def by simp

text\<open>The threshold function is a Boolean function
  which also satisfies the condition of being \emph{evasive}.
  We follow the definition by Scoville~\<^cite>\<open>\<open>Problem 6.5\<close> in "SC19"\<close>.\<close>

definition bool_fun_threshold :: "nat => (bool vec => bool)"
  where "bool_fun_threshold i = (\<lambda>v. if i \<le> count_true v then True else False)"

context boolean_functions
begin

lemma "mono_on UNIV bool_fun_top"
  by (simp add: bool_fun_top_def mono_onI monotone_bool_fun_def)

lemma "monotone_bool_fun bool_fun_top"
  by (simp add: bool_fun_top_def mono_onI monotone_bool_fun_def)

lemma "mono_on UNIV bool_fun_bot"
  by (simp add: bool_fun_bot_def mono_onI monotone_bool_fun_def)

lemma "monotone_bool_fun bool_fun_bot"
  by (simp add: bool_fun_bot_def mono_onI monotone_bool_fun_def)

lemma
  monotone_count_true:
  assumes ulev: "(u::bool vec) \<le> v"
  shows "count_true u \<le> count_true v"
  unfolding count_true_def
  using Groups_Big.ordered_comm_monoid_add_class.sum_mono
    [of "{0..<dim_vec u}"
      "(\<lambda>i. if vec_index u i then 1 else 0)"
      "(\<lambda>i. if vec_index v i then 1 else 0)"]
  using ulev
  unfolding Matrix.less_eq_vec_def
  by fastforce

text\<open>The threshold function is monotone.\<close>

lemma
  monotone_threshold:
  assumes ulev: "(u::bool vec) \<le> v"
  shows "bool_fun_threshold n u \<le> bool_fun_threshold n v"
  unfolding bool_fun_threshold_def
  using monotone_count_true [OF ulev] by simp

lemma
  assumes "(u::bool vec) \<le> v"
  and "n < dim_vec u"
  shows "bool_fun_threshold n u \<le> bool_fun_threshold n v"
  using monotone_threshold [OF assms(1)] .

lemma "mono_on UNIV (bool_fun_threshold n)"
  by (meson mono_onI monotone_bool_fun_def monotone_threshold)

lemma "monotone_bool_fun (bool_fun_threshold n)"
  unfolding monotone_bool_fun_def
  by (meson boolean_functions.monotone_threshold mono_onI)

end

end


theory Supplementary_Ring_Facts
imports "HOL-Algebra.Ring"
        "HOL-Algebra.UnivPoly"
        "HOL-Algebra.Subrings"

begin

section\<open>Supplementary Ring Facts\<close>

text\<open>The nonzero elements of a ring.\<close>

definition nonzero :: "('a, 'b) ring_scheme \<Rightarrow> 'a set" where
"nonzero R = {a \<in> carrier R. a \<noteq> \<zero>\<^bsub>R\<^esub>}"

lemma zero_not_in_nonzero:
"\<zero>\<^bsub>R\<^esub> \<notin> nonzero R"
  unfolding nonzero_def by blast

lemma(in domain) nonzero_memI:
  assumes "a \<in> carrier R"
  assumes "a \<noteq> \<zero>"
  shows "a \<in> nonzero R"
  using assms by(simp add: nonzero_def)

lemma(in domain) nonzero_memE:
  assumes "a \<in> nonzero R"
  shows "a \<in> carrier R" "a \<noteq>\<zero>"
  using assms by(auto simp: nonzero_def)

lemma(in domain) not_nonzero_memE:
  assumes "a \<notin> nonzero R"
  assumes "a \<in> carrier R"
  shows "a = \<zero>"
  using assms
  by (simp add: nonzero_def)

lemma(in domain) not_nonzero_memI:
  assumes "a = \<zero>"
  shows "a \<notin> nonzero R"
  using assms nonzero_memE(2) by auto

lemma(in domain) nonzero_closed:
  assumes "a \<in> nonzero R"
  shows "a \<in> carrier R"
  using assms
  by (simp add: nonzero_def)

lemma(in domain) nonzero_mult_in_car:
  assumes "a \<in> nonzero R"
  assumes "b \<in> nonzero R"
  shows "a \<otimes> b \<in> carrier R"
  using assms
  by (simp add: nonzero_def)

lemma(in domain) nonzero_mult_closed:
  assumes "a \<in> nonzero R"
  assumes "b \<in> nonzero R"
  shows "a \<otimes> b \<in> nonzero R"
  apply(rule nonzero_memI)
  using assms nonzero_memE apply blast
    using assms nonzero_memE
    by (simp add: integral_iff)

lemma(in domain) nonzero_one_closed:
"\<one> \<in> nonzero R"
  by (simp add: nonzero_def)

lemma(in domain) one_nonzero:
"\<one> \<in> nonzero R"
  by (simp add: nonzero_one_closed)

lemma(in domain) nat_pow_nonzero:
  assumes "x \<in>nonzero R"
  shows "x[^](n::nat) \<in> nonzero R"
  unfolding nonzero_def
  apply(induction n)
  using assms integral_iff nonzero_closed zero_not_in_nonzero by auto

lemma(in monoid) Units_int_pow_closed:
  assumes "x \<in> Units G"
  shows "x[^](n::int) \<in> Units G"
  by (metis Units_pow_closed assms int_pow_def2 monoid.Units_inv_Units monoid_axioms)

lemma(in comm_monoid) UnitsI:
  assumes "a \<in> carrier G"
  assumes "b \<in> carrier G"
  assumes "a \<otimes> b = \<one>"
  shows "a \<in> Units G" "b \<in> Units G"
  unfolding Units_def using comm_monoid_axioms_def assms m_comm[of a b]
  by auto

lemma(in comm_monoid) is_invI:
  assumes "a \<in> carrier G"
  assumes "b \<in> carrier G"
  assumes "a \<otimes> b = \<one>"
  shows "inv\<^bsub>G\<^esub> b = a" "inv\<^bsub>G\<^esub> a = b"
  using assms inv_char m_comm
  by auto

lemma(in ring) ring_in_Units_imp_not_zero:
  assumes "\<one> \<noteq> \<zero>"
  assumes "a \<in> Units R"
  shows "a \<noteq> \<zero>"
  using assms monoid.Units_l_cancel
  by (metis l_null  monoid_axioms one_closed zero_closed)

lemma(in ring) Units_nonzero:
  assumes "u \<in> Units R"
  assumes "\<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
  shows "u \<in> nonzero R"
proof-
  have "u \<in>carrier R"
    using Units_closed assms by auto
  have "u \<noteq>\<zero>"
    using Units_r_inv_ex assms(1) assms(2)
    by force
  thus ?thesis
    by (simp add: \<open>u \<in> carrier R\<close> nonzero_def)
qed

lemma(in ring) Units_inverse:
  assumes "u \<in> Units R"
  shows "inv u \<in> Units R"
  by (simp add: assms)

lemma(in cring) invI:
  assumes "x \<in> carrier R"
  assumes "y \<in> carrier R"
  assumes "x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub>"
  shows "y = inv \<^bsub>R\<^esub> x"
        "x = inv \<^bsub>R\<^esub> y"
  using assms(1) assms(2) assms(3) is_invI
  by auto

lemma(in cring) inv_cancelR:
  assumes "x \<in> Units R"
  assumes "y \<in> carrier R"
  assumes "z \<in> carrier R"
  assumes "y = x \<otimes>\<^bsub>R\<^esub> z"
  shows "inv\<^bsub>R\<^esub> x \<otimes>\<^bsub>R\<^esub> y = z"
        "y \<otimes>\<^bsub>R\<^esub> (inv\<^bsub>R\<^esub> x)  = z"
  apply (metis Units_closed assms(1) assms(3) assms(4) cring.cring_simprules(12)
    is_cring m_assoc monoid.Units_inv_closed monoid.Units_l_inv monoid_axioms)
  by (metis Units_closed assms(1) assms(3) assms(4) m_assoc m_comm monoid.Units_inv_closed
      monoid.Units_r_inv monoid.r_one monoid_axioms)

lemma(in cring) inv_cancelL:
  assumes "x \<in> Units R"
  assumes "y \<in> carrier R"
  assumes "z \<in> carrier R"
  assumes "y = z \<otimes>\<^bsub>R\<^esub> x"
  shows "inv\<^bsub>R\<^esub> x \<otimes>\<^bsub>R\<^esub> y = z"
        "y \<otimes>\<^bsub>R\<^esub> (inv\<^bsub>R\<^esub> x)  = z"
  apply (simp add: Units_closed assms(1) assms(3) assms(4) m_lcomm)
  by (simp add: Units_closed assms(1) assms(3) assms(4) m_assoc)

end


(*  Title:     Sensors.thy
    Author:     Sven Linker

Defines perfect sensors for cars. Cars can perceive both
the physical size and braking distance of all other cars.
*)

section\<open> Sensors for Cars\<close>
text\<open>
This section presents the abstract definition of a function
determining the sensor capabilities of cars. Such a function
takes a car \(e\), a traffic snapshot \(ts\) and another
car \(c\), and returns the length of \(c\) as perceived
by \(e\) at the situation determined by \(ts\). The
only restriction we impose is that this length is always
greater than zero.

With such a function, we define a derived notion of the
\emph{space} the car \(c\) occupies as perceived by \(e\).
However, this does not define the lanes \(c\) occupies, but
only a continuous interval. The lanes occupied by \(c\)
are given by the reservation and claim functions of
the traffic snapshot \(ts\).
\<close>

theory Sensors
  imports "Traffic" "Views"
begin

locale sensors = traffic + view +
  fixes sensors::"(cars) \<Rightarrow> traffic \<Rightarrow> (cars) \<Rightarrow> real"
  assumes sensors_ge:"(sensors e ts c) > 0"
begin

definition space ::" traffic \<Rightarrow> view \<Rightarrow> cars \<Rightarrow> real_int"
  where "space ts v c \<equiv> stretch (pos ts c)  ( sensors (own v) ts c)"

lemma left_space: "left (space ts v c) = pos ts c"
  using sensors_ge space_def stretch_left
  by (simp add: less_eq_real_def)

lemma right_space: "right (space ts v c) =   pos ts c + sensors (own v) ts c"
  using sensors_ge space_def stretch_right
  by (simp add: less_eq_real_def)

lemma space_nonempty:"left (space ts v c ) < right (space ts v c)"
  using left_space right_space sensors_ge by simp

end
end


theory ValuesFSet
  imports Main Lambda "HOL-Library.FSet"
begin

datatype val = VNat nat | VFun "(val \<times> val) fset" | VPair val val

type_synonym func = "(val \<times> val) fset"

inductive val_le :: "val \<Rightarrow> val \<Rightarrow> bool" (infix "\<sqsubseteq>" 52) where
  vnat_le[intro!]: "(VNat n) \<sqsubseteq> (VNat n)" |
  vfun_le[intro!]: "fset t1 \<subseteq> fset t2 \<Longrightarrow> (VFun t1) \<sqsubseteq> (VFun t2)" |
  vpair_le[intro!]: "v1 \<sqsubseteq> v1' \<and> v2 \<sqsubseteq> v2' \<Longrightarrow> (VPair v1 v2) \<sqsubseteq> (VPair v1' v2')"

type_synonym env = "((name \<times> val) list)"

definition env_le :: "env \<Rightarrow> env \<Rightarrow> bool" (infix "\<sqsubseteq>" 52) where
  "\<rho> \<sqsubseteq> \<rho>' \<equiv> \<forall> x v. lookup \<rho> x = Some v \<longrightarrow> (\<exists> v'. lookup \<rho>' x = Some v' \<and> v \<sqsubseteq> v')"

definition env_eq :: "env \<Rightarrow> env \<Rightarrow> bool" (infix "\<approx>" 50) where
  "\<rho> \<approx> \<rho>' \<equiv> (\<forall> x. lookup \<rho> x = lookup \<rho>' x)"

fun vadd :: "(val \<times> nat) \<times> (val \<times> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "vadd ((_,v),(_,u)) r = v + u + r"

primrec vsize :: "val \<Rightarrow> nat" where
"vsize (VNat n) = 1" |
"vsize (VPair v1 v2) = 1 + (vsize v1) + (vsize v2)" |
"vsize (VFun t) = 1 + ffold vadd 0
                            (fimage (map_prod (\<lambda> v. (v,vsize v)) (\<lambda> v. (v,vsize v))) t)"

abbreviation vprod_size :: "val \<times> val \<Rightarrow> (val \<times> nat) \<times> (val \<times> nat)" where
  "vprod_size \<equiv> map_prod (\<lambda> v. (v,vsize v)) (\<lambda> v. (v,vsize v))"

abbreviation fsize :: "func \<Rightarrow> nat" where
  "fsize t \<equiv> 1 + ffold vadd 0 (fimage vprod_size t)"

interpretation vadd_vprod: comp_fun_commute "vadd \<circ> vprod_size"
  unfolding comp_fun_commute_def by auto

lemma vprod_size_inj: "inj_on vprod_size (fset A)"
  unfolding inj_on_def by auto

lemma fsize_def2: "fsize t = 1 + ffold (vadd \<circ> vprod_size) 0 t"
  using vprod_size_inj[of t] ffold_fimage[of vprod_size t vadd 0] by simp

lemma fsize_finsert_in[simp]:
  assumes v12_t: "(v1,v2) |\<in>| t" shows "fsize (finsert (v1,v2) t) = fsize t"
proof -
  from v12_t have "finsert (v1,v2) t = t" by auto
  from this show ?thesis by simp
qed

lemma fsize_finsert_notin[simp]:
  assumes v12_t: "(v1,v2) |\<notin>| t"
  shows "fsize (finsert (v1,v2) t) = vsize v1 + vsize v2 + fsize t"
proof -
  let ?f = "vadd \<circ> vprod_size"
  have "fsize (finsert (v1,v2) t) = 1 + ffold ?f 0 (finsert (v1,v2) t)"
    using fsize_def2[of "finsert (v1,v2) t"] by simp
  also from v12_t have "... = 1 + ?f (v1,v2) (ffold ?f 0 t)" by simp
  finally have "fsize (finsert (v1,v2) t) = 1 + ?f (v1,v2) (ffold ?f 0 t)" .
  from this show ?thesis using fsize_def2[of t] by simp
qed

end


theory Imp
  imports Basics
begin

datatype aexp = ANum nat |
                APlus aexp aexp |
                AMinus aexp aexp |
                AMult aexp aexp

datatype bexp = BTrue |
                BFalse |
                BEq aexp aexp |
                BLe aexp aexp |
                BNot bexp |
                BAnd bexp bexp

section {* Evaluation *}

fun aeval :: "aexp \<Rightarrow> nat" where
  "aeval (ANum n) = n"
| "aeval (APlus a1 a2) = (aeval a1) + (aeval a2)"
| "aeval (AMinus a1 a2) = (aeval a1) - (aeval a2)"
| "aeval (AMult a1 a2) = (aeval a1) * (aeval a2)"

lemma test_aeval: "aeval (APlus (ANum 2) (ANum 2)) = 4"
  apply (simp)
  done

fun beval :: "bexp \<Rightarrow> bool" where
  "beval BTrue = True"
| "beval BFalse = False"
| "beval (BEq a1 a2) = beq_nat (aeval a1) (aeval a2)"
| "beval (BLe a1 a2) = leb (aeval a1) (aeval a2)"
| "beval (BNot b1) = negb (beval b1)"
| "beval (BAnd b1 b2) = andb (beval b1) (beval b2)"

section {* Optimization *}

fun optimize_0plus :: "aexp \<Rightarrow> aexp" where
  "optimize_0plus (ANum n) = ANum n"
| "optimize_0plus (APlus (ANum 0) e2) = e2"
| "optimize_0plus (APlus e1 e2) = APlus (optimize_0plus e1) (optimize_0plus e2)"
| "optimize_0plus (AMinus e1 e2) = AMinus (optimize_0plus e1) (optimize_0plus e2)"
| "optimize_0plus (AMult e1 e2) = AMult (optimize_0plus e1) (optimize_0plus e2)"

lemma test_optimize_0plus:
  "(beval (BEq (optimize_0plus (APlus (ANum (Suc 1)) (APlus (ANum 0) (APlus (ANum 0) (ANum 1)))))
           (APlus (ANum (Suc 1)) (ANum 1)))) = True"
  apply (simp)
  done

theorem optimize_0plus_sound: "aeval (optimize_0plus a) = aeval a"
  apply (induction a)
     apply (simp) (* ANum *)
    apply (cases a) (* APlus *)
       apply (simp)
  oops

section {* Expression with variables *}

datatype aexpr = ANum nat |
                 AId string |
                 APlus aexpr aexpr |
                 AMinus aexpr aexpr |
                AMult aexpr aexpr

definition W :: string where "W = ''W''"
definition X :: string where "X = ''X''"
definition Y :: string where "Y = ''Y''"
definition Z :: string where "Z = ''Z''"

datatype bexpr = BTrue |
                BFalse |
                BEq aexpr aexpr |
                BLe aexpr aexpr |
                BNot bexpr |
                BAnd bexpr bexpr

type_synonym state = "string \<Rightarrow> nat"

fun aval :: "state \<Rightarrow> aexpr \<Rightarrow> nat" where
  "aval _ (ANum n) = n"
| "aval st (AId x) = st x"
| "aval st (APlus a1 a2) = (aval st a1) + (aval st a2)"
| "aval st (AMinus a1 a2) = (aval st a1) - (aval st a2)"
| "aval st (AMult a1 a2) = (aval st a1) * (aval st a2)"

fun bval :: "state \<Rightarrow> bexpr \<Rightarrow> bool" where
  "bval _ BTrue = True"
| "bval _ BFalse = False"
| "bval st (BEq a1 a2) = beq_nat (aval st a1) (aval st a2)"
| "bval st (BLe a1 a2) = leb (aval st a1) (aval st a2)"
| "bval st (BNot b1) = negb (bval st b1)"
| "bval st (BAnd b1 b2) = andb (bval st b1) (bval st b2)"

value "aval (\<lambda> x. 0) (APlus (ANum 3) (AId ''v''))"

subsection {* Notation *}

definition bool_to_bexpr :: "Basics.bool \<Rightarrow> bexpr" where
  "bool_to_bexpr b = (if b = True then BTrue else BFalse)"

section {* Command *}

datatype com = CSkip ("SKIP") |
               CAss string aexpr ("_ ::= _" [1000, 61] 61) |
               CSeq com com ("_;;/ _" [60, 61] 60) |
               CIf bexpr com com ("(IFB _/ THEN _/ ELSE _/ FI)" [0, 0, 61] 60) |
               CWhile bexpr com com ("(WHILE _/ DO _/ END)" [0, 61] 61)

value "SKIP"
value "IFB BTrue THEN SKIP ELSE SKIP FI"

(*
definition fact_in_isabelle :: com where
 "fact_in_isabelle =
    Z ::= AId X;;
    Y ::= ANum 1;;
    WHILE BNot (BEq (AId Z) (ANum 0)) DO (
      Y ::= AMult (AId Y) (AId Z);;
      Z ::= AMinus (AId Z) (ANum 1)
    ) END
"
*)

definition plus2 :: com where "plus2 = X ::= (APlus (AId X) (ANum 2))"
definition XtimesYinZ :: com where "XtimesYinZ = Z ::= (AMult (AId X) (AId Y))"
definition subtract_slowly_body :: com where
  "subtract_slowly_body =
     Z ::= AMinus (AId Z) (ANum 1);;
     X ::= AMinus (AId X) (ANum 1)
"

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Auxiliary Facts\<close>

theory Preliminaries2
  imports Main "HOL-Library.Infinite_Set"
begin

subsection \<open>Finite and Infinite Sets\<close>

lemma finite_product:
  assumes fst: "finite (fst ` A)"
  and     snd: "finite (snd ` A)"
  shows   "finite A"
proof -
  have "A \<subseteq> (fst ` A) \<times> (snd ` A)"
    by force
  thus ?thesis
    using snd fst finite_subset by blast
qed

subsection \<open>Cofinite Filters\<close>

lemma almost_all_commutative:
  "finite S \<Longrightarrow> (\<forall>x \<in> S. \<forall>\<^sub>\<infinity>i. P x (i::nat)) = (\<forall>\<^sub>\<infinity>i. \<forall>x \<in> S. P x i)"
proof (induction rule: finite_induct)
  case (insert x S)
    {
      assume "\<forall>x \<in> insert x S. \<forall>\<^sub>\<infinity>i. P x i"
      hence "\<forall>\<^sub>\<infinity>i. \<forall>x \<in> S. P x i" and "\<forall>\<^sub>\<infinity>i. P x i"
        using insert by simp+
      then obtain i\<^sub>1 i\<^sub>2 where "\<And>j. j \<ge> i\<^sub>1 \<Longrightarrow> \<forall>x \<in> S. P x j"
        and "\<And>j. j \<ge> i\<^sub>2 \<Longrightarrow> P x j"
        unfolding MOST_nat_le by auto
      hence "\<And>j. j \<ge> max i\<^sub>1 i\<^sub>2 \<Longrightarrow> \<forall>x \<in> S \<union> {x}. P x j"
        by simp
      hence "\<forall>\<^sub>\<infinity>i. \<forall>x \<in> insert x S. P x i"
        unfolding MOST_nat_le by blast
    }
    moreover
    have "\<forall>\<^sub>\<infinity>i. \<forall>x \<in> insert x S. P x i \<Longrightarrow> \<forall>x \<in> insert x S. \<forall>\<^sub>\<infinity>i. P x i"
      unfolding MOST_nat_le by auto
    ultimately
    show ?case
      by blast
qed simp

lemma almost_all_commutative':
  "finite S \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> \<forall>\<^sub>\<infinity>i. P x (i::nat)) \<Longrightarrow> (\<forall>\<^sub>\<infinity>i. \<forall>x \<in> S. P x i)"
  using almost_all_commutative by blast

fun index
where
  "index P = (if \<forall>\<^sub>\<infinity>i. P i then Some (LEAST i. \<forall>j \<ge> i. P j) else None)"

lemma index_properties:
  fixes i :: nat
  shows "index P = Some i \<Longrightarrow> 0 < i \<Longrightarrow> \<not> P (i - 1)"
    and "index P = Some i \<Longrightarrow> j \<ge> i \<Longrightarrow> P j"
proof -
  assume "index P = Some i"
  moreover
  hence i_def: "i = (LEAST i. \<forall>j \<ge> i. P j)" and "\<forall>\<^sub>\<infinity>i. P i"
    unfolding index.simps using option.distinct(2) option.sel
    by (metis (erased, lifting))+
  then obtain i' where "\<forall>j \<ge> i'.  P j"
    unfolding MOST_nat_le by blast
  ultimately
  show "\<And>j. j \<ge> i \<Longrightarrow> P j"
    using LeastI[of "\<lambda>i. \<forall>j \<ge> i. P j"] by (metis i_def)
  {
    assume "0 < i"
    then obtain j where "i = Suc j" and "j < i"
      using lessE by blast
    hence "\<And>j'. j' > j \<Longrightarrow> P j'"
      using \<open>\<And>j. j \<ge> i \<Longrightarrow> P j\<close> by force
    hence "\<not> P j"
      using not_less_Least[OF \<open>j < i\<close>[unfolded i_def]] by (metis leI le_antisym)
    thus "\<not> P (i - 1)"
      unfolding \<open>i = Suc j\<close> by simp
  }
qed

end


(*  Title:      HOL/Metis_Examples/Trans_Closure.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring the transitive closure.
*)

section \<open>Metis Example Featuring the Transitive Closure\<close>

theory Trans_Closure
imports Main
begin

declare [[metis_new_skolem]]

type_synonym addr = nat

datatype val
  = Unit        \<comment> \<open>dummy result value of void expressions\<close>
  | Null        \<comment> \<open>null reference\<close>
  | Bool bool   \<comment> \<open>Boolean value\<close>
  | Intg int    \<comment> \<open>integer value\<close>
  | Addr addr   \<comment> \<open>addresses of objects in the heap\<close>

consts R :: "(addr \<times> addr) set"

consts f :: "addr \<Rightarrow> val"

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b, c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
(* sledgehammer *)
proof -
  assume A1: "f c = Intg x"
  assume A2: "\<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x"
  assume A3: "(a, b) \<in> R\<^sup>*"
  assume A4: "(b, c) \<in> R\<^sup>*"
  have F1: "f c \<noteq> f b" using A2 A1 by metis
  have F2: "\<forall>u. (b, u) \<in> R \<longrightarrow> (a, u) \<in> R\<^sup>*" using A3 by (metis transitive_closure_trans(6))
  have F3: "\<exists>x. (b, x b c R) \<in> R \<or> c = b" using A4 by (metis converse_rtranclE)
  have "c \<noteq> b" using F1 by metis
  hence "\<exists>u. (b, u) \<in> R" using F3 by metis
  thus "\<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*" using F2 by metis
qed

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b,c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
(* sledgehammer [isar_proofs, compress = 2] *)
proof -
  assume A1: "f c = Intg x"
  assume A2: "\<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x"
  assume A3: "(a, b) \<in> R\<^sup>*"
  assume A4: "(b, c) \<in> R\<^sup>*"
  have "b \<noteq> c" using A1 A2 by metis
  hence "\<exists>x\<^sub>1. (b, x\<^sub>1) \<in> R" using A4 by (metis converse_rtranclE)
  thus "\<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*" using A3 by (metis transitive_closure_trans(6))
qed

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b, c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
apply (erule_tac x = b in converse_rtranclE)
 apply metis
by (metis transitive_closure_trans(6))

end


(* author: wzh*)

theory MyAdd
  imports Main

begin

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

lemma add_02: "add m 0 = m"
  apply (induction m)
  apply (auto)
  done

thm add_02

end


theory CS_Chap3

imports Main
  "~~/src/HOL/IMP/BExp"

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

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

(*
  Given an expression and a state (variable value) it evaluates the primer
  giving the expression final value
*)
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

(*
  Performs constant folding, i.e., reduces the expression, resolving
  trivial Plus operations
*)
fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "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

(*
  Plus operation optimization, intended to eliminate 0 and
  simplify trivial summations
*)
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N i1) (N i2) = N (i1 + i2)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a1 a2 = Plus a1 a2"

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

(* Function for simplify expressions using the plus function *)
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)"

lemma "aval (asimp a) s = aval a s"
  apply (induction a)
  apply (auto)
  done

(* EXERCISE 3.1 *)
fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (N n) = True" |
  "optimal (V x) = True" |
  "optimal (Plus (N i) (N j)) = False" |
  "optimal (Plus a1 a2) = ((optimal a1) \<and> (optimal a2))"

theorem "optimal (asimp_const a)"
  apply (induction a)
  apply (auto split: aexp.split)
  done

(* EXERCISE 3.2 *)
(* Return the total summation of all constants in an expression *)
fun sumN :: "aexp \<Rightarrow> int" where
  "sumN (N n) = n" |
  "sumN (V x) = 0" |
  "sumN (Plus a1 a2) = sumN a1 + sumN a2"

value "sumN (Plus (N 1) (Plus (V x) (N 2)))" (* It works! *)

(* Giving an expression, return it with all constants replaced by zero *)
fun zeroN :: "aexp \<Rightarrow> aexp" where
  "zeroN (N n) = (N 0)" |
  "zeroN (V x) = (V x)" |
  "zeroN (Plus a1 a2) = Plus (zeroN a1) (zeroN a2)"

value "zeroN (Plus (N 1) (Plus (V x) (N 2)))" (* It works! *)

(* Transform a given expression in an addition of the sumN and zeroN of that expression*)
fun sepN :: "aexp \<Rightarrow> aexp" where
  "sepN a = Plus (N (sumN a)) (zeroN a)"

value "sepN (Plus (N 1) (Plus (V x) (N 2)))" (* It works! *)

lemma aval_sepN [simp] : "aval (sepN a) s = aval a s"
  apply (induction a)
  apply (auto)
  done

(*
  Finally, for performing the full_asimp, we just simplify the expression as we can
  and then apply the sepN function, transforming it in an addition of the variable
  and resulting constant.
 *)
fun full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp a = asimp (sepN a)"

value "full_asimp (Plus (N 1) (Plus (V x) (N 2)))" (* It works *)

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

(* EXERCISE 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 (N n) = (N n)" |
  "subst x a (Plus a1 a2) = Plus (subst x a a1) (subst x a a2)"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y''))" (* It works! *)

lemma substitution_

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

(* EXERCISE 3.4 *)
(*
  Instead of important and extending the AExp theory, let's just create
  our own types,  adding the letter t, of times, at the end
  of our constructors. Seems more portable.
*)
datatype aexpt = Nt int
  | Vt vname
  | Plust aexpt aexpt
  | Times aexpt aexpt

(* We have now the Times case. Pretty trivial! *)
fun avalt :: "aexpt \<Rightarrow> state \<Rightarrow> val" where
  "avalt (Nt n) s = n" |
  "avalt (Vt x) s = s x" |
  "avalt (Plust a1 a2) s = avalt a1 s + avalt a2 s" |
  "avalt (Times a1 a2) s = avalt a1 s * avalt a2 s "

(* plust definition follows equal as our previous plus function *)
fun plust :: "aexpt \<Rightarrow> aexpt \<Rightarrow> aexpt" where
  "plust (Nt n1) (Nt n2) = Nt (n1 + n2)" |
  "plust (Nt n) a = (if n = 0 then a else Plust (Nt n) a)" |
  "plust a (Nt n) = (if n = 0 then a else Plust a (Nt n))" |
  "plust a1 a2 = Plust a1 a2"

(* In multiplication, we have 2 special cases: null factor (zero) and neutral factor (one) *)
fun times :: "aexpt \<Rightarrow> aexpt \<Rightarrow> aexpt" where
  "times (Nt n1) (Nt n2) = Nt (n1 * n2)" |
  "times (Nt n) a =
    (if n = 0 then (Nt 0) else
    if n = 1 then a else
    Times (Nt n) a)" |
  "times a (Nt n) =
    (if n = 0 then (Nt 0) else
    if n = 1 then a else
    Times a (Nt n))" |
  "times a1 a2 = Times a1 a2"

(* Let's test times *)
value "times (Nt 3) (Nt 4)" (* = 12 | Ok*)
value "times (Nt 3) (Nt 0)" (* = 0 | Ok*)
value "times (Nt 3) (Nt 1)" (* = 3 | Ok*)
value "times (Nt 0) (Nt 4)" (* = 0 | Ok*)
value "times (Nt 1) (Nt 4)" (* = 4 | Ok*)
value "times (Add (Nt 3) (Nt 2)) (Nt 4)" (* = aexpt | Ok*)
value "times (Nt 4) (Add (Nt 3) (Nt 2))" (* = aexpt | Ok*)
value "times (Add (Nt 3) (Nt 2)) (Add (Nt 3) (Nt 2))" (* = aexpt | Ok*)

(* Times case is added to our simplification function *)
fun asimpt :: "aexpt \<Rightarrow> aexpt" where
  "asimpt (Nt n) = Nt n" |
  "asimpt (Vt v) = Vt v" |
  "asimpt (Plust a1 a2) = plust (asimpt a1) (asimpt a2)" |
  "asimpt (Times a1 a2) = times (asimpt a1) (asimpt a2)"

(* Proving that plust function has distributive properties *)
lemma avalt_plust [simp] : "avalt (plust a1 a2) s = avalt a1 s + avalt a2 s"
  apply (induction a1 a2 rule: plust.induct)
  apply (simp_all)
  done

(* Proving that times function has distributive properties *)
lemma avalt_times [simp] : "avalt (times a1 a2) s = avalt a1 s * avalt a2 s"
  apply (induction a1 a2 rule: times.induct)
  apply (auto)
  done

(* Finally, proving that our simplification function is correct *)
theorem "avalt (asimpt a) s = avalt a s"
  apply (induction a)
  apply (auto)
  done

(* EXERCISE 3.5 *)
datatype aexp2 = N2 int
  | V2 vname
  | Plus2 aexp2 aexp2
  | PostPlus vname
  | Times2 aexp2 aexp2
  | Div2 aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state)" where
  "aval2 (N2 n) s = (n, s)" |
  "aval2 (V2 x) s = (s x, s)" |
  "aval2 (Plus2 a1 a2) s = (fst (aval2 a1 s) + fst (aval2 a2 s),
    (\<lambda> x. (snd (aval2 a1 s) x) + (snd (aval2 a2 s) x) - (s x)))" |
  "aval2 (Times2 a1 a2) s = (fst (aval2 a1 s) * fst (aval2 a2 s),
    (\<lambda> x. (snd (aval2 a1 s) x) * (snd (aval2 a2 s) x) - (s x)))" |
  "aval2 (Div2 a1 a2) s = (fst (aval2 a1 s) div fst (aval2 a2 s),
    (\<lambda> x. (snd (aval2 a1 s) x) div (snd (aval2 a2 s) x) - (s x)))" |
  "aval2 (PostPlus x) s = (s x, s(x:= 1 + s x))"

(* EXERCISE 3.6 *)
datatype lexp = Nl int
  | Vl vname
  | Plusl lexp lexp
  | LET vname lexp lexp

(*
  Now, for a proper avaliation, we need to implement the LET aval.
  Basically, this means that we need to replace the ocurrence of
  variable x in a2 by expression a1.
*)
fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
  "lval (Nl n) s = n" |
  "lval (Vl x) s = s x" |
  "lval (Plusl a1 a2) s = lval a1 s + lval a2 s" |
  "lval (LET x a1 a2) s = lval a2 (s(x := lval a1 s))"

value "lval (Vl x) (s 5)"
value "lval (LET v (Plusl (Nl 1) (Nl 2)) (Plusl (Nl 5) (Vl v))) s" (* It works *)

(*
  Here we want to transform an lexp expression into an aexp one.
  Pretty straighforward for int and variables. Addition is done
  recursively. For the LET constructor, we just use our subst function,
  which already apply the variable value over an aexp expression, with
  recursion over the expression parameters.
  Piece of cake!
*)
fun inline :: "lexp \<Rightarrow> aexp" where
  "inline (Nl n) = N n" |
  "inline (Vl x) = V x" |
  "inline (Plusl a1 a2) = Plus (inline a1) (inline a2)" |
  "inline (LET x a1 a2) = subst x (inline a1) (inline a2)"

(*
  Proving that inline function is correct is proving that we
  can correctly evaluate the resulting expression.
*)
theorem inline_correctness : "lval l s = aval (inline l) s"
  apply (induction l arbitrary: s)
  apply auto
  done

(* EXERCISE 3.7 *)
(* Extensions can be done with definitions *)
definition Le :: "AExp.aexp \<Rightarrow> AExp.aexp \<Rightarrow> bexp" where
  "Le a1 a2 = Not (Less a2 a1)"

definition Eq :: "AExp.aexp \<Rightarrow> AExp.aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = And (Not (Less a1 a2)) (Not (Less a2 a1))"

(* Correctness of both operations is easy over definitions *)
theorem Le_correctness : "bval (Le a1 a2) s = (AExp.aval a1 s \<le> AExp.aval a2 s)"
  apply (auto simp add: Le_def)
  done

theorem Eq_correctness : "bval (Eq a1 a2) s = (AExp.aval a1 s = AExp.aval a2 s)"
  apply (auto simp add: Eq_def)
  done

(* EXERCISE 3.8 *)
datatype ifexp = Bi bool
  | If ifexp ifexp ifexp
  | Less2 AExp.aexp AExp.aexp

(*
  The If statement should evaluate the first parameter and, based on that
  give the evaluation of the second or the third.
*)
fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bi v) s = v" |
  "ifval (If a b c) s = (if (ifval a s) then (ifval b s) else (ifval c s))" |
  "ifval (Less2 a1 a2) s = (AExp.aval a1 s < AExp.aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = Bi v" |
  "b2ifexp (Not b) = If (b2ifexp b) (Bi False) (Bi True)" |
  "b2ifexp (And b1 b2) = If (b2ifexp b1) (b2ifexp b2) (Bi False)" |
  "b2ifexp (Less a1 a2) = Less2 a1 a2"

(*
  What does If a b c means? (a \<and> b) \<or> (\<not>a \<and> c), right?
  But we need to get rid of that disjunction, since we don't have it.
  So we negate two times! \<not>\<not>((a \<and> b) \<or> (\<not>a \<and> c)), leading to:
  \<not>(\<not>(a \<and> b) \<and> \<not>(\<not>a \<and> c))

*)
fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bi 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 a1 a2) = Less a1 a2"

(* Proving correctness is proving that the resulting expression evaluates right *)
theorem b2ifexp_correctness : "ifval (b2ifexp e) s = bval e s"
  apply (induction e)
  apply auto
  done

theorem if2bexp_correctness : "bval (if2bexp e) s = ifval e s"
  apply (induction e)
  apply auto
  done

(* EXERCISE 3.9 *)
datatype pbexp = VAR vname
  | NOT pbexp
  | AND pbexp pbexp
  | OR pbexp pbexp

(* Evaluates an expression *)
fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
  "pbval (VAR v) s = s v" |
  "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)"

(* Tells if the boolean expression is in the negative normal formula *)
fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf (VAR _) = True" |
  "is_nnf (NOT (VAR _)) = True" |
  "is_nnf (NOT _) = False" |
  "is_nnf (AND b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
  "is_nnf (OR b1 b2) = (is_nnf b1 \<and> is_nnf b2)"

value "is_nnf (AND (VAR a) (NOT (VAR B)))" (* = True *)
value "is_nnf (OR (VAR a) (NOT (VAR B)))" (* = True *)
value "is_nnf (NOT (OR (VAR a) (NOT (VAR B))))" (* = False *)
value "is_nnf (NOT (AND (VAR a) (VAR B)))" (* = False *)

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf (VAR v) = VAR v" |
  "nnf (NOT (VAR v)) = NOT (VAR v)" |
  "nnf (NOT (NOT b)) = nnf b" |
  "nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
  "nnf (OR b1 b2) = OR (nnf b1) (nnf b2)"

value "nnf (NOT (OR (VAR a) (VAR B)))" (* It works! *)

(*
  Lemma nnf_correctness raises a subgoal, requiring that
  we prove that the NOT operator properly negate an expression.
  So we prove it.
*)
lemma negation_correctness [simp] : "pbval (nnf (NOT b)) s = (\<not> (pbval (nnf b) s))"
  apply (induction b)
  apply auto
  done

(* Here, the correctness follows easily. Induction is enough. *)
theorem nnf_correctness : "pbval (nnf b) s = pbval b s"
  apply (induction b)
  apply auto
  done

(* TODO: explain the induct rule *)
theorem is_nff_correctness : "is_nnf (nnf b)"
  apply (induction b rule: nnf.induct)
  apply auto
  done

fun is_not_or :: "pbexp \<Rightarrow> bool" where
  "is_not_or (OR b1 b2) = False" |
  "is_not_or (AND b1 b2) = (is_not_or b1 \<and> is_not_or b2)" |
  "is_not_or b = True"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
  "is_dnf (VAR _) = True" |
  "is_dnf (NOT _) = True" |
  "is_dnf (AND b1 b2) = ((is_not_or b1) \<and> (is_not_or b2))" |
  "is_dnf (OR b1 b2) = (is_dnf b1 \<and> is_dnf b2)"

(* As the exercise hinted, let's make a distribution function for the AND operator *)
fun distribute_and :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
  "distribute_and x (OR b1 b2) = OR (distribute_and x b1) (distribute_and x b2)" |
  "distribute_and (OR b1 b2) x = OR (distribute_and b1 x) (distribute_and b2 x)" |
  "distribute_and b1 b2 = AND b1 b2"

(* Before defining dnf_of_nnf, let's prove that distribute_and is correct! *)
(* First, checking it preserves the expression value... *)
lemma distribution_preserves [simp] : "pbval (distribute_and b1 b2) s = pbval (AND b1 b2) s"
  apply (induction b1 b2 rule: distribute_and.induct)
  apply (auto)
  done

(* Then, applied at two dnf expressions, its result still is a dnf *)
lemma distribution_correctness [simp] :
    "\<lbrakk>is_dnf b1; is_dnf b2\<rbrakk> \<Longrightarrow> is_dnf (distribute_and b1 b2)"
  apply (induction b1 b2 rule: distribute_and.induct)
  apply (auto)
  done

(* Ok, now let's define dnf_of_nnf *)
fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (VAR x) = VAR x" |
  "dnf_of_nnf (NOT b) = NOT b" |
  "dnf_of_nnf (OR b1 b2) = OR (dnf_of_nnf b1) (dnf_of_nnf b2)" |
  "dnf_of_nnf (AND b1 b2) = distribute_and (dnf_of_nnf b1) (dnf_of_nnf b2)"

(* Here, simple induction is enough *)
theorem dnf_of_nnf_preserves : "pbval (dnf_of_nnf b) s = pbval b s"
  apply (induction b rule: dnf_of_nnf.induct)
  apply (auto)
  done

(*
  In prior tries, I needed this lemma. In this one, it is not necessary,
  but I found interesting to leave it here. We are just proving that negation
  is still preserved.
*)
lemma dnf_of_nnf_negation [simp] : "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
  apply (induction b)
  apply (auto)
  done

(* Simple induction, as always. *)
theorem dnf_to_nnf_correctness : "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply (induction b rule: dnf_of_nnf.induct)
  apply (auto)
  done

(* Fuck, that was long... *)

(* EXERCISE 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 (LOAD v) s stk = Some (s(v) # stk)" |
  "exec1 ADD s [] = None" |
  "exec1 ADD s [x] = None" |
  "exec1 ADD s (x # y # stk) = Some((x+y) # 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
    None \<Rightarrow> None |
    Some stkx \<Rightarrow> exec is s stkx
  )"

fun comp :: "aexp \<Rightarrow> instr list" where
  "comp (N n) = [LOADI n]" |
  "comp (V x) = [LOAD x]" |
  "comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma exec_appending [simp] :
  "exec is1 s stk = Some stk2 \<Longrightarrow> exec (is1 @ is2) s stk = exec is2 s stk2"
  apply (induction is1 arbitrary: stk)
  apply (auto)
  by (metis option.case_eq_if option.distinct(1))

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

(* EXERCISE 3.11 *)
type_synonym reg = nat
datatype instrr = LDI int reg | LD vname reg | ADD reg reg

type_synonym regstate = "reg \<Rightarrow> int"

fun execr1 :: "instrr \<Rightarrow> state \<Rightarrow> regstate \<Rightarrow> regstate" where
  "execr1 (LDI n r) _ rs = rs(r := n)" |
  "execr1 (LD v r) s rs = rs(r := s v)" |
  "execr1 (ADD r1 r2) _ rs = rs(r1 := rs r1 + rs r2)"

fun execr :: "instrr list \<Rightarrow> state \<Rightarrow> regstate \<Rightarrow> regstate" where
  "execr [] _ rs = rs" |
  "execr (i # is) s rs = execr is s (execr1 i s rs)"

fun compr :: "aexp \<Rightarrow> reg \<Rightarrow> instrr list" where
  "compr (N n) r = [LDI n r]" |
  "compr (V x) r = [LD x r]" |
  "compr (Plus e1 e2) r = compr e1 r @ compr e2 (r+1) @ [ADD r (r+1)]"

lemma execr_appending [simp] : "execr (xs @ ys) s rs = execr ys s (execr xs s rs)"
  apply (induction xs arbitrary: rs)
  apply (auto)
  done

lemma [simp] : "r1 < r2 \<Longrightarrow> execr (compr e r2) s rs r1 = rs r1"
  apply (induction e arbitrary: rs r1 r2)
  apply (auto)
  done

theorem "execr (compr a r) s rs r = aval a s"
  apply (induction a arbitrary: rs r)
  apply (auto)
  done

(* EXERCISE 3.12 *)
datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> regstate \<Rightarrow> regstate" where
  "exec01 (LDI0 n) _ rs = rs(0 := n)" |
  "exec01 (LD0 v) s rs = rs(0 := s v)" |
  "exec01 (MV0 r) s rs = rs(r := rs 0)" |
  "exec01 (ADD0 r) _ rs = rs(0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> regstate \<Rightarrow> regstate" where
  "exec0 [] _ rs = rs" |
  "exec0 (i # is) s rs = exec0 is s (exec01 i s rs)"

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
  "comp0 (N n) r = [LDI0 n]" |
  "comp0 (V x) r = [LD0 x]" |
  "comp0 (Plus e1 e2) r = comp0 e1 (r+1) @ [MV0 (r+1)] @ comp0 e2 (r+2) @ [ADD0 (r+1)]"

lemma exec0_appending [simp] : "exec0 (xs @ ys) s rs = exec0 ys s (exec0 xs s rs)"
  apply (induction xs arbitrary: rs)
  apply (auto)
  done

lemma [simp] : "(0 < r1) \<and> (r1 \<le> r2) \<Longrightarrow> exec0 (comp0 e r2) s rs r1 = rs r1"
  apply (induction e arbitrary: rs r1 r2)
  apply (auto)
  done

theorem "exec0 (comp0 e r) s rs 0 = aval e s"
  apply (induction e arbitrary: r rs)
  apply (auto)
  done

end


(*  Title:      HOL/Library/FuncSet.thy
    Author:     Florian Kammueller and Lawrence C Paulson, Lukas Bulwahn
*)

section \<open>Pi and Function Sets\<close>

theory FuncSet
imports Hilbert_Choice Main
begin

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

definition extensional :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "extensional A = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = undefined}"

definition "restrict" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
  where "restrict f A = (\<lambda>x. if x \<in> A then f x else undefined)"

abbreviation funcset :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  (infixr "\<rightarrow>" 60)
  where "A \<rightarrow> B \<equiv> Pi A (\<lambda>_. B)"

syntax (ASCII)
  "_Pi"  :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3PI _:_./ _)" 10)
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3%_:_./ _)" [0,0,3] 3)
syntax
  "_Pi" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi> _\<in>_./ _)"   10)
  "_lam" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"  ("(3\<lambda>_\<in>_./ _)" [0,0,3] 3)
translations
  "\<Pi> x\<in>A. B" \<rightleftharpoons> "CONST Pi A (\<lambda>x. B)"
  "\<lambda>x\<in>A. f" \<rightleftharpoons> "CONST restrict (\<lambda>x. f) A"

definition "compose" :: "'a set \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c)"
  where "compose A g f = (\<lambda>x\<in>A. g (f x))"

subsection \<open>Basic Properties of @{term Pi}\<close>

lemma Pi_I[intro!]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi A B"
  by (simp add: Pi_def)

lemma Pi_I'[simp]: "(\<And>x. x \<in> A \<longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi A B"
  by (simp add:Pi_def)

lemma funcsetI: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> f \<in> A \<rightarrow> B"
  by (simp add: Pi_def)

lemma Pi_mem: "f \<in> Pi A B \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<in> B x"
  by (simp add: Pi_def)

lemma Pi_iff: "f \<in> Pi I X \<longleftrightarrow> (\<forall>i\<in>I. f i \<in> X i)"
  unfolding Pi_def by auto

lemma PiE [elim]: "f \<in> Pi A B \<Longrightarrow> (f x \<in> B x \<Longrightarrow> Q) \<Longrightarrow> (x \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: Pi_def)

lemma Pi_cong: "(\<And>w. w \<in> A \<Longrightarrow> f w = g w) \<Longrightarrow> f \<in> Pi A B \<longleftrightarrow> g \<in> Pi A B"
  by (auto simp: Pi_def)

lemma funcset_id [simp]: "(\<lambda>x. x) \<in> A \<rightarrow> A"
  by auto

lemma funcset_mem: "f \<in> A \<rightarrow> B \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<in> B"
  by (simp add: Pi_def)

lemma funcset_image: "f \<in> A \<rightarrow> B \<Longrightarrow> f ` A \<subseteq> B"
  by auto

lemma image_subset_iff_funcset: "F ` A \<subseteq> B \<longleftrightarrow> F \<in> A \<rightarrow> B"
  by auto

lemma Pi_eq_empty[simp]: "(\<Pi> x \<in> A. B x) = {} \<longleftrightarrow> (\<exists>x\<in>A. B x = {})"
  apply (simp add: Pi_def)
  apply auto
  txt \<open>Converse direction requires Axiom of Choice to exhibit a function
  picking an element from each non-empty @{term "B x"}\<close>
  apply (drule_tac x = "\<lambda>u. SOME y. y \<in> B u" in spec)
  apply auto
  apply (cut_tac P = "\<lambda>y. y \<in> B x" in some_eq_ex)
  apply auto
  done

lemma Pi_empty [simp]: "Pi {} B = UNIV"
  by (simp add: Pi_def)

lemma Pi_Int: "Pi I E \<inter> Pi I F = (\<Pi> i\<in>I. E i \<inter> F i)"
  by auto

lemma Pi_UN:
  fixes A :: "nat \<Rightarrow> 'i \<Rightarrow> 'a set"
  assumes "finite I"
    and mono: "\<And>i n m. i \<in> I \<Longrightarrow> n \<le> m \<Longrightarrow> A n i \<subseteq> A m i"
  shows "(\<Union>n. Pi I (A n)) = (\<Pi> i\<in>I. \<Union>n. A n i)"
proof (intro set_eqI iffI)
  fix f
  assume "f \<in> (\<Pi> i\<in>I. \<Union>n. A n i)"
  then have "\<forall>i\<in>I. \<exists>n. f i \<in> A n i"
    by auto
  from bchoice[OF this] obtain n where n: "f i \<in> A (n i) i" if "i \<in> I" for i
    by auto
  obtain k where k: "n i \<le> k" if "i \<in> I" for i
    using \<open>finite I\<close> finite_nat_set_iff_bounded_le[of "n`I"] by auto
  have "f \<in> Pi I (A k)"
  proof (intro Pi_I)
    fix i
    assume "i \<in> I"
    from mono[OF this, of "n i" k] k[OF this] n[OF this]
    show "f i \<in> A k i" by auto
  qed
  then show "f \<in> (\<Union>n. Pi I (A n))"
    by auto
qed auto

lemma Pi_UNIV [simp]: "A \<rightarrow> UNIV = UNIV"
  by (simp add: Pi_def)

text \<open>Covariance of Pi-sets in their second argument\<close>
lemma Pi_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> Pi A B \<subseteq> Pi A C"
  by auto

text \<open>Contravariance of Pi-sets in their first argument\<close>
lemma Pi_anti_mono: "A' \<subseteq> A \<Longrightarrow> Pi A B \<subseteq> Pi A' B"
  by auto

lemma prod_final:
  assumes 1: "fst \<circ> f \<in> Pi A B"
    and 2: "snd \<circ> f \<in> Pi A C"
  shows "f \<in> (\<Pi> z \<in> A. B z \<times> C z)"
proof (rule Pi_I)
  fix z
  assume z: "z \<in> A"
  have "f z = (fst (f z), snd (f z))"
    by simp
  also have "\<dots> \<in> B z \<times> C z"
    by (metis SigmaI PiE o_apply 1 2 z)
  finally show "f z \<in> B z \<times> C z" .
qed

lemma Pi_split_domain[simp]: "x \<in> Pi (I \<union> J) X \<longleftrightarrow> x \<in> Pi I X \<and> x \<in> Pi J X"
  by (auto simp: Pi_def)

lemma Pi_split_insert_domain[simp]: "x \<in> Pi (insert i I) X \<longleftrightarrow> x \<in> Pi I X \<and> x i \<in> X i"
  by (auto simp: Pi_def)

lemma Pi_cancel_fupd_range[simp]: "i \<notin> I \<Longrightarrow> x \<in> Pi I (B(i := b)) \<longleftrightarrow> x \<in> Pi I B"
  by (auto simp: Pi_def)

lemma Pi_cancel_fupd[simp]: "i \<notin> I \<Longrightarrow> x(i := a) \<in> Pi I B \<longleftrightarrow> x \<in> Pi I B"
  by (auto simp: Pi_def)

lemma Pi_fupd_iff: "i \<in> I \<Longrightarrow> f \<in> Pi I (B(i := A)) \<longleftrightarrow> f \<in> Pi (I - {i}) B \<and> f i \<in> A"
  apply auto
  apply (drule_tac x=x in Pi_mem)
  apply (simp_all split: if_split_asm)
  apply (drule_tac x=i in Pi_mem)
  apply (auto dest!: Pi_mem)
  done

subsection \<open>Composition With a Restricted Domain: @{term compose}\<close>

lemma funcset_compose: "f \<in> A \<rightarrow> B \<Longrightarrow> g \<in> B \<rightarrow> C \<Longrightarrow> compose A g f \<in> A \<rightarrow> C"
  by (simp add: Pi_def compose_def restrict_def)

lemma compose_assoc:
  assumes "f \<in> A \<rightarrow> B"
    and "g \<in> B \<rightarrow> C"
    and "h \<in> C \<rightarrow> D"
  shows "compose A h (compose A g f) = compose A (compose B h g) f"
  using assms by (simp add: fun_eq_iff Pi_def compose_def restrict_def)

lemma compose_eq: "x \<in> A \<Longrightarrow> compose A g f x = g (f x)"
  by (simp add: compose_def restrict_def)

lemma surj_compose: "f ` A = B \<Longrightarrow> g ` B = C \<Longrightarrow> compose A g f ` A = C"
  by (auto simp add: image_def compose_eq)

subsection \<open>Bounded Abstraction: @{term restrict}\<close>

lemma restrict_cong: "I = J \<Longrightarrow> (\<And>i. i \<in> J =simp=> f i = g i) \<Longrightarrow> restrict f I = restrict g J"
  by (auto simp: restrict_def fun_eq_iff simp_implies_def)

lemma restrict_in_funcset: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> A \<rightarrow> B"
  by (simp add: Pi_def restrict_def)

lemma restrictI[intro!]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> Pi A B"
  by (simp add: Pi_def restrict_def)

lemma restrict_apply[simp]: "(\<lambda>y\<in>A. f y) x = (if x \<in> A then f x else undefined)"
  by (simp add: restrict_def)

lemma restrict_apply': "x \<in> A \<Longrightarrow> (\<lambda>y\<in>A. f y) x = f x"
  by simp

lemma restrict_ext: "(\<And>x. x \<in> A \<Longrightarrow> f x = g x) \<Longrightarrow> (\<lambda>x\<in>A. f x) = (\<lambda>x\<in>A. g x)"
  by (simp add: fun_eq_iff Pi_def restrict_def)

lemma restrict_UNIV: "restrict f UNIV = f"
  by (simp add: restrict_def)

lemma inj_on_restrict_eq [simp]: "inj_on (restrict f A) A = inj_on f A"
  by (simp add: inj_on_def restrict_def)

lemma Id_compose: "f \<in> A \<rightarrow> B \<Longrightarrow> f \<in> extensional A \<Longrightarrow> compose A (\<lambda>y\<in>B. y) f = f"
  by (auto simp add: fun_eq_iff compose_def extensional_def Pi_def)

lemma compose_Id: "g \<in> A \<rightarrow> B \<Longrightarrow> g \<in> extensional A \<Longrightarrow> compose A g (\<lambda>x\<in>A. x) = g"
  by (auto simp add: fun_eq_iff compose_def extensional_def Pi_def)

lemma image_restrict_eq [simp]: "(restrict f A) ` A = f ` A"
  by (auto simp add: restrict_def)

lemma restrict_restrict[simp]: "restrict (restrict f A) B = restrict f (A \<inter> B)"
  unfolding restrict_def by (simp add: fun_eq_iff)

lemma restrict_fupd[simp]: "i \<notin> I \<Longrightarrow> restrict (f (i := x)) I = restrict f I"
  by (auto simp: restrict_def)

lemma restrict_upd[simp]: "i \<notin> I \<Longrightarrow> (restrict f I)(i := y) = restrict (f(i := y)) (insert i I)"
  by (auto simp: fun_eq_iff)

lemma restrict_Pi_cancel: "restrict x I \<in> Pi I A \<longleftrightarrow> x \<in> Pi I A"
  by (auto simp: restrict_def Pi_def)

subsection \<open>Bijections Between Sets\<close>

text \<open>The definition of @{const bij_betw} is in \<open>Fun.thy\<close>, but most of
the theorems belong here, or need at least @{term Hilbert_Choice}.\<close>

lemma bij_betwI:
  assumes "f \<in> A \<rightarrow> B"
    and "g \<in> B \<rightarrow> A"
    and g_f: "\<And>x. x\<in>A \<Longrightarrow> g (f x) = x"
    and f_g: "\<And>y. y\<in>B \<Longrightarrow> f (g y) = y"
  shows "bij_betw f A B"
  unfolding bij_betw_def
proof
  show "inj_on f A"
    by (metis g_f inj_on_def)
  have "f ` A \<subseteq> B"
    using \<open>f \<in> A \<rightarrow> B\<close> by auto
  moreover
  have "B \<subseteq> f ` A"
    by auto (metis Pi_mem \<open>g \<in> B \<rightarrow> A\<close> f_g image_iff)
  ultimately show "f ` A = B"
    by blast
qed

lemma bij_betw_imp_funcset: "bij_betw f A B \<Longrightarrow> f \<in> A \<rightarrow> B"
  by (auto simp add: bij_betw_def)

lemma inj_on_compose: "bij_betw f A B \<Longrightarrow> inj_on g B \<Longrightarrow> inj_on (compose A g f) A"
  by (auto simp add: bij_betw_def inj_on_def compose_eq)

lemma bij_betw_compose: "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (compose A g f) A C"
  apply (simp add: bij_betw_def compose_eq inj_on_compose)
  apply (auto simp add: compose_def image_def)
  done

lemma bij_betw_restrict_eq [simp]: "bij_betw (restrict f A) A B = bij_betw f A B"
  by (simp add: bij_betw_def)

subsection \<open>Extensionality\<close>

lemma extensional_empty[simp]: "extensional {} = {\<lambda>x. undefined}"
  unfolding extensional_def by auto

lemma extensional_arb: "f \<in> extensional A \<Longrightarrow> x \<notin> A \<Longrightarrow> f x = undefined"
  by (simp add: extensional_def)

lemma restrict_extensional [simp]: "restrict f A \<in> extensional A"
  by (simp add: restrict_def extensional_def)

lemma compose_extensional [simp]: "compose A f g \<in> extensional A"
  by (simp add: compose_def)

lemma extensionalityI:
  assumes "f \<in> extensional A"
    and "g \<in> extensional A"
    and "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
  shows "f = g"
  using assms by (force simp add: fun_eq_iff extensional_def)

lemma extensional_restrict:  "f \<in> extensional A \<Longrightarrow> restrict f A = f"
  by (rule extensionalityI[OF restrict_extensional]) auto

lemma extensional_subset: "f \<in> extensional A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f \<in> extensional B"
  unfolding extensional_def by auto

lemma inv_into_funcset: "f ` A = B \<Longrightarrow> (\<lambda>x\<in>B. inv_into A f x) \<in> B \<rightarrow> A"
  by (unfold inv_into_def) (fast intro: someI2)

lemma compose_inv_into_id: "bij_betw f A B \<Longrightarrow> compose A (\<lambda>y\<in>B. inv_into A f y) f = (\<lambda>x\<in>A. x)"
  apply (simp add: bij_betw_def compose_def)
  apply (rule restrict_ext, auto)
  done

lemma compose_id_inv_into: "f ` A = B \<Longrightarrow> compose B f (\<lambda>y\<in>B. inv_into A f y) = (\<lambda>x\<in>B. x)"
  apply (simp add: compose_def)
  apply (rule restrict_ext)
  apply (simp add: f_inv_into_f)
  done

lemma extensional_insert[intro, simp]:
  assumes "a \<in> extensional (insert i I)"
  shows "a(i := b) \<in> extensional (insert i I)"
  using assms unfolding extensional_def by auto

lemma extensional_Int[simp]: "extensional I \<inter> extensional I' = extensional (I \<inter> I')"
  unfolding extensional_def by auto

lemma extensional_UNIV[simp]: "extensional UNIV = UNIV"
  by (auto simp: extensional_def)

lemma restrict_extensional_sub[intro]: "A \<subseteq> B \<Longrightarrow> restrict f A \<in> extensional B"
  unfolding restrict_def extensional_def by auto

lemma extensional_insert_undefined[intro, simp]:
  "a \<in> extensional (insert i I) \<Longrightarrow> a(i := undefined) \<in> extensional I"
  unfolding extensional_def by auto

lemma extensional_insert_cancel[intro, simp]:
  "a \<in> extensional I \<Longrightarrow> a \<in> extensional (insert i I)"
  unfolding extensional_def by auto

subsection \<open>Cardinality\<close>

lemma card_inj: "f \<in> A \<rightarrow> B \<Longrightarrow> inj_on f A \<Longrightarrow> finite B \<Longrightarrow> card A \<le> card B"
  by (rule card_inj_on_le) auto

lemma card_bij:
  assumes "f \<in> A \<rightarrow> B" "inj_on f A"
    and "g \<in> B \<rightarrow> A" "inj_on g B"
    and "finite A" "finite B"
  shows "card A = card B"
  using assms by (blast intro: card_inj order_antisym)

subsection \<open>Extensional Function Spaces\<close>

definition PiE :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "PiE S T = Pi S T \<inter> extensional S"

abbreviation "Pi\<^sub>E A B \<equiv> PiE A B"

syntax (ASCII)
  "_PiE" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3PIE _:_./ _)" 10)
syntax
  "_PiE" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(3\<Pi>\<^sub>E _\<in>_./ _)" 10)
translations
  "\<Pi>\<^sub>E x\<in>A. B" \<rightleftharpoons> "CONST Pi\<^sub>E A (\<lambda>x. B)"

abbreviation extensional_funcset :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>E" 60)
  where "A \<rightarrow>\<^sub>E B \<equiv> (\<Pi>\<^sub>E i\<in>A. B)"

lemma extensional_funcset_def: "extensional_funcset S T = (S \<rightarrow> T) \<inter> extensional S"
  by (simp add: PiE_def)

lemma PiE_empty_domain[simp]: "PiE {} T = {\<lambda>x. undefined}"
  unfolding PiE_def by simp

lemma PiE_UNIV_domain: "PiE UNIV T = Pi UNIV T"
  unfolding PiE_def by simp

lemma PiE_empty_range[simp]: "i \<in> I \<Longrightarrow> F i = {} \<Longrightarrow> (\<Pi>\<^sub>E i\<in>I. F i) = {}"
  unfolding PiE_def by auto

lemma PiE_eq_empty_iff: "Pi\<^sub>E I F = {} \<longleftrightarrow> (\<exists>i\<in>I. F i = {})"
proof
  assume "Pi\<^sub>E I F = {}"
  show "\<exists>i\<in>I. F i = {}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "\<forall>i. \<exists>y. (i \<in> I \<longrightarrow> y \<in> F i) \<and> (i \<notin> I \<longrightarrow> y = undefined)"
      by auto
    from choice[OF this]
    obtain f where " \<forall>x. (x \<in> I \<longrightarrow> f x \<in> F x) \<and> (x \<notin> I \<longrightarrow> f x = undefined)" ..
    then have "f \<in> Pi\<^sub>E I F"
      by (auto simp: extensional_def PiE_def)
    with \<open>Pi\<^sub>E I F = {}\<close> show False
      by auto
  qed
qed (auto simp: PiE_def)

lemma PiE_arb: "f \<in> PiE S T \<Longrightarrow> x \<notin> S \<Longrightarrow> f x = undefined"
  unfolding PiE_def by auto (auto dest!: extensional_arb)

lemma PiE_mem: "f \<in> PiE S T \<Longrightarrow> x \<in> S \<Longrightarrow> f x \<in> T x"
  unfolding PiE_def by auto

lemma PiE_fun_upd: "y \<in> T x \<Longrightarrow> f \<in> PiE S T \<Longrightarrow> f(x := y) \<in> PiE (insert x S) T"
  unfolding PiE_def extensional_def by auto

lemma fun_upd_in_PiE: "x \<notin> S \<Longrightarrow> f \<in> PiE (insert x S) T \<Longrightarrow> f(x := undefined) \<in> PiE S T"
  unfolding PiE_def extensional_def by auto

lemma PiE_insert_eq: "PiE (insert x S) T = (\<lambda>(y, g). g(x := y)) ` (T x \<times> PiE S T)"
proof -
  {
    fix f assume "f \<in> PiE (insert x S) T" "x \<notin> S"
    then have "f \<in> (\<lambda>(y, g). g(x := y)) ` (T x \<times> PiE S T)"
      by (auto intro!: image_eqI[where x="(f x, f(x := undefined))"] intro: fun_upd_in_PiE PiE_mem)
  }
  moreover
  {
    fix f assume "f \<in> PiE (insert x S) T" "x \<in> S"
    then have "f \<in> (\<lambda>(y, g). g(x := y)) ` (T x \<times> PiE S T)"
      by (auto intro!: image_eqI[where x="(f x, f)"] intro: fun_upd_in_PiE PiE_mem simp: insert_absorb)
  }
  ultimately show ?thesis
    by (auto intro: PiE_fun_upd)
qed

lemma PiE_Int: "Pi\<^sub>E I A \<inter> Pi\<^sub>E I B = Pi\<^sub>E I (\<lambda>x. A x \<inter> B x)"
  by (auto simp: PiE_def)

lemma PiE_cong: "(\<And>i. i\<in>I \<Longrightarrow> A i = B i) \<Longrightarrow> Pi\<^sub>E I A = Pi\<^sub>E I B"
  unfolding PiE_def by (auto simp: Pi_cong)

lemma PiE_E [elim]:
  assumes "f \<in> PiE A B"
  obtains "x \<in> A" and "f x \<in> B x"
    | "x \<notin> A" and "f x = undefined"
  using assms by (auto simp: Pi_def PiE_def extensional_def)

lemma PiE_I[intro!]:
  "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> (\<And>x. x \<notin> A \<Longrightarrow> f x = undefined) \<Longrightarrow> f \<in> PiE A B"
  by (simp add: PiE_def extensional_def)

lemma PiE_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> PiE A B \<subseteq> PiE A C"
  by auto

lemma PiE_iff: "f \<in> PiE I X \<longleftrightarrow> (\<forall>i\<in>I. f i \<in> X i) \<and> f \<in> extensional I"
  by (simp add: PiE_def Pi_iff)

lemma PiE_restrict[simp]:  "f \<in> PiE A B \<Longrightarrow> restrict f A = f"
  by (simp add: extensional_restrict PiE_def)

lemma restrict_PiE[simp]: "restrict f I \<in> PiE I S \<longleftrightarrow> f \<in> Pi I S"
  by (auto simp: PiE_iff)

lemma PiE_eq_subset:
  assumes ne: "\<And>i. i \<in> I \<Longrightarrow> F i \<noteq> {}" "\<And>i. i \<in> I \<Longrightarrow> F' i \<noteq> {}"
    and eq: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
    and "i \<in> I"
  shows "F i \<subseteq> F' i"
proof
  fix x
  assume "x \<in> F i"
  with ne have "\<forall>j. \<exists>y. (j \<in> I \<longrightarrow> y \<in> F j \<and> (i = j \<longrightarrow> x = y)) \<and> (j \<notin> I \<longrightarrow> y = undefined)"
    by auto
  from choice[OF this] obtain f
    where f: " \<forall>j. (j \<in> I \<longrightarrow> f j \<in> F j \<and> (i = j \<longrightarrow> x = f j)) \<and> (j \<notin> I \<longrightarrow> f j = undefined)" ..
  then have "f \<in> Pi\<^sub>E I F"
    by (auto simp: extensional_def PiE_def)
  then have "f \<in> Pi\<^sub>E I F'"
    using assms by simp
  then show "x \<in> F' i"
    using f \<open>i \<in> I\<close> by (auto simp: PiE_def)
qed

lemma PiE_eq_iff_not_empty:
  assumes ne: "\<And>i. i \<in> I \<Longrightarrow> F i \<noteq> {}" "\<And>i. i \<in> I \<Longrightarrow> F' i \<noteq> {}"
  shows "Pi\<^sub>E I F = Pi\<^sub>E I F' \<longleftrightarrow> (\<forall>i\<in>I. F i = F' i)"
proof (intro iffI ballI)
  fix i
  assume eq: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
  assume i: "i \<in> I"
  show "F i = F' i"
    using PiE_eq_subset[of I F F', OF ne eq i]
    using PiE_eq_subset[of I F' F, OF ne(2,1) eq[symmetric] i]
    by auto
qed (auto simp: PiE_def)

lemma PiE_eq_iff:
  "Pi\<^sub>E I F = Pi\<^sub>E I F' \<longleftrightarrow> (\<forall>i\<in>I. F i = F' i) \<or> ((\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {}))"
proof (intro iffI disjCI)
  assume eq[simp]: "Pi\<^sub>E I F = Pi\<^sub>E I F'"
  assume "\<not> ((\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {}))"
  then have "(\<forall>i\<in>I. F i \<noteq> {}) \<and> (\<forall>i\<in>I. F' i \<noteq> {})"
    using PiE_eq_empty_iff[of I F] PiE_eq_empty_iff[of I F'] by auto
  with PiE_eq_iff_not_empty[of I F F'] show "\<forall>i\<in>I. F i = F' i"
    by auto
next
  assume "(\<forall>i\<in>I. F i = F' i) \<or> (\<exists>i\<in>I. F i = {}) \<and> (\<exists>i\<in>I. F' i = {})"
  then show "Pi\<^sub>E I F = Pi\<^sub>E I F'"
    using PiE_eq_empty_iff[of I F] PiE_eq_empty_iff[of I F'] by (auto simp: PiE_def)
qed

lemma extensional_funcset_fun_upd_restricts_rangeI:
  "\<forall>y \<in> S. f x \<noteq> f y \<Longrightarrow> f \<in> (insert x S) \<rightarrow>\<^sub>E T \<Longrightarrow> f(x := undefined) \<in> S \<rightarrow>\<^sub>E (T - {f x})"
  unfolding extensional_funcset_def extensional_def
  apply auto
  apply (case_tac "x = xa")
  apply auto
  done

lemma extensional_funcset_fun_upd_extends_rangeI:
  assumes "a \<in> T" "f \<in> S \<rightarrow>\<^sub>E (T - {a})"
  shows "f(x := a) \<in> insert x S \<rightarrow>\<^sub>E  T"
  using assms unfolding extensional_funcset_def extensional_def by auto

subsubsection \<open>Injective Extensional Function Spaces\<close>

lemma extensional_funcset_fun_upd_inj_onI:
  assumes "f \<in> S \<rightarrow>\<^sub>E (T - {a})"
    and "inj_on f S"
  shows "inj_on (f(x := a)) S"
  using assms
  unfolding extensional_funcset_def by (auto intro!: inj_on_fun_updI)

lemma extensional_funcset_extend_domain_inj_on_eq:
  assumes "x \<notin> S"
  shows "{f. f \<in> (insert x S) \<rightarrow>\<^sub>E T \<and> inj_on f (insert x S)} =
    (\<lambda>(y, g). g(x:=y)) ` {(y, g). y \<in> T \<and> g \<in> S \<rightarrow>\<^sub>E (T - {y}) \<and> inj_on g S}"
  using assms
  apply (auto del: PiE_I PiE_E)
  apply (auto intro: extensional_funcset_fun_upd_inj_onI
    extensional_funcset_fun_upd_extends_rangeI del: PiE_I PiE_E)
  apply (auto simp add: image_iff inj_on_def)
  apply (rule_tac x="xa x" in exI)
  apply (auto intro: PiE_mem del: PiE_I PiE_E)
  apply (rule_tac x="xa(x := undefined)" in exI)
  apply (auto intro!: extensional_funcset_fun_upd_restricts_rangeI)
  apply (auto dest!: PiE_mem split: if_split_asm)
  done

lemma extensional_funcset_extend_domain_inj_onI:
  assumes "x \<notin> S"
  shows "inj_on (\<lambda>(y, g). g(x := y)) {(y, g). y \<in> T \<and> g \<in> S \<rightarrow>\<^sub>E (T - {y}) \<and> inj_on g S}"
  using assms
  apply (auto intro!: inj_onI)
  apply (metis fun_upd_same)
  apply (metis assms PiE_arb fun_upd_triv fun_upd_upd)
  done

subsubsection \<open>Cardinality\<close>

lemma finite_PiE: "finite S \<Longrightarrow> (\<And>i. i \<in> S \<Longrightarrow> finite (T i)) \<Longrightarrow> finite (\<Pi>\<^sub>E i \<in> S. T i)"
  by (induct S arbitrary: T rule: finite_induct) (simp_all add: PiE_insert_eq)

lemma inj_combinator: "x \<notin> S \<Longrightarrow> inj_on (\<lambda>(y, g). g(x := y)) (T x \<times> Pi\<^sub>E S T)"
proof (safe intro!: inj_onI ext)
  fix f y g z
  assume "x \<notin> S"
  assume fg: "f \<in> Pi\<^sub>E S T" "g \<in> Pi\<^sub>E S T"
  assume "f(x := y) = g(x := z)"
  then have *: "\<And>i. (f(x := y)) i = (g(x := z)) i"
    unfolding fun_eq_iff by auto
  from this[of x] show "y = z" by simp
  fix i from *[of i] \<open>x \<notin> S\<close> fg show "f i = g i"
    by (auto split: if_split_asm simp: PiE_def extensional_def)
qed

lemma card_PiE: "finite S \<Longrightarrow> card (\<Pi>\<^sub>E i \<in> S. T i) = (\<Prod> i\<in>S. card (T i))"
proof (induct rule: finite_induct)
  case empty
  then show ?case by auto
next
  case (insert x S)
  then show ?case
    by (simp add: PiE_insert_eq inj_combinator card_image card_cartesian_product)
qed

end


(*  Title:      HOL/Library/Product_Order.thy
    Author:     Brian Huffman
*)

section {* Pointwise order on product types *}

theory Product_Order
imports Product_plus Conditionally_Complete_Lattices
begin

subsection {* Pointwise ordering *}

instantiation prod :: (ord, ord) ord
begin

definition
  "x \<le> y \<longleftrightarrow> fst x \<le> fst y \<and> snd x \<le> snd y"

definition
  "(x::'a \<times> 'b) < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

instance ..

end

lemma fst_mono: "x \<le> y \<Longrightarrow> fst x \<le> fst y"
  unfolding less_eq_prod_def by simp

lemma snd_mono: "x \<le> y \<Longrightarrow> snd x \<le> snd y"
  unfolding less_eq_prod_def by simp

lemma Pair_mono: "x \<le> x' \<Longrightarrow> y \<le> y' \<Longrightarrow> (x, y) \<le> (x', y')"
  unfolding less_eq_prod_def by simp

lemma Pair_le [simp]: "(a, b) \<le> (c, d) \<longleftrightarrow> a \<le> c \<and> b \<le> d"
  unfolding less_eq_prod_def by simp

instance prod :: (preorder, preorder) preorder
proof
  fix x y z :: "'a \<times> 'b"
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    by (rule less_prod_def)
  show "x \<le> x"
    unfolding less_eq_prod_def
    by fast
  assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
    unfolding less_eq_prod_def
    by (fast elim: order_trans)
qed

instance prod :: (order, order) order
  by default auto

subsection {* Binary infimum and supremum *}

instantiation prod :: (inf, inf) inf
begin

definition
  "inf x y = (inf (fst x) (fst y), inf (snd x) (snd y))"

lemma inf_Pair_Pair [simp]: "inf (a, b) (c, d) = (inf a c, inf b d)"
  unfolding inf_prod_def by simp

lemma fst_inf [simp]: "fst (inf x y) = inf (fst x) (fst y)"
  unfolding inf_prod_def by simp

lemma snd_inf [simp]: "snd (inf x y) = inf (snd x) (snd y)"
  unfolding inf_prod_def by simp

instance proof qed
end

instance prod :: (semilattice_inf, semilattice_inf) semilattice_inf
  by default auto

instantiation prod :: (sup, sup) sup
begin

definition
  "sup x y = (sup (fst x) (fst y), sup (snd x) (snd y))"

lemma sup_Pair_Pair [simp]: "sup (a, b) (c, d) = (sup a c, sup b d)"
  unfolding sup_prod_def by simp

lemma fst_sup [simp]: "fst (sup x y) = sup (fst x) (fst y)"
  unfolding sup_prod_def by simp

lemma snd_sup [simp]: "snd (sup x y) = sup (snd x) (snd y)"
  unfolding sup_prod_def by simp

instance proof qed
end

instance prod :: (semilattice_sup, semilattice_sup) semilattice_sup
  by default auto

instance prod :: (lattice, lattice) lattice ..

instance prod :: (distrib_lattice, distrib_lattice) distrib_lattice
  by default (auto simp add: sup_inf_distrib1)

subsection {* Top and bottom elements *}

instantiation prod :: (top, top) top
begin

definition
  "top = (top, top)"

instance ..

end

lemma fst_top [simp]: "fst top = top"
  unfolding top_prod_def by simp

lemma snd_top [simp]: "snd top = top"
  unfolding top_prod_def by simp

lemma Pair_top_top: "(top, top) = top"
  unfolding top_prod_def by simp

instance prod :: (order_top, order_top) order_top
  by default (auto simp add: top_prod_def)

instantiation prod :: (bot, bot) bot
begin

definition
  "bot = (bot, bot)"

instance ..

end

lemma fst_bot [simp]: "fst bot = bot"
  unfolding bot_prod_def by simp

lemma snd_bot [simp]: "snd bot = bot"
  unfolding bot_prod_def by simp

lemma Pair_bot_bot: "(bot, bot) = bot"
  unfolding bot_prod_def by simp

instance prod :: (order_bot, order_bot) order_bot
  by default (auto simp add: bot_prod_def)

instance prod :: (bounded_lattice, bounded_lattice) bounded_lattice ..

instance prod :: (boolean_algebra, boolean_algebra) boolean_algebra
  by default (auto simp add: prod_eqI inf_compl_bot sup_compl_top diff_eq)

subsection {* Complete lattice operations *}

instantiation prod :: (Inf, Inf) Inf
begin

definition
  "Inf A = (INF x:A. fst x, INF x:A. snd x)"

instance proof qed
end

instantiation prod :: (Sup, Sup) Sup
begin

definition
  "Sup A = (SUP x:A. fst x, SUP x:A. snd x)"

instance proof qed
end

instance prod :: (conditionally_complete_lattice, conditionally_complete_lattice)
    conditionally_complete_lattice
  by default (force simp: less_eq_prod_def Inf_prod_def Sup_prod_def bdd_below_def bdd_above_def
    INF_def SUP_def simp del: Inf_image_eq Sup_image_eq intro!: cInf_lower cSup_upper cInf_greatest cSup_least)+

instance prod :: (complete_lattice, complete_lattice) complete_lattice
  by default (simp_all add: less_eq_prod_def Inf_prod_def Sup_prod_def
    INF_lower SUP_upper le_INF_iff SUP_le_iff bot_prod_def top_prod_def)

lemma fst_Sup: "fst (Sup A) = (SUP x:A. fst x)"
  unfolding Sup_prod_def by simp

lemma snd_Sup: "snd (Sup A) = (SUP x:A. snd x)"
  unfolding Sup_prod_def by simp

lemma fst_Inf: "fst (Inf A) = (INF x:A. fst x)"
  unfolding Inf_prod_def by simp

lemma snd_Inf: "snd (Inf A) = (INF x:A. snd x)"
  unfolding Inf_prod_def by simp

lemma fst_SUP: "fst (SUP x:A. f x) = (SUP x:A. fst (f x))"
  using fst_Sup [of "f ` A", symmetric] by (simp add: comp_def)

lemma snd_SUP: "snd (SUP x:A. f x) = (SUP x:A. snd (f x))"
  using snd_Sup [of "f ` A", symmetric] by (simp add: comp_def)

lemma fst_INF: "fst (INF x:A. f x) = (INF x:A. fst (f x))"
  using fst_Inf [of "f ` A", symmetric] by (simp add: comp_def)

lemma snd_INF: "snd (INF x:A. f x) = (INF x:A. snd (f x))"
  using snd_Inf [of "f ` A", symmetric] by (simp add: comp_def)

lemma SUP_Pair: "(SUP x:A. (f x, g x)) = (SUP x:A. f x, SUP x:A. g x)"
  unfolding SUP_def Sup_prod_def by (simp add: comp_def)

lemma INF_Pair: "(INF x:A. (f x, g x)) = (INF x:A. f x, INF x:A. g x)"
  unfolding INF_def Inf_prod_def by (simp add: comp_def)

text {* Alternative formulations for set infima and suprema over the product
of two complete lattices: *}

lemma INF_prod_alt_def:
  "INFIMUM A f = (INFIMUM A (fst o f), INFIMUM A (snd o f))"
  unfolding INF_def Inf_prod_def by simp

lemma SUP_prod_alt_def:
  "SUPREMUM A f = (SUPREMUM A (fst o f), SUPREMUM A (snd o f))"
  unfolding SUP_def Sup_prod_def by simp

subsection {* Complete distributive lattices *}

(* Contribution: Alessandro Coglio *)

instance prod ::
  (complete_distrib_lattice, complete_distrib_lattice) complete_distrib_lattice
proof
  case goal1 thus ?case
    by (auto simp: sup_prod_def Inf_prod_def INF_prod_alt_def sup_Inf sup_INF comp_def)
next
  case goal2 thus ?case
    by (auto simp: inf_prod_def Sup_prod_def SUP_prod_alt_def inf_Sup inf_SUP comp_def)
qed

end