theory "Fibs"
  imports
    "../HOLCF_Prelude"
    "../Definedness"
begin

section \<open>Fibonacci sequence\<close>

text \<open>
  In this example, we show that the self-recursive lazy definition of the
  fibonacci sequence is actually defined and correct.
\<close>

fixrec fibs :: "[Integer]" where
  [simp del]: "fibs = 0 : 1 : zipWith\<cdot>(+)\<cdot>fibs\<cdot>(tail\<cdot>fibs)"

fun fib :: "int \<Rightarrow> int" where
  "fib n = (if n \<le> 0 then 0 else if n = 1 then 1 else fib (n - 1) + fib (n - 2))"

declare fib.simps [simp del]

lemma fibs_0 [simp]:
  "fibs !! 0 = 0"
  by (subst fibs.simps) simp

lemma fibs_1 [simp]:
  "fibs !! 1 = 1"
  by (subst fibs.simps) simp

text \<open>And the proof that @{term "fibs !! i"} is defined and the fibs value.\<close>

(* Strange isabelle simplifier bug? *)

lemma nth_fibs:
  assumes "defined i" and "\<lbrakk> i \<rbrakk> \<ge> 0" shows "defined (fibs !! i)" and "\<lbrakk> fibs !! i \<rbrakk> = fib \<lbrakk> i \<rbrakk>"
  using assms
proof(induction i rule:nonneg_full_Int_induct)
  case (Suc i)
  case 1
  with Suc show ?case
    apply (cases "\<lbrakk>i\<rbrakk> = 0")
     apply (subst fibs.simps, (subst fib.simps)?, simp add: nth_zipWith nth_tail)
    apply (cases "\<lbrakk>i\<rbrakk> = 1")
     apply (subst fibs.simps, (subst fib.simps)?, simp add: nth_zipWith nth_tail)
    apply (subst fibs.simps, (subst fib.simps)?, simp add: nth_zipWith nth_tail)
    done
qed (subst fibs.simps, (subst fib.simps)?, simp add: nth_zipWith nth_tail)+

end


theory HSV_chapter5 imports Main begin

text \<open>Defining a data structure to represent fan-out-free circuits with numbered inputs\<close>

datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

text \<open>A few example circuits\<close>

definition "circuit1 == AND (INPUT 1) (INPUT 2)"
definition "circuit2 == OR (NOT circuit1) FALSE"
definition "circuit3 == NOT (NOT circuit2)"
definition "circuit4 == AND circuit3 (INPUT 3)"

text \<open>Simulates a circuit given a valuation for each input wire\<close>

fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

text \<open>A few example valuations\<close>

definition "\<rho>0 == \<lambda>_. True"
definition "\<rho>1 == \<rho>0(1 := True, 2 := False, 3 := True)"
definition "\<rho>2 == \<rho>0(1 := True, 2 := True, 3 := True)"

text \<open>Trying out the simulator\<close>

value "simulate circuit1 \<rho>1"
value "simulate circuit2 \<rho>1"
value "simulate circuit3 \<rho>1"
value "simulate circuit4 \<rho>1"
value "simulate circuit1 \<rho>2"
value "simulate circuit2 \<rho>2"
value "simulate circuit3 \<rho>2"
value "simulate circuit4 \<rho>2"

text \<open>A function that switches each pair of wires entering an OR or AND gate\<close>

fun mirror where
  "mirror (NOT c) = NOT (mirror c)"
| "mirror (AND c1 c2) = AND (mirror c2) (mirror c1)"
| "mirror (OR c1 c2) = OR (mirror c2) (mirror c1)"
| "mirror TRUE = TRUE"
| "mirror FALSE = FALSE"
| "mirror (INPUT i) = INPUT i"

value "circuit1"
value "mirror circuit1"
value "circuit2"
value "mirror circuit2"

text \<open>The following non-theorem is easily contradicted.\<close>

theorem "mirror c = c"
  oops

text \<open>Proving that mirroring doesn't affect simulation behaviour.\<close>

theorem "simulate (mirror c) \<rho> = simulate c \<rho>"
  by (induct c, auto)

text \<open>A Fibonacci function that demonstrates complex recursion schemes\<close>

fun f :: "nat \<Rightarrow> nat" where
  "f (Suc (Suc n)) = f n + f (Suc n)"
| "f (Suc 0) = 1"
| "f 0 = 1"

thm f.induct (* rule induction theorem for f *)

text \<open>We need to prove a stronger version of the theorem below
  first, in order to make the inductive step work. Just like how
  it often goes with loop invariants in Dafny!\<close>
lemma helper: "f n \<ge> n \<and> f n \<ge> 1"
  by (rule f.induct[of "\<lambda>n. f n \<ge> n \<and> f n \<ge> 1"], auto)

text \<open>The nth Fibonacci number is greater than or equal to n\<close>
theorem "f n \<ge> n"
  using helper by simp

text \<open>A function that optimises a circuit by removing pairs of consecutive NOT gates\<close>

fun opt_NOT where
  "opt_NOT (NOT (NOT c)) = opt_NOT c"
| "opt_NOT (NOT c) = NOT (opt_NOT c)"
| "opt_NOT (AND c1 c2) = AND (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT (OR c1 c2) = OR (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT TRUE = TRUE"
| "opt_NOT FALSE = FALSE"
| "opt_NOT (INPUT i) = INPUT i"

text \<open>Trying out the optimiser\<close>

value "circuit1"
value "opt_NOT circuit1"
value "circuit2"
value "opt_NOT circuit2"
value "circuit3"
value "opt_NOT circuit3"
value "circuit4"
value "opt_NOT circuit4"

text \<open>The following non-theorem is easily contradicted.\<close>

theorem "opt_NOT c = c"
  oops

text \<open>The following theorem says that the optimiser is sound.\<close>

theorem opt_NOT_is_sound: "simulate (opt_NOT c) \<rho> = simulate c \<rho>"
  by (induct rule:opt_NOT.induct, auto)

text \<open>The following function calculates the area of a circuit (i.e. number of gates).\<close>

fun area :: "circuit \<Rightarrow> nat" where
  "area (NOT c) = 1 + area c"
| "area (AND c1 c2) = 1 + area c1 + area c2"
| "area (OR c1 c2) = 1 + area c1 + area c2"
| "area _ = 0"

end


(*  Title:      HOL/ex/CTL.thy
    Author:     Gertrud Bauer
*)

section \<open>CTL formulae\<close>

theory CTL
imports Main
begin

text \<open>
  We formalize basic concepts of Computational Tree Logic (CTL) \<^cite>\<open>"McMillan-PhDThesis"\<close> within the simply-typed
  set theory of HOL.

  By using the common technique of ``shallow embedding'', a CTL formula is
  identified with the corresponding set of states where it holds.
  Consequently, CTL operations such as negation, conjunction, disjunction
  simply become complement, intersection, union of sets. We only require a
  separate operation for implication, as point-wise inclusion is usually not
  encountered in plain set-theory.
\<close>

lemmas [intro!] = Int_greatest Un_upper2 Un_upper1 Int_lower1 Int_lower2

type_synonym 'a ctl = "'a set"

definition imp :: "'a ctl \<Rightarrow> 'a ctl \<Rightarrow> 'a ctl"  (infixr "\<rightarrow>" 75)
  where "p \<rightarrow> q = - p \<union> q"

lemma [intro!]: "p \<inter> p \<rightarrow> q \<subseteq> q" unfolding imp_def by auto
lemma [intro!]: "p \<subseteq> (q \<rightarrow> p)" unfolding imp_def by rule

text \<open>
  \<^smallskip>
  The CTL path operators are more interesting; they are based on an arbitrary,
  but fixed model \<open>\<M>\<close>, which is simply a transition relation over states
  \<^typ>\<open>'a\<close>.
\<close>

axiomatization \<M> :: "('a \<times> 'a) set"

text \<open>
  The operators \<open>\<^bold>E\<^bold>X\<close>, \<open>\<^bold>E\<^bold>F\<close>, \<open>\<^bold>E\<^bold>G\<close> are taken as primitives, while \<open>\<^bold>A\<^bold>X\<close>,
  \<open>\<^bold>A\<^bold>F\<close>, \<open>\<^bold>A\<^bold>G\<close> are defined as derived ones. The formula \<open>\<^bold>E\<^bold>X p\<close> holds in a
  state \<open>s\<close>, iff there is a successor state \<open>s'\<close> (with respect to the model
  \<open>\<M>\<close>), such that \<open>p\<close> holds in \<open>s'\<close>. The formula \<open>\<^bold>E\<^bold>F p\<close> holds in a state
  \<open>s\<close>, iff there is a path in \<open>\<M>\<close>, starting from \<open>s\<close>, such that there exists a
  state \<open>s'\<close> on the path, such that \<open>p\<close> holds in \<open>s'\<close>. The formula \<open>\<^bold>E\<^bold>G p\<close>
  holds in a state \<open>s\<close>, iff there is a path, starting from \<open>s\<close>, such that for
  all states \<open>s'\<close> on the path, \<open>p\<close> holds in \<open>s'\<close>. It is easy to see that \<open>\<^bold>E\<^bold>F
  p\<close> and \<open>\<^bold>E\<^bold>G p\<close> may be expressed using least and greatest fixed points
  \<^cite>\<open>"McMillan-PhDThesis"\<close>.
\<close>

definition EX  ("\<^bold>E\<^bold>X _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>X p = {s. \<exists>s'. (s, s') \<in> \<M> \<and> s' \<in> p}"

definition EF ("\<^bold>E\<^bold>F _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>F p = lfp (\<lambda>s. p \<union> \<^bold>E\<^bold>X s)"

definition EG ("\<^bold>E\<^bold>G _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>G p = gfp (\<lambda>s. p \<inter> \<^bold>E\<^bold>X s)"

text \<open>
  \<open>\<^bold>A\<^bold>X\<close>, \<open>\<^bold>A\<^bold>F\<close> and \<open>\<^bold>A\<^bold>G\<close> are now defined dually in terms of \<open>\<^bold>E\<^bold>X\<close>,
  \<open>\<^bold>E\<^bold>F\<close> and \<open>\<^bold>E\<^bold>G\<close>.
\<close>

definition AX  ("\<^bold>A\<^bold>X _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>X p = - \<^bold>E\<^bold>X - p"
definition AF  ("\<^bold>A\<^bold>F _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>F p = - \<^bold>E\<^bold>G - p"
definition AG  ("\<^bold>A\<^bold>G _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>G p = - \<^bold>E\<^bold>F - p"

subsection \<open>Basic fixed point properties\<close>

text \<open>
  First of all, we use the de-Morgan property of fixed points.
\<close>

lemma lfp_gfp: "lfp f = - gfp (\<lambda>s::'a set. - (f (- s)))"
proof
  show "lfp f \<subseteq> - gfp (\<lambda>s. - f (- s))"
  proof
    show "x \<in> - gfp (\<lambda>s. - f (- s))" if l: "x \<in> lfp f" for x
    proof
      assume "x \<in> gfp (\<lambda>s. - f (- s))"
      then obtain u where "x \<in> u" and "u \<subseteq> - f (- u)"
        by (auto simp add: gfp_def)
      then have "f (- u) \<subseteq> - u" by auto
      then have "lfp f \<subseteq> - u" by (rule lfp_lowerbound)
      from l and this have "x \<notin> u" by auto
      with \<open>x \<in> u\<close> show False by contradiction
    qed
  qed
  show "- gfp (\<lambda>s. - f (- s)) \<subseteq> lfp f"
  proof (rule lfp_greatest)
    fix u
    assume "f u \<subseteq> u"
    then have "- u \<subseteq> - f u" by auto
    then have "- u \<subseteq> - f (- (- u))" by simp
    then have "- u \<subseteq> gfp (\<lambda>s. - f (- s))" by (rule gfp_upperbound)
    then show "- gfp (\<lambda>s. - f (- s)) \<subseteq> u" by auto
  qed
qed

lemma lfp_gfp': "- lfp f = gfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

lemma gfp_lfp': "- gfp f = lfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

text \<open>
  In order to give dual fixed point representations of \<^term>\<open>\<^bold>A\<^bold>F p\<close> and
  \<^term>\<open>\<^bold>A\<^bold>G p\<close>:
\<close>

lemma AF_lfp: "\<^bold>A\<^bold>F p = lfp (\<lambda>s. p \<union> \<^bold>A\<^bold>X s)"
  by (simp add: lfp_gfp)

lemma AG_gfp: "\<^bold>A\<^bold>G p = gfp (\<lambda>s. p \<inter> \<^bold>A\<^bold>X s)"
  by (simp add: lfp_gfp)

lemma EF_fp: "\<^bold>E\<^bold>F p = p \<union> \<^bold>E\<^bold>X \<^bold>E\<^bold>F p"
proof -
  have "mono (\<lambda>s. p \<union> \<^bold>E\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: EF_def) (rule lfp_unfold)
qed

lemma AF_fp: "\<^bold>A\<^bold>F p = p \<union> \<^bold>A\<^bold>X \<^bold>A\<^bold>F p"
proof -
  have "mono (\<lambda>s. p \<union> \<^bold>A\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: AF_lfp) (rule lfp_unfold)
qed

lemma EG_fp: "\<^bold>E\<^bold>G p = p \<inter> \<^bold>E\<^bold>X \<^bold>E\<^bold>G p"
proof -
  have "mono (\<lambda>s. p \<inter> \<^bold>E\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: EG_def) (rule gfp_unfold)
qed

text \<open>
  From the greatest fixed point definition of \<^term>\<open>\<^bold>A\<^bold>G p\<close>, we derive as
  a consequence of the Knaster-Tarski theorem on the one hand that \<^term>\<open>\<^bold>A\<^bold>G p\<close> is a fixed point of the monotonic function
  \<^term>\<open>\<lambda>s. p \<inter> \<^bold>A\<^bold>X s\<close>.
\<close>

lemma AG_fp: "\<^bold>A\<^bold>G p = p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  have "mono (\<lambda>s. p \<inter> \<^bold>A\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: AG_gfp) (rule gfp_unfold)
qed

text \<open>
  This fact may be split up into two inequalities (merely using transitivity
  of \<open>\<subseteq>\<close>, which is an instance of the overloaded \<open>\<le>\<close> in Isabelle/HOL).
\<close>

lemma AG_fp_1: "\<^bold>A\<^bold>G p \<subseteq> p"
proof -
  note AG_fp also have "p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p \<subseteq> p" by auto
  finally show ?thesis .
qed

lemma AG_fp_2: "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  note AG_fp also have "p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by auto
  finally show ?thesis .
qed

text \<open>
  On the other hand, we have from the Knaster-Tarski fixed point theorem that
  any other post-fixed point of \<^term>\<open>\<lambda>s. p \<inter> \<^bold>A\<^bold>X s\<close> is smaller than
  \<^term>\<open>\<^bold>A\<^bold>G p\<close>. A post-fixed point is a set of states \<open>q\<close> such that \<^term>\<open>q \<subseteq> p \<inter> \<^bold>A\<^bold>X q\<close>. This leads to the following co-induction principle for
  \<^term>\<open>\<^bold>A\<^bold>G p\<close>.
\<close>

lemma AG_I: "q \<subseteq> p \<inter> \<^bold>A\<^bold>X q \<Longrightarrow> q \<subseteq> \<^bold>A\<^bold>G p"
  by (simp only: AG_gfp) (rule gfp_upperbound)

subsection \<open>The tree induction principle \label{sec:calc-ctl-tree-induct}\<close>

text \<open>
  With the most basic facts available, we are now able to establish a few more
  interesting results, leading to the \<^emph>\<open>tree induction\<close> principle for \<open>\<^bold>A\<^bold>G\<close>
  (see below). We will use some elementary monotonicity and distributivity
  rules.
\<close>

lemma AX_int: "\<^bold>A\<^bold>X (p \<inter> q) = \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X q" by auto
lemma AX_mono: "p \<subseteq> q \<Longrightarrow> \<^bold>A\<^bold>X p \<subseteq> \<^bold>A\<^bold>X q" by auto
lemma AG_mono: "p \<subseteq> q \<Longrightarrow> \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G q"
  by (simp only: AG_gfp, rule gfp_mono) auto

text \<open>
  The formula \<^term>\<open>AG p\<close> implies \<^term>\<open>AX p\<close> (we use substitution of
  \<open>\<subseteq>\<close> with monotonicity).
\<close>

lemma AG_AX: "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p"
proof -
  have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by (rule AG_fp_2)
  also have "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
  moreover note AX_mono
  finally show ?thesis .
qed

text \<open>
  Furthermore we show idempotency of the \<open>\<^bold>A\<^bold>G\<close> operator. The proof is a good
  example of how accumulated facts may get used to feed a single rule step.
\<close>

lemma AG_AG: "\<^bold>A\<^bold>G \<^bold>A\<^bold>G p = \<^bold>A\<^bold>G p"
proof
  show "\<^bold>A\<^bold>G \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p" by (rule AG_fp_1)
next
  show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G \<^bold>A\<^bold>G p"
  proof (rule AG_I)
    have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p" ..
    moreover have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by (rule AG_fp_2)
    ultimately show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" ..
  qed
qed

text \<open>
  \<^smallskip>
  We now give an alternative characterization of the \<open>\<^bold>A\<^bold>G\<close> operator, which
  describes the \<open>\<^bold>A\<^bold>G\<close> operator in an ``operational'' way by tree induction:
  In a state holds \<^term>\<open>AG p\<close> iff in that state holds \<open>p\<close>, and in all
  reachable states \<open>s\<close> follows from the fact that \<open>p\<close> holds in \<open>s\<close>, that \<open>p\<close>
  also holds in all successor states of \<open>s\<close>. We use the co-induction principle
  @{thm [source] AG_I} to establish this in a purely algebraic manner.
\<close>

theorem AG_induct: "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) = \<^bold>A\<^bold>G p"
proof
  show "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> \<^bold>A\<^bold>G p"  (is "?lhs \<subseteq> _")
  proof (rule AG_I)
    show "?lhs \<subseteq> p \<inter> \<^bold>A\<^bold>X ?lhs"
    proof
      show "?lhs \<subseteq> p" ..
      show "?lhs \<subseteq> \<^bold>A\<^bold>X ?lhs"
      proof -
        {
          have "\<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> p \<rightarrow> \<^bold>A\<^bold>X p" by (rule AG_fp_1)
          also have "p \<inter> p \<rightarrow> \<^bold>A\<^bold>X p \<subseteq> \<^bold>A\<^bold>X p" ..
          finally have "?lhs \<subseteq> \<^bold>A\<^bold>X p" by auto
        }
        moreover
        {
          have "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" ..
          also have "\<dots> \<subseteq> \<^bold>A\<^bold>X \<dots>" by (rule AG_fp_2)
          finally have "?lhs \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" .
        }
        ultimately have "?lhs \<subseteq> \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" ..
        also have "\<dots> = \<^bold>A\<^bold>X ?lhs" by (simp only: AX_int)
        finally show ?thesis .
      qed
    qed
  qed
next
  show "\<^bold>A\<^bold>G p \<subseteq> p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)"
  proof
    show "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
    show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)"
    proof -
      have "\<^bold>A\<^bold>G p = \<^bold>A\<^bold>G \<^bold>A\<^bold>G p" by (simp only: AG_AG)
      also have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p" by (rule AG_AX) moreover note AG_mono
      also have "\<^bold>A\<^bold>X p \<subseteq> (p \<rightarrow> \<^bold>A\<^bold>X p)" .. moreover note AG_mono
      finally show ?thesis .
    qed
  qed
qed

subsection \<open>An application of tree induction \label{sec:calc-ctl-commute}\<close>

text \<open>
  Further interesting properties of CTL expressions may be demonstrated with
  the help of tree induction; here we show that \<open>\<^bold>A\<^bold>X\<close> and \<open>\<^bold>A\<^bold>G\<close> commute.
\<close>

theorem AG_AX_commute: "\<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  have "\<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G \<^bold>A\<^bold>X p" by (rule AG_fp)
  also have "\<dots> = \<^bold>A\<^bold>X (p \<inter> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p)" by (simp only: AX_int)
  also have "p \<inter> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>G p"  (is "?lhs = _")
  proof
    have "\<^bold>A\<^bold>X p \<subseteq> p \<rightarrow> \<^bold>A\<^bold>X p" ..
    also have "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) = \<^bold>A\<^bold>G p" by (rule AG_induct)
    also note Int_mono AG_mono
    ultimately show "?lhs \<subseteq> \<^bold>A\<^bold>G p" by fast
  next
    have "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
    moreover
    {
      have "\<^bold>A\<^bold>G p = \<^bold>A\<^bold>G \<^bold>A\<^bold>G p" by (simp only: AG_AG)
      also have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p" by (rule AG_AX)
      also note AG_mono
      ultimately have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p" .
    }
    ultimately show "\<^bold>A\<^bold>G p \<subseteq> ?lhs" ..
  qed
  finally show ?thesis .
qed

end


(*  Title:      HOL/Boolean_Algebras.thy
    Author:     Brian Huffman
    Author:     Florian Haftmann
*)

section \<open>Boolean Algebras\<close>

theory Boolean_Algebras
  imports Lattices
begin

subsection \<open>Abstract boolean algebra\<close>

locale abstract_boolean_algebra = conj: abel_semigroup \<open>(\<^bold>\<sqinter>)\<close> + disj: abel_semigroup \<open>(\<^bold>\<squnion>)\<close>
  for conj :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<sqinter>\<close> 70)
    and disj :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<squnion>\<close> 65) +
  fixes compl :: \<open>'a \<Rightarrow> 'a\<close>  (\<open>\<^bold>- _\<close> [81] 80)
    and zero :: \<open>'a\<close>  (\<open>\<^bold>0\<close>)
    and one  :: \<open>'a\<close>  (\<open>\<^bold>1\<close>)
  assumes conj_disj_distrib: \<open>x \<^bold>\<sqinter> (y \<^bold>\<squnion> z) = (x \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z)\<close>
    and disj_conj_distrib: \<open>x \<^bold>\<squnion> (y \<^bold>\<sqinter> z) = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (x \<^bold>\<squnion> z)\<close>
    and conj_one_right: \<open>x \<^bold>\<sqinter> \<^bold>1 = x\<close>
    and disj_zero_right: \<open>x \<^bold>\<squnion> \<^bold>0 = x\<close>
    and conj_cancel_right [simp]: \<open>x \<^bold>\<sqinter> \<^bold>- x = \<^bold>0\<close>
    and disj_cancel_right [simp]: \<open>x \<^bold>\<squnion> \<^bold>- x = \<^bold>1\<close>
begin

sublocale conj: semilattice_neutr \<open>(\<^bold>\<sqinter>)\<close> \<open>\<^bold>1\<close>
proof
  show "x \<^bold>\<sqinter> \<^bold>1 = x" for x
    by (fact conj_one_right)
  show "x \<^bold>\<sqinter> x = x" for x
  proof -
    have "x \<^bold>\<sqinter> x = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> \<^bold>0"
      by (simp add: disj_zero_right)
    also have "\<dots> = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- x)"
      by simp
    also have "\<dots> = x \<^bold>\<sqinter> (x \<^bold>\<squnion> \<^bold>- x)"
      by (simp only: conj_disj_distrib)
    also have "\<dots> = x \<^bold>\<sqinter> \<^bold>1"
      by simp
    also have "\<dots> = x"
      by (simp add: conj_one_right)
    finally show ?thesis .
  qed
qed

sublocale disj: semilattice_neutr \<open>(\<^bold>\<squnion>)\<close> \<open>\<^bold>0\<close>
proof
  show "x \<^bold>\<squnion> \<^bold>0 = x" for x
    by (fact disj_zero_right)
  show "x \<^bold>\<squnion> x = x" for x
  proof -
    have "x \<^bold>\<squnion> x = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> \<^bold>1"
      by simp
    also have "\<dots> = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> (x \<^bold>\<squnion> \<^bold>- x)"
      by simp
    also have "\<dots> = x \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- x)"
      by (simp only: disj_conj_distrib)
    also have "\<dots> = x \<^bold>\<squnion> \<^bold>0"
      by simp
    also have "\<dots> = x"
      by (simp add: disj_zero_right)
    finally show ?thesis .
  qed
qed

subsubsection \<open>Complement\<close>

lemma complement_unique:
  assumes 1: "a \<^bold>\<sqinter> x = \<^bold>0"
  assumes 2: "a \<^bold>\<squnion> x = \<^bold>1"
  assumes 3: "a \<^bold>\<sqinter> y = \<^bold>0"
  assumes 4: "a \<^bold>\<squnion> y = \<^bold>1"
  shows "x = y"
proof -
  from 1 3 have "(a \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (a \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> y)"
    by simp
  then have "(x \<^bold>\<sqinter> a) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (y \<^bold>\<sqinter> a) \<^bold>\<squnion> (y \<^bold>\<sqinter> x)"
    by (simp add: ac_simps)
  then have "x \<^bold>\<sqinter> (a \<^bold>\<squnion> y) = y \<^bold>\<sqinter> (a \<^bold>\<squnion> x)"
    by (simp add: conj_disj_distrib)
  with 2 4 have "x \<^bold>\<sqinter> \<^bold>1 = y \<^bold>\<sqinter> \<^bold>1"
    by simp
  then show "x = y"
    by simp
qed

lemma compl_unique: "x \<^bold>\<sqinter> y = \<^bold>0 \<Longrightarrow> x \<^bold>\<squnion> y = \<^bold>1 \<Longrightarrow> \<^bold>- x = y"
  by (rule complement_unique [OF conj_cancel_right disj_cancel_right])

lemma double_compl [simp]: "\<^bold>- (\<^bold>- x) = x"
proof (rule compl_unique)
  show "\<^bold>- x \<^bold>\<sqinter> x = \<^bold>0"
    by (simp only: conj_cancel_right conj.commute)
  show "\<^bold>- x \<^bold>\<squnion> x = \<^bold>1"
    by (simp only: disj_cancel_right disj.commute)
qed

lemma compl_eq_compl_iff [simp]:
  \<open>\<^bold>- x = \<^bold>- y \<longleftrightarrow> x = y\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume \<open>?Q\<close>
  then show ?P by simp
next
  assume \<open>?P\<close>
  then have \<open>\<^bold>- (\<^bold>- x) = \<^bold>- (\<^bold>- y)\<close>
    by simp
  then show ?Q
    by simp
qed

subsubsection \<open>Conjunction\<close>

lemma conj_zero_right [simp]: "x \<^bold>\<sqinter> \<^bold>0 = \<^bold>0"
  using conj.left_idem conj_cancel_right by fastforce

lemma compl_one [simp]: "\<^bold>- \<^bold>1 = \<^bold>0"
  by (rule compl_unique [OF conj_zero_right disj_zero_right])

lemma conj_zero_left [simp]: "\<^bold>0 \<^bold>\<sqinter> x = \<^bold>0"
  by (subst conj.commute) (rule conj_zero_right)

lemma conj_cancel_left [simp]: "\<^bold>- x \<^bold>\<sqinter> x = \<^bold>0"
  by (subst conj.commute) (rule conj_cancel_right)

lemma conj_disj_distrib2: "(y \<^bold>\<squnion> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x)"
  by (simp only: conj.commute conj_disj_distrib)

lemmas conj_disj_distribs = conj_disj_distrib conj_disj_distrib2

subsubsection \<open>Disjunction\<close>

context
begin

interpretation dual: abstract_boolean_algebra \<open>(\<^bold>\<squnion>)\<close> \<open>(\<^bold>\<sqinter>)\<close> compl \<open>\<^bold>1\<close> \<open>\<^bold>0\<close>
  apply standard
       apply (rule disj_conj_distrib)
      apply (rule conj_disj_distrib)
     apply simp_all
  done

lemma disj_one_right [simp]: "x \<^bold>\<squnion> \<^bold>1 = \<^bold>1"
  by (fact dual.conj_zero_right)

lemma compl_zero [simp]: "\<^bold>- \<^bold>0 = \<^bold>1"
  by (fact dual.compl_one)

lemma disj_one_left [simp]: "\<^bold>1 \<^bold>\<squnion> x = \<^bold>1"
  by (fact dual.conj_zero_left)

lemma disj_cancel_left [simp]: "\<^bold>- x \<^bold>\<squnion> x = \<^bold>1"
  by (fact dual.conj_cancel_left)

lemma disj_conj_distrib2: "(y \<^bold>\<sqinter> z) \<^bold>\<squnion> x = (y \<^bold>\<squnion> x) \<^bold>\<sqinter> (z \<^bold>\<squnion> x)"
  by (fact dual.conj_disj_distrib2)

lemmas disj_conj_distribs = disj_conj_distrib disj_conj_distrib2

end

subsubsection \<open>De Morgan's Laws\<close>

lemma de_Morgan_conj [simp]: "\<^bold>- (x \<^bold>\<sqinter> y) = \<^bold>- x \<^bold>\<squnion> \<^bold>- y"
proof (rule compl_unique)
  have "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<^bold>- y)"
    by (rule conj_disj_distrib)
  also have "\<dots> = (y \<^bold>\<sqinter> (x \<^bold>\<sqinter> \<^bold>- x)) \<^bold>\<squnion> (x \<^bold>\<sqinter> (y \<^bold>\<sqinter> \<^bold>- y))"
    by (simp only: ac_simps)
  finally show "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = \<^bold>0"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_right)
next
  have "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = (x \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)) \<^bold>\<sqinter> (y \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y))"
    by (rule disj_conj_distrib2)
  also have "\<dots> = (\<^bold>- y \<^bold>\<squnion> (x \<^bold>\<squnion> \<^bold>- x)) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> (y \<^bold>\<squnion> \<^bold>- y))"
    by (simp only: ac_simps)
  finally show "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = \<^bold>1"
    by (simp only: disj_cancel_right disj_one_right conj_one_right)
qed

context
begin

interpretation dual: abstract_boolean_algebra \<open>(\<^bold>\<squnion>)\<close> \<open>(\<^bold>\<sqinter>)\<close> compl \<open>\<^bold>1\<close> \<open>\<^bold>0\<close>
  apply standard
       apply (rule disj_conj_distrib)
      apply (rule conj_disj_distrib)
     apply simp_all
  done

lemma de_Morgan_disj [simp]: "\<^bold>- (x \<^bold>\<squnion> y) = \<^bold>- x \<^bold>\<sqinter> \<^bold>- y"
  by (fact dual.de_Morgan_conj)

end

end

subsection \<open>Symmetric Difference\<close>

locale abstract_boolean_algebra_sym_diff = abstract_boolean_algebra +
  fixes xor :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<ominus>\<close> 65)
  assumes xor_def : \<open>x \<^bold>\<ominus> y = (x \<^bold>\<sqinter> \<^bold>- y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> y)\<close>
begin

sublocale xor: comm_monoid xor \<open>\<^bold>0\<close>
proof
  fix x y z :: 'a
  let ?t = "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z)"
  have "?t \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (z \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- y) = ?t \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z \<^bold>\<sqinter> \<^bold>- z)"
    by (simp only: conj_cancel_right conj_zero_right)
  then show "(x \<^bold>\<ominus> y) \<^bold>\<ominus> z = x \<^bold>\<ominus> (y \<^bold>\<ominus> z)"
    by (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
      (simp only: conj_disj_distribs conj_ac ac_simps)
  show "x \<^bold>\<ominus> y = y \<^bold>\<ominus> x"
    by (simp only: xor_def ac_simps)
  show "x \<^bold>\<ominus> \<^bold>0 = x"
    by (simp add: xor_def)
qed

lemma xor_def2:
  \<open>x \<^bold>\<ominus> y = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)\<close>
proof -
  note xor_def [of x y]
  also have \<open>x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<squnion> \<^bold>- x \<^bold>\<sqinter> y = ((x \<^bold>\<squnion> \<^bold>- x) \<^bold>\<sqinter> (\<^bold>- y \<^bold>\<squnion> \<^bold>- x)) \<^bold>\<sqinter> (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- y \<^bold>\<squnion> y)\<close>
    by (simp add: ac_simps disj_conj_distribs)
  also have \<open>\<dots> = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)\<close>
    by (simp add: ac_simps)
  finally show ?thesis .
qed

lemma xor_one_right [simp]: "x \<^bold>\<ominus> \<^bold>1 = \<^bold>- x"
  by (simp only: xor_def compl_one conj_zero_right conj_one_right disj.left_neutral)

lemma xor_one_left [simp]: "\<^bold>1 \<^bold>\<ominus> x = \<^bold>- x"
  using xor_one_right [of x] by (simp add: ac_simps)

lemma xor_self [simp]: "x \<^bold>\<ominus> x = \<^bold>0"
  by (simp only: xor_def conj_cancel_right conj_cancel_left disj_zero_right)

lemma xor_left_self [simp]: "x \<^bold>\<ominus> (x \<^bold>\<ominus> y) = y"
  by (simp only: xor.assoc [symmetric] xor_self xor.left_neutral)

lemma xor_compl_left [simp]: "\<^bold>- x \<^bold>\<ominus> y = \<^bold>- (x \<^bold>\<ominus> y)"
  by (simp add: ac_simps flip: xor_one_left)

lemma xor_compl_right [simp]: "x \<^bold>\<ominus> \<^bold>- y = \<^bold>- (x \<^bold>\<ominus> y)"
  using xor.commute xor_compl_left by auto

lemma xor_cancel_right [simp]: "x \<^bold>\<ominus> \<^bold>- x = \<^bold>1"
  by (simp only: xor_compl_right xor_self compl_zero)

lemma xor_cancel_left [simp]: "\<^bold>- x \<^bold>\<ominus> x = \<^bold>1"
  by (simp only: xor_compl_left xor_self compl_zero)

lemma conj_xor_distrib: "x \<^bold>\<sqinter> (y \<^bold>\<ominus> z) = (x \<^bold>\<sqinter> y) \<^bold>\<ominus> (x \<^bold>\<sqinter> z)"
proof -
  have *: "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z) =
        (y \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z)"
    by (simp only: conj_cancel_right conj_zero_right disj.left_neutral)
  then show "x \<^bold>\<sqinter> (y \<^bold>\<ominus> z) = (x \<^bold>\<sqinter> y) \<^bold>\<ominus> (x \<^bold>\<sqinter> z)"
    by (simp (no_asm_use) only:
        xor_def de_Morgan_disj de_Morgan_conj double_compl
        conj_disj_distribs ac_simps)
qed

lemma conj_xor_distrib2: "(y \<^bold>\<ominus> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<^bold>\<ominus> (z \<^bold>\<sqinter> x)"
  by (simp add: conj.commute conj_xor_distrib)

lemmas conj_xor_distribs = conj_xor_distrib conj_xor_distrib2

end

subsection \<open>Type classes\<close>

class boolean_algebra = distrib_lattice + bounded_lattice + minus + uminus +
  assumes inf_compl_bot: \<open>x \<sqinter> - x = \<bottom>\<close>
    and sup_compl_top: \<open>x \<squnion> - x = \<top>\<close>
  assumes diff_eq: \<open>x - y = x \<sqinter> - y\<close>
begin

sublocale boolean_algebra: abstract_boolean_algebra \<open>(\<sqinter>)\<close> \<open>(\<squnion>)\<close> uminus \<bottom> \<top>
  apply standard
       apply (rule inf_sup_distrib1)
      apply (rule sup_inf_distrib1)
     apply (simp_all add: ac_simps inf_compl_bot sup_compl_top)
  done

lemma compl_inf_bot: "- x \<sqinter> x = \<bottom>"
  by (fact boolean_algebra.conj_cancel_left)

lemma compl_sup_top: "- x \<squnion> x = \<top>"
  by (fact boolean_algebra.disj_cancel_left)

lemma compl_unique:
  assumes "x \<sqinter> y = \<bottom>"
    and "x \<squnion> y = \<top>"
  shows "- x = y"
  using assms by (rule boolean_algebra.compl_unique)

lemma double_compl: "- (- x) = x"
  by (fact boolean_algebra.double_compl)

lemma compl_eq_compl_iff: "- x = - y \<longleftrightarrow> x = y"
  by (fact boolean_algebra.compl_eq_compl_iff)

lemma compl_bot_eq: "- \<bottom> = \<top>"
  by (fact boolean_algebra.compl_zero)

lemma compl_top_eq: "- \<top> = \<bottom>"
  by (fact boolean_algebra.compl_one)

lemma compl_inf: "- (x \<sqinter> y) = - x \<squnion> - y"
  by (fact boolean_algebra.de_Morgan_conj)

lemma compl_sup: "- (x \<squnion> y) = - x \<sqinter> - y"
  by (fact boolean_algebra.de_Morgan_disj)

lemma compl_mono:
  assumes "x \<le> y"
  shows "- y \<le> - x"
proof -
  from assms have "x \<squnion> y = y" by (simp only: le_iff_sup)
  then have "- (x \<squnion> y) = - y" by simp
  then have "- x \<sqinter> - y = - y" by simp
  then have "- y \<sqinter> - x = - y" by (simp only: inf_commute)
  then show ?thesis by (simp only: le_iff_inf)
qed

lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x"
  by (auto dest: compl_mono)

lemma compl_le_swap2:
  assumes "- y \<le> x"
  shows "- x \<le> y"
proof -
  from assms have "- x \<le> - (- y)" by (simp only: compl_le_compl_iff)
  then show ?thesis by simp
qed

lemma compl_less_compl_iff [simp]: "- x < - y \<longleftrightarrow> y < x"
  by (auto simp add: less_le)

lemma compl_less_swap1:
  assumes "y < - x"
  shows "x < - y"
proof -
  from assms have "- (- x) < - y" by (simp only: compl_less_compl_iff)
  then show ?thesis by simp
qed

lemma compl_less_swap2:
  assumes "- y < x"
  shows "- x < y"
proof -
  from assms have "- x < - (- y)"
    by (simp only: compl_less_compl_iff)
  then show ?thesis by simp
qed

lemma sup_cancel_left1: \<open>x \<squnion> a \<squnion> (- x \<squnion> b) = \<top>\<close>
  by (simp add: ac_simps)

lemma sup_cancel_left2: \<open>- x \<squnion> a \<squnion> (x \<squnion> b) = \<top>\<close>
  by (simp add: ac_simps)

lemma inf_cancel_left1: \<open>x \<sqinter> a \<sqinter> (- x \<sqinter> b) = \<bottom>\<close>
  by (simp add: ac_simps)

lemma inf_cancel_left2: \<open>- x \<sqinter> a \<sqinter> (x \<sqinter> b) = \<bottom>\<close>
  by (simp add: ac_simps)

lemma sup_compl_top_left1 [simp]: \<open>- x \<squnion> (x \<squnion> y) = \<top>\<close>
  by (simp add: sup_assoc [symmetric])

lemma sup_compl_top_left2 [simp]: \<open>x \<squnion> (- x \<squnion> y) = \<top>\<close>
  using sup_compl_top_left1 [of "- x" y] by simp

lemma inf_compl_bot_left1 [simp]: \<open>- x \<sqinter> (x \<sqinter> y) = \<bottom>\<close>
  by (simp add: inf_assoc [symmetric])

lemma inf_compl_bot_left2 [simp]: \<open>x \<sqinter> (- x \<sqinter> y) = \<bottom>\<close>
  using inf_compl_bot_left1 [of "- x" y] by simp

lemma inf_compl_bot_right [simp]: \<open>x \<sqinter> (y \<sqinter> - x) = \<bottom>\<close>
  by (subst inf_left_commute) simp

end

subsection \<open>Lattice on \<^typ>\<open>bool\<close>\<close>

instantiation bool :: boolean_algebra
begin

definition bool_Compl_def [simp]: "uminus = Not"

definition bool_diff_def [simp]: "A - B \<longleftrightarrow> A \<and> \<not> B"

definition [simp]: "P \<sqinter> Q \<longleftrightarrow> P \<and> Q"

definition [simp]: "P \<squnion> Q \<longleftrightarrow> P \<or> Q"

instance by standard auto

end

lemma sup_boolI1: "P \<Longrightarrow> P \<squnion> Q"
  by simp

lemma sup_boolI2: "Q \<Longrightarrow> P \<squnion> Q"
  by simp

lemma sup_boolE: "P \<squnion> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
  by auto

instance "fun" :: (type, boolean_algebra) boolean_algebra
  by standard (rule ext, simp_all add: inf_compl_bot sup_compl_top diff_eq)+

subsection \<open>Lattice on unary and binary predicates\<close>

lemma inf1I: "A x \<Longrightarrow> B x \<Longrightarrow> (A \<sqinter> B) x"
  by (simp add: inf_fun_def)

lemma inf2I: "A x y \<Longrightarrow> B x y \<Longrightarrow> (A \<sqinter> B) x y"
  by (simp add: inf_fun_def)

lemma inf1E: "(A \<sqinter> B) x \<Longrightarrow> (A x \<Longrightarrow> B x \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp add: inf_fun_def)

lemma inf2E: "(A \<sqinter> B) x y \<Longrightarrow> (A x y \<Longrightarrow> B x y \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp add: inf_fun_def)

lemma inf1D1: "(A \<sqinter> B) x \<Longrightarrow> A x"
  by (rule inf1E)

lemma inf2D1: "(A \<sqinter> B) x y \<Longrightarrow> A x y"
  by (rule inf2E)

lemma inf1D2: "(A \<sqinter> B) x \<Longrightarrow> B x"
  by (rule inf1E)

lemma inf2D2: "(A \<sqinter> B) x y \<Longrightarrow> B x y"
  by (rule inf2E)

lemma sup1I1: "A x \<Longrightarrow> (A \<squnion> B) x"
  by (simp add: sup_fun_def)

lemma sup2I1: "A x y \<Longrightarrow> (A \<squnion> B) x y"
  by (simp add: sup_fun_def)

lemma sup1I2: "B x \<Longrightarrow> (A \<squnion> B) x"
  by (simp add: sup_fun_def)

lemma sup2I2: "B x y \<Longrightarrow> (A \<squnion> B) x y"
  by (simp add: sup_fun_def)

lemma sup1E: "(A \<squnion> B) x \<Longrightarrow> (A x \<Longrightarrow> P) \<Longrightarrow> (B x \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp add: sup_fun_def) iprover

lemma sup2E: "(A \<squnion> B) x y \<Longrightarrow> (A x y \<Longrightarrow> P) \<Longrightarrow> (B x y \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp add: sup_fun_def) iprover

text \<open> \<^medskip> Classical introduction rule: no commitment to \<open>A\<close> vs \<open>B\<close>.\<close>

lemma sup1CI: "(\<not> B x \<Longrightarrow> A x) \<Longrightarrow> (A \<squnion> B) x"
  by (auto simp add: sup_fun_def)

lemma sup2CI: "(\<not> B x y \<Longrightarrow> A x y) \<Longrightarrow> (A \<squnion> B) x y"
  by (auto simp add: sup_fun_def)

subsection \<open>Simproc setup\<close>

locale boolean_algebra_cancel
begin

lemma sup1: "(A::'a::semilattice_sup) \<equiv> sup k a \<Longrightarrow> sup A b \<equiv> sup k (sup a b)"
  by (simp only: ac_simps)

lemma sup2: "(B::'a::semilattice_sup) \<equiv> sup k b \<Longrightarrow> sup a B \<equiv> sup k (sup a b)"
  by (simp only: ac_simps)

lemma sup0: "(a::'a::bounded_semilattice_sup_bot) \<equiv> sup a bot"
  by simp

lemma inf1: "(A::'a::semilattice_inf) \<equiv> inf k a \<Longrightarrow> inf A b \<equiv> inf k (inf a b)"
  by (simp only: ac_simps)

lemma inf2: "(B::'a::semilattice_inf) \<equiv> inf k b \<Longrightarrow> inf a B \<equiv> inf k (inf a b)"
  by (simp only: ac_simps)

lemma inf0: "(a::'a::bounded_semilattice_inf_top) \<equiv> inf a top"
  by simp

end

ML_file \<open>Tools/boolean_algebra_cancel.ML\<close>

simproc_setup boolean_algebra_cancel_sup ("sup a b::'a::boolean_algebra") =
  \<open>fn phi => fn ss => try Boolean_Algebra_Cancel.cancel_sup_conv\<close>

simproc_setup boolean_algebra_cancel_inf ("inf a b::'a::boolean_algebra") =
  \<open>fn phi => fn ss => try Boolean_Algebra_Cancel.cancel_inf_conv\<close>

context boolean_algebra
begin

lemma shunt1: "(x \<sqinter> y \<le> z) \<longleftrightarrow> (x \<le> -y \<squnion> z)"
proof
  assume "x \<sqinter> y \<le> z"
  hence  "-y \<squnion> (x \<sqinter> y) \<le> -y \<squnion> z"
    using sup.mono by blast
  hence "-y \<squnion> x \<le> -y \<squnion> z"
    by (simp add: sup_inf_distrib1)
  thus "x \<le> -y \<squnion> z"
    by simp
next
  assume "x \<le> -y \<squnion> z"
  hence "x \<sqinter> y \<le> (-y \<squnion> z) \<sqinter> y"
    using inf_mono by auto
  thus  "x \<sqinter> y \<le> z"
    using inf.boundedE inf_sup_distrib2 by auto
qed

lemma shunt2: "(x \<sqinter> -y \<le> z) \<longleftrightarrow> (x \<le> y \<squnion> z)"
  by (simp add: shunt1)

lemma inf_shunt: "(x \<sqinter> y = \<bottom>) \<longleftrightarrow> (x \<le> - y)"
  by (simp add: order.eq_iff shunt1)

lemma sup_shunt: "(x \<squnion> y = \<top>) \<longleftrightarrow> (- x \<le> y)"
  using inf_shunt [of \<open>- x\<close> \<open>- y\<close>, symmetric]
  by (simp flip: compl_sup compl_top_eq)

lemma diff_shunt_var: "(x - y = \<bottom>) \<longleftrightarrow> (x \<le> y)"
  by (simp add: diff_eq inf_shunt)

lemma sup_neg_inf:
  \<open>p \<le> q \<squnion> r \<longleftrightarrow> p \<sqinter> -q \<le> r\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?P
  then have \<open>p \<sqinter> - q \<le> (q \<squnion> r) \<sqinter> - q\<close>
    by (rule inf_mono) simp
  then show ?Q
    by (simp add: inf_sup_distrib2)
next
  assume ?Q
  then have \<open>p \<sqinter> - q \<squnion> q \<le> r \<squnion> q\<close>
    by (rule sup_mono) simp
  then show ?P
    by (simp add: sup_inf_distrib ac_simps)
qed

end

end


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

section "Mathematical Preliminaries"

text \<open>
  We begin by proving some general-purpose lemmas that underly our
  developments, but that could also be useful in other contexts.

  The first subsection establishes various random results about
  existing theories of Isabelle/HOL. The second subsection
  introduces general concepts of $\omega$-words (i.e., infinite
  sequences), and $\omega$-dags are formalized in the third subsection.
\<close>

subsection \<open> General-purpose lemmas \<close>

text \<open>
  The standard library contains theorem @{text less_iff_Suc_add}

  @{thm less_iff_Suc_add [no_vars]}

  that can be used to reduce ``less than'' to addition and successor.
  The following lemma is the analogous result for ``less or equal''.
\<close>

lemma le_iff_add:
  "(m::nat) \<le> n = (\<exists> k. n = m+k)"
proof
  assume le: "m \<le> n"
  thus "\<exists> k. n = m+k"
  proof (auto simp add: order_le_less)
    assume "m<n"
    then obtain k where "n = Suc(m+k)"
      by (auto simp add: less_iff_Suc_add)
    thus ?thesis by auto
  qed
next
  assume "\<exists> k. n = m+k"
  thus "m \<le> n" by auto
qed

lemma exists_leI:
  assumes hyp: "(\<forall>n' < n. \<not> P n') \<Longrightarrow> P (n::nat)"
  shows "\<exists>n' \<le> n. P n'"
proof (rule classical)
  assume contra: "\<not> (\<exists>n'\<le>n. P n')"
  hence "\<forall>n' < n. \<not> P n'" by auto
  hence "P n" by (rule hyp)
  thus "\<exists>n'\<le>n. P n'" by auto
qed

text \<open>
  An ``induction'' law for modulus arithmetic: if $P$ holds for some
  $i<p$ and if $P(i)$ implies $P((i+1) \bmod p)$, for all $i<p$, then
  $P(i)$ holds for all $i<p$.
\<close>

lemma mod_induct_0:
  assumes step: "\<forall>i<p. P i \<longrightarrow> P ((Suc i) mod p)"
  and base: "P i" and i: "i<p"
  shows "P 0"
proof (rule ccontr)
  assume contra: "\<not>(P 0)"
  from i have p: "0<p" by simp
  have "\<forall>k. 0<k \<longrightarrow> \<not> P (p-k)" (is "\<forall>k. ?A k")
  proof
    fix k
    show "?A k"
    proof (induct k)
      show "?A 0" by simp  \<comment>\<open>by contradiction\<close>
    next
      fix n
      assume ih: "?A n"
      show "?A (Suc n)"
      proof (clarsimp)
	assume y: "P (p - Suc n)"
	have n: "Suc n < p"
	proof (rule ccontr)
	  assume "\<not>(Suc n < p)"
	  hence "p - Suc n = 0"
	    by simp
	  with y contra show "False"
	    by simp
	qed
	hence n2: "Suc (p - Suc n) = p-n" by arith
	from p have "p - Suc n < p" by arith
	with y step have z: "P ((Suc (p - Suc n)) mod p)"
	  by blast
	show "False"
	proof (cases "n=0")
	  case True
	  with z n2 contra show ?thesis by simp
	next
	  case False
	  with p have "p-n < p" by arith
	  with z n2 False ih show ?thesis by simp
	qed
      qed
    qed
  qed
  moreover
  from i obtain k where "0<k \<and> i+k=p"
    by (blast dest: less_imp_add_positive)
  hence "0<k \<and> i=p-k" by auto
  moreover
  note base
  ultimately
  show "False" by blast
qed

lemma mod_induct:
  assumes step: "\<forall>i<p. P i \<longrightarrow> P ((Suc i) mod p)"
  and base: "P i" and i: "i<p" and j: "j<p"
  shows "P j"
proof -
  have "\<forall>j<p. P j"
  proof
    fix j
    show "j<p \<longrightarrow> P j" (is "?A j")
    proof (induct j)
      from step base i show "?A 0"
	by (auto elim: mod_induct_0)
    next
      fix k
      assume ih: "?A k"
      show "?A (Suc k)"
      proof
	assume suc: "Suc k < p"
	hence k: "k<p" by simp
	with ih have "P k" ..
	with step k have "P (Suc k mod p)"
	  by blast
	moreover
	from suc have "Suc k mod p = Suc k"
	  by simp
	ultimately
	show "P (Suc k)" by simp
      qed
    qed
  qed
  with j show ?thesis by blast
qed

text \<open>
  Pairs and functions whose codomains are pairs.
\<close>

lemma img_fst [intro]:
  assumes "(a,b) \<in> S"
  shows "a \<in> fst ` S"
by (rule image_eqI[OF _ assms]) simp

lemma img_snd [intro]:
  assumes "(a,b) \<in> S"
  shows "b \<in> snd ` S"
by (rule image_eqI[OF _ assms]) simp

lemma range_prod:
  "range f \<subseteq> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
proof
  fix y
  assume "y \<in> range f"
  then obtain x where y: "y = f x" by auto
  hence "y = (fst(f x), snd(f x))"
    by simp
  thus "y \<in> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
    by (fastforce simp add: image_def)
qed

lemma finite_range_prod:
  assumes fst: "finite (range (fst \<circ> f))"
  and     snd: "finite (range (snd \<circ> f))"
  shows "finite (range f)"
proof -
  from fst snd have "finite (range (fst \<circ> f) \<times> range (snd \<circ> f))"
    by (rule finite_SigmaI)
  thus ?thesis
    by (rule finite_subset[OF range_prod])
qed

text \<open>
  Decompose general union over sum types.
\<close>

lemma Union_plus:
  "(\<Union> x \<in> A <+> B. f x) = (\<Union> a \<in> A. f (Inl a)) \<union> (\<Union>b \<in> B. f (Inr b))"
by auto

lemma Union_sum:
  "(\<Union>x. f (x::'a+'b)) = (\<Union>l. f (Inl l)) \<union> (\<Union>r. f (Inr r))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<Union>x \<in> UNIV <+> UNIV. f x)"
    by simp
  thus ?thesis
    by (simp only: Union_plus)
qed

lemma card_Plus:
  assumes fina: "finite (A::'a set)" and finb: "finite (B::'b set)"
  shows "card (A <+> B) = (card A) + (card B)"
proof -
  from fina finb
  have "card ((Inl ` A) \<union> (Inr ` B)) =
        (card ((Inl ` A)::('a+'b)set)) + (card ((Inr ` B)::('a+'b)set))"
    by (auto intro: card_Un_disjoint finite_imageI)
  thus ?thesis
    by (simp add: Plus_def card_image inj_on_def)
qed

text \<open>
  The standard library proves that a generalized union is finite
  if the index set is finite and if for every index the component
  set is itself finite. Conversely, we show that every component
  set must be finite when the union is finite.
\<close>
(*
lemma finite_UNION_then_finite:
  assumes hyp: "finite (UNION A B)" and a: "a \<in> A"
  shows "finite (B a)"
proof (rule ccontr)
  assume cc: "infinite (B a)"
  from a have "B a \<subseteq> UNION A B" by auto
  from this cc have "infinite (UNION A B)" by (rule infinite_super)
  from this hyp show "False" ..
qed
*)

lemma finite_UNION_then_finite:
  "finite (\<Union>(B ` A)) \<Longrightarrow> a \<in> A \<Longrightarrow> finite (B a)"
by (metis Set.set_insert UN_insert Un_infinite)

end


theory Game_Theory
  imports "HOL-Probability.Probability_Mass_Function"
begin

section "Defining a Simultaneous Move Game"

locale strategic_game =
  fixes pure_strategies :: "'player :: finite  \<Rightarrow> 'strategy set"
    and payoffs :: "'strategy^'player \<Rightarrow> ('payoff :: linorder)^'player"
assumes players_can_play: "pure_strategies i \<noteq> {}"
begin

corollary players_have_a_move: "\<exists>s. s\<in>pure_strategies i"
  using players_can_play by auto

text "Strategy selection"
definition pure_profile :: "('strategy^'player) \<Rightarrow> bool"
  where "pure_profile s = (\<forall>i. s$i \<in> pure_strategies i)"

definition payoff :: "'strategy^'player \<Rightarrow> 'player \<Rightarrow> 'payoff"
  where "payoff s i = (payoffs s)$i"

text "We prove the existence of legal plays, represented as vectors of legal strategies.
In particular, legal plays exist that include any particular choice of strategy for any player."

lemma pure_profile_fix_exists:
  fixes s\<^sub>i :: "'strategy"
    and i :: 'player
  assumes fixed_strategy:  "s\<^sub>i \<in> pure_strategies i"
  shows "\<exists>s. pure_profile s \<and> s$i = s\<^sub>i"
proof -
  let ?s = "(\<chi> j. if j = i then s\<^sub>i else (SOME s\<^sub>j. s\<^sub>j \<in> pure_strategies j))"
  have "\<forall>j. ?s$j \<in> pure_strategies j"
    by (simp add: fixed_strategy players_can_play some_in_eq)
  hence "pure_profile ?s"
    by (simp add: pure_profile_def)

  moreover have "?s$i = s\<^sub>i"
    by simp

  ultimately show ?thesis
    by auto
qed

lemma pure_profile_exists: "\<exists>s. pure_profile s"
  using pure_profile_fix_exists players_have_a_move by blast

text "If n denotes the number of players, we represent the (n-1)-dimensional vector of strategies
chosen by players other than player i as a function from strategies (which player i may choose) to
(n-dimensional) strategy vectors."

definition pure_profile_completion :: "'strategy \<Rightarrow> 'strategy^'player \<Rightarrow> 'player \<Rightarrow> 'strategy^'player"
  where "pure_profile_completion s\<^sub>i s i = (\<chi> j. if j = i then s\<^sub>i else s$j)"

notation pure_profile_completion ("(_,_\<^sub>-\<^sub>_)" [80, 80] 80)

lemma player_chooses_completion: "(s\<^sub>i,s\<^sub>-\<^sub>i)$i = s\<^sub>i"
  by (simp add: pure_profile_completion_def)

lemma pure_completion_fixes_other_players:
  fixes i :: 'player
    and j :: 'player
  assumes "i \<noteq> j"
  shows "(s\<^sub>i,s\<^sub>-\<^sub>i)$j = s$j"
  using assms pure_profile_completion_def by auto

lemma pure_completion_legal_iff:
  fixes i :: 'player
    and s :: "'strategy^'player"
  shows "(pure_profile (s\<^sub>i,s\<^sub>-\<^sub>i)) = ((s\<^sub>i \<in> pure_strategies i) \<and>
        (\<forall>j. ((j \<noteq> i) \<longrightarrow> s$j \<in> pure_strategies j)))"
proof -
  have "(pure_profile (s\<^sub>i,s\<^sub>-\<^sub>i)) = (\<forall>j. (s\<^sub>i,s\<^sub>-\<^sub>i)$j \<in> pure_strategies j)"
    by (simp add: pure_profile_def)
  hence "(pure_profile (s\<^sub>i,s\<^sub>-\<^sub>i)) = (((s\<^sub>i,s\<^sub>-\<^sub>i)$i \<in> pure_strategies i) \<and>
         (\<forall>j. ((j \<noteq> i) \<longrightarrow> (s\<^sub>i,s\<^sub>-\<^sub>i)$j \<in> pure_strategies j)))"
    by auto
  thus ?thesis
    by (simp add: player_chooses_completion pure_completion_fixes_other_players)
qed

lemma pure_completion_of_legal_play:
    fixes s :: "'strategy^'player"
  assumes legal_play: "pure_profile s"
    shows "pure_profile (s\<^sub>i,s\<^sub>-\<^sub>i) = (s\<^sub>i \<in> pure_strategies i)"
  using pure_completion_legal_iff legal_play pure_profile_def by auto

lemma reconstruct_pure_profile [simp]:
  fixes s :: "'strategy^'player"
    and i :: 'player
  shows "(s$i,s\<^sub>-\<^sub>i) = s"
proof -
  have "\<forall>j. (s$i,s\<^sub>-\<^sub>i)$j = s$j"
    using pure_completion_fixes_other_players player_chooses_completion by metis
  thus ?thesis
    by (simp add: vec_eq_iff)
qed

subsection "Basic solution concepts"

(* Note that ((s')$i,s'\<^sub>-\<^sub>i) is just s', which simp knows due to reconstruct_pure_profile. *)
definition dominant_strategy_solution :: "'strategy^'player \<Rightarrow> bool"
  where "dominant_strategy_solution s = ((pure_profile s) \<and>
        (\<forall>i. \<forall>s'. (pure_profile s' \<longrightarrow> payoff (s$i,s'\<^sub>-\<^sub>i) i \<ge> payoff (s'$i,s'\<^sub>-\<^sub>i) i)))"

definition pure_nash_equilibrium :: "'strategy^'player \<Rightarrow> bool"
  where "pure_nash_equilibrium s = ((pure_profile s) \<and>
        (\<forall>i. \<forall>s'\<^sub>i \<in> pure_strategies i. payoff (s$i,s\<^sub>-\<^sub>i) i \<ge> payoff (s'\<^sub>i,s\<^sub>-\<^sub>i) i))"

lemma completion_reverses_itself: "(a,(b,s\<^sub>-\<^sub>i)\<^sub>-\<^sub>i) = (a,s\<^sub>-\<^sub>i)"
proof -
  have "\<forall>j. (a,(b,s\<^sub>-\<^sub>i)\<^sub>-\<^sub>i)$j = (a,s\<^sub>-\<^sub>i)$j"
    by (metis player_chooses_completion pure_completion_fixes_other_players)
  thus ?thesis
    by (simp add: vec_eq_iff)
qed

text "Dominant pure strategy solutions are pure Nash equilibria."
lemma dominant_imp_pure_nash:
  fixes s
  assumes dom: "dominant_strategy_solution s"
  shows "pure_nash_equilibrium s"
proof -
  have "pure_profile s"
    using dom dominant_strategy_solution_def by auto

  moreover have "\<forall>i. \<forall>s'. (pure_profile s' \<longrightarrow> payoff (s$i,s'\<^sub>-\<^sub>i) i \<ge> payoff s' i)"
    using dom dominant_strategy_solution_def by auto
  hence "\<forall>i. \<forall>s'\<^sub>i \<in> pure_strategies i. (pure_profile (s'\<^sub>i,s\<^sub>-\<^sub>i) \<longrightarrow>
        payoff (s$i,(s'\<^sub>i,s\<^sub>-\<^sub>i)\<^sub>-\<^sub>i) i \<ge> payoff (s'\<^sub>i,s\<^sub>-\<^sub>i) i)"
    by simp
  hence "\<forall>i. \<forall>s'\<^sub>i \<in> pure_strategies i. (pure_profile (s'\<^sub>i,s\<^sub>-\<^sub>i) \<longrightarrow>
        payoff s i \<ge> payoff (s'\<^sub>i,s\<^sub>-\<^sub>i) i)"
    by (simp add: completion_reverses_itself)
  hence "\<forall>i. \<forall>s'\<^sub>i \<in> pure_strategies i. (pure_profile s \<longrightarrow>
        payoff s i \<ge> payoff (s'\<^sub>i,s\<^sub>-\<^sub>i) i)"
    using pure_completion_of_legal_play by simp

  ultimately show ?thesis
    using pure_nash_equilibrium_def by auto
qed

end

text "Strategic form games with real-valued payoffs."
locale real_out_strategic_game = strategic_game pure_strategies payoffs
  for pure_strategies
  and payoffs :: "('strategy, 'player) vec \<Rightarrow> (real, 'player :: finite) vec"
begin

text "For real-valued payoffs, costs can be defined to be their additive inverse."
definition costs :: "('strategy, 'player) vec \<Rightarrow> (real, 'player) vec"
  where "costs s = -payoffs s"

definition cost :: "('strategy, 'player) vec \<Rightarrow> 'player \<Rightarrow> real"
  where "cost s i = (costs s)$i"

lemma cost_neg_pay:
  shows "cost s i = -payoff s i"
  by (simp add: cost_def costs_def payoff_def)

end

section "Example Games"

subsection "2-player games"
datatype two_player = P1 | P2

instance two_player :: finite
proof
  have "(UNIV :: two_player set) = {P1, P2}"
    by (metis UNIV_eq_I insertCI two_player.exhaust)
  thus "finite (UNIV :: two_player set)"
    using finite.simps by auto
qed

text "The Prisoner's Dilemma"
datatype prisoner_strat = Confess | Silent

interpretation real_out_strategic_game
  "(\<lambda>(i::two_player). {Confess, Silent})"
  "(\<lambda>s. (\<chi> i. if s$i = Confess then
          (if s = (\<chi> j. Confess) then 4 else 1)
        else
          (if s = (\<chi> j. Silent) then 2 else 5) ))"
proof
  show "{Confess, Silent} \<noteq> {}"
    by simp
qed

end


section {* Arrays *}

theory Array
  imports Main
begin

type_synonym 'a array = "(nat \<Rightarrow> 'a) \<times> nat"

definition len_array :: "'a array \<Rightarrow> nat" ("len _" [100] 100) where
  "len a \<equiv> snd a"

definition access_array :: "'a array \<Rightarrow> nat \<Rightarrow> 'a" ("_<_>" [100, 50] 100) where
  "a<i> \<equiv> (fst a) i"

definition is_empty_array :: "'a array \<Rightarrow> bool" where
  "is_empty_array a \<equiv> len a = 0"

definition upd_array :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array" ("_<_ := _>" [100, 50, 50] 100) where
  "a<i := n> \<equiv> ((fst a)(i := n), snd a)"

definition new_array :: "nat \<Rightarrow> 'a \<Rightarrow> 'a array" where
  "new_array l n = (\<lambda>_. n, l)"

definition array_rev :: "'a array \<Rightarrow> 'a array" ("rev _" [100] 100) where
  "rev a \<equiv> (\<lambda>i. if i > 0 \<and> i \<le> len a then a<len a - i + 1> else a<i>, len a)"

lemma len_rev [simp]: "len (rev a) = len a"
  by (auto simp: len_array_def array_rev_def)

lemma rev_rev [simp]: "rev (rev a) = a"
  apply (auto simp: array_rev_def len_array_def access_array_def)
  apply (case_tac a)
  apply auto
  apply (rule ext)
  apply (auto simp: len_array_def access_array_def)
done

definition interval :: "nat \<Rightarrow> nat \<Rightarrow> nat set" ("\<lbrace>_, _\<rbrace>") where
  "\<lbrace>k, l\<rbrace> \<equiv> {i. k \<le> i \<and> i \<le> l}"

(* Sum from offset the number of value n *)
primrec array_sum :: "'a array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  'a :: {plus, zero}" where
  "array_sum a off 0 = 0"
| "array_sum a off (Suc n) = a<off + n> + array_sum a off n"

fun array_sorted_off :: "'a :: order array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "array_sorted_off a off 0 \<longleftrightarrow> True"
| "array_sorted_off a off (Suc 0) \<longleftrightarrow> True"
| "array_sorted_off a off (Suc (Suc n)) \<longleftrightarrow> a<off + n> \<le> a<off + Suc n> \<and> array_sorted_off a off (Suc n)"

lemma array_sorted_off_var: "array_sorted_off a (Suc 0) N \<longleftrightarrow> (\<forall>i j. 0 < i \<and> i \<le> j \<and> j \<le> N \<longrightarrow> a<i> \<le> a <j>)"
  apply (induct N)
  apply clarsimp
  apply (case_tac N)
  apply auto
  using le_Suc_eq apply auto[1]
by (metis dual_order.trans le_SucE le_less)

(* Array is sorted except in one place *)
definition sorted_but :: "('a :: order) array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "sorted_but a N k \<equiv> \<forall>i j. 0 < i \<and> i \<le> j \<and> j \<le> N \<and> i \<noteq> k \<and> k \<noteq> j \<longrightarrow> a<i> \<le> a<j>"

definition array_sorted :: "'a :: order array \<Rightarrow> bool" where
  "array_sorted a \<equiv> array_sorted_off a 1 (len a)"

lemma "array_sorted_off a i n \<Longrightarrow> array_sorted_off a (Suc i) (n - 1)"
  apply (induct n)
  apply auto
  apply (case_tac n)
  apply auto
  apply (case_tac nat)
by auto

definition bij_prop :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "bij_prop f x y \<equiv> bij f \<and> (\<forall>i. i \<notin> \<lbrace>x, y\<rbrace> \<longrightarrow> f i = i)"

lemma bij_prop1: "bij_prop f x y \<Longrightarrow> \<forall>i \<in> \<lbrace>x, y\<rbrace>. f i \<in> \<lbrace>x, y\<rbrace>"
  apply (clarsimp simp: bij_prop_def)
  by (metis bij_pointE)

lemma bij_prop2: "bij_prop f x y \<Longrightarrow> x' \<le> x \<Longrightarrow> y \<le> y' \<Longrightarrow> bij_prop f x' y'"
  by (auto simp: bij_prop_def interval_def)

lemma bij_prop_id [simp, intro]: "bij_prop id x y"
  by (auto simp: bij_prop_def)

definition perm_betw :: "'a array \<Rightarrow> 'a array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "perm_betw a b x y \<equiv> \<exists>f. bij_prop f x y \<and> (\<forall>i. a<i> = b<f i>)"

definition perm :: "'a array \<Rightarrow> 'a array \<Rightarrow> bool" ("_ <~~> _"  [50, 50] 50)  where
  "perm a b \<equiv> len a = len b \<and> perm_betw a b 1 (len a)"

lemma perm_refl [iff]: "l <~~> l"
  by (auto simp: perm_def perm_betw_def)

lemma xperm_empty_imp: "is_empty_array a \<Longrightarrow> a <~~> b \<Longrightarrow> is_empty_array b"
  by (auto simp: is_empty_array_def perm_def)

lemma perm_length: "a <~~> b \<Longrightarrow> len a = len b"
  by (auto simp: perm_def)

lemma perm_comm: "a <~~> b \<Longrightarrow> b <~~> a"
  apply (clarsimp simp: perm_def perm_betw_def)
  apply (rule_tac x="the_inv f" in exI)
  apply (clarsimp simp:  bij_prop_def bij_betw_the_inv_into bij_is_inj bij_is_surj f_the_inv_into_f)
  apply (metis bij_is_inj the_inv_f_f)
done

lemma perm_rev: "rev a <~~> a"
  apply (simp add: perm_def perm_betw_def)
  apply (rule_tac x="\<lambda>i. if i > 0 \<and> i \<le> len a then len a - i + 1 else i" in exI)
  apply (auto simp: array_rev_def access_array_def bij_prop_def interval_def)
  apply (auto simp: bij_def inj_on_def image_def)
  by presburger

end


theory examples
  imports Main
begin
declare [[names_short]]

(* datatype nat = null | Suc nat *)

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

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

lemma add_Suc: "Suc (add m n) = add m (Suc n)"
  apply (induction m)
  apply (auto)
  done

theorem add_comm: "add n m = add m n"
  apply (induction n)
  apply (auto simp add: add_02 add_Suc)
  done

datatype 'a list = Nil | Cons 'a "'a list"

fun conc :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"conc Nil ys = ys" |
"conc (Cons x xs) ys = Cons x (conc xs ys)"

lemma conc_nil: "conc xs Nil = xs"
  apply(induction xs)
  apply (auto)
  done

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = conc (rev xs) (Cons x Nil)"

lemma rev_rev: "rev (rev xs) = xs"
  apply (induction xs)
  oops

end


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

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "Nat => Nat" where
  "nmsorttdhalf1 x =
   (if (x = (S Z)) then Z else
      (case x of
         Z => Z
         | S y => plus (S Z) (nmsorttdhalf1 (minus x (S (S Z))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function nmsorttd :: "Nat list => Nat list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (nmsorttd xs)"
  oops

end


theory PBExp imports AExp begin

subsection "Boolean Expressions"

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

type_synonym bstate = "vname \<Rightarrow> bool"

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

subsection "Exercise 3.9"

lemma not_not_is_id[simp]: "pbval (NOT (NOT exp)) s = pbval exp s"
  apply(induction exp)
  by simp_all

lemma equal_implies_nots_equal:
  assumes "pbval e1 s = pbval e2 s"
  shows "pbval (NOT e1) s = pbval (NOT e2) s"
  by (simp add: assms)

text{* Optimizing constructors: *}

  (* remove extraneous NOTs, i.e. NOT(NOT(x)) = x *)
fun not_simp :: "pbexp \<Rightarrow> pbexp"where
  "not_simp (VAR x) = (VAR x)" |
  (* First recurse on b, then pattern match *)
  "not_simp (NOT b) = (
    case not_simp b of
      (NOT c) \<Rightarrow> c|
      _       \<Rightarrow> NOT b)" |
  "not_simp (AND b1 b2) = (AND (not_simp b1) (not_simp b2))" |
  "not_simp (OR b1 b2) = (OR (not_simp b1) (not_simp b2))"

value "not_simp (NOT (NOT exp))"
value "not_simp (NOT (NOT (NOT exp)))"
value "not_simp (NOT (NOT (NOT (NOT exp))))"

lemma not_preserves_value[simp]: "pbval (not_simp exp\<^sub>o) s = pbval exp\<^sub>o s"
  apply(induction exp\<^sub>o)
     apply simp_all
  apply(simp split: pbexp.splits)
  by auto

    (* This implementation could not even be auto-proved to terminate. *)
     (* Converts a pbexp into NNF by pushing NOT inwards as much as possible. *)
(* fun nnf_bad :: "pbexp \<Rightarrow> pbexp" where
  "nnf_bad (VAR x) = (VAR x)" |
   "nnf_bad (NOT b) = (
    case nnf_bad b of
      (NOT c)     \<Rightarrow> c |
      (AND b1 b2) \<Rightarrow> (OR   (nnf_bad (NOT b1)) (nnf_bad (NOT b2))) |
      (OR b1 b2)  \<Rightarrow> (AND  (nnf_bad (NOT b1)) (nnf_bad (NOT b2))) |
      (VAR c)     \<Rightarrow> NOT (VAR c))" |
  "nnf_bad (AND b1 b2) = (AND (nnf_bad b1) (nnf_bad b2))" |
  "nnf_bad (OR b1 b2) = (OR (nnf_bad b1) (nnf_bad b2))"  *)

(* https://github.com/cmr/ConcreteSemantics/blob/master/CS_Ch3.thy   *)

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

(*     (* How many NOTs have been encountered so far, travelling from the expression's root to this point?
Every time two NOTs are encountered, the count is reset to zero. *)
datatype num_nots = ZeroN | OneN

  (* Convert an expression to negative normal form; pass it ZeroN to begin with   *)
fun nnf :: "pbexp \<Rightarrow> num_nots \<Rightarrow> pbexp" where
  "nnf (VAR x) ZeroN = (VAR x)" |
  "nnf (VAR x) OneN = NOT (VAR x)" |
  "nnf (NOT b) ZeroN = nnf b OneN" |
  "nnf (NOT b) OneN = nnf b ZeroN" |
  "nnf (AND b1 b2) ZeroN = (AND (nnf b1 ZeroN) (nnf b2 ZeroN))" |
  "nnf (AND b1 b2) OneN = (OR (nnf b1 OneN) (nnf b2 OneN))" |
  "nnf (OR b1 b2) ZeroN = (OR (nnf b1 ZeroN) (nnf b2 ZeroN))" |
  "nnf (OR b1 b2) OneN = (AND (nnf b1 OneN) (nnf b2 OneN))"

value "nnf (NOT (NOT (VAR ''x''))) ZeroN"
value "nnf (NOT (NOT (NOT (VAR ''x'')))) ZeroN"
value "nnf (NOT (NOT (NOT (NOT (VAR ''x''))))) ZeroN"

lemma nnf_preserves_value:
  "pbval (nnf exp num) s =
    (case num of ZeroN \<Rightarrow> pbval exp s | OneN \<Rightarrow> (\<not> pbval exp s))"
  apply(simp split: num_nots.splits)
  apply(induction exp arbitrary:num)
  by simp_all *)

lemma nnf_preserves_value:"pbval (nnf exp) s = pbval exp s"
  apply(induction rule: nnf.induct)
  by simp_all

    (* True when NOT is only applied to VARs. Otherwise, false.
What about not(not(var))? *)
fun is_nnf::"pbexp \<Rightarrow> bool"where
  "is_nnf (VAR x) = True" |
  "is_nnf (NOT (VAR _)) = True" |
  "is_nnf (NOT _) = False" |
(*   "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 (VAR ''x'')"
value "is_nnf (NOT(VAR x))"
value "is_nnf (NOT(NOT(VAR x)))"

(* lemma nnf_returns_nnf_expression: "is_nnf (nnf exp num)"
proof(induction exp arbitrary:num)
  case (VAR x)
  then show ?case
  proof(induction num)
    case ZeroN
    then show ?case by simp
  next
    case OneN
    then show ?case by simp
  qed
next
  case (AND exp1 exp2)
  then show ?case
  proof(induction num)
    case ZeroN
    then show ?case by simp
  next
    case OneN
    then show ?case by simp
  qed
next
  case (OR exp1 exp2)
  then show ?case
  proof(induction num)
    case ZeroN
    then show ?case by simp
  next
    case OneN
    then show ?case by simp
  qed
next
  case (NOT exp)
  then show ?case
  proof(induction num)
    case ZeroN
    then show ?case by simp
  next
    case OneN
    then show ?case by simp
  qed
qed *)

  (* NB: when using 'rule: nnf.induct', you MUST specify the induction variable! *)
lemma nnf_returns_nnf_expression: "is_nnf (nnf exp)"
  (* 4. \<And>a b. is_nnf (NOT a) \<Longrightarrow> is_nnf (NOT b) \<Longrightarrow> is_nnf (NOT (AND a b)) *)
  (* apply(induction rule: nnf.induct) (* Was creating FALSE goals *) *)

    (* 4. \<And>a b. is_nnf (nnf (NOT a)) \<Longrightarrow> is_nnf (nnf (NOT b))
\<Longrightarrow> is_nnf (nnf (NOT (AND a b))) *)
  apply(induction exp rule: nnf.induct)
  by simp_all

(*   (* Returns true if the expression is an OR   *)
fun is_OR :: "pbexp \<Rightarrow> bool" where
  "is_OR (OR _ _) = True" |
  "is_OR _ = False"

  (* No ANDs have been seen yet (when traversing the tree from root to here)
| at least one AND has been seen. *)
datatype seen_and = NeverSeenAnd | SeenAnAnd

  (* An expression is in DNF (disjunctive normal form) if it is in NNF and if no OR occurs below an
AND.*)
fun is_dnf:: "pbexp \<Rightarrow> bool"where
  "is_dnf (VAR _) = True" |
  "is_dnf (NOT b) = is_dnf b"|
  "is_dnf (AND b1 b2) = (is_dnf b1 \<and> is_dnf b2 \<and> (\<not> is_OR b1) \<and> (\<not> is_OR b2))" |
  "is_dnf (OR b1 b2) = (is_dnf b1 \<and> is_dnf b2)" *)

  (* An expression is in DNF (disjunctive normal form) if it is in NNF and if no OR occurs below an
AND.*)
fun is_dnf:: "pbexp \<Rightarrow> bool"where
  "is_dnf (VAR _) = True" |
  "is_dnf (NOT b) = is_dnf b"|
  "is_dnf (AND (OR _ _) _) = False" |
  "is_dnf (AND _ (OR _ _)) = False" |
  "is_dnf (AND bl br) = (is_dnf bl \<and> is_dnf br)" |
  "is_dnf (OR b1 b2) = (is_dnf b1 \<and> is_dnf b2)"

(* The argument must be in NNF form (NOTs may only be applied to VAR, i.e. are at the leaves)
 If the arg is in NNF form, then once we have moved up the tree past the VARs and NOTs, all that
 remains are ANDs and ORs.
 We would like to bubble up the ORs*)
(* fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (VAR x) = (VAR x)" |

  (* No need to recurse inside NOT, because arg is already in NNF form *)
  (* "dnf_of_nnf (NOT b) = NOT (dnf_of_nnf b)" | *)
  "dnf_of_nnf (NOT b) = NOT b" |

  "dnf_of_nnf (OR b1 b2) = (OR (dnf_of_nnf b1) (dnf_of_nnf b2))"|

(*   I think this is wrong; needs to recurse on children of AND before
  pattern matching on those transformed children *)
  "dnf_of_nnf (AND (OR ll lr) (OR rl rr)) =
    OR (OR (AND ll rl) (AND ll rr)) (OR (AND lr rl) (AND lr rr))"|
  "dnf_of_nnf (AND (OR ll lr) r) = (OR (AND ll r) (AND lr r))"|
  "dnf_of_nnf (AND l (OR rl rr)) = (OR (AND l rl) (AND l rr))"|
  "dnf_of_nnf (AND l r) = AND (dnf_of_nnf l) (dnf_of_nnf r)" *)

(* Before adding extra recursion   *)
(* args:
first child on an AND, already dnf'ed
second child on an AND, already dnf'ed
returns: the transformed expression; pulling ORs up through the parent AND as needed *)
(* fun push_and_below_or :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"push_and_below_or (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) (OR or\<^sub>r\<^sub>l or\<^sub>r\<^sub>r) =
  (OR (OR (AND or\<^sub>l\<^sub>l or\<^sub>r\<^sub>l) (AND or\<^sub>l\<^sub>l or\<^sub>r\<^sub>r)) (OR (AND or\<^sub>l\<^sub>r or\<^sub>r\<^sub>l) (AND or\<^sub>l\<^sub>r or\<^sub>r\<^sub>r)))"|
"push_and_below_or (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) notOr =
  OR (AND or\<^sub>l\<^sub>l notOr) (AND or\<^sub>l\<^sub>r notOr)"|
"push_and_below_or notOr (OR or\<^sub>r\<^sub>l or\<^sub>r\<^sub>r) =
  OR (AND or\<^sub>r\<^sub>l notOr) (AND or\<^sub>r\<^sub>r notOr)"|
"push_and_below_or notOr\<^sub>l notOr\<^sub>r = AND notOr\<^sub>l notOr\<^sub>r" *)

(* TODO I think I need a new function: push AND down, that pushes AND down below all OR
children. push_and_below_or is halfway there. *)
  (* Push AND down:
when encountering an AND above an OR (in dnf_of_nnf), this function is called.
It recursively pushes down AND until a AND, NOT, or VAR is found.
It converts a
       and
     or   or
into:
        or
    or      or
 and and and and
Then it recurses on the 4 AND's that were just created, because there may be ORs beneath them.
 *)

(* args:
first child on an AND, already dnf'ed
second child on an AND, already dnf'ed
returns: the transformed expression; pushing an AND below its OR children (if there are any). This
function will recursively call itself until all ORs have been moved above the ANDs.

Because dnf_of_nnf is this function's only caller, and dnf_of_nnf recurses on the children of an AND
before calling this function, we know that we may stop once we encounter an AND, NOT, or VAR.*)
fun push_and_below_or :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"push_and_below_or (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) (OR or\<^sub>r\<^sub>l or\<^sub>r\<^sub>r) =
  (OR (OR (push_and_below_or or\<^sub>l\<^sub>l or\<^sub>r\<^sub>l) (push_and_below_or or\<^sub>l\<^sub>l or\<^sub>r\<^sub>r))
      (OR (push_and_below_or or\<^sub>l\<^sub>r or\<^sub>r\<^sub>l) (push_and_below_or or\<^sub>l\<^sub>r or\<^sub>r\<^sub>r)))"|
(* NB: the order of arguments to the recursive calls to push_and_below_or, found below, are
critical. For example, changing (push_and_below_or or\<^sub>l\<^sub>l notOr) to (push_and_below_or notOr or\<^sub>l\<^sub>l)
will cause auto-termination proof of this function to fail.*)
"push_and_below_or (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) notOr =
  OR (push_and_below_or or\<^sub>l\<^sub>l notOr) (push_and_below_or or\<^sub>l\<^sub>r notOr)"|
"push_and_below_or notOr (OR or\<^sub>r\<^sub>l or\<^sub>r\<^sub>r) =
  OR (push_and_below_or notOr or\<^sub>r\<^sub>l) (push_and_below_or notOr or\<^sub>r\<^sub>r)"|
"push_and_below_or notOr\<^sub>l notOr\<^sub>r = AND notOr\<^sub>l notOr\<^sub>r"

value "push_and_below_or (OR (VAR ''1'') (OR (VAR ''2'') (VAR ''3''))) (OR (VAR ''4'') (VAR ''5''))"
value "push_and_below_or (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) (VAR ''y'')"
value "push_and_below_or (VAR ''x'') (OR or\<^sub>r\<^sub>l or\<^sub>r\<^sub>r)"
value "push_and_below_or (VAR ''x'') (VAR ''y'')"

lemma push_and_below_or_preserves_eval:"pbval (push_and_below_or el er) s = pbval (AND el er) s"
  apply(induction el er rule: push_and_below_or.induct)
                      apply(simp_all)
  by auto

lemma push_and_below_or_preserves_nnf:"is_nnf el \<Longrightarrow> is_nnf er \<Longrightarrow> is_nnf (push_and_below_or el er)"
  apply(induction el er rule: push_and_below_or.induct)
  by (simp_all)

lemma push_and_below_or_preserves_dnf:
  "is_dnf el \<Longrightarrow> is_dnf er \<Longrightarrow> is_dnf (push_and_below_or el er)"
  apply(induction el er rule: push_and_below_or.induct)
  by (simp_all)

(* The argument must be in NNF form (NOTs may only be applied to VAR, i.e. are at the leaves)
 If the arg is in NNF form, then once we have moved up the tree past the VARs and NOTs, all that
 remains are ANDs and ORs.
 We would like to bubble up the ORs*)
fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (VAR x) = (VAR x)" |
  (* No need to recurse inside the NOT because we know it's in NNF form. *)
  "dnf_of_nnf (NOT b) = NOT b" |
  "dnf_of_nnf (AND b\<^sub>l b\<^sub>r) =
    (let dnf_b\<^sub>l = dnf_of_nnf b\<^sub>l;
         dnf_b\<^sub>r = dnf_of_nnf b\<^sub>r
    in push_and_below_or dnf_b\<^sub>l dnf_b\<^sub>r)" |
  "dnf_of_nnf (OR b1 b2) = (OR (dnf_of_nnf b1) (dnf_of_nnf b2))"

value "dnf_of_nnf (AND (OR or\<^sub>l\<^sub>l or\<^sub>l\<^sub>r) (VAR ''y''))"

lemma dnf_preserves_value[simp]:"pbval (dnf_of_nnf exp) s = pbval exp s"
  apply(induction exp)
     apply(simp_all)
  using push_and_below_or_preserves_eval by simp

lemma dnf_of_nnf_returns_dnf:"is_nnf exp \<Longrightarrow> is_dnf (dnf_of_nnf exp)"
proof(induction exp rule: dnf_of_nnf.induct)
  case (1 x)
  then show ?case by simp
next
  case (2 b)
  then show ?case
    apply simp
      using is_dnf.simps(1) is_nnf.elims(2) by blast
next
  case (3 b\<^sub>l b\<^sub>r)
  then show ?case
    by (simp add: push_and_below_or_preserves_dnf)
next
  case (4 b1 b2)
  then show ?case by simp
qed

end


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

theory Complex_Vectors
imports
  Quantum
  VectorSpace.VectorSpace
begin

section \<open>The Vector Space of Complex Vectors of Dimension n\<close>

definition module_cpx_vec:: "nat \<Rightarrow> (complex, complex vec) module" where
"module_cpx_vec n \<equiv> module_vec TYPE(complex) n"

definition cpx_rng:: "complex ring" where
"cpx_rng \<equiv> \<lparr>carrier = UNIV, mult = (*), one = 1, zero = 0, add = (+)\<rparr>"

lemma cpx_cring_is_field [simp]:
  "field cpx_rng"
  apply unfold_locales
  apply (auto intro: right_inverse simp: cpx_rng_def Units_def field_simps)
  by (metis add.right_neutral add_diff_cancel_left' add_uminus_conv_diff)

lemma cpx_abelian_monoid [simp]:
  "abelian_monoid cpx_rng"
  using cpx_cring_is_field
  by (simp add: field_def abelian_group_def cring_def domain_def ring_def)

lemma vecspace_cpx_vec [simp]:
  "vectorspace cpx_rng (module_cpx_vec n)"
  apply unfold_locales
  apply (auto simp: cpx_rng_def module_cpx_vec_def module_vec_def Units_def field_simps)
  apply (auto intro: right_inverse add_inv_exists_vec)
  by (metis add.right_neutral add_diff_cancel_left' add_uminus_conv_diff)

definition state_basis:: "nat \<Rightarrow> nat \<Rightarrow> complex vec" where
"state_basis n i \<equiv> unit_vec (2^n) i"

definition unit_vectors:: "nat \<Rightarrow> (complex vec) set" where
"unit_vectors n \<equiv> {unit_vec n i | i::nat. 0 \<le> i \<and> i < n}"

lemma unit_vectors_carrier_vec [simp]:
  "unit_vectors n \<subseteq> carrier_vec n"
  using unit_vectors_def by auto

lemma (in Module.module) finsum_over_singleton [simp]:
  assumes "f x \<in> carrier M"
  shows "finsum M f {x} = f x"
  using assms by simp

lemma lincomb_over_singleton [simp]:
  assumes "x \<in> carrier_vec n" and "f \<in> {x} \<rightarrow> UNIV"
  shows "module.lincomb (module_cpx_vec n) f {x} = f x \<cdot>\<^sub>v x"
  using assms module.lincomb_def module_cpx_vec module_cpx_vec_def module.finsum_over_singleton
  by (smt module_vec_simps(3) module_vec_simps(4) smult_carrier_vec)

lemma dim_vec_lincomb [simp]:
  assumes "finite F" and "f: F \<rightarrow> UNIV" and "F \<subseteq> carrier_vec n"
  shows "dim_vec (module.lincomb (module_cpx_vec n) f F) = n"
  using assms
proof(induct F)
  case empty
  show "dim_vec (module.lincomb (module_cpx_vec n) f {}) = n"
  proof -
    have "module.lincomb (module_cpx_vec n) f {} = 0\<^sub>v n"
      using module.lincomb_def abelian_monoid.finsum_empty module_cpx_vec_def vecspace_cpx_vec vectorspace_def
      by (smt abelian_group_def Module.module_def module_vec_simps(2))
    thus ?thesis by simp
  qed
next
  case (insert x F)
  hence "module.lincomb (module_cpx_vec n) f (insert x F) =
    (f x \<cdot>\<^sub>v x) \<oplus>\<^bsub>module_cpx_vec n\<^esub> module.lincomb (module_cpx_vec n) f F"
    using module_cpx_vec_def module_vec_def module_cpx_vec module.lincomb_insert cpx_rng_def insert_subset
    by (smt Pi_I' UNIV_I Un_insert_right module_vec_simps(4) partial_object.select_convs(1) sup_bot.comm_neutral)
  hence "dim_vec (module.lincomb (module_cpx_vec n) f (insert x F)) =
    dim_vec (module.lincomb (module_cpx_vec n) f F)"
    using index_add_vec by (simp add: module_cpx_vec_def module_vec_simps(1))
  thus "dim_vec (module.lincomb (module_cpx_vec n) f (insert x F)) = n"
    using insert.hyps(3) insert.prems(2) by simp
qed

lemma lincomb_vec_index [simp]:
  assumes "finite F" and a2:"i < n" and "F \<subseteq> carrier_vec n" and "f: F \<rightarrow> UNIV"
  shows "module.lincomb (module_cpx_vec n) f F $ i = (\<Sum>v\<in>F. f v * (v $ i))"
  using assms
proof(induct F)
  case empty
  then show "module.lincomb (module_cpx_vec n) f {} $ i = (\<Sum>v\<in>{}. f v * v $ i)"
    apply auto
    using a2 module.lincomb_def abelian_monoid.finsum_empty module_cpx_vec_def
    by (metis (mono_tags) abelian_group_def index_zero_vec(1) module_cpx_vec Module.module_def module_vec_simps(2))
next
  case(insert x F)
  then show "module.lincomb (module_cpx_vec n) f (insert x F) $ i = (\<Sum>v\<in>insert x F. f v * v $ i)"
    apply auto
  proof -
    have "module.lincomb (module_cpx_vec n) f (insert x F) =
      f x \<cdot>\<^sub>v x \<oplus>\<^bsub>module_cpx_vec n\<^esub> module.lincomb (module_cpx_vec n) f F"
      using module.lincomb_insert module_cpx_vec insert.hyps(1) module_cpx_vec_def module_vec_def
        insert.prems(2) insert.hyps(2) insert.prems(3) insert_def
      by (smt Pi_I' UNIV_I Un_insert_right cpx_rng_def insert_subset module_vec_simps(4)
          partial_object.select_convs(1) sup_bot.comm_neutral)
    then have "module.lincomb (module_cpx_vec n) f (insert x F) $ i =
      (f x \<cdot>\<^sub>v x) $ i + module.lincomb (module_cpx_vec n) f F $ i"
      using index_add_vec(1) a2 dim_vec_lincomb
      by (metis Pi_split_insert_domain  insert.hyps(1) insert.prems(2) insert.prems(3) insert_subset
          module_cpx_vec_def module_vec_simps(1))
    thus "module.lincomb (module_cpx_vec n) f (insert x F) $ i = f x * x $ i + (\<Sum>v\<in>F. f v * v $ i)"
      using index_smult_vec a2 insert.prems(2) insert_def insert.hyps(3) by auto
  qed
qed

lemma unit_vectors_is_lin_indpt [simp]:
  "module.lin_indpt cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof
  assume "module.lin_dep cpx_rng (module_cpx_vec n) (unit_vectors n)"
  hence "\<exists>A a v. (finite A \<and> A \<subseteq> (unit_vectors n) \<and> (a \<in> A \<rightarrow> UNIV) \<and>
    (module.lincomb (module_cpx_vec n) a A = \<zero>\<^bsub>module_cpx_vec n\<^esub>) \<and> (v \<in> A) \<and> (a v \<noteq> \<zero>\<^bsub>cpx_rng\<^esub>))"
    using module.lin_dep_def cpx_rng_def module_cpx_vec by (smt Pi_UNIV UNIV_I)
  moreover obtain A and a and v where f1:"finite A" and f2:"A \<subseteq> (unit_vectors n)" and "a \<in> A \<rightarrow> UNIV"
    and f4:"module.lincomb (module_cpx_vec n) a A = \<zero>\<^bsub>module_cpx_vec n\<^esub>" and f5:"v \<in> A" and
    f6:"a v \<noteq> \<zero>\<^bsub>cpx_rng\<^esub>"
    using calculation by blast
  moreover obtain i where f7:"v = unit_vec n i" and f8:"i < n"
    using unit_vectors_def calculation by auto
  ultimately have f9:"module.lincomb (module_cpx_vec n) a A $ i = (\<Sum>u\<in>A. a u * (u $ i))"
    using lincomb_vec_index
    by (smt carrier_dim_vec index_unit_vec(3) mem_Collect_eq subset_iff sum.cong unit_vectors_def)
  moreover have "\<forall>u\<in>A.\<forall>j<n. u = unit_vec n j \<longrightarrow> j \<noteq> i \<longrightarrow> a u * (u $ i) = 0"
    using unit_vectors_def index_unit_vec by (simp add: f8)
  then have "(\<Sum>u\<in>A. a u * (u $ i)) = (\<Sum>u\<in>A. if u=v then a v * v $ i else 0)"
    using f2 unit_vectors_def f7 by (smt mem_Collect_eq subsetCE sum.cong)
  also have "\<dots> = a v * (v $ i)"
    using abelian_monoid.finsum_singleton[of cpx_rng v A "\<lambda>u\<in>A. a u * (u $ i)"] cpx_abelian_monoid
      f5 f1 cpx_rng_def by simp
  also have "\<dots> = a v"
    using f7 index_unit_vec f8 by simp
  also have "\<dots> \<noteq> 0"
    using f6 by (simp add: cpx_rng_def)
  finally show False
    using f4 module_cpx_vec_def module_vec_def index_zero_vec f8 f9 by (simp add: module_vec_simps(2))
qed

lemma unit_vectors_is_genset [simp]:
  "module.gen_set cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof
  show "module.span cpx_rng (module_cpx_vec n) (unit_vectors n) \<subseteq> carrier (module_cpx_vec n)"
    using module.span_def dim_vec_lincomb carrier_vec_def cpx_rng_def
    by (smt Collect_mono index_unit_vec(3) module.span_is_subset2 module_cpx_vec module_cpx_vec_def
        module_vec_simps(3) unit_vectors_def)
next
  show "carrier (module_cpx_vec n) \<subseteq> module.span cpx_rng (module_cpx_vec n) (unit_vectors n)"
  proof
    fix v
    assume a1:"v \<in> carrier (module_cpx_vec n)"
    define A a lc where "A = {unit_vec n i ::complex vec| i::nat. i < n \<and> v $ i \<noteq> 0}" and
      "a = (\<lambda>u\<in>A. u \<bullet> v)" and "lc = module.lincomb (module_cpx_vec n) a A"
    then have f1:"finite A" by simp
    have f2:"A \<subseteq> carrier_vec n"
      using carrier_vec_def A_def by auto
    have f3:"a \<in> A \<rightarrow> UNIV"
      using a_def by simp
    then have f4:"dim_vec v = dim_vec lc"
      using f1 f2 f3 a1 module_cpx_vec_def dim_vec_lincomb lc_def by (simp add: module_vec_simps(3))
    then have f5:"i < n \<Longrightarrow> lc $ i = (\<Sum>u\<in>A. u \<bullet> v * u $ i)" for i
      using lincomb_vec_index lc_def a_def f1 f2 f3 by simp
    then have "i < n \<Longrightarrow> j < n \<Longrightarrow> j \<noteq> i \<Longrightarrow> unit_vec n j \<bullet> v * unit_vec n j $ i = 0" for i j by simp
    then have "i < n \<Longrightarrow> lc $ i = (\<Sum>u\<in>A. if u = unit_vec n i then v $ i else 0)" for i
      using a1 A_def f5 scalar_prod_left_unit
      by (smt f4 carrier_vecI dim_vec_lincomb f1 f2 f3 index_unit_vec(2) lc_def
          mem_Collect_eq mult.right_neutral sum.cong)
    then have "i < n \<Longrightarrow> lc $ i = v $ i" for i
      using abelian_monoid.finsum_singleton[of cpx_rng i] A_def cpx_rng_def by simp
    then have f6:"v = lc"
      using eq_vecI f4 dim_vec_lincomb f1 f2 lc_def by auto
    have "A \<subseteq> unit_vectors n"
      using A_def unit_vectors_def by auto
    thus "v \<in> module.span cpx_rng (module_cpx_vec n) (unit_vectors n)"
      using f6 module.span_def[of cpx_rng "module_cpx_vec n"] lc_def f1 f2 cpx_rng_def module_cpx_vec
      by (smt Pi_I' UNIV_I mem_Collect_eq partial_object.select_convs(1))
  qed
qed

lemma unit_vectors_is_basis [simp]:
  "vectorspace.basis cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof -
  fix n
  have "unit_vectors n \<subseteq> carrier (module_cpx_vec n)"
    using unit_vectors_def module_cpx_vec_def module_vec_simps(3) by fastforce
  then show ?thesis
    using vectorspace.basis_def unit_vectors_is_lin_indpt unit_vectors_is_genset vecspace_cpx_vec
    by(smt carrier_dim_vec index_unit_vec(3) mem_Collect_eq module_cpx_vec_def module_vec_simps(3)
        subsetI unit_vectors_def)
qed

lemma state_qbit_is_lincomb [simp]:
  "state_qbit n =
  {module.lincomb (module_cpx_vec (2^n)) a A|a A.
    finite A \<and> A\<subseteq>(unit_vectors (2^n)) \<and> a\<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
proof
  show "state_qbit n
    \<subseteq> {module.lincomb (module_cpx_vec (2^n)) a A |a A.
        finite A \<and> A \<subseteq> unit_vectors (2^n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
  proof
    fix v
    assume a1:"v \<in> state_qbit n"
    then show "v \<in> {module.lincomb (module_cpx_vec (2^n)) a A |a A.
               finite A \<and> A \<subseteq> unit_vectors (2^n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
    proof -
      obtain a and A where "finite A" and "a\<in> A \<rightarrow> UNIV" and "A \<subseteq> unit_vectors (2^n)" and
        "v = module.lincomb (module_cpx_vec (2^n)) a A"
        using a1 state_qbit_def unit_vectors_is_basis vectorspace.basis_def module.span_def
        vecspace_cpx_vec module_cpx_vec module_cpx_vec_def module_vec_def carrier_vec_def
        by(smt Pi_UNIV UNIV_I mem_Collect_eq module_vec_simps(3))
      thus ?thesis
        using a1 state_qbit_def by auto
    qed
  qed
  show "{module.lincomb (module_cpx_vec (2 ^ n)) a A |a A.
     finite A \<and> A \<subseteq> unit_vectors (2 ^ n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2 ^ n)) a A\<parallel> = 1}
    \<subseteq> state_qbit n"
  proof
    fix v
    assume "v \<in> {module.lincomb (module_cpx_vec (2 ^ n)) a A |a A.
              finite A \<and> A \<subseteq> unit_vectors (2 ^ n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2 ^ n)) a A\<parallel> = 1}"
    then show "v \<in> state_qbit n"
      using state_qbit_def dim_vec_lincomb unit_vectors_carrier_vec by(smt mem_Collect_eq order_trans)
  qed
qed

end


theory ex04
  imports "Demos/BST_Demo"
begin

fun in_range :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "in_range \<langle>\<rangle> _ _ = []" |
  "in_range (Node l a r) u v =
    (if u < a then in_range l u v else []) @
    (if u \<le> a \<and> a \<le> v then [a] else []) @
    (if a < v then in_range r u v else [])
"

value "set_tree (Node (Node (Node \<langle>\<rangle> (1::nat) \<langle>\<rangle>) 2 (Node \<langle>\<rangle> (3::nat) \<langle>\<rangle>)) 4 (Node \<langle>\<rangle> (5::nat) \<langle>\<rangle>))"

lemma "bst t \<Longrightarrow> set (in_range t u v) = {x \<in>set_tree t. u\<le>x \<and> x \<le>v }"
  apply(induction t)
  apply auto
  done

thm filter_empty_conv

lemma [simp]: "[] = filter P xs \<longleftrightarrow> filter P xs = []"
  apply (induction xs)
   apply auto
  done

lemma "bst t \<Longrightarrow> in_range t u v = filter (\<lambda>x . u\<le>x \<and> x \<le>v ) (inorder t)"
  apply(induction t)
   apply (fastforce simp: filter_empty_conv)+
  done

text \<open>A version that needs less lemmas:\<close>

fun in_range' where
  "in_range' Leaf u v = []"
| "in_range' (Node l x r) u v =
      (if u < x \<and> x < v then in_range' l u v @ x # in_range' r u v
      else if u \<le> x \<and> x < v then x # in_range' r u v
      else if u < x \<and> x \<le> v then in_range' l u v @ [x]
      else if x < u then in_range' r u v
      else if v < x then in_range' l u v
      else if x = u \<and> x = v then [x]
      else []
      )"

lemma "bst t \<Longrightarrow> set (in_range' t u v) = {x\<in>set_tree t. u\<le>x \<and> x\<le>v}"
  apply (induction t)
   apply auto
  done

lemma "bst t \<Longrightarrow> in_range' t u v = filter (\<lambda>x. u\<le>x \<and> x\<le>v) (inorder t)"
  apply (induction t)
   apply (auto simp: filter_empty_conv)
  done

term "()"

term "(\<union>)"

fun enum :: "nat \<Rightarrow> unit tree set" where
  "enum 0 = {}" |
  "enum (Suc n) = enum n \<union> {Node l () r | l r. l \<in> enum n \<and> r \<in> enum n}"

find_theorems "_ \<le> _ \<Longrightarrow> _ \<le> Suc _"

lemma enum_sound: "t \<in> enum n \<Longrightarrow> height t \<le> n"
  apply(induction n arbitrary: t)
   apply (auto simp: le_SucI)
  done

text \<open>The correct definition of enum is below and the one above is the one is developed during the tutorial.
            One cannot tell there is a mistake since the soundness theorem does not properly cover that mistake.
            This shows how underspecifying formal properties can lead to missing bugs....
            \<close>

fun enum' :: "nat \<Rightarrow> unit tree set" where
  "enum' 0 = {Leaf}" |
  "enum' (Suc n) = enum' n \<union> {Node l () r | l r. l \<in> enum' n \<and> r \<in> enum' n}"

end


(*  Title:      HOL/Library/Quotient_Type.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Quotient types\<close>

theory Quotient_Type
imports Main
begin

text \<open>We introduce the notion of quotient types over equivalence relations
  via type classes.\<close>

subsection \<open>Equivalence relations and quotient types\<close>

text \<open>Type class \<open>equiv\<close> models equivalence relations
  \<open>\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>.\<close>

class eqv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infixl "\<sim>" 50)

class equiv = eqv +
  assumes equiv_refl [intro]: "x \<sim> x"
    and equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
    and equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
begin

lemma equiv_not_sym [sym]: "\<not> x \<sim> y \<Longrightarrow> \<not> y \<sim> x"
proof -
  assume "\<not> x \<sim> y"
  then show "\<not> y \<sim> x" by (rule contrapos_nn) (rule equiv_sym)
qed

lemma not_equiv_trans1 [trans]: "\<not> x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> x \<sim> y" and "y \<sim> z"
  show "\<not> x \<sim> z"
  proof
    assume "x \<sim> z"
    also from \<open>y \<sim> z\<close> have "z \<sim> y" ..
    finally have "x \<sim> y" .
    with \<open>\<not> x \<sim> y\<close> show False by contradiction
  qed
qed

lemma not_equiv_trans2 [trans]: "x \<sim> y \<Longrightarrow> \<not> y \<sim> z \<Longrightarrow> \<not> x \<sim> z"
proof -
  assume "\<not> y \<sim> z"
  then have "\<not> z \<sim> y" ..
  also
  assume "x \<sim> y"
  then have "y \<sim> x" ..
  finally have "\<not> z \<sim> x" .
  then show "\<not> x \<sim> z" ..
qed

end

text \<open>The quotient type \<open>'a quot\<close> consists of all \emph{equivalence
  classes} over elements of the base type \<^typ>\<open>'a\<close>.\<close>

definition (in eqv) "quot = {{x. a \<sim> x} | a. True}"

typedef (overloaded) 'a quot = "quot :: 'a::eqv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]:
  assumes "R \<in> quot"
  obtains a where "R = {x. a \<sim> x}"
  using assms unfolding quot_def by blast

text \<open>Abstracted equivalence classes are the canonical representation of
  elements of a quotient type.\<close>

definition "class" :: "'a::equiv \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R
  assume R: "A = Abs_quot R"
  assume "R \<in> quot"
  then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis unfolding class_def .
qed

lemma quot_cases [cases type: quot]:
  obtains a where "A = \<lfloor>a\<rfloor>"
  using quot_exhaust by blast

subsection \<open>Equality on quotients\<close>

text \<open>Equality of canonical quotient elements coincides with the original
  relation.\<close>

theorem quot_equality [iff?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
proof
  assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  show "a \<sim> b"
  proof -
    from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
      by (simp only: class_def Abs_quot_inject quotI)
    moreover have "a \<sim> a" ..
    ultimately have "a \<in> {x. b \<sim> x}" by blast
    then have "b \<sim> a" by blast
    then show ?thesis ..
  qed
next
  assume ab: "a \<sim> b"
  show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  proof -
    have "{x. a \<sim> x} = {x. b \<sim> x}"
    proof (rule Collect_cong)
      fix x show "(a \<sim> x) = (b \<sim> x)"
      proof
        from ab have "b \<sim> a" ..
        also assume "a \<sim> x"
        finally show "b \<sim> x" .
      next
        note ab
        also assume "b \<sim> x"
        finally show "a \<sim> x" .
      qed
    qed
    then show ?thesis by (simp only: class_def)
  qed
qed

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    then have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by (simp only: pick_equiv)
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
  with a show ?thesis by simp
qed

text \<open>The following rules support canonical function definitions on quotient
  types (with up to two arguments). Note that the stripped-down version
  without additional conditions is sufficient most of the time.\<close>

theorem quot_cond_function:
  assumes eq: "\<And>X Y. P X Y \<Longrightarrow> f X Y \<equiv> g (pick X) (pick Y)"
    and cong: "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
      \<Longrightarrow> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> \<Longrightarrow> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
    and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
proof -
  from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
  also have "... = g a b"
  proof (rule cong)
    show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
    moreover
    show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
    moreover
    show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
    ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
  qed
  finally show ?thesis .
qed

theorem quot_function:
  assumes "\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)"
    and "\<And>x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> \<Longrightarrow> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> \<Longrightarrow> g x y = g x' y'"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  using assms and TrueI
  by (rule quot_cond_function)

theorem quot_function':
  "(\<And>X Y. f X Y \<equiv> g (pick X) (pick Y)) \<Longrightarrow>
    (\<And>x x' y y'. x \<sim> x' \<Longrightarrow> y \<sim> y' \<Longrightarrow> g x y = g x' y') \<Longrightarrow>
    f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  by (rule quot_function) (simp_all only: quot_equality)

end