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

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

datatype A = X | Y

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

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

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

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

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

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

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

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

theorem property0 :
  "((recognise (Star p) s) =
      (recognise (Plus Eps (Seq p (Star p))) s))"
  oops

end


theory prop_46
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insert2 :: "Nat => Nat list => Nat list" where
  "insert2 x (Nil2) = Cons2 x (Nil2)"
  | "insert2 x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  (*hipster le insert2 equal2 elem *)

(*hipster equal2*)
lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

(*hipster_cond equal2*)

lemma lemma_ac []: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps)

hipster le equal2
lemma lemma_ad []: "le x2 x2 = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ae []: "equal2 x2 Z = le x2 Z"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_af []: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ag []: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps equal2.simps)

(*hipster_cond le
hipster_cond equal2 le
hipster_cond equal2 elem
hipster_cond le elem
hipster_cond elem equal2
hipster_cond elem le
hipster insert2 elem equal2 le
hipster_cond elem equal2*)

  theorem x0 :
    "(x = y) ==> (elem x (insert2 y z))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(** Score: 10/20 *)

(**
Formalized a little bit of DFAs and the Pumping Lemma. Unfortunately only one
proof, the pigeonhole principle, which requires an unproved lemma and which
is still some way removed from the Pumping Lemma itself.
*)

theory GabrielaLimonta
imports Main
begin

(* Pumping Lemma for regular languages *)

(* We start by formalizing a representation of a DFA, the states will be represented by nat numbers.
   The delta function has the type "'a \<Rightarrow> state \<Rightarrow> state".
   A DFA has the following type: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state)", this
   represents the states of the DFA, the initial state, the final states and the delta function. *)
type_synonym state = nat

(* the states for our DFA are identified by nat and a word is a list of nat numbers, a language
   represented by the DFA is a set of nat list *)

(* A word in a language is represented by a list. The language represented by a DFA is a set of lists.
   The function consume takes a word and indicates the state the DFA is after consuming that word. *)
fun consume :: "'a list \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> state set \<Rightarrow> state \<Rightarrow> state" where
  "consume [] \<delta> Q = id" |
  "consume (a#w) \<delta> Q = consume w \<delta> Q \<circ> \<delta> a"

value "consume [] (\<lambda>x y. y+1) {0,1,2} 0"
value "consume [1,2,3] (\<lambda>x y. y+1) {0,1,2} 0"

(* The language represented by a DFA is the set of words w that allow us to go from the initial
   state to one of the final states *)
fun language :: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> 'a list set" where
  "language Q q\<^sub>0 q\<^sub>f \<delta> = {w. consume w \<delta> Q q\<^sub>0 \<in> q\<^sub>f}"

(* This is an example for the abstraction of a DFA *)
datatype alphabet = a | b

fun lang_ab :: "alphabet \<Rightarrow> state \<Rightarrow> state" where
  "lang_ab a s = (if s = 0 then 0 else 2)" |
  "lang_ab b s = (if s = 0 \<or> s = 1 then 1 else 2)"

value "consume [a,a,a,a,a,a,a,a,b] lang_ab {0,1,2} 0 \<in> {1}"
value "consume [a,a,a,a,a,b,a,a,b] lang_ab {0,1,2} 0 \<in> {1}"

(* A DFA is correctly formed when the set of states is finite, the initial state is in the set of
   states the final states are a subset of the states and that the delta function always yields as
   a result a state that belongs to the states of the DFA *)
definition dfa :: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> bool" where
  "dfa Q q\<^sub>0 q\<^sub>f \<delta> \<equiv> finite Q \<and> q\<^sub>0 \<in> Q \<and> q\<^sub>f \<subseteq> Q \<and> (\<forall> a q. q \<in> Q \<and> \<delta> a q \<in> Q )"

(* We define injectivity for further use in the proof *)
definition injective :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "injective f A \<longleftrightarrow> (\<forall> x \<in> A. \<forall> y \<in> A . f x = f y \<longrightarrow> x = y)"

(* Auxiliary lemma to proove pidgeonhole: Assuming a set A is finite then a function f is
   is injective over the set A iff the cardinality of the image of f applied to A is equal to
   the cardinality of A *)
lemma cardi: "finite A \<Longrightarrow> injective f A \<longleftrightarrow> card {y. (\<exists>x \<in> A. y = f x)} = card A"
sorry

(* Proof of the pidgeonhole principle *)
lemma pigeonhole: "finite A \<Longrightarrow> finite B \<Longrightarrow> card B < card A \<Longrightarrow> (\<forall> x \<in> A. f x \<in> B)
  \<Longrightarrow> (\<exists> x y. x \<noteq> y \<and> f x = f y \<and> x \<in> A \<and> y \<in> A)"
proof -
  assume "(\<forall>x \<in> A. f x \<in> B)"
  from this have a: "{y. (\<exists>x \<in> A. y = f x)} \<subseteq> B" by auto
  assume "finite B"
  then have b: "card {y. (\<exists>x \<in> A. y = f x)} \<le> card B" using a and card_mono by auto
  assume "card B < card A"
  then have "card {y. (\<exists>x \<in> A. y = f x)} < card A" using b by auto
  then have c: "card {y. (\<exists>x \<in> A. y = f x)} \<noteq> card A" by auto
  assume "finite A"
  then have "\<not> injective f A" using cardi and c by auto
  thus ?thesis using injective_def by blast
qed

(* We define a function pump that is meant to "pump" a word a k number of times, that is, it yields
  the word repeated a k number of times. *)
fun pump :: "nat => 'a list \<Rightarrow> 'a list" where
  "pump 0 y = []" |
  "pump k y = pump (k - 1) y@y"

(* Finally the formalization of the pumping lemma, this lemma is usually used to proof that some
   language is not a regular language. *)
lemma pumping:
  assumes "dfa Q q\<^sub>0 q\<^sub>f \<delta>"
  shows "\<exists> p. p\<ge>1 \<and> (\<forall>w. w \<in> (language Q q\<^sub>0 q\<^sub>f \<delta>) \<and> length w \<ge> p
        \<longrightarrow> (\<exists> x y z. w = x@y@z \<and> length y \<ge> 1 \<and> length (x@y) \<le> p \<and> (\<forall>i. i\<ge>0
            \<longrightarrow> (x @ (pump i y) @ z) \<in> (language Q q\<^sub>0 q\<^sub>f \<delta>))))"
sorry

end


section \<open>Proof of the DPRM theorem\<close>

theory DPRM
  imports "Machine_Equations/Machine_Equation_Equivalence"
begin

definition is_recenum :: "nat set \<Rightarrow> bool" where
  "is_recenum A =
    (\<exists> p :: program.
     \<exists> n :: nat.
     \<forall> a :: nat. \<exists> ic. ic = initial_config n a \<and> is_valid_initial ic p a \<and>
    (a \<in> A) = (\<exists> q::nat. terminates ic p q))"

theorem DPRM: "is_recenum A \<Longrightarrow> is_dioph_set A"
proof -
  assume "is_recenum A"
  hence "(\<exists> p :: program.
          \<exists> n :: nat. \<forall> a :: nat.
          \<exists> ic. ic = initial_config n a \<and> is_valid_initial ic p a \<and>
            (a \<in> A) = (\<exists> q::nat. terminates ic p q))" using is_recenum_def by auto
  then obtain p n where p:
         "\<forall> a :: nat.
          \<exists> ic. ic = initial_config n a \<and> is_valid_initial ic p a \<and>
            (a \<in> A) = (\<exists> q::nat. terminates ic p q)" by auto

  interpret rm: register_machine p "Suc n" apply (unfold_locales)
  proof -
    from p have
      "\<exists> ic. ic = initial_config n 0 \<and> is_valid_initial ic p 0 \<and>
            (0 \<in> A) = (\<exists> q::nat. terminates ic p q)" by auto
    then obtain ic where ic: "ic = initial_config n 0" and is_val: "is_valid_initial ic p 0" by auto

    show "length p > 0"
      using is_val unfolding is_valid_initial_def is_valid_def by auto

    have "length (snd ic) = Suc n"
      unfolding ic initial_config_def by auto

    moreover have "snd ic \<noteq> []"
      using is_val unfolding is_valid_initial_def is_valid_def tape_check_initial.simps by auto

    ultimately show "Suc n > 0"
      by auto

    show "program_register_check p (Suc n)"
      using is_val unfolding is_valid_initial_def is_valid_def using \<open>length (snd ic) = Suc n\<close>
      by auto
  qed

  have equiv: "a \<in> A \<longleftrightarrow> register_machine.rm_equations p (Suc n) a" for a
    proof -
      from p have "\<exists> ic. ic = initial_config n a \<and> is_valid_initial ic p a \<and>
      (a \<in> A) = (\<exists> q::nat. terminates ic p q)" by auto
      then obtain ic where ic: "ic = initial_config n a \<and> is_valid_initial ic p a \<and>
      (a \<in> A) = (\<exists> q::nat. terminates ic p q)" by blast

      have ic_def: "ic = initial_config n a" using ic by auto
      hence n_is_length: "Suc n = length (snd ic)" using initial_config_def[of "n" "a"] by auto
      have is_val: "is_valid_initial ic p a" using ic by auto
      have "(a \<in> A) = (\<exists>q. terminates ic p q)" using ic by auto
      moreover have "(\<exists>q. terminates ic p q) = register_machine.rm_equations p (Suc n) a"
        using is_val n_is_length rm.conclusion_4_5
        by auto

      ultimately show ?thesis by auto
   qed

  hence A_characterization: "A = {a::nat. register_machine.rm_equations p (Suc n) a}" by auto

  have eq_dioph: "\<exists>P\<^sub>1 P\<^sub>2. \<forall>a. register_machine.rm_equations p (Suc n) (peval A a)
                    = (\<exists>v. ppeval P\<^sub>1 a v = ppeval P\<^sub>2 a v)" for A
    using rm.rm_dioph[of A] using is_dioph_rel_def[of "rm.rm_equations_relation A"]
    unfolding rm.rm_equations_relation_def by(auto simp: unary_eval)

  have "\<exists>P\<^sub>1 P\<^sub>2. \<forall>b. register_machine.rm_equations p (Suc n) (peval (Param 0) (\<lambda>x. b))
         = (\<exists>v. ppeval P\<^sub>1 (\<lambda>x. b) v = ppeval P\<^sub>2 (\<lambda>x. b) v)"
    using eq_dioph[of "Param 0"] by blast

  hence "\<exists>P1 P2. \<forall>a. register_machine.rm_equations p (Suc n) a
                    = (\<exists>v. ppeval P1 (\<lambda>x. a) v = ppeval P2 (\<lambda>x. a) v)"
    by auto

  thus ?thesis
    unfolding A_characterization is_dioph_set_def by simp
qed

end


(*  Title:       Miscellaneous results
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(* After Isabelle 2012, some of these theorems
may be moved to the Isabelle repository *)

header "Miscellaneous results"

theory Miscellany
imports
  "~~/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space"
  Metric
begin

lemma unordered_pair_element_equality:
  assumes "{p, q} = {r, s}" and "p = r"
  shows "q = s"
proof cases
  assume "p = q"
  with `{p, q} = {r, s}` have "{r, s} = {q}" by simp
  thus "q = s" by simp
next
  assume "p \<noteq> q"
  with `{p, q} = {r, s}` have "{r, s} - {p} = {q}" by auto
  moreover
    from `p = r` have "{r, s} - {p} \<subseteq> {s}" by auto
  ultimately have "{q} \<subseteq> {s}" by simp
  thus "q = s" by simp
qed

lemma unordered_pair_equality: "{p, q} = {q, p}"
  by auto

lemma cosine_rule:
  fixes a b c :: "real ^ ('n::finite)"
  shows "(norm_dist a c)\<^sup>2 =
  (norm_dist a b)\<^sup>2 + (norm_dist b c)\<^sup>2 + 2 * ((a - b) \<bullet> (b - c))"
proof -
  have "(a - b) + (b - c) = a - c" by simp
  with dot_norm [of "a - b" "b - c"]
    have "(a - b) \<bullet> (b - c) =
        ((norm (a - c))\<^sup>2 - (norm (a - b))\<^sup>2 - (norm (b - c))\<^sup>2) / 2"
      by simp
  thus ?thesis by simp
qed

lemma scalar_equiv: "r *s x = r *\<^sub>R x"
  by vector

lemma norm_dist_dot: "(norm_dist x y)\<^sup>2 = (x - y) \<bullet> (x - y)"
  by (simp add: power2_norm_eq_inner)

definition dep2 :: "'a::real_vector \<Rightarrow> 'a \<Rightarrow> bool" where
  "dep2 u v \<equiv> \<exists>w r s. u = r *\<^sub>R w \<and> v = s *\<^sub>R w"

lemma real2_eq:
  fixes u v :: "real^2"
  assumes "u$1 = v$1" and "u$2 = v$2"
  shows "u = v"
  by (simp add: vec_eq_iff [of u v] forall_2 assms)

definition rotate2 :: "real^2 \<Rightarrow> real^2" where
  "rotate2 x \<equiv> vector [-x$2, x$1]"

declare vector_2 [simp]

lemma rotate2 [simp]:
  "(rotate2 x)$1 = -x$2"
  "(rotate2 x)$2 = x$1"
  by (simp add: rotate2_def)+

lemma rotate2_rotate2 [simp]: "rotate2 (rotate2 x) = -x"
proof -
  have "(rotate2 (rotate2 x))$1 = -x$1" and "(rotate2 (rotate2 x))$2 = -x$2"
    by simp+
  with real2_eq show "rotate2 (rotate2 x) = -x" by simp
qed

lemma rotate2_dot [simp]: "(rotate2 u) \<bullet> (rotate2 v) = u \<bullet> v"
  unfolding inner_vec_def
  by (simp add: setsum_2)

lemma rotate2_scaleR [simp]: "rotate2 (k *\<^sub>R x) = k *\<^sub>R (rotate2 x)"
proof -
  have "(rotate2 (k *\<^sub>R x))$1 = (k *\<^sub>R (rotate2 x))$1" and
    "(rotate2 (k *\<^sub>R x))$2 = (k *\<^sub>R (rotate2 x))$2" by simp+
  with real2_eq show ?thesis by simp
qed

lemma rotate2_uminus [simp]: "rotate2 (-x) = -(rotate2 x)"
proof -
  from scaleR_minus_left [of 1] have
    "-1 *\<^sub>R x = -x" and "-1 *\<^sub>R (rotate2 x) = -(rotate2 x)" by auto
  with rotate2_scaleR [of "-1" x] show ?thesis by simp
qed

lemma rotate2_eq [iff]: "rotate2 x = rotate2 y \<longleftrightarrow> x = y"
proof
  assume "x = y"
  thus "rotate2 x = rotate2 y" by simp
next
  assume "rotate2 x = rotate2 y"
  hence "rotate2 (rotate2 x) = rotate2 (rotate2 y)" by simp
  hence "-(-x) = -(-y)" by simp
  thus "x = y" by simp
qed

lemma dot2_rearrange_1:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x$1 \<noteq> 0"
  shows "u = (u$2 / x$1) *\<^sub>R (rotate2 x)" (is "u = ?u'")
proof -
  from `u \<bullet> x = 0` have "u$1 * x$1 = -(u$2) * (x$2)"
    unfolding inner_vec_def
    by (simp add: setsum_2)
  hence "u$1 * x$1 / x$1 = -u$2 / x$1 * x$2" by simp
  with `x$1 \<noteq> 0` have "u$1 = ?u'$1" by simp
  from `x$1 \<noteq> 0` have "u$2 = ?u'$2" by simp
  with `u$1 = ?u'$1` and real2_eq show "u = ?u'" by simp
qed

lemma dot2_rearrange_2:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x$2 \<noteq> 0"
  shows "u = -(u$1 / x$2) *\<^sub>R (rotate2 x)" (is "u = ?u'")
proof -
  from assms and dot2_rearrange_1 [of "rotate2 u" "rotate2 x"] have
    "rotate2 u = rotate2 ?u'" by simp
  thus "u = ?u'" by blast
qed

lemma dot2_rearrange:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x \<noteq> 0"
  shows "\<exists>k. u = k *\<^sub>R (rotate2 x)"
proof cases
  assume "x$1 = 0"
  with real2_eq [of x 0] and `x \<noteq> 0` have "x$2 \<noteq> 0" by auto
  with dot2_rearrange_2 and `u \<bullet> x = 0` show ?thesis by blast
next
  assume "x$1 \<noteq> 0"
  with dot2_rearrange_1 and `u \<bullet> x = 0` show ?thesis by blast
qed

lemma dot_left_diff_distrib:
  fixes u v x :: "real^('n::finite)"
  shows "(u - v) \<bullet> x = (u \<bullet> x) - (v \<bullet> x)"
proof -
  have "(u \<bullet> x) - (v \<bullet> x) = (\<Sum>i\<in>UNIV. u$i * x$i) - (\<Sum>i\<in>UNIV. v$i * x$i)"
    unfolding inner_vec_def
    by simp
  also from setsum_subtractf [of "\<lambda> i. u$i * x$i" "\<lambda> i. v$i * x$i"] have
    "\<dots> = (\<Sum>i\<in>UNIV. u$i * x$i - v$i * x$i)" by simp
  also from left_diff_distrib [where 'a = real] have
    "\<dots> = (\<Sum>i\<in>UNIV. (u$i - v$i) * x$i)" by simp
  also have
    "\<dots> = (u - v) \<bullet> x"
    unfolding inner_vec_def
    by simp
  finally show ?thesis ..
qed

lemma dot_right_diff_distrib:
  fixes u v x :: "real^('n::finite)"
  shows "x \<bullet> (u - v) = (x \<bullet> u) - (x \<bullet> v)"
proof -
  from inner_commute have "x \<bullet> (u - v) = (u - v) \<bullet> x" by auto
  also from dot_left_diff_distrib [of u v x] have
    "\<dots> = u \<bullet> x - v \<bullet> x" .
  also from inner_commute [of x] have
    "\<dots> = x \<bullet> u - x \<bullet> v" by simp
  finally show ?thesis .
qed

lemma am_gm2:
  fixes a b :: real
  assumes "a \<ge> 0" and "b \<ge> 0"
  shows "sqrt (a * b) \<le> (a + b) / 2"
  and "sqrt (a * b) = (a + b) / 2 \<longleftrightarrow> a = b"
proof -
  have "0 \<le> (a - b) * (a - b)" and "0 = (a - b) * (a - b) \<longleftrightarrow> a = b" by simp+
  with right_diff_distrib [of "a - b" a b] and left_diff_distrib [of a b] have
    "0 \<le> a * a - 2 * a * b + b * b"
    and "0 = a * a - 2 * a * b + b * b \<longleftrightarrow> a = b" by auto
  hence "4 * a * b \<le> a * a + 2 * a * b + b * b"
    and "4 * a * b = a * a + 2 * a * b + b * b \<longleftrightarrow> a = b" by auto
  with distrib_right [of "a + b" a b] and distrib_left [of a b] have
    "4 * a * b \<le> (a + b) * (a + b)"
    and "4 * a * b = (a + b) * (a + b) \<longleftrightarrow> a = b" by (simp add: field_simps)+
  with real_sqrt_le_mono [of "4 * a * b" "(a + b) * (a + b)"]
    and real_sqrt_eq_iff [of "4 * a * b" "(a + b) * (a + b)"] have
    "sqrt (4 * a * b) \<le> sqrt ((a + b) * (a + b))"
    and "sqrt (4 * a * b) = sqrt ((a + b) * (a + b)) \<longleftrightarrow> a = b" by simp+
  with `a \<ge> 0` and `b \<ge> 0` have "sqrt (4 * a * b) \<le> a + b"
    and "sqrt (4 * a * b) = a + b \<longleftrightarrow> a = b" by simp+
  with real_sqrt_abs2 [of 2] and real_sqrt_mult [of 4 "a * b"] show
    "sqrt (a * b) \<le> (a + b) / 2"
    and "sqrt (a * b) = (a + b) / 2 \<longleftrightarrow> a = b" by (simp add: ac_simps)+
qed

lemma refl_on_allrel: "refl_on A (A \<times> A)"
  unfolding refl_on_def
  by simp

lemma refl_on_restrict:
  assumes "refl_on A r"
  shows "refl_on (A \<inter> B) (r \<inter> B \<times> B)"
proof -
  from `refl_on A r` and refl_on_allrel [of B] and refl_on_Int
  show ?thesis by auto
qed

lemma sym_allrel: "sym (A \<times> A)"
  unfolding sym_def
  by simp

lemma sym_restrict:
  assumes "sym r"
  shows "sym (r \<inter> A \<times> A)"
proof -
  from `sym r` and sym_allrel and sym_Int
  show ?thesis by auto
qed

lemma trans_allrel: "trans (A \<times> A)"
  unfolding trans_def
  by simp

lemma trans_restrict:
  assumes "trans r"
  shows "trans (r \<inter> A \<times> A)"
proof -
  from `trans r` and trans_allrel and trans_Int
  show ?thesis by auto
qed

lemma equiv_Int:
  assumes "equiv A r" and "equiv B s"
  shows "equiv (A \<inter> B) (r \<inter> s)"
proof -
  from assms and refl_on_Int [of A r B s] and sym_Int and trans_Int
  show ?thesis
    unfolding equiv_def
    by auto
qed

lemma equiv_allrel: "equiv A (A \<times> A)"
  unfolding equiv_def
  by (simp add: refl_on_allrel sym_allrel trans_allrel)

lemma equiv_restrict:
  assumes "equiv A r"
  shows "equiv (A \<inter> B) (r \<inter> B \<times> B)"
proof -
  from `equiv A r` and equiv_allrel [of B] and equiv_Int
  show ?thesis by auto
qed

lemma scalar_vector_matrix_assoc:
  fixes k :: real and x :: "real^('n::finite)" and A :: "real^('m::finite)^'n"
  shows "(k *\<^sub>R x) v* A = k *\<^sub>R (x v* A)"
proof -
  { fix i
    from setsum_right_distrib [of k "\<lambda>j. x$j * A$j$i" UNIV]
    have "(\<Sum>j\<in>UNIV. k * (x$j * A$j$i)) = k * (\<Sum>j\<in>UNIV. x$j * A$j$i)" .. }
  thus "(k *\<^sub>R x) v* A = k *\<^sub>R (x v* A)"
    unfolding vector_matrix_mult_def
    by (simp add: vec_eq_iff algebra_simps)
qed

lemma vector_scalar_matrix_ac:
  fixes k :: real and x :: "real^('n::finite)" and A :: "real^('m::finite)^'n"
  shows "x v* (k *\<^sub>R A) = k *\<^sub>R (x v* A)"
proof -
  have "x v* (k *\<^sub>R A) = (k *\<^sub>R x) v* A"
    unfolding vector_matrix_mult_def
    by (simp add: algebra_simps)
  with scalar_vector_matrix_assoc
  show "x v* (k *\<^sub>R A) = k *\<^sub>R (x v* A)"
    by auto
qed

lemma vector_matrix_left_distrib:
  fixes x y :: "real^('n::finite)" and A :: "real^('m::finite)^'n"
  shows "(x + y) v* A = x v* A + y v* A"
  unfolding vector_matrix_mult_def
  by (simp add: algebra_simps setsum.distrib vec_eq_iff)

lemma times_zero_vector [simp]: "A *v 0 = 0"
  unfolding matrix_vector_mult_def
  by (simp add: vec_eq_iff)

lemma invertible_times_eq_zero:
  fixes x :: "real^('n::finite)" and A :: "real^'n^'n"
  assumes "invertible A" and "A *v x = 0"
  shows "x = 0"
proof -
  from `invertible A`
    and someI_ex [of "\<lambda>A'. A ** A' = mat 1 \<and> A' ** A = mat 1"]
  have "matrix_inv A ** A = mat 1"
    unfolding invertible_def matrix_inv_def
    by simp
  hence "x = (matrix_inv A ** A) *v x" by (simp add: matrix_vector_mul_lid)
  also have "\<dots> = matrix_inv A *v (A *v x)"
    by (simp add: matrix_vector_mul_assoc)
  also from `A *v x = 0` have "\<dots> = 0" by simp
  finally show "x = 0" .
qed

lemma vector_transpose_matrix [simp]: "x v* transpose A = A *v x"
  unfolding transpose_def vector_matrix_mult_def matrix_vector_mult_def
  by simp

lemma transpose_matrix_vector [simp]: "transpose A *v x = x v* A"
  unfolding transpose_def vector_matrix_mult_def matrix_vector_mult_def
  by simp

lemma transpose_invertible:
  fixes A :: "real^('n::finite)^'n"
  assumes "invertible A"
  shows "invertible (transpose A)"
proof -
  from `invertible A` obtain A' where "A ** A' = mat 1" and "A' ** A = mat 1"
    unfolding invertible_def
    by auto
  with matrix_transpose_mul [of A A'] and matrix_transpose_mul [of A' A]
  have "transpose A' ** transpose A = mat 1" and "transpose A ** transpose A' = mat 1"
    by (simp add: transpose_mat)+
  thus "invertible (transpose A)"
    unfolding invertible_def
    by auto
qed

lemma times_invertible_eq_zero:
  fixes x :: "real^('n::finite)" and A :: "real^'n^'n"
  assumes "invertible A" and "x v* A = 0"
  shows "x = 0"
proof -
  from transpose_invertible and `invertible A` have "invertible (transpose A)" by auto
  with invertible_times_eq_zero [of "transpose A" x] and `x v* A = 0`
  show "x = 0" by simp
qed

lemma matrix_id_invertible:
  "invertible (mat 1 :: ('a::semiring_1)^('n::finite)^'n)"
proof -
  from matrix_mul_lid [of "mat 1 :: 'a^'n^'n"]
  show "invertible (mat 1 :: 'a^'n^'n)"
    unfolding invertible_def
    by auto
qed

lemma Image_refl_on_nonempty:
  assumes "refl_on A r" and "x \<in> A"
  shows "x \<in> r``{x}"
proof
  from `refl_on A r` and `x \<in> A` show "(x, x) \<in> r"
    unfolding refl_on_def
    by simp
qed

lemma quotient_element_nonempty:
  assumes "equiv A r" and "X \<in> A//r"
  shows "\<exists> x. x \<in> X"
proof -
  from `X \<in> A//r` obtain x where "x \<in> A" and "X = r``{x}"
    unfolding quotient_def
    by auto
  with equiv_class_self [of A r x] and `equiv A r` show "\<exists> x. x \<in> X" by auto
qed

lemma zero_3: "(3::3) = 0"
  by simp

lemma card_suc_ge_insert:
  fixes A and x
  shows "card A + 1 \<ge> card (insert x A)"
proof cases
  assume "finite A"
  with card_insert_if [of A x] show "card A + 1 \<ge> card (insert x A)" by simp
next
  assume "infinite A"
  thus "card A + 1 \<ge> card (insert x A)" by simp
qed

lemma card_le_UNIV:
  fixes A :: "('n::finite) set"
  shows "card A \<le> CARD('n)"
  by (simp add: card_mono)

lemma setsum_forall_cong:
  assumes "\<forall> x\<in>A. f x = g x"
  shows "(\<Sum> x\<in>A. f x) = (\<Sum> x\<in>A. g x)"
proof -
  from `\<forall> x\<in>A. f x = g x` have "\<And> x. x \<in> A \<Longrightarrow> f x = g x" ..
  with setsum.cong show "(\<Sum> x\<in>A. f x) = (\<Sum> x\<in>A. g x)" by simp
qed

lemma partition_Image_element:
  assumes "equiv A r" and "X \<in> A//r" and "x \<in> X"
  shows "r``{x} = X"
proof -
  from Union_quotient and assms have "x \<in> A" by auto
  with quotientI [of x A r] have "r``{x} \<in> A//r" by simp

  from equiv_class_self and `equiv A r` and `x \<in> A` have "x \<in> r``{x}" by simp

  from `equiv A r` and `x \<in> A` have "(x, x) \<in> r"
    unfolding equiv_def and refl_on_def
    by simp

  with quotient_eqI [of A r X "r``{x}" x x]
    and assms and `Image r {x} \<in> A//r` and `x \<in> Image r {x}`
  show "r``{x} = X" by simp
qed

lemma card_insert_ge: "card (insert x A) \<ge> card A"
proof cases
  assume "finite A"
  with card_insert_le [of A x] show "card (insert x A) \<ge> card A" by simp
next
  assume "infinite A"
  hence "card A = 0" by simp
  thus "card (insert x A) \<ge> card A" by simp
qed

lemma choose_1:
  assumes "card S = 1"
  shows "\<exists> x. S = {x}"
  using `card S = 1` and card_eq_SucD [of S 0]
  by simp

lemma choose_2:
  assumes "card S = 2"
  shows "\<exists> x y. S = {x,y}"
proof -
  from `card S = 2` and card_eq_SucD [of S 1]
  obtain x and T where "S = insert x T" and "card T = 1" by auto
  from `card T = 1` and choose_1 obtain y where "T = {y}" by auto
  with `S = insert x T` have "S = {x,y}" by simp
  thus "\<exists> x y. S = {x,y}" by auto
qed

lemma choose_3:
  assumes "card S = 3"
  shows "\<exists> x y z. S = {x,y,z}"
proof -
  from `card S = 3` and card_eq_SucD [of S 2]
  obtain x and T where "S = insert x T" and "card T = 2" by auto
  from `card T = 2` and choose_2 [of T] obtain y and z where "T = {y,z}" by auto
  with `S = insert x T` have "S = {x,y,z}" by simp
  thus "\<exists> x y z. S = {x,y,z}" by auto
qed

lemma card_gt_0_diff_singleton:
  assumes "card S > 0" and "x \<in> S"
  shows "card (S - {x}) = card S - 1"
proof -
  from `card S > 0` have "finite S" by (rule card_ge_0_finite)
  with `x \<in> S`
  show "card (S - {x}) = card S - 1" by (simp add: card_Diff_singleton)
qed

lemma eq_3_or_of_3:
  fixes j :: 4
  shows "j = 3 \<or> (\<exists> j'::3. j = of_int (Rep_bit1 j'))"
proof (induct j)
  fix j_int :: int
  assume "0 \<le> j_int"
  assume "j_int < int CARD(4)"
  hence "j_int \<le> 3" by simp

  show "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
  proof cases
    assume "j_int = 3"
    thus
      "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
      by simp
  next
    assume "j_int \<noteq> 3"
    with `j_int \<le> 3` have "j_int < 3" by simp
    with `0 \<le> j_int` have "j_int \<in> {0..<3}" by simp
    hence "Rep_bit1 (Abs_bit1 j_int :: 3) = j_int"
      by (simp add: bit1.Abs_inverse)
    hence "of_int j_int = of_int (Rep_bit1 (Abs_bit1 j_int :: 3))" by simp
    thus
      "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
      by auto
  qed
qed

lemma sgn_plus:
  fixes x y :: "'a::linordered_idom"
  assumes "sgn x = sgn y"
  shows "sgn (x + y) = sgn x"
proof cases
  assume "x = 0"
  with `sgn x = sgn y` have "y = 0" by (simp add: sgn_0_0)
  with `x = 0` show "sgn (x + y) = sgn x" by (simp add: sgn_0_0)
next
  assume "x \<noteq> 0"
  show "sgn (x + y) = sgn x"
  proof cases
    assume "x > 0"
    with `sgn x = sgn y` and sgn_1_pos [where ?'a = 'a] have "y > 0" by simp
    with `x > 0` and sgn_1_pos [where ?'a = 'a]
    show "sgn (x + y) = sgn x" by simp
  next
    assume "\<not> x > 0"
    with `x \<noteq> 0` have "x < 0" by simp
    with `sgn x = sgn y` and sgn_1_neg [where ?'a = 'a] have "y < 0" by auto
    with `x < 0` and sgn_1_neg [where ?'a = 'a]
    show "sgn (x + y) = sgn x" by simp
  qed
qed

lemma sgn_div:
  fixes x y :: "'a::linordered_field_inverse_zero"
  assumes "y \<noteq> 0" and "sgn x = sgn y"
  shows "x / y > 0"
proof cases
  assume "y > 0"
  with `sgn x = sgn y` and sgn_1_pos [where ?'a = 'a] have "x > 0" by simp
  with `y > 0` show "x / y > 0" by (simp add: zero_less_divide_iff)
next
  assume "\<not> y > 0"
  with `y \<noteq> 0` have "y < 0" by simp
  with `sgn x = sgn y` and sgn_1_neg [where ?'a = 'a] have "x < 0" by simp
  with `y < 0` show "x / y > 0" by (simp add: zero_less_divide_iff)
qed

lemma abs_plus:
  fixes x y :: "'a::linordered_idom"
  assumes "sgn x = sgn y"
  shows "\<bar>x + y\<bar> = \<bar>x\<bar> + \<bar>y\<bar>"
proof -
  from `sgn x = sgn y` have "sgn (x + y) = sgn x" by (rule sgn_plus)
  hence "\<bar>x + y\<bar> = (x + y) * sgn x" by (simp add: abs_sgn)
  also from `sgn x = sgn y`
  have "\<dots> = x * sgn x + y * sgn y" by (simp add: algebra_simps)
  finally show "\<bar>x + y\<bar> = \<bar>x\<bar> + \<bar>y\<bar>" by (simp add: abs_sgn)
qed

lemma sgn_plus_abs:
  fixes x y :: "'a::linordered_idom"
  assumes "\<bar>x\<bar> > \<bar>y\<bar>"
  shows "sgn (x + y) = sgn x"
proof cases
  assume "x > 0"
  with `\<bar>x\<bar> > \<bar>y\<bar>` have "x + y > 0" by simp
  with `x > 0` show "sgn (x + y) = sgn x" by simp
next
  assume "\<not> x > 0"

  from `\<bar>x\<bar> > \<bar>y\<bar>` have "x \<noteq> 0" by simp
  with `\<not> x > 0` have "x < 0" by simp
  with `\<bar>x\<bar> > \<bar>y\<bar>` have "x + y < 0" by simp
  with `x < 0` show "sgn (x + y) = sgn x" by simp
qed

lemma sqrt_4 [simp]: "sqrt 4 = 2"
proof -
  have "sqrt 4 = sqrt (2 * 2)" by simp
  thus "sqrt 4 = 2" by (unfold real_sqrt_abs2) simp
qed

end


theory Examples imports "~~/src/HOL/Number_Theory/Binomial" begin

declare [[eta_contract = false]]

text{*membership, intersection *}
text{*difference and empty set*}
text{*complement, union and universal set*}

lemma "(x \<in> A \<inter> B) = (x \<in> A \<and> x \<in> B)"
by blast

text{*
@{thm[display] IntI[no_vars]}
\rulename{IntI}

@{thm[display] IntD1[no_vars]}
\rulename{IntD1}

@{thm[display] IntD2[no_vars]}
\rulename{IntD2}
*}

lemma "(x \<in> -A) = (x \<notin> A)"
by blast

text{*
@{thm[display] Compl_iff[no_vars]}
\rulename{Compl_iff}
*}

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

text{*
@{thm[display] Compl_Un[no_vars]}
\rulename{Compl_Un}
*}

lemma "A-A = {}"
by blast

text{*
@{thm[display] Diff_disjoint[no_vars]}
\rulename{Diff_disjoint}
*}

lemma "A \<union> -A = UNIV"
by blast

text{*
@{thm[display] Compl_partition[no_vars]}
\rulename{Compl_partition}
*}

text{*subset relation*}

text{*
@{thm[display] subsetI[no_vars]}
\rulename{subsetI}

@{thm[display] subsetD[no_vars]}
\rulename{subsetD}
*}

lemma "((A \<union> B) \<subseteq> C) = (A \<subseteq> C \<and> B \<subseteq> C)"
by blast

text{*
@{thm[display] Un_subset_iff[no_vars]}
\rulename{Un_subset_iff}
*}

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

lemma "(A <= -B) = (B <= -A)"
  oops

text{*ASCII version: blast fails because of overloading because
 it doesn't have to be sets*}

lemma "((A:: 'a set) <= -B) = (B <= -A)"
by blast

text{*A type constraint lets it work*}

text{*An issue here: how do we discuss the distinction between ASCII and
symbol notation?  Here the latter disambiguates.*}

text{*
set extensionality

@{thm[display] set_eqI[no_vars]}
\rulename{set_eqI}

@{thm[display] equalityI[no_vars]}
\rulename{equalityI}

@{thm[display] equalityE[no_vars]}
\rulename{equalityE}
*}

text{*finite sets: insertion and membership relation*}
text{*finite set notation*}

lemma "insert x A = {x} \<union> A"
by blast

text{*
@{thm[display] insert_is_Un[no_vars]}
\rulename{insert_is_Un}
*}

lemma "{a,b} \<union> {c,d} = {a,b,c,d}"
by blast

lemma "{a,b} \<inter> {b,c} = {b}"
apply auto
oops
text{*fails because it isn't valid*}

lemma "{a,b} \<inter> {b,c} = (if a=c then {a,b} else {b})"
apply simp
by blast

text{*or just force or auto.  blast alone can't handle the if-then-else*}

text{*next: some comprehension examples*}

lemma "(a \<in> {z. P z}) = P a"
by blast

text{*
@{thm[display] mem_Collect_eq[no_vars]}
\rulename{mem_Collect_eq}
*}

lemma "{x. x \<in> A} = A"
by blast

text{*
@{thm[display] Collect_mem_eq[no_vars]}
\rulename{Collect_mem_eq}
*}

lemma "{x. P x \<or> x \<in> A} = {x. P x} \<union> A"
by blast

lemma "{x. P x \<longrightarrow> Q x} = -{x. P x} \<union> {x. Q x}"
by blast

definition prime :: "nat set" where
    "prime == {p. 1<p & (ALL m. m dvd p --> m=1 | m=p)}"

lemma "{p*q | p q. p\<in>prime \<and> q\<in>prime} =
       {z. \<exists>p q. z = p*q \<and> p\<in>prime \<and> q\<in>prime}"
by (rule refl)

text{*binders*}

text{*bounded quantifiers*}

lemma "(\<exists>x\<in>A. P x) = (\<exists>x. x\<in>A \<and> P x)"
by blast

text{*
@{thm[display] bexI[no_vars]}
\rulename{bexI}
*}

text{*
@{thm[display] bexE[no_vars]}
\rulename{bexE}
*}

lemma "(\<forall>x\<in>A. P x) = (\<forall>x. x\<in>A \<longrightarrow> P x)"
by blast

text{*
@{thm[display] ballI[no_vars]}
\rulename{ballI}
*}

text{*
@{thm[display] bspec[no_vars]}
\rulename{bspec}
*}

text{*indexed unions and variations*}

lemma "(\<Union>x. B x) = (\<Union>x\<in>UNIV. B x)"
by blast

text{*
@{thm[display] UN_iff[no_vars]}
\rulename{UN_iff}
*}

text{*
@{thm[display] Union_iff[no_vars]}
\rulename{Union_iff}
*}

lemma "(\<Union>x\<in>A. B x) = {y. \<exists>x\<in>A. y \<in> B x}"
by blast

lemma "\<Union>S = (\<Union>x\<in>S. x)"
by blast

text{*
@{thm[display] UN_I[no_vars]}
\rulename{UN_I}
*}

text{*
@{thm[display] UN_E[no_vars]}
\rulename{UN_E}
*}

text{*indexed intersections*}

lemma "(\<Inter>x. B x) = {y. \<forall>x. y \<in> B x}"
by blast

text{*
@{thm[display] INT_iff[no_vars]}
\rulename{INT_iff}
*}

text{*
@{thm[display] Inter_iff[no_vars]}
\rulename{Inter_iff}
*}

text{*mention also card, Pow, etc.*}

text{*
@{thm[display] card_Un_Int[no_vars]}
\rulename{card_Un_Int}

@{thm[display] card_Pow[no_vars]}
\rulename{card_Pow}

@{thm[display] n_subsets[no_vars]}
\rulename{n_subsets}
*}

end


section "Priority Queues Based on Braun Trees"

theory Priority_Queue_Braun
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Priority_Queue_Specs"
  "HOL-Data_Structures.Braun_Tree"
begin

subsection "Introduction"

text\<open>Braun, Rem and Hoogerwoord \cite{BraunRem,Hoogerwoord} used
specific balanced binary trees, often called Braun trees (where in
each node with subtrees $l$ and $r$, $size(r) \le size(l) \le
size(r)+1$), to implement flexible arrays. Paulson \cite{Paulson}
(based on code supplied by Okasaki)
implemented priority queues via Braun trees. This theory verifies
Paulsons's implementation, with small simplifications.\<close>

text \<open>Direct proof of logarithmic height. Also follows from the fact that Braun
trees are balanced (proved in the base theory).\<close>

lemma height_size_braun: "braun t \<Longrightarrow> 2 ^ (height t) \<le> 2 * size t + 1"
proof(induction t)
  case (Node t1)
  show ?case
  proof (cases "height t1")
    case 0 thus ?thesis using Node by simp
  next
    case (Suc n)
    hence "2 ^ n \<le> size t1" using Node by simp
    thus ?thesis using Suc Node by(auto simp: max_def)
  qed
qed simp

subsection "Get Minimum"

fun get_min :: "'a::linorder tree \<Rightarrow> 'a" where
"get_min (Node l a r) = a"

lemma get_min: "\<lbrakk> heap t;  t \<noteq> Leaf \<rbrakk> \<Longrightarrow> get_min t = Min_mset (mset_tree t)"
by (auto simp add: eq_Min_iff neq_Leaf_iff)

subsection \<open>Insertion\<close>

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert a Leaf = Node Leaf a Leaf" |
"insert a (Node l x r) =
 (if a < x then Node (insert x r) a l else Node (insert a r) x l)"

lemma size_insert[simp]: "size(insert x t) = size t + 1"
by(induction t arbitrary: x) auto

lemma mset_insert: "mset_tree(insert x t) = {#x#} + mset_tree t"
by(induction t arbitrary: x) (auto simp: ac_simps)

lemma set_insert[simp]: "set_tree(insert x t) = {x} \<union> (set_tree t)"
by(simp add: mset_insert flip: set_mset_tree)

lemma braun_insert: "braun t \<Longrightarrow> braun(insert x t)"
by(induction t arbitrary: x) auto

lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
by(induction t arbitrary: x) (auto  simp add: ball_Un)

subsection \<open>Deletion\<close>

text \<open>Slightly simpler definition of @{text del_left}
which avoids the need to appeal to the Braun invariant.\<close>

fun del_left :: "'a tree \<Rightarrow> 'a * 'a tree" where
"del_left (Node Leaf x r) = (x,r)" |
"del_left (Node l x r) = (let (y,l') = del_left l in (y,Node r x l'))"

lemma del_left_mset_plus:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> mset_tree t = {#x#} + mset_tree t'"
  by (induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits)

lemma del_left_mset:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> x \<in># mset_tree t \<and> mset_tree t' = mset_tree t - {#x#}"
by (simp add: del_left_mset_plus)

lemma del_left_set:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> set_tree t = {x} \<union> set_tree t'"
by(simp add: del_left_mset_plus flip: set_mset_tree)

lemma del_left_heap:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> heap t \<Longrightarrow> heap t'"
  by (induction t arbitrary: x t' rule: del_left.induct;
    fastforce split: prod.splits dest: del_left_set[THEN equalityD2])

lemma del_left_size:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> size t = size t' + 1"
  by(induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits)

lemma del_left_braun:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> braun t \<Longrightarrow> braun t'"
  by(induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits dest: del_left_size)

context includes pattern_aliases
begin

text \<open>Slightly simpler definition: \<open>_\<close> instead of @{const Leaf} because of Braun invariant.\<close>

function (sequential) sift_down :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"sift_down Leaf a _ = Node Leaf a Leaf" |
"sift_down (Node Leaf x _) a Leaf =
  (if a \<le> x then Node (Node Leaf x Leaf) a Leaf
   else Node (Node Leaf a Leaf) x Leaf)" |
"sift_down (Node l1 x1 r1 =: t1) a (Node l2 x2 r2 =: t2) =
  (if a \<le> x1 \<and> a \<le> x2
   then Node t1 a t2
   else if x1 \<le> x2 then Node (sift_down l1 a r1) x1 t2
        else Node t1 x2 (sift_down l2 a r2))"
by pat_completeness auto
termination
by (relation "measure (%(l,a,r). size l + size r)") auto

end

lemma size_sift_down:
  "braun(Node l a r) \<Longrightarrow> size(sift_down l a r) = size l + size r + 1"
by(induction l a r rule: sift_down.induct) (auto simp: Let_def)

lemma braun_sift_down:
  "braun(Node l a r) \<Longrightarrow> braun(sift_down l a r)"
by(induction l a r rule: sift_down.induct) (auto simp: size_sift_down Let_def)

lemma mset_sift_down:
  "braun(Node l a r) \<Longrightarrow> mset_tree(sift_down l a r) = {#a#} + (mset_tree l + mset_tree r)"
by(induction l a r rule: sift_down.induct) (auto simp: ac_simps Let_def)

lemma set_sift_down: "braun(Node l a r)
  \<Longrightarrow> set_tree(sift_down l a r) = {a} \<union> (set_tree l \<union> set_tree r)"
by(drule arg_cong[where f=set_mset, OF mset_sift_down]) (simp)

lemma heap_sift_down:
  "braun(Node l a r) \<Longrightarrow> heap l \<Longrightarrow> heap r \<Longrightarrow> heap(sift_down l a r)"
by (induction l a r rule: sift_down.induct) (auto simp: set_sift_down ball_Un Let_def)

fun del_min :: "'a::linorder tree \<Rightarrow> 'a tree" where
"del_min Leaf = Leaf" |
"del_min (Node Leaf x r) = Leaf" |
"del_min (Node l x r) = (let (y,l') = del_left l in sift_down r y l')"

lemma braun_del_min: "braun t \<Longrightarrow> braun(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: braun_sift_down
  dest: del_left_size del_left_braun)
done

lemma heap_del_min: "heap t \<Longrightarrow> braun t \<Longrightarrow> heap(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: heap_sift_down
  dest: del_left_size del_left_braun del_left_heap)
done

lemma mset_del_min: assumes "braun t" "t \<noteq> Leaf"
shows "mset_tree(del_min t) = mset_tree t - {#get_min t#}"
proof(cases t rule: del_min.cases)
  case 1 with assms show ?thesis by simp
next
  case 2 with assms show ?thesis by (simp)
next
  case [simp]: (3 ll b lr a r)
  have "mset_tree(sift_down r y l') = mset_tree t - {#a#}"
    if del: "del_left (Node ll b lr) = (y,l')" for y l'
    using assms del_left_mset[OF del] del_left_size[OF del]
      del_left_braun[OF del] del_left_mset_plus[OF del]
    apply (subst mset_sift_down)
    apply (auto simp: ac_simps del_left_mset_plus[OF del])
    done
  thus ?thesis by(auto split: prod.split)
qed

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation braun: Priority_Queue
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and insert = insert and del_min = del_min
and get_min = get_min and invar = "\<lambda>h. braun h \<and> heap h"
and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case 3 show ?case by(simp add: mset_insert)
next
  case 4 thus ?case by(simp add: mset_del_min)
next
  case 5 thus ?case using get_min mset_tree.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(simp add: heap_insert braun_insert)
next
  case 8 thus ?case by(simp add: heap_del_min braun_del_min)
qed

end


(*  Title:      HOL/Nunchaku_Examples/Typedef_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples featuring Nunchaku applied to typedefs.
*)

section {* Examples Featuring Nunchaku Applied to Typedefs *}

theory Typedef_Nuns
imports Complex_Main "../Nunchaku"
begin

nunchaku_params [verbose, timeout = 240]

definition "three = {0::nat, 1, 2}"
typedef three = three
unfolding three_def by blast

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

lemma "x = (y::three)"
nunchaku [expect = genuine]
oops

definition "one_or_two = {undefined False::'a, undefined True}"

typedef 'a one_or_two = "one_or_two :: 'a set"
unfolding one_or_two_def by auto

lemma "x = (y::unit one_or_two)"
nunchaku [expect = none]
sorry

lemma "x = (y::bool one_or_two)"
nunchaku [expect = genuine]
oops

lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> x = (y::bool one_or_two)"
nunchaku [expect = none]
sorry

lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> \<exists>x (y::bool one_or_two). x \<noteq> y"
nunchaku [expect = potential] (* unfortunate *)
oops

lemma "\<exists>x (y::bool one_or_two). x \<noteq> y"
nunchaku [expect = none]
oops

definition "bounded = {n::nat. finite (UNIV :: 'a set) \<longrightarrow> n < card (UNIV :: 'a set)}"

typedef 'a bounded = "bounded(TYPE('a))"
unfolding bounded_def
apply (rule_tac x = 0 in exI)
apply (case_tac "card UNIV = 0")
by auto

lemma "x = (y::unit bounded)"
nunchaku [expect = none]
sorry

lemma "x = (y::bool bounded)"
nunchaku [expect = genuine]
oops

lemma "x \<noteq> (y::bool bounded) \<Longrightarrow> z = x \<or> z = y"
nunchaku [expect = potential] (* unfortunate *)
sorry

lemma "x \<noteq> (y::(bool \<times> bool) bounded) \<Longrightarrow> z = x \<or> z = y"
nunchaku [expect = genuine]
oops

lemma "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"
nunchaku [expect = none]
by (rule True_def)

lemma "False \<equiv> \<forall>P. P"
nunchaku [expect = none]
by (rule False_def)

lemma "() = Abs_unit True"
nunchaku [expect = none]
by (rule Unity_def)

lemma "() = Abs_unit False"
nunchaku [expect = none]
by simp

lemma "Rep_unit () = True"
nunchaku [expect = none]
by (insert Rep_unit) simp

lemma "Rep_unit () = False"
nunchaku [expect = genuine]
oops

lemma "Pair a b = Abs_prod (Pair_Rep a b)"
nunchaku [expect = none]
by (rule Pair_def)

lemma "Pair a b = Abs_prod (Pair_Rep b a)"
nunchaku [expect = none]
nunchaku [dont_box, expect = genuine]
oops

lemma "fst (Abs_prod (Pair_Rep a b)) = a"
nunchaku [expect = none]
by (simp add: Pair_def [THEN sym])

lemma "fst (Abs_prod (Pair_Rep a b)) = b"
nunchaku [expect = none]
nunchaku [dont_box, expect = genuine]
oops

lemma "a \<noteq> a' \<Longrightarrow> Pair_Rep a b \<noteq> Pair_Rep a' b"
nunchaku [expect = none]
apply (rule ccontr)
apply simp
apply (drule subst [where P = "\<lambda>r. Abs_prod r = Abs_prod (Pair_Rep a b)"])
 apply (rule refl)
by (simp add: Pair_def [THEN sym])

lemma "Abs_prod (Rep_prod a) = a"
nunchaku [expect = none]
by (rule Rep_prod_inverse)

lemma "Inl \<equiv> \<lambda>a. Abs_sum (Inl_Rep a)"
nunchaku [expect = none]
by (simp add: Inl_def o_def)

lemma "Inl \<equiv> \<lambda>a. Abs_sum (Inr_Rep a)"
nunchaku [card "'a + 'a" = 2, expect = genuine]
oops

lemma "Inl_Rep a \<noteq> Inr_Rep a"
nunchaku [expect = none]
by (rule Inl_Rep_not_Inr_Rep)

lemma "Abs_sum (Rep_sum a) = a"
nunchaku [expect = none]
nunchaku [expect = none]
by (rule Rep_sum_inverse)

lemma "0::nat \<equiv> Abs_Nat Zero_Rep"
nunchaku [expect = none]
by (rule Zero_nat_def [abs_def])

lemma "Suc n = Abs_Nat (Suc_Rep (Rep_Nat n))"
nunchaku [expect = none]
by (rule Nat.Suc_def)

lemma "Suc n = Abs_Nat (Suc_Rep (Suc_Rep (Rep_Nat n)))"
nunchaku [expect = genuine]
oops

lemma "Abs_Nat (Rep_Nat a) = a"
nunchaku [expect = none]
by (rule Rep_Nat_inverse)

lemma "Abs_list (Rep_list a) = a"
(* nunchaku [expect = none] FIXME *)
by (rule Rep_list_inverse)

record point =
  Xcoord :: int
  Ycoord :: int

lemma "Abs_point_ext (Rep_point_ext a) = a"
nunchaku [expect = none]
by (fact Rep_point_ext_inverse)

lemma "Fract a b = of_int a / of_int b"
nunchaku [expect = none]
by (rule Fract_of_int_quotient)

lemma "Abs_rat (Rep_rat a) = a"
nunchaku [expect = none]
by (rule Rep_rat_inverse)

typedef check = "{x::nat. x < 2}" by (rule exI[of _ 0], auto)

lemma "Rep_check (Abs_check n) = n \<Longrightarrow> n < 2"
nunchaku [expect = none]
using Rep_check[of "Abs_check n"] by auto

lemma "Rep_check (Abs_check n) = n \<Longrightarrow> n < 1"
nunchaku [expect = genuine]
oops

end


theory topo_strict_implication
  imports topo_frontier_algebra
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Strict implication\<close>

text\<open>\noindent{We can also employ the closure and interior operations to define different sorts of implications.
In this section we preliminary explore a sort of strict implication and check some relevant properties.}\<close>

text\<open>\noindent{A 'strict' implication should entail the classical one. Hence we define it using the interior operator.}\<close>
definition imp_I::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infix "\<^bold>\<Rightarrow>" 51) where "\<alpha> \<^bold>\<Rightarrow> \<beta> \<equiv> \<I>(\<alpha> \<^bold>\<rightarrow> \<beta>)"
abbreviation imp_I'::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infix "\<^bold>\<Leftarrow>" 51) where "\<beta> \<^bold>\<Leftarrow> \<alpha> \<equiv> \<alpha> \<^bold>\<Rightarrow> \<beta>"
declare imp_I_def[conn]

text\<open>\noindent{Under appropriate conditions this implication satisfies a weak variant of the deduction theorem (DT),}\<close>
lemma DTw1: "\<forall>a b. a \<^bold>\<Rightarrow> b \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<preceq> b" by (simp add: Int_fr_def conn)

text\<open>\noindent{However the full DT (actually right-to-left: implication introduction) is not valid.}\<close>
lemma DT1: "\<forall>a b X. X \<^bold>\<preceq> a \<^bold>\<Rightarrow> b \<longrightarrow> X \<^bold>\<and> a \<^bold>\<preceq> b" by (simp add: Int_fr_def conn)
lemma DT2: "\<FF> \<F> \<Longrightarrow> \<forall>a b X. X \<^bold>\<and> a \<^bold>\<preceq> b \<longrightarrow> X \<^bold>\<preceq> a \<^bold>\<Rightarrow> b" nitpick oops (*counterexample*)

text\<open>\noindent{This implication has thus a sort of 'relevant' behaviour. For instance, the following are not valid:}\<close>
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> a)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> ((a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> b) \<^bold>\<or> (b \<^bold>\<Rightarrow> c) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. ((a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> a) \<^bold>\<Rightarrow> a \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample*)

text\<open>\noindent{In contrast the properties below are valid for appropriate conditions.}\<close>
lemma iprop0: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a. a \<^bold>\<Rightarrow> a \<^bold>\<approx> \<^bold>\<top>" using DTw2 pI2 by fastforce
lemma iprop1: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<and> (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> b  \<^bold>\<approx> \<^bold>\<top>" using DTw2 pI2 unfolding conn by fastforce
lemma iprop2: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>" using DTw2 pI2 unfolding conn by fastforce
lemma iprop3: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. ((a \<^bold>\<Rightarrow> a) \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> b \<^bold>\<approx> \<^bold>\<top>" using DTw2 pI2 unfolding conn by fastforce

lemma iprop7': "Fr_1 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> (b \<^bold>\<Rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<Rightarrow> c)" proof -
 assume fr1: "Fr_1 \<F>"
  { fix a b c
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> (b \<^bold>\<rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<rightarrow> c)" unfolding conn by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> (b \<^bold>\<rightarrow> c)) \<^bold>\<preceq> \<I>(a \<^bold>\<rightarrow> c)" using MONO_def PF1 fr1 monI by simp
    moreover from fr1 have "let A=(a \<^bold>\<rightarrow> b); B=(b \<^bold>\<rightarrow> c) in  \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I> A \<^bold>\<and> \<I> B" using IF1 MULT_def by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(b \<^bold>\<rightarrow> c) \<^bold>\<preceq> \<I>(a \<^bold>\<rightarrow> c)" unfolding conn by simp
  } thus ?thesis unfolding conn by blast
qed
lemma iprop7: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (b \<^bold>\<Rightarrow> c)) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> c) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop7')

lemma iprop8a': "Fr_1 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> c) \<^bold>\<preceq> a \<^bold>\<Rightarrow> (b \<^bold>\<and> c)" proof -
  assume fr1: "Fr_1 \<F>"
  { fix a b c
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> (a \<^bold>\<rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<rightarrow> (b \<^bold>\<and> c))" unfolding conn by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> (a \<^bold>\<rightarrow> c)) \<^bold>\<preceq> \<I>(a \<^bold>\<rightarrow> (b \<^bold>\<and> c))" using MONO_def PF1 fr1 monI by simp
    moreover from fr1 have "let A=(a \<^bold>\<rightarrow> b); B=(a \<^bold>\<rightarrow> c) in  \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I> A \<^bold>\<and> \<I> B" using IF1 MULT_def by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(a \<^bold>\<rightarrow> c) \<^bold>\<preceq> \<I>(a \<^bold>\<rightarrow> (b \<^bold>\<and> c))" unfolding conn by simp
  } thus ?thesis unfolding conn by simp
qed
lemma iprop8b': "Fr_1b \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> c) \<^bold>\<succeq> a \<^bold>\<Rightarrow> (b \<^bold>\<and> c)" by (smt MONO_def monI conn)
lemma iprop8a: "Fr_1 \<F>  \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> c)) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> (b \<^bold>\<and> c)) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop8a')
lemma iprop8b: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> c)) \<^bold>\<Leftarrow> (a \<^bold>\<Rightarrow> (b \<^bold>\<and> c)) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop8b')

lemma iprop9a': "Fr_1 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (c \<^bold>\<Rightarrow> b)) \<^bold>\<preceq> ((a \<^bold>\<or> c) \<^bold>\<Rightarrow> b)" proof -
  assume fr1: "Fr_1 \<F>"
  { fix a b c
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> (c \<^bold>\<rightarrow> b) \<^bold>\<preceq> (a \<^bold>\<or> c) \<^bold>\<rightarrow> b" unfolding conn by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> (c \<^bold>\<rightarrow> b)) \<^bold>\<preceq> \<I>((a \<^bold>\<or> c) \<^bold>\<rightarrow> b)" using MONO_def PF1 fr1 monI by simp
    moreover from fr1 have "let A=(a \<^bold>\<rightarrow> b); B=(c \<^bold>\<rightarrow> b) in  \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I> A \<^bold>\<and> \<I> B" using IF1 MULT_def by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(c \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<I>((a \<^bold>\<or> c) \<^bold>\<rightarrow> b)" unfolding conn by simp
  } thus ?thesis unfolding conn by simp
qed
lemma iprop9b': "Fr_1b \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (c \<^bold>\<Rightarrow> b)) \<^bold>\<succeq> ((a \<^bold>\<or> c) \<^bold>\<Rightarrow> b)" by (smt MONO_def monI conn)
lemma iprop9a: "Fr_1 \<F>  \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (c \<^bold>\<Rightarrow> b)) \<^bold>\<Rightarrow> ((a \<^bold>\<or> c) \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop9a')
lemma iprop9b: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> (c \<^bold>\<Rightarrow> b)) \<^bold>\<Leftarrow> ((a \<^bold>\<or> c) \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop9b')

lemma iprop10': "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c. a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> c)" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr4: "Fr_4 \<F>"
  { fix a b c
    have "a \<^bold>\<rightarrow> (b \<^bold>\<rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> (a \<^bold>\<rightarrow> c)" unfolding conn by simp
    hence "a \<^bold>\<rightarrow> (b \<^bold>\<Rightarrow> c) \<^bold>\<preceq> (a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> (a \<^bold>\<rightarrow> c)" using Int_fr_def conn by auto
    hence "\<I>(a \<^bold>\<rightarrow> (b \<^bold>\<Rightarrow> c)) \<^bold>\<preceq> \<I>((a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> (a \<^bold>\<rightarrow> c))" using MONO_def PF1 fr1 monI by simp
    moreover from fr1 have "let A=(a \<^bold>\<rightarrow> b); B=(a \<^bold>\<rightarrow> c) in \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<I> A \<^bold>\<rightarrow> \<I> B" using IF1 Int_7_def PI7 by auto
    ultimately have "\<I>(a \<^bold>\<rightarrow> (b \<^bold>\<Rightarrow> c)) \<^bold>\<preceq> \<I>(a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> \<I>(a \<^bold>\<rightarrow> c)" by (metis (full_types))
    hence "\<I>(\<I>(a \<^bold>\<rightarrow> (b \<^bold>\<Rightarrow> c))) \<^bold>\<preceq> \<I>(\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> \<I>(a \<^bold>\<rightarrow> c))" using MONO_def PF1 fr1 monI by simp
    hence "\<I>(a \<^bold>\<rightarrow> (b \<^bold>\<Rightarrow> c)) \<^bold>\<preceq> \<I>(\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<rightarrow> \<I>(a \<^bold>\<rightarrow> c))" using Int_Open PF1 fr1 fr2 fr4 by blast
    hence "(a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> c)) \<^bold>\<preceq> (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> c)" using Int_Open PF1 fr1 fr2 fr4 unfolding conn by blast
  } thus ?thesis by blast
qed
lemma iprop10: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> c)) \<^bold>\<Rightarrow> ((a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> c)) \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 iprop10')
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b c. a \<^bold>\<Rightarrow> (b \<^bold>\<Rightarrow> c) \<^bold>\<succeq> (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> c)" nitpick oops (*counterexample*)

lemma iprop11a': "Fr_1 \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<preceq> (a \<^bold>\<Rightarrow> b)" by (smt MONO_def PF1 imp_rel monI conn)
lemma iprop11b': "\<FF> \<F>    \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<succeq> (a \<^bold>\<Rightarrow> b)" unfolding PF1 by (metis Int_Open MONO_def imp_I_def impl_def monI)
lemma iprop11a: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F>  \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>" using DTw2 iprop11a' by blast
lemma iprop11b: "\<FF> \<F>                            \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<Leftarrow> (a \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>" using DTw2 iprop11b' by blast

text\<open>\noindent{In particular, 'strenghening the antecedent' is valid only under certain conditions:}\<close>
lemma SA':"Fr_1b \<F>                        \<Longrightarrow> \<forall>a b c.  a \<^bold>\<Rightarrow> c  \<^bold>\<preceq>  (a \<^bold>\<and> b) \<^bold>\<Rightarrow> c" by (smt MONO_def monI conn)
lemma SA: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> c) \<^bold>\<Rightarrow> ((a \<^bold>\<and> b) \<^bold>\<Rightarrow> c) \<^bold>\<approx> \<^bold>\<top>" using SA' using DTw2 by fastforce
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c.  a \<^bold>\<Rightarrow> c  \<^bold>\<preceq>  (a \<^bold>\<and> b) \<^bold>\<Rightarrow> c" nitpick oops (*counterexample*)
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> c) \<^bold>\<Rightarrow> ((a \<^bold>\<and> b) \<^bold>\<Rightarrow> c) \<^bold>\<approx> \<^bold>\<top>" nitpick oops  (*counterexample*)

text\<open>\noindent{Similarly, 'weakening the consequent' is valid only under certain conditions.}\<close>
lemma WC':"Fr_1b \<F> \<Longrightarrow>                        \<forall>a b c.  a \<^bold>\<Rightarrow> c  \<^bold>\<preceq>  a \<^bold>\<Rightarrow> (c \<^bold>\<or> b)" by (smt MONO_def monI conn)
lemma WC: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> c) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> (c \<^bold>\<or> b)) \<^bold>\<approx> \<^bold>\<top>" using DTw2 WC' by fastforce
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c.  a \<^bold>\<Rightarrow> c  \<^bold>\<preceq>  a \<^bold>\<Rightarrow> (c \<^bold>\<or> b)" nitpick oops (*counterexample*)
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>a b c. (a \<^bold>\<Rightarrow> c) \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> (c \<^bold>\<or> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample*)

end