(*  Title:      HOL/SMT_Examples/SMT_Examples_Verit.thy
    Author:     Sascha Boehme, TU Muenchen
    Author:     Mathias Fleury, JKU

Half of the examples come from the corresponding file for z3,
the others come from the Isabelle distribution or the AFP.
*)

section \<open>Examples for the (smt (verit)) binding\<close>

theory SMT_Examples_Verit
imports Complex_Main
begin

external_file \<open>SMT_Examples_Verit.certs\<close>

declare [[smt_certificates = "SMT_Examples_Verit.certs"]]
declare [[smt_read_only_certificates = true]]

section \<open>Propositional and first-order logic\<close>

lemma "True" by (smt (verit))
lemma "p \<or> \<not>p" by (smt (verit))
lemma "(p \<and> True) = p" by (smt (verit))
lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by (smt (verit))
lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by (smt (verit))
lemma "(p1 \<and> p2) \<or> p3 \<longrightarrow> (p1 \<longrightarrow> (p3 \<and> p2) \<or> (p1 \<and> p3)) \<or> p1" by (smt (verit))
lemma "P = P = P = P = P = P = P = P = P = P" by (smt (verit))

lemma
  assumes "a \<or> b \<or> c \<or> d"
      and "e \<or> f \<or> (a \<and> d)"
      and "\<not> (a \<or> (c \<and> ~c)) \<or> b"
      and "\<not> (b \<and> (x \<or> \<not> x)) \<or> c"
      and "\<not> (d \<or> False) \<or> c"
      and "\<not> (c \<or> (\<not> p \<and> (p \<or> (q \<and> \<not> q))))"
  shows False
  using assms by (smt (verit))

axiomatization symm_f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  symm_f: "symm_f x y = symm_f y x"

lemma "a = a \<and> symm_f a b = symm_f b a"
  by (smt (verit) symm_f)

(*
Taken from ~~/src/HOL/ex/SAT_Examples.thy.
Translated from TPTP problem library: PUZ015-2.006.dimacs
*)
lemma
  assumes "~x0"
  and "~x30"
  and "~x29"
  and "~x59"
  and "x1 \<or> x31 \<or> x0"
  and "x2 \<or> x32 \<or> x1"
  and "x3 \<or> x33 \<or> x2"
  and "x4 \<or> x34 \<or> x3"
  and "x35 \<or> x4"
  and "x5 \<or> x36 \<or> x30"
  and "x6 \<or> x37 \<or> x5 \<or> x31"
  and "x7 \<or> x38 \<or> x6 \<or> x32"
  and "x8 \<or> x39 \<or> x7 \<or> x33"
  and "x9 \<or> x40 \<or> x8 \<or> x34"
  and "x41 \<or> x9 \<or> x35"
  and "x10 \<or> x42 \<or> x36"
  and "x11 \<or> x43 \<or> x10 \<or> x37"
  and "x12 \<or> x44 \<or> x11 \<or> x38"
  and "x13 \<or> x45 \<or> x12 \<or> x39"
  and "x14 \<or> x46 \<or> x13 \<or> x40"
  and "x47 \<or> x14 \<or> x41"
  and "x15 \<or> x48 \<or> x42"
  and "x16 \<or> x49 \<or> x15 \<or> x43"
  and "x17 \<or> x50 \<or> x16 \<or> x44"
  and "x18 \<or> x51 \<or> x17 \<or> x45"
  and "x19 \<or> x52 \<or> x18 \<or> x46"
  and "x53 \<or> x19 \<or> x47"
  and "x20 \<or> x54 \<or> x48"
  and "x21 \<or> x55 \<or> x20 \<or> x49"
  and "x22 \<or> x56 \<or> x21 \<or> x50"
  and "x23 \<or> x57 \<or> x22 \<or> x51"
  and "x24 \<or> x58 \<or> x23 \<or> x52"
  and "x59 \<or> x24 \<or> x53"
  and "x25 \<or> x54"
  and "x26 \<or> x25 \<or> x55"
  and "x27 \<or> x26 \<or> x56"
  and "x28 \<or> x27 \<or> x57"
  and "x29 \<or> x28 \<or> x58"
  and "~x1 \<or> ~x31"
  and "~x1 \<or> ~x0"
  and "~x31 \<or> ~x0"
  and "~x2 \<or> ~x32"
  and "~x2 \<or> ~x1"
  and "~x32 \<or> ~x1"
  and "~x3 \<or> ~x33"
  and "~x3 \<or> ~x2"
  and "~x33 \<or> ~x2"
  and "~x4 \<or> ~x34"
  and "~x4 \<or> ~x3"
  and "~x34 \<or> ~x3"
  and "~x35 \<or> ~x4"
  and "~x5 \<or> ~x36"
  and "~x5 \<or> ~x30"
  and "~x36 \<or> ~x30"
  and "~x6 \<or> ~x37"
  and "~x6 \<or> ~x5"
  and "~x6 \<or> ~x31"
  and "~x37 \<or> ~x5"
  and "~x37 \<or> ~x31"
  and "~x5 \<or> ~x31"
  and "~x7 \<or> ~x38"
  and "~x7 \<or> ~x6"
  and "~x7 \<or> ~x32"
  and "~x38 \<or> ~x6"
  and "~x38 \<or> ~x32"
  and "~x6 \<or> ~x32"
  and "~x8 \<or> ~x39"
  and "~x8 \<or> ~x7"
  and "~x8 \<or> ~x33"
  and "~x39 \<or> ~x7"
  and "~x39 \<or> ~x33"
  and "~x7 \<or> ~x33"
  and "~x9 \<or> ~x40"
  and "~x9 \<or> ~x8"
  and "~x9 \<or> ~x34"
  and "~x40 \<or> ~x8"
  and "~x40 \<or> ~x34"
  and "~x8 \<or> ~x34"
  and "~x41 \<or> ~x9"
  and "~x41 \<or> ~x35"
  and "~x9 \<or> ~x35"
  and "~x10 \<or> ~x42"
  and "~x10 \<or> ~x36"
  and "~x42 \<or> ~x36"
  and "~x11 \<or> ~x43"
  and "~x11 \<or> ~x10"
  and "~x11 \<or> ~x37"
  and "~x43 \<or> ~x10"
  and "~x43 \<or> ~x37"
  and "~x10 \<or> ~x37"
  and "~x12 \<or> ~x44"
  and "~x12 \<or> ~x11"
  and "~x12 \<or> ~x38"
  and "~x44 \<or> ~x11"
  and "~x44 \<or> ~x38"
  and "~x11 \<or> ~x38"
  and "~x13 \<or> ~x45"
  and "~x13 \<or> ~x12"
  and "~x13 \<or> ~x39"
  and "~x45 \<or> ~x12"
  and "~x45 \<or> ~x39"
  and "~x12 \<or> ~x39"
  and "~x14 \<or> ~x46"
  and "~x14 \<or> ~x13"
  and "~x14 \<or> ~x40"
  and "~x46 \<or> ~x13"
  and "~x46 \<or> ~x40"
  and "~x13 \<or> ~x40"
  and "~x47 \<or> ~x14"
  and "~x47 \<or> ~x41"
  and "~x14 \<or> ~x41"
  and "~x15 \<or> ~x48"
  and "~x15 \<or> ~x42"
  and "~x48 \<or> ~x42"
  and "~x16 \<or> ~x49"
  and "~x16 \<or> ~x15"
  and "~x16 \<or> ~x43"
  and "~x49 \<or> ~x15"
  and "~x49 \<or> ~x43"
  and "~x15 \<or> ~x43"
  and "~x17 \<or> ~x50"
  and "~x17 \<or> ~x16"
  and "~x17 \<or> ~x44"
  and "~x50 \<or> ~x16"
  and "~x50 \<or> ~x44"
  and "~x16 \<or> ~x44"
  and "~x18 \<or> ~x51"
  and "~x18 \<or> ~x17"
  and "~x18 \<or> ~x45"
  and "~x51 \<or> ~x17"
  and "~x51 \<or> ~x45"
  and "~x17 \<or> ~x45"
  and "~x19 \<or> ~x52"
  and "~x19 \<or> ~x18"
  and "~x19 \<or> ~x46"
  and "~x52 \<or> ~x18"
  and "~x52 \<or> ~x46"
  and "~x18 \<or> ~x46"
  and "~x53 \<or> ~x19"
  and "~x53 \<or> ~x47"
  and "~x19 \<or> ~x47"
  and "~x20 \<or> ~x54"
  and "~x20 \<or> ~x48"
  and "~x54 \<or> ~x48"
  and "~x21 \<or> ~x55"
  and "~x21 \<or> ~x20"
  and "~x21 \<or> ~x49"
  and "~x55 \<or> ~x20"
  and "~x55 \<or> ~x49"
  and "~x20 \<or> ~x49"
  and "~x22 \<or> ~x56"
  and "~x22 \<or> ~x21"
  and "~x22 \<or> ~x50"
  and "~x56 \<or> ~x21"
  and "~x56 \<or> ~x50"
  and "~x21 \<or> ~x50"
  and "~x23 \<or> ~x57"
  and "~x23 \<or> ~x22"
  and "~x23 \<or> ~x51"
  and "~x57 \<or> ~x22"
  and "~x57 \<or> ~x51"
  and "~x22 \<or> ~x51"
  and "~x24 \<or> ~x58"
  and "~x24 \<or> ~x23"
  and "~x24 \<or> ~x52"
  and "~x58 \<or> ~x23"
  and "~x58 \<or> ~x52"
  and "~x23 \<or> ~x52"
  and "~x59 \<or> ~x24"
  and "~x59 \<or> ~x53"
  and "~x24 \<or> ~x53"
  and "~x25 \<or> ~x54"
  and "~x26 \<or> ~x25"
  and "~x26 \<or> ~x55"
  and "~x25 \<or> ~x55"
  and "~x27 \<or> ~x26"
  and "~x27 \<or> ~x56"
  and "~x26 \<or> ~x56"
  and "~x28 \<or> ~x27"
  and "~x28 \<or> ~x57"
  and "~x27 \<or> ~x57"
  and "~x29 \<or> ~x28"
  and "~x29 \<or> ~x58"
  and "~x28 \<or> ~x58"
shows False
  using assms by (smt (verit))

lemma "\<forall>x::int. P x \<longrightarrow> (\<forall>y::int. P x \<or> P y)"
  by (smt (verit))

lemma
  assumes "(\<forall>x y. P x y = x)"
  shows "(\<exists>y. P x y) = P x c"
  using assms by (smt (verit))

lemma
  assumes "(\<forall>x y. P x y = x)"
  and "(\<forall>x. \<exists>y. P x y) = (\<forall>x. P x c)"
  shows "(\<exists>y. P x y) = P x c"
  using assms by (smt (verit))

lemma
  assumes "if P x then \<not>(\<exists>y. P y) else (\<forall>y. \<not>P y)"
  shows "P x \<longrightarrow> P y"
  using assms by (smt (verit))

section \<open>Arithmetic\<close>

subsection \<open>Linear arithmetic over integers and reals\<close>

lemma "(3::int) = 3" by (smt (verit))
lemma "(3::real) = 3" by (smt (verit))
lemma "(3 :: int) + 1 = 4" by (smt (verit))
lemma "x + (y + z) = y + (z + (x::int))" by (smt (verit))
lemma "max (3::int) 8 > 5" by (smt (verit))
lemma "\<bar>x :: real\<bar> + \<bar>y\<bar> \<ge> \<bar>x + y\<bar>" by (smt (verit))
lemma "P ((2::int) < 3) = P True" supply[[smt_trace]] by (smt (verit))
lemma "x + 3 \<ge> 4 \<or> x < (1::int)" by (smt (verit))

lemma
  assumes "x \<ge> (3::int)" and "y = x + 4"
  shows "y - x > 0"
  using assms by (smt (verit))

lemma "let x = (2 :: int) in x + x \<noteq> 5" by (smt (verit))

lemma
  fixes x :: int
  assumes "3 * x + 7 * a < 4" and "3 < 2 * x"
  shows "a < 0"
  using assms by (smt (verit))

lemma "(0 \<le> y + -1 * x \<or> \<not> 0 \<le> x \<or> 0 \<le> (x::int)) = (\<not> False)" by (smt (verit))

lemma "
  (n < m \<and> m < n') \<or> (n < m \<and> m = n') \<or> (n < n' \<and> n' < m) \<or>
  (n = n' \<and> n' < m) \<or> (n = m \<and> m < n') \<or>
  (n' < m \<and> m < n) \<or> (n' < m \<and> m = n) \<or>
  (n' < n \<and> n < m) \<or> (n' = n \<and> n < m) \<or> (n' = m \<and> m < n) \<or>
  (m < n \<and> n < n') \<or> (m < n \<and> n' = n) \<or> (m < n' \<and> n' < n) \<or>
  (m = n \<and> n < n') \<or> (m = n' \<and> n' < n) \<or>
  (n' = m \<and> m = (n::int))"
  by (smt (verit))

text\<open>
The following example was taken from HOL/ex/PresburgerEx.thy, where it says:

  This following theorem proves that all solutions to the
  recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
  period 9.  The example was brought to our attention by John
  Harrison. It does does not require Presburger arithmetic but merely
  quantifier-free linear arithmetic and holds for the rationals as well.

  Warning: it takes (in 2006) over 4.2 minutes!

There, it is proved by "arith". (smt (verit)) is able to prove this within a fraction
of one second. With proof reconstruction, it takes about 13 seconds on a Core2
processor.
\<close>

lemma "\<lbrakk> x3 = \<bar>x2\<bar> - x1; x4 = \<bar>x3\<bar> - x2; x5 = \<bar>x4\<bar> - x3;
         x6 = \<bar>x5\<bar> - x4; x7 = \<bar>x6\<bar> - x5; x8 = \<bar>x7\<bar> - x6;
         x9 = \<bar>x8\<bar> - x7; x10 = \<bar>x9\<bar> - x8; x11 = \<bar>x10\<bar> - x9 \<rbrakk>
 \<Longrightarrow> x1 = x10 \<and> x2 = (x11::int)"
  by (smt (verit))

lemma "let P = 2 * x + 1 > x + (x::real) in P \<or> False \<or> P" by (smt (verit))

subsection \<open>Linear arithmetic with quantifiers\<close>

lemma "~ (\<exists>x::int. False)" by (smt (verit))
lemma "~ (\<exists>x::real. False)" by (smt (verit))

lemma "\<forall>x y::int. (x = 0 \<and> y = 1) \<longrightarrow> x \<noteq> y" by (smt (verit))
lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by (smt (verit))
lemma "\<forall>x y::int. x + y > 2 \<or> x + y = 2 \<or> x + y < 2" by (smt (verit))
lemma "\<forall>x::int. if x > 0 then x + 1 > 0 else 1 > x" by (smt (verit))
lemma "(if (\<forall>x::int. x < 0 \<or> x > 0) then -1 else 3) > (0::int)" by (smt (verit))
lemma "\<exists>x::int. \<forall>x y. 0 < x \<and> 0 < y \<longrightarrow> (0::int) < x + y" by (smt (verit))
lemma "\<exists>u::int. \<forall>(x::int) y::real. 0 < x \<and> 0 < y \<longrightarrow> -1 < x" by (smt (verit))
lemma "\<forall>(a::int) b::int. 0 < b \<or> b < 1" by (smt (verit))

subsection \<open>Linear arithmetic for natural numbers\<close>

declare [[smt_nat_as_int]]

lemma "2 * (x::nat) \<noteq> 1" by (smt (verit))

lemma "a < 3 \<Longrightarrow> (7::nat) > 2 * a" by (smt (verit))

lemma "let x = (1::nat) + y in x - y > 0 * x" by (smt (verit))

lemma
  "let x = (1::nat) + y in
   let P = (if x > 0 then True else False) in
   False \<or> P = (x - 1 = y) \<or> (\<not>P \<longrightarrow> False)"
  by (smt (verit))

lemma "int (nat \<bar>x::int\<bar>) = \<bar>x\<bar>" by (smt (verit) int_nat_eq)

definition prime_nat :: "nat \<Rightarrow> bool" where
  "prime_nat p = (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"

lemma "prime_nat (4*m + 1) \<Longrightarrow> m \<ge> (1::nat)" by (smt (verit) prime_nat_def)

lemma "2 * (x::nat) \<noteq> 1"
  by (smt (verit))

lemma \<open>2*(x :: int) \<noteq> 1\<close>
  by (smt (verit))

declare [[smt_nat_as_int = false]]

section \<open>Pairs\<close>

lemma "fst (x, y) = a \<Longrightarrow> x = a"
  using fst_conv by (smt (verit))

lemma "p1 = (x, y) \<and> p2 = (y, x) \<Longrightarrow> fst p1 = snd p2"
  using fst_conv snd_conv by (smt (verit))

section \<open>Higher-order problems and recursion\<close>

lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> (f (i1 := v1, i2 := v2)) i = f i"
  using fun_upd_same fun_upd_apply by (smt (verit))

lemma "(f g (x::'a::type) = (g x \<and> True)) \<or> (f g x = True) \<or> (g x = True)"
  by (smt (verit))

lemma "id x = x \<and> id True = True"
  by (smt (verit) id_def)

lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> ((f (i1 := v1)) (i2 := v2)) i = f i"
  using fun_upd_same fun_upd_apply by (smt (verit))

lemma
  "f (\<exists>x. g x) \<Longrightarrow> True"
  "f (\<forall>x. g x) \<Longrightarrow> True"
  by (smt (verit))+

lemma True using let_rsp by (smt (verit))
lemma "le = (\<le>) \<Longrightarrow> le (3::int) 42" by (smt (verit))
lemma "map (\<lambda>i::int. i + 1) [0, 1] = [1, 2]" by (smt (verit) list.map)
lemma "(\<forall>x. P x) \<or> \<not> All P" by (smt (verit))

fun dec_10 :: "int \<Rightarrow> int" where
  "dec_10 n = (if n < 10 then n else dec_10 (n - 10))"

lemma "dec_10 (4 * dec_10 4) = 6" by (smt (verit) dec_10.simps)

context complete_lattice
begin

lemma
  assumes "Sup {a | i::bool. True} \<le> Sup {b | i::bool. True}"
  and "Sup {b | i::bool. True} \<le> Sup {a | i::bool. True}"
  shows "Sup {a | i::bool. True} \<le> Sup {a | i::bool. True}"
  using assms by (smt (verit) order_trans)

end

lemma
 "eq_set (List.coset xs) (set ys) = rhs"
    if "\<And>ys. subset' (List.coset xs) (set ys) = (let n = card (UNIV::'a set) in 0 < n \<and> card (set (xs @ ys)) = n)"
      and "\<And>uu A. (uu::'a) \<in> - A \<Longrightarrow> uu \<notin> A"
      and "\<And>uu. card (set (uu::'a list)) = length (remdups uu)"
      and "\<And>uu. finite (set (uu::'a list))"
      and "\<And>uu. (uu::'a) \<in> UNIV"
      and "(UNIV::'a set) \<noteq> {}"
      and "\<And>c A B P. \<lbrakk>(c::'a) \<in> A \<union> B; c \<in> A \<Longrightarrow> P; c \<in> B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
      and "\<And>a b. (a::nat) + b = b + a"
      and "\<And>a b. ((a::nat) = a + b) = (b = 0)"
      and "card' (set xs) = length (remdups xs)"
      and "card' = (card :: 'a set \<Rightarrow> nat)"
      and "\<And>A B. \<lbrakk>finite (A::'a set); finite B\<rbrakk> \<Longrightarrow> card A + card B = card (A \<union> B) + card (A \<inter> B)"
      and "\<And>A. (card (A::'a set) = 0) = (A = {} \<or> infinite A)"
      and "\<And>A. \<lbrakk>finite (UNIV::'a set); card (A::'a set) = card (UNIV::'a set)\<rbrakk> \<Longrightarrow> A = UNIV"
      and "\<And>xs. - List.coset (xs::'a list) = set xs"
      and "\<And>xs. - set (xs::'a list) = List.coset xs"
      and "\<And>A B. (A \<inter> B = {}) = (\<forall>x. (x::'a) \<in> A \<longrightarrow> x \<notin> B)"
      and "eq_set = (=)"
      and "\<And>A. finite (A::'a set) \<Longrightarrow> finite (- A) = finite (UNIV::'a set)"
      and "rhs \<equiv> let n = card (UNIV::'a set) in if n = 0 then False else let xs' = remdups xs; ys' = remdups ys in length xs' + length ys' = n \<and> (\<forall>x\<in>set xs'. x \<notin> set ys') \<and> (\<forall>y\<in>set ys'. y \<notin> set xs')"
      and "\<And>xs ys. set ((xs::'a list) @ ys) = set xs \<union> set ys"
      and "\<And>A B. ((A::'a set) = B) = (A \<subseteq> B \<and> B \<subseteq> A)"
      and "\<And>xs. set (remdups (xs::'a list)) = set xs"
      and "subset' = (\<subseteq>)"
      and "\<And>A B. (\<And>x. (x::'a) \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> A \<subseteq> B"
      and "\<And>A B. \<lbrakk>(A::'a set) \<subseteq> B; B \<subseteq> A\<rbrakk> \<Longrightarrow> A = B"
      and "\<And>A ys. (A \<subseteq> List.coset ys) = (\<forall>y\<in>set ys. (y::'a) \<notin> A)"
  using that by (smt (verit, default))

notepad
begin
  have "line_integral F {i, j} g = line_integral F {i} g + line_integral F {j} g"
    if \<open>(k, g) \<in> one_chain_typeI\<close>
      \<open>\<And>A b B. ({} = (A::(real \<times> real) set) \<inter> insert (b::real \<times> real) (B::(real \<times> real) set)) = (b \<notin> A \<and> {} = A \<inter> B)\<close>
      \<open>finite ({} :: (real \<times> real) set)\<close>
      \<open>\<And>a A. finite (A::(real \<times> real) set) \<Longrightarrow> finite (insert (a::real \<times> real) A)\<close>
      \<open>(i::real \<times> real) = (1::real, 0::real)\<close>
      \<open> \<And>a A. (a::real \<times> real) \<in> (A::(real \<times> real) set) \<Longrightarrow> insert a A = A\<close> \<open>j = (0, 1)\<close>
      \<open>\<And>x. (x::(real \<times> real) set) \<inter> {} = {}\<close>
      \<open>\<And>y x A. insert (x::real \<times> real) (insert (y::real \<times> real) (A::(real \<times> real) set)) =  insert y (insert x A)\<close>
      \<open>\<And>a A. insert (a::real \<times> real) (A::(real \<times> real) set) = {a} \<union> A\<close>
      \<open>\<And>F u basis2 basis1 \<gamma>. finite (u :: (real \<times> real) set) \<Longrightarrow>
    line_integral_exists F basis1 \<gamma> \<Longrightarrow>
    line_integral_exists F basis2 \<gamma> \<Longrightarrow>
    basis1 \<union> basis2 = u \<Longrightarrow>
    basis1 \<inter> basis2 = {} \<Longrightarrow>
    line_integral F u \<gamma> = line_integral F basis1 \<gamma> + line_integral F basis2 \<gamma>\<close>
      \<open>one_chain_line_integral F {i} one_chain_typeI =
    one_chain_line_integral F {i} one_chain_typeII \<and>
    (\<forall>(k, \<gamma>)\<in>one_chain_typeI. line_integral_exists F {i} \<gamma>) \<and>
    (\<forall>(k, \<gamma>)\<in>one_chain_typeII. line_integral_exists F {i} \<gamma>)\<close>
      \<open> one_chain_line_integral (F::real \<times> real \<Rightarrow> real \<times> real) {j::real \<times> real}
     (one_chain_typeII::(int \<times> (real \<Rightarrow> real \<times> real)) set) =
    one_chain_line_integral F {j} (one_chain_typeI::(int \<times> (real \<Rightarrow> real \<times> real)) set) \<and>
    (\<forall>(k::int, \<gamma>::real \<Rightarrow> real \<times> real)\<in>one_chain_typeII. line_integral_exists F {j} \<gamma>) \<and>
    (\<forall>(k::int, \<gamma>::real \<Rightarrow> real \<times> real)\<in>one_chain_typeI. line_integral_exists F {j} \<gamma>)\<close>
    for F i j g one_chain_typeI one_chain_typeII and
      line_integral :: \<open>(real \<times> real \<Rightarrow> real \<times> real) \<Rightarrow> (real \<times> real) set \<Rightarrow> (real \<Rightarrow> real \<times> real) \<Rightarrow> real\<close> and
      line_integral_exists :: \<open>(real \<times> real \<Rightarrow> real \<times> real) \<Rightarrow> (real \<times> real) set \<Rightarrow> (real \<Rightarrow> real \<times> real) \<Rightarrow> bool\<close> and
      one_chain_line_integral :: \<open>(real \<times> real \<Rightarrow> real \<times> real) \<Rightarrow> (real \<times> real) set \<Rightarrow> (int \<times> (real \<Rightarrow> real \<times> real)) set \<Rightarrow> real\<close> and
      k
    using prod.case_eq_if singleton_inject snd_conv
      that
    by (smt (verit))
end

lemma
  fixes x y z :: real
  assumes \<open>x + 2 * y > 0\<close> and
    \<open>x - 2 * y > 0\<close> and
    \<open>x < 0\<close>
  shows False
  using assms by (smt (verit))

(*test for arith reconstruction*)
lemma
  fixes d :: real
  assumes \<open>0 < d\<close>
   \<open>diamond_y \<equiv> \<lambda>t. d / 2 - \<bar>t\<bar>\<close>
   \<open>\<And>a b c :: real. (a / c < b / c) =
    ((0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0)\<close>
   \<open>\<And>a b c :: real. (a / c < b / c) =
    ((0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0)\<close>
   \<open>\<And>a b :: real. - a / b = - (a / b)\<close>
   \<open>\<And>a b :: real. - a * b = - (a * b)\<close>
   \<open>\<And>(x1 :: real) x2 y1 y2 :: real. ((x1, x2) = (y1, y2)) = (x1 = y1 \<and> x2 = y2)\<close>
 shows \<open>(\<lambda>y. (d / 2, (2 * y - 1) * diamond_y (d / 2))) \<noteq>
    (\<lambda>x. ((x - 1 / 2) * d, - diamond_y ((x - 1 / 2) * d))) \<Longrightarrow>
    (\<lambda>y. (- (d / 2), (2 * y - 1) * diamond_y (- (d / 2)))) =
    (\<lambda>x. ((x - 1 / 2) * d, diamond_y ((x - 1 / 2) * d))) \<Longrightarrow>
    False\<close>
  using assms
  by (smt (verit,del_insts))

lemma
  fixes d :: real
  assumes \<open>0 < d\<close>
   \<open>diamond_y \<equiv> \<lambda>t. d / 2 - \<bar>t\<bar>\<close>
   \<open>\<And>a b c :: real. (a / c < b / c) =
    ((0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0)\<close>
   \<open>\<And>a b c :: real. (a / c < b / c) =
    ((0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0)\<close>
   \<open>\<And>a b :: real. - a / b = - (a / b)\<close>
   \<open>\<And>a b :: real. - a * b = - (a * b)\<close>
   \<open>\<And>(x1 :: real) x2 y1 y2 :: real. ((x1, x2) = (y1, y2)) = (x1 = y1 \<and> x2 = y2)\<close>
 shows \<open>(\<lambda>y. (d / 2, (2 * y - 1) * diamond_y (d / 2))) \<noteq>
    (\<lambda>x. ((x - 1 / 2) * d, - diamond_y ((x - 1 / 2) * d))) \<Longrightarrow>
    (\<lambda>y. (- (d / 2), (2 * y - 1) * diamond_y (- (d / 2)))) =
    (\<lambda>x. ((x - 1 / 2) * d, diamond_y ((x - 1 / 2) * d))) \<Longrightarrow>
    False\<close>
  using assms
  by (smt (verit,ccfv_threshold))

(*qnt_rm_unused example*)
lemma
  assumes \<open>\<forall>z y x. P z y\<close>
    \<open>P z y \<Longrightarrow> False\<close>
  shows False
  using assms
  by (smt (verit))

lemma
  "max (x::int) y \<ge> y"
  supply [[smt_trace]]
  by (smt (verit))+

context
begin
abbreviation finite' :: "'a set \<Rightarrow> bool"
  where "finite' A \<equiv> finite A \<and> A \<noteq> {}"

lemma
  fixes f :: "'b \<Rightarrow> 'c :: linorder"
  assumes
    \<open>\<forall>(S::'b::type set) f::'b::type \<Rightarrow> 'c::linorder. finite' S \<longrightarrow> arg_min_on f S \<in> S\<close>
    \<open>\<forall>(S::'a::type set) f::'a::type \<Rightarrow> 'c::linorder. finite' S \<longrightarrow> arg_min_on f S \<in> S\<close>
    \<open>\<forall>(S::'b::type set) (y::'b::type) f::'b::type \<Rightarrow> 'c::linorder.
       finite S \<and> S \<noteq> {} \<and> y \<in> S \<longrightarrow> f (arg_min_on f S) \<le> f y\<close>
    \<open>\<forall>(S::'a::type set) (y::'a::type) f::'a::type \<Rightarrow> 'c::linorder.
       finite S \<and> S \<noteq> {} \<and> y \<in> S \<longrightarrow> f (arg_min_on f S) \<le> f y\<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'c::linorder) (g::'a::type \<Rightarrow> 'b::type) x::'a::type. (f \<circ> g) x = f (g x)\<close>
    \<open>\<forall>(F::'b::type set) h::'b::type \<Rightarrow> 'a::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'b::type set) h::'b::type \<Rightarrow> 'b::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'a::type set) h::'a::type \<Rightarrow> 'b::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'a::type set) h::'a::type \<Rightarrow> 'a::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(b::'a::type) (f::'b::type \<Rightarrow> 'a::type) A::'b::type set.
       b \<in> f ` A \<and> (\<forall>x::'b::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'b::type) (f::'b::type \<Rightarrow> 'b::type) A::'b::type set.
       b \<in> f ` A \<and> (\<forall>x::'b::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'b::type) (f::'a::type \<Rightarrow> 'b::type) A::'a::type set.
       b \<in> f ` A \<and> (\<forall>x::'a::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'a::type) (f::'a::type \<Rightarrow> 'a::type) A::'a::type set.
       b \<in> f ` A \<and> (\<forall>x::'a::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'a::type) (f::'b::type \<Rightarrow> 'a::type) (x::'b::type) A::'b::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A    \<close>
    \<open>\<forall>(b::'b::type) (f::'b::type \<Rightarrow> 'b::type) (x::'b::type) A::'b::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A    \<close>
    \<open>\<forall>(b::'b::type) (f::'a::type \<Rightarrow> 'b::type) (x::'a::type) A::'a::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A    \<close>
    \<open>\<forall>(b::'a::type) (f::'a::type \<Rightarrow> 'a::type) (x::'a::type) A::'a::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A    \<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'a::type) A::'b::type set. (f ` A = {}) = (A = {})  \<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'b::type) A::'b::type set. (f ` A = {}) = (A = {})  \<close>
    \<open>\<forall>(f::'a::type \<Rightarrow> 'b::type) A::'a::type set. (f ` A = {}) = (A = {})  \<close>
    \<open>\<forall>(f::'a::type \<Rightarrow> 'a::type) A::'a::type set. (f ` A = {}) = (A = {})  \<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'c::linorder) (A::'b::type set) (x::'b::type) y::'b::type.
       inj_on f A \<and> f x = f y \<and> x \<in> A \<and> y \<in> A \<longrightarrow> x = y\<close>
    \<open>\<forall>(x::'c::linorder) y::'c::linorder. (x < y) = (x \<le> y \<and> x \<noteq> y)\<close>
    \<open>inj_on (f::'b::type \<Rightarrow> 'c::linorder) ((g::'a::type \<Rightarrow> 'b::type) ` (B::'a::type set))\<close>
    \<open>finite (B::'a::type set)\<close>
    \<open>(B::'a::type set) \<noteq> {}\<close>
    \<open>arg_min_on ((f::'b::type \<Rightarrow> 'c::linorder) \<circ> (g::'a::type \<Rightarrow> 'b::type)) (B::'a::type set) \<in> B\<close>
    \<open>\<nexists>x::'a::type.
       x \<in> (B::'a::type set) \<and>
       ((f::'b::type \<Rightarrow> 'c::linorder) \<circ> (g::'a::type \<Rightarrow> 'b::type)) x < (f \<circ> g) (arg_min_on (f \<circ> g) B)\<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'c::linorder) (P::'b::type \<Rightarrow> bool) a::'b::type.
       inj_on f (Collect P) \<and> P a \<and> (\<forall>y::'b::type. P y \<longrightarrow> f a \<le> f y) \<longrightarrow> arg_min f P = a\<close>
    \<open>\<forall>(S::'b::type set) f::'b::type \<Rightarrow> 'c::linorder. finite' S \<longrightarrow> arg_min_on f S \<in> S\<close>
    \<open>\<forall>(S::'a::type set) f::'a::type \<Rightarrow> 'c::linorder. finite' S \<longrightarrow> arg_min_on f S \<in> S\<close>
    \<open>\<forall>(S::'b::type set) (y::'b::type) f::'b::type \<Rightarrow> 'c::linorder.
       finite S \<and> S \<noteq> {} \<and> y \<in> S \<longrightarrow> f (arg_min_on f S) \<le> f y\<close>
    \<open>\<forall>(S::'a::type set) (y::'a::type) f::'a::type \<Rightarrow> 'c::linorder.
       finite S \<and> S \<noteq> {} \<and> y \<in> S \<longrightarrow> f (arg_min_on f S) \<le> f y\<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'c::linorder) (g::'a::type \<Rightarrow> 'b::type) x::'a::type. (f \<circ> g) x = f (g x)\<close>
    \<open>\<forall>(F::'b::type set) h::'b::type \<Rightarrow> 'a::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'b::type set) h::'b::type \<Rightarrow> 'b::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'a::type set) h::'a::type \<Rightarrow> 'b::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(F::'a::type set) h::'a::type \<Rightarrow> 'a::type. finite F \<longrightarrow> finite (h ` F)\<close>
    \<open>\<forall>(b::'a::type) (f::'b::type \<Rightarrow> 'a::type) A::'b::type set.
       b \<in> f ` A \<and> (\<forall>x::'b::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'b::type) (f::'b::type \<Rightarrow> 'b::type) A::'b::type set.
       b \<in> f ` A \<and> (\<forall>x::'b::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'b::type) (f::'a::type \<Rightarrow> 'b::type) A::'a::type set.
       b \<in> f ` A \<and> (\<forall>x::'a::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'a::type) (f::'a::type \<Rightarrow> 'a::type) A::'a::type set.
       b \<in> f ` A \<and> (\<forall>x::'a::type. b = f x \<and> x \<in> A \<longrightarrow> False) \<longrightarrow> False\<close>
    \<open>\<forall>(b::'a::type) (f::'b::type \<Rightarrow> 'a::type) (x::'b::type) A::'b::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A \<close>
    \<open>\<forall>(b::'b::type) (f::'b::type \<Rightarrow> 'b::type) (x::'b::type) A::'b::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A \<close>
    \<open>\<forall>(b::'b::type) (f::'a::type \<Rightarrow> 'b::type) (x::'a::type) A::'a::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A \<close>
    \<open>\<forall>(b::'a::type) (f::'a::type \<Rightarrow> 'a::type) (x::'a::type) A::'a::type set. b = f x \<and> x \<in> A \<longrightarrow> b \<in> f ` A \<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'a::type) A::'b::type set. (f ` A = {}) = (A = {})      \<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'b::type) A::'b::type set. (f ` A = {}) = (A = {})      \<close>
    \<open>\<forall>(f::'a::type \<Rightarrow> 'b::type) A::'a::type set. (f ` A = {}) = (A = {})      \<close>
    \<open>\<forall>(f::'a::type \<Rightarrow> 'a::type) A::'a::type set. (f ` A = {}) = (A = {})\<close>
    \<open>\<forall>(f::'b::type \<Rightarrow> 'c::linorder) (A::'b::type set) (x::'b::type) y::'b::type.
       inj_on f A \<and> f x = f y \<and> x \<in> A \<and> y \<in> A \<longrightarrow> x = y\<close>
    \<open>\<forall>(x::'c::linorder) y::'c::linorder. (x < y) = (x \<le> y \<and> x \<noteq> y)\<close>
    \<open>arg_min_on (f::'b::type \<Rightarrow> 'c::linorder) ((g::'a::type \<Rightarrow> 'b::type) ` (B::'a::type set)) \<noteq>
       g (arg_min_on (f \<circ> g) B) \<close>
   shows False
  using assms
  by (smt (verit))
end

experiment
begin
private datatype abort =
    Rtype_error
  | Rtimeout_error
private datatype ('a) error_result =
  Rraise " 'a " \<comment> \<open>\<open> Should only be a value of type exn \<close>\<close>
  | Rabort " abort "

private datatype( 'a, 'b) result =
    Rval " 'a "
    | Rerr " ('b) error_result "

lemma
  fixes clock :: \<open>'astate \<Rightarrow> nat\<close> and
    fun_evaluate_match :: \<open>'astate \<Rightarrow> 'vsemv_env \<Rightarrow> _ \<Rightarrow> ('pat \<times> 'exp0) list \<Rightarrow> _ \<Rightarrow>
      'astate*((('v)list),('v))result\<close>
  assumes
         " fix_clock (st::'astate) (fun_evaluate st (env::'vsemv_env) [e::'exp0]) =
       (st'::'astate, r::('v list, 'v) result)"
      " clock (fst (fun_evaluate (st::'astate) (env::'vsemv_env) [e::'exp0])) \<le> clock st"
       "\<forall>(b::nat) (a::nat) c::nat. b \<le> a \<and> c \<le> b \<longrightarrow> c \<le> a"
       "\<forall>(a::'astate) p::'astate \<times> ('v list, 'v) result. (a = fst p) = (\<exists>b::('v list, 'v) result. p = (a, b))"
       "\<forall>y::'v error_result. (\<forall>x1::'v. y = Rraise x1 \<longrightarrow> False) \<and> (\<forall>x2::abort. y = Rabort x2 \<longrightarrow> False) \<longrightarrow> False"
       "\<forall>(f1::'v \<Rightarrow> 'astate \<times> ('v list, 'v) result) (f2::abort \<Rightarrow> 'astate \<times> ('v list, 'v) result) x1::'v.
          (case Rraise x1 of Rraise (x::'v) \<Rightarrow> f1 x | Rabort (x::abort) \<Rightarrow> f2 x) = f1 x1"
      " \<forall>(f1::'v \<Rightarrow> 'astate \<times> ('v list, 'v) result) (f2::abort \<Rightarrow> 'astate \<times> ('v list, 'v) result) x2::abort.
          (case Rabort x2 of Rraise (x::'v) \<Rightarrow> f1 x | Rabort (x::abort) \<Rightarrow> f2 x) = f2 x2"
       "\<forall>(s1::'astate) (s2::'astate) (x::('v list, 'v) result) s::'astate.
          fix_clock s1 (s2, x) = (s, x) \<longrightarrow> clock s \<le> clock s2"
       "\<forall>(s::'astate) (s'::'astate) res::('v list, 'v) result.
          fix_clock s (s', res) =
          (update_clock (\<lambda>_::nat. if clock s' \<le> clock s then clock s' else clock s) s', res)"
       "\<forall>(x2::'v error_result) x1::'v.
          (r::('v list, 'v) result) = Rerr x2 \<and> x2 = Rraise x1 \<longrightarrow>
          clock (fst (fun_evaluate_match (st'::'astate) (env::'vsemv_env) x1 (pes::('pat \<times> 'exp0) list) x1))
          \<le> clock st'"
     shows "((r::('v list, 'v) result) = Rerr (x2::'v error_result) \<longrightarrow>
           clock
            (fst (case x2 of
                  Rraise (v2::'v) \<Rightarrow>
                    fun_evaluate_match (st'::'astate) (env::'vsemv_env) v2 (pes::('pat \<times> 'exp0) list) v2
                  | Rabort (abort::abort) \<Rightarrow> (st', Rerr (Rabort abort))))
           \<le> clock (st::'astate)) "
  using assms by (smt (verit))
end

context
  fixes piecewise_C1 :: "('real :: {one,zero,ord} \<Rightarrow> 'a :: {one,zero,ord}) \<Rightarrow> 'real set \<Rightarrow> bool"  and
     joinpaths :: "('real \<Rightarrow> 'a) \<Rightarrow> ('real \<Rightarrow> 'a) \<Rightarrow> 'real \<Rightarrow> 'a"
begin
notation piecewise_C1 (infixr "piecewise'_C1'_differentiable'_on" 50)
notation joinpaths (infixr "+++" 75)

lemma
   \<open>(\<And>v1. \<forall>v0. (rec_join v0 = v1 \<and>
               (v0 = [] \<and> (\<lambda>uu. 0) = v1 \<longrightarrow> False) \<and>
               (\<forall>v2. v0 = [v2] \<and> v1 = coeff_cube_to_path v2 \<longrightarrow> False) \<and>
               (\<forall>v2 v3 v4.
                   v0 = v2 # v3 # v4 \<and> v1 = coeff_cube_to_path v2 +++ rec_join (v3 # v4) \<longrightarrow> False) \<longrightarrow>
               False) =
              (rec_join v0 = rec_join v0 \<and>
               (v0 = [] \<and> (\<lambda>uu. 0) = rec_join v0 \<longrightarrow> False) \<and>
               (\<forall>v2. v0 = [v2] \<and> rec_join v0 = coeff_cube_to_path v2 \<longrightarrow> False) \<and>
               (\<forall>v2 v3 v4.
                   v0 = v2 # v3 # v4 \<and> rec_join v0 = coeff_cube_to_path v2 +++ rec_join (v3 # v4) \<longrightarrow>
                   False) \<longrightarrow>
               False)) \<Longrightarrow>
         (\<forall>v0 v1.
             rec_join v0 = v1 \<and>
             (v0 = [] \<and> (\<lambda>uu. 0) = v1 \<longrightarrow> False) \<and>
             (\<forall>v2. v0 = [v2] \<and> v1 = coeff_cube_to_path v2 \<longrightarrow> False) \<and>
             (\<forall>v2 v3 v4. v0 = v2 # v3 # v4 \<and> v1 = coeff_cube_to_path v2 +++ rec_join (v3 # v4) \<longrightarrow> False) \<longrightarrow>
             False) =
         (\<forall>v0. rec_join v0 = rec_join v0 \<and>
               (v0 = [] \<and> (\<lambda>uu. 0) = rec_join v0 \<longrightarrow> False) \<and>
               (\<forall>v2. v0 = [v2] \<and> rec_join v0 = coeff_cube_to_path v2 \<longrightarrow> False) \<and>
               (\<forall>v2 v3 v4.
                   v0 = v2 # v3 # v4 \<and> rec_join v0 = coeff_cube_to_path v2 +++ rec_join (v3 # v4) \<longrightarrow>
                   False) \<longrightarrow>
               False)\<close>
  by (smt (verit))

end

section \<open>Monomorphization examples\<close>

definition Pred :: "'a \<Rightarrow> bool" where
  "Pred x = True"

lemma poly_Pred: "Pred x \<and> (Pred [x] \<or> \<not> Pred [x])"
  by (simp add: Pred_def)

lemma "Pred (1::int)"
  by (smt (verit) poly_Pred)

axiomatization g :: "'a \<Rightarrow> nat"
axiomatization where
  g1: "g (Some x) = g [x]" and
  g2: "g None = g []" and
  g3: "g xs = length xs"

lemma "g (Some (3::int)) = g (Some True)" by (smt (verit) g1 g2 g3 list.size)

end


section \<open>Attractor Sets\<close>
text \<open>\label{sec:attractor}\<close>

theory Attractor
imports
  Main
  AttractingStrategy
begin

text \<open>Here we define the @{term p}-attractor of a set of nodes.\<close>

context ParityGame begin

text \<open>We define the conditions for a node to be directly attracted from a given set.\<close>
definition directly_attracted :: "Player \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "directly_attracted p S \<equiv> {v \<in> V - S. \<not>deadend v \<and>
      (v \<in> VV p   \<longrightarrow> (\<exists>w. v\<rightarrow>w \<and> w \<in> S))
    \<and> (v \<in> VV p** \<longrightarrow> (\<forall>w. v\<rightarrow>w \<longrightarrow> w \<in> S))}"

abbreviation "attractor_step p W S \<equiv> W \<union> S \<union> directly_attracted p S"

text \<open>The \<open>p\<close>-attractor set of \<open>W\<close>, defined as a least fixed point.\<close>
definition attractor :: "Player \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "attractor p W = lfp (attractor_step p W)"

subsection \<open>@{const directly_attracted}\<close>

text \<open>Show a few basic properties of @{const directly_attracted}.\<close>
lemma directly_attracted_disjoint     [simp]: "directly_attracted p W \<inter> W = {}"
  and directly_attracted_empty        [simp]: "directly_attracted p {} = {}"
  and directly_attracted_V_empty      [simp]: "directly_attracted p V = {}"
  and directly_attracted_bounded_by_V [simp]: "directly_attracted p W \<subseteq> V"
  and directly_attracted_contains_no_deadends [elim]: "v \<in> directly_attracted p W \<Longrightarrow> \<not>deadend v"
  unfolding directly_attracted_def by blast+

subsection \<open>\<open>attractor_step\<close>\<close>

lemma attractor_step_empty: "attractor_step p {} {} = {}"
  and attractor_step_bounded_by_V: "\<lbrakk> W \<subseteq> V; S \<subseteq> V \<rbrakk> \<Longrightarrow> attractor_step p W S \<subseteq> V"
  by simp_all

text \<open>
  The definition of @{const attractor} uses @{const lfp}.  For this to be well-defined, we
  need show that \<open>attractor_step\<close> is monotone.
\<close>

lemma attractor_step_mono: "mono (attractor_step p W)"
  unfolding directly_attracted_def by (rule monoI) auto

subsection \<open>Basic Properties of an Attractor\<close>

lemma attractor_unfolding: "attractor p W = attractor_step p W (attractor p W)"
  unfolding attractor_def using attractor_step_mono lfp_unfold by blast
lemma attractor_lowerbound: "attractor_step p W S \<subseteq> S \<Longrightarrow> attractor p W \<subseteq> S"
  unfolding attractor_def using attractor_step_mono by (simp add: lfp_lowerbound)
lemma attractor_set_non_empty: "W \<noteq> {} \<Longrightarrow> attractor p W \<noteq> {}"
  and attractor_set_base: "W \<subseteq> attractor p W"
  using attractor_unfolding by auto

subsection \<open>Attractor Set Extensions\<close>

lemma attractor_set_VVp:
  assumes "v \<in> VV p" "v\<rightarrow>w" "w \<in> attractor p W"
  shows "v \<in> attractor p W"
  apply (subst attractor_unfolding) unfolding directly_attracted_def using assms by auto

lemma attractor_set_VVpstar:
  assumes "\<not>deadend v" "\<And>w. v\<rightarrow>w \<Longrightarrow> w \<in> attractor p W"
  shows "v \<in> attractor p W"
  apply (subst attractor_unfolding) unfolding directly_attracted_def using assms by auto

subsection \<open>Removing an Attractor\<close>

lemma removing_attractor_induces_no_deadends:
  assumes "v \<in> S - attractor p W" "v\<rightarrow>w" "w \<in> S" "\<And>w. \<lbrakk> v \<in> VV p**; v\<rightarrow>w \<rbrakk> \<Longrightarrow> w \<in> S"
  shows "\<exists>w \<in> S - attractor p W. v\<rightarrow>w"
proof-
  have "v \<in> V" using \<open>v\<rightarrow>w\<close> by blast
  thus ?thesis proof (cases rule: VV_cases)
    assume "v \<in> VV p"
    thus ?thesis using attractor_set_VVp assms by blast
  next
    assume "v \<in> VV p**"
    thus ?thesis using attractor_set_VVpstar assms by (metis Diff_iff edges_are_in_V(2))
  qed
qed

text \<open>Removing the attractor sets of deadends leaves a subgame without deadends.\<close>

lemma subgame_without_deadends:
  assumes V'_def: "V' = V - attractor p (deadends p**) - attractor p** (deadends p****)"
    (is "V' = V - ?A - ?B")
    and v: "v \<in> V\<^bsub>subgame V'\<^esub>"
  shows "\<not>Digraph.deadend (subgame V') v"
proof (cases)
  assume "deadend v"
  have v: "v \<in> V - ?A - ?B" using v unfolding V'_def subgame_def by simp
  { fix p' assume "v \<in> VV p'**"
    hence "v \<in> attractor p' (deadends p'**)"
      using \<open>deadend v\<close> attractor_set_base[of "deadends p'**" p']
      unfolding deadends_def by blast
    hence False using v by (cases p'; cases p) auto
  }
  thus ?thesis using v by blast
next
  assume "\<not>deadend v"
  have v: "v \<in> V - ?A - ?B" using v unfolding V'_def subgame_def by simp
  define G' where "G' = subgame V'"
  interpret G': ParityGame G' unfolding G'_def using subgame_ParityGame .
  show ?thesis proof
    assume "Digraph.deadend (subgame V') v"
    hence "G'.deadend v" unfolding G'_def .
    have all_in_attractor: "\<And>w. v\<rightarrow>w \<Longrightarrow> w \<in> ?A \<or> w \<in> ?B" proof (rule ccontr)
      fix w
      assume "v\<rightarrow>w" "\<not>(w \<in> ?A \<or> w \<in> ?B)"
      hence "w \<in> V'" unfolding V'_def by blast
      hence "w \<in> V\<^bsub>G'\<^esub>" unfolding G'_def subgame_def using \<open>v\<rightarrow>w\<close> by auto
      hence "v \<rightarrow>\<^bsub>G'\<^esub> w" using \<open>v\<rightarrow>w\<close> assms(2) unfolding G'_def subgame_def by auto
      thus False using \<open>G'.deadend v\<close> using \<open>w \<in> V\<^bsub>G'\<^esub>\<close> by blast
    qed
    { fix p' assume "v \<in> VV p'"
      { assume "\<exists>w. v\<rightarrow>w \<and> w \<in> attractor p' (deadends p'**)"
        hence "v \<in> attractor p' (deadends p'**)" using \<open>v \<in> VV p'\<close> attractor_set_VVp by blast
        hence False using v by (cases p'; cases p) auto
      }
      hence "\<And>w. v\<rightarrow>w \<Longrightarrow> w \<in> attractor p'** (deadends p'****)"
        using all_in_attractor by (cases p'; cases p) auto
      hence "v \<in> attractor p'** (deadends p'****)"
        using \<open>\<not>deadend v\<close> \<open>v \<in> VV p'\<close> attractor_set_VVpstar by auto
      hence False using v by (cases p'; cases p) auto
    }
    thus False using v by blast
  qed
qed

subsection \<open>Attractor Set Induction\<close>

lemma mono_restriction_is_mono: "mono f \<Longrightarrow> mono (\<lambda>S. f (S \<inter> V))"
  unfolding mono_def by (meson inf_mono monoD subset_refl)

text \<open>
  Here we prove a powerful induction schema for @{term attractor}.  Being able to prove this is the
  only reason why we do not use \texttt{inductive\_set} to define the attractor set.

  See also \url{https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2015-October/msg00123.html}
\<close>
lemma attractor_set_induction [consumes 1, case_names step union]:
  assumes "W \<subseteq> V"
    and step: "\<And>S. S \<subseteq> V \<Longrightarrow> P S \<Longrightarrow> P (attractor_step p W S)"
    and union: "\<And>M. \<forall>S \<in> M. S \<subseteq> V \<and> P S \<Longrightarrow> P (\<Union>M)"
  shows "P (attractor p W)"
proof-
  let ?P = "\<lambda>S. P (S \<inter> V)"
  let ?f = "\<lambda>S. attractor_step p W (S \<inter> V)"
  let ?A = "lfp ?f"
  let ?B = "lfp (attractor_step p W)"
  have f_mono: "mono ?f"
    using mono_restriction_is_mono[of "attractor_step p W"] attractor_step_mono by simp
  have P_A: "?P ?A" proof (rule lfp_ordinal_induct_set)
    show "\<And>S. ?P S \<Longrightarrow> ?P (W \<union> (S \<inter> V) \<union> directly_attracted p (S \<inter> V))"
      by (metis assms(1) attractor_step_bounded_by_V inf.absorb1 inf_le2 local.step)
    show "\<And>M. \<forall>S \<in> M. ?P S \<Longrightarrow> ?P (\<Union>M)" proof-
      fix M
      let ?M = "{S \<inter> V | S. S \<in> M}"
      assume "\<forall>S\<in>M. ?P S"
      hence "\<forall>S \<in> ?M. S \<subseteq> V \<and> P S" by auto
      hence *: "P (\<Union>?M)" by (simp add: union)
      have "\<Union>?M = (\<Union>M) \<inter> V" by blast
      thus "?P (\<Union>M)" using * by auto
    qed
  qed (insert f_mono)

  have *: "W \<union> (V \<inter> V) \<union> directly_attracted p (V \<inter> V) \<subseteq> V"
    using \<open>W \<subseteq> V\<close> attractor_step_bounded_by_V by auto
  have "?A \<subseteq> V" "?B \<subseteq> V" using * by (simp_all add: lfp_lowerbound)

  have "?A = ?f ?A" using f_mono lfp_unfold by blast
  hence "?A = W \<union> (?A \<inter> V) \<union> directly_attracted p (?A \<inter> V)" using \<open>?A \<subseteq> V\<close> by simp
  hence *: "attractor_step p W ?A \<subseteq> ?A" using \<open>?A \<subseteq> V\<close> inf.absorb1 by fastforce

  have "?B = attractor_step p W ?B" using attractor_step_mono lfp_unfold by blast
  hence "?f ?B \<subseteq> ?B" using \<open>?B \<subseteq> V\<close> by (metis (no_types, lifting) equalityD2 le_iff_inf)

  have "?A = ?B" proof
    show "?A \<subseteq> ?B" using \<open>?f ?B \<subseteq> ?B\<close> by (simp add: lfp_lowerbound)
    show "?B \<subseteq> ?A" using * by (simp add: lfp_lowerbound)
  qed
  hence "?P ?B" using P_A by (simp add: attractor_def)
  thus ?thesis using \<open>?B \<subseteq> V\<close> by (simp add: attractor_def le_iff_inf)
qed

end \<comment> \<open>context ParityGame\<close>

end


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

section\<open>Booleans in Zermelo-Fraenkel Set Theory\<close>

theory Bool imports pair begin

abbreviation
  one  (\<open>1\<close>) where
  "1 \<equiv> succ(0)"

abbreviation
  two  (\<open>2\<close>) where
  "2 \<equiv> succ(1)"

text\<open>2 is equal to bool, but is used as a number rather than a type.\<close>

definition "bool \<equiv> {0,1}"

definition "cond(b,c,d) \<equiv> if(b=1,c,d)"

definition "not(b) \<equiv> cond(b,0,1)"

definition
  "and"       :: "[i,i]\<Rightarrow>i"      (infixl \<open>and\<close> 70)  where
    "a and b \<equiv> cond(a,b,0)"

definition
  or          :: "[i,i]\<Rightarrow>i"      (infixl \<open>or\<close> 65)  where
    "a or b \<equiv> cond(a,1,b)"

definition
  xor         :: "[i,i]\<Rightarrow>i"      (infixl \<open>xor\<close> 65) where
    "a xor b \<equiv> cond(a,not(b),b)"

lemmas bool_defs = bool_def cond_def

lemma singleton_0: "{0} = 1"
by (simp add: succ_def)

(* Introduction rules *)

lemma bool_1I [simp,TC]: "1 \<in> bool"
by (simp add: bool_defs )

lemma bool_0I [simp,TC]: "0 \<in> bool"
by (simp add: bool_defs)

lemma one_not_0: "1\<noteq>0"
by (simp add: bool_defs )

(** 1=0 \<Longrightarrow> R **)
lemmas one_neq_0 = one_not_0 [THEN notE]

lemma boolE:
    "\<lbrakk>c: bool;  c=1 \<Longrightarrow> P;  c=0 \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (simp add: bool_defs, blast)

(** cond **)

(*1 means true*)
lemma cond_1 [simp]: "cond(1,c,d) = c"
by (simp add: bool_defs )

(*0 means false*)
lemma cond_0 [simp]: "cond(0,c,d) = d"
by (simp add: bool_defs )

lemma cond_type [TC]: "\<lbrakk>b: bool;  c: A(1);  d: A(0)\<rbrakk> \<Longrightarrow> cond(b,c,d): A(b)"
by (simp add: bool_defs, blast)

(*For Simp_tac and Blast_tac*)
lemma cond_simple_type: "\<lbrakk>b: bool;  c: A;  d: A\<rbrakk> \<Longrightarrow> cond(b,c,d): A"
by (simp add: bool_defs )

lemma def_cond_1: "\<lbrakk>\<And>b. j(b)\<equiv>cond(b,c,d)\<rbrakk> \<Longrightarrow> j(1) = c"
by simp

lemma def_cond_0: "\<lbrakk>\<And>b. j(b)\<equiv>cond(b,c,d)\<rbrakk> \<Longrightarrow> j(0) = d"
by simp

lemmas not_1 = not_def [THEN def_cond_1, simp]
lemmas not_0 = not_def [THEN def_cond_0, simp]

lemmas and_1 = and_def [THEN def_cond_1, simp]
lemmas and_0 = and_def [THEN def_cond_0, simp]

lemmas or_1 = or_def [THEN def_cond_1, simp]
lemmas or_0 = or_def [THEN def_cond_0, simp]

lemmas xor_1 = xor_def [THEN def_cond_1, simp]
lemmas xor_0 = xor_def [THEN def_cond_0, simp]

lemma not_type [TC]: "a:bool \<Longrightarrow> not(a) \<in> bool"
by (simp add: not_def)

lemma and_type [TC]: "\<lbrakk>a:bool;  b:bool\<rbrakk> \<Longrightarrow> a and b \<in> bool"
by (simp add: and_def)

lemma or_type [TC]: "\<lbrakk>a:bool;  b:bool\<rbrakk> \<Longrightarrow> a or b \<in> bool"
by (simp add: or_def)

lemma xor_type [TC]: "\<lbrakk>a:bool;  b:bool\<rbrakk> \<Longrightarrow> a xor b \<in> bool"
by (simp add: xor_def)

lemmas bool_typechecks = bool_1I bool_0I cond_type not_type and_type
                         or_type xor_type

subsection\<open>Laws About 'not'\<close>

lemma not_not [simp]: "a:bool \<Longrightarrow> not(not(a)) = a"
by (elim boolE, auto)

lemma not_and [simp]: "a:bool \<Longrightarrow> not(a and b) = not(a) or not(b)"
by (elim boolE, auto)

lemma not_or [simp]: "a:bool \<Longrightarrow> not(a or b) = not(a) and not(b)"
by (elim boolE, auto)

subsection\<open>Laws About 'and'\<close>

lemma and_absorb [simp]: "a: bool \<Longrightarrow> a and a = a"
by (elim boolE, auto)

lemma and_commute: "\<lbrakk>a: bool; b:bool\<rbrakk> \<Longrightarrow> a and b = b and a"
by (elim boolE, auto)

lemma and_assoc: "a: bool \<Longrightarrow> (a and b) and c  =  a and (b and c)"
by (elim boolE, auto)

lemma and_or_distrib: "\<lbrakk>a: bool; b:bool; c:bool\<rbrakk> \<Longrightarrow>
       (a or b) and c  =  (a and c) or (b and c)"
by (elim boolE, auto)

subsection\<open>Laws About 'or'\<close>

lemma or_absorb [simp]: "a: bool \<Longrightarrow> a or a = a"
by (elim boolE, auto)

lemma or_commute: "\<lbrakk>a: bool; b:bool\<rbrakk> \<Longrightarrow> a or b = b or a"
by (elim boolE, auto)

lemma or_assoc: "a: bool \<Longrightarrow> (a or b) or c  =  a or (b or c)"
by (elim boolE, auto)

lemma or_and_distrib: "\<lbrakk>a: bool; b: bool; c: bool\<rbrakk> \<Longrightarrow>
           (a and b) or c  =  (a or c) and (b or c)"
by (elim boolE, auto)

definition
  bool_of_o :: "o\<Rightarrow>i" where
   "bool_of_o(P) \<equiv> (if P then 1 else 0)"

lemma [simp]: "bool_of_o(False) = 0"
by (simp add: bool_of_o_def)

lemma [simp,TC]: "bool_of_o(P) \<in> bool"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 1) \<longleftrightarrow> P"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 0) \<longleftrightarrow> \<not>P"
by (simp add: bool_of_o_def)

end


theory T80
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*
  Title: Locale-Based Duality
  Author: Georg Struth
  Maintainer:Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Locale-Based Duality\<close>

theory Order_Lattice_Props_Loc
  imports Main
          "HOL-Library.Lattice_Syntax"

begin

text \<open>This section explores order and lattice duality based on locales. Used within the context of a class or locale,
this is very effective, though more opaque than the previous approach. Outside of such a context, however, it apparently
cannot be used for dualising theorems. Examples are properties of  functions between orderings or lattices.\<close>

definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where
  "Fix f = {x. f x = x}"

context ord
begin

definition min_set :: "'a set \<Rightarrow> 'a set" where
 "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"

definition max_set :: "'a set \<Rightarrow> 'a set" where
 "max_set X = {x \<in> X. \<forall>y \<in> X. x \<le> y \<longrightarrow> x = y}"

definition directed :: "'a set \<Rightarrow> bool" where
 "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"

definition filtered :: "'a set \<Rightarrow> bool" where
 "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"

definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
  "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"

definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
 "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"

definition downset :: "'a \<Rightarrow> 'a set" ("\<down>") where
  "\<down> = \<Down> \<circ> (\<lambda>x. {x})"

definition upset :: "'a \<Rightarrow> 'a set" ("\<up>") where
  "\<up> = \<Up> \<circ> (\<lambda>x. {x})"

definition downsets :: "'a set set" where
  "downsets = Fix \<Down>"

definition upsets :: "'a set set" where
  "upsets = Fix \<Up>"

abbreviation "downset_setp X \<equiv> X \<in> downsets"

abbreviation "upset_setp X \<equiv> X \<in> upsets"

definition ideals :: "'a set set" where
  "ideals = {X. X \<noteq> {} \<and> downset_setp X \<and> directed X}"

definition filters :: "'a  set set" where
  "filters = {X. X \<noteq> {} \<and> upset_setp X \<and> filtered X}"

abbreviation "idealp X \<equiv> X \<in> ideals"

abbreviation "filterp X \<equiv> X \<in> filters"

end

abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
  "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> (`) f"

abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
  "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> (`) f"

abbreviation sup_pres :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
  "sup_pres f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y)"

abbreviation inf_pres :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
 "inf_pres f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y)"

abbreviation bot_pres :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
  "bot_pres f \<equiv> f \<bottom> = \<bottom>"

abbreviation top_pres :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool" where
  "top_pres f \<equiv> f \<top> = \<top>"

abbreviation Sup_dual :: "('a::Sup \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
  "Sup_dual f \<equiv> f \<circ> Sup = Inf \<circ> (`) f"

abbreviation Inf_dual :: "('a::Inf \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
  "Inf_dual f \<equiv> f \<circ> Inf = Sup \<circ> (`) f"

abbreviation sup_dual :: "('a::sup \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
  "sup_dual f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<sqinter> f y)"

abbreviation inf_dual :: "('a::inf \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
 "inf_dual f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<squnion> f y)"

abbreviation bot_dual :: "('a::bot \<Rightarrow> 'b::top) \<Rightarrow> bool" where
 "bot_dual f \<equiv> f \<bottom> = \<top>"

abbreviation top_dual :: "('a::top \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
  "top_dual f \<equiv> f \<top> = \<bottom>"

subsection \<open>Duality via Locales\<close>

sublocale ord \<subseteq> dual_ord: ord "(\<ge>)" "(>)"
  rewrites dual_max_set: "max_set = dual_ord.min_set"
  and dual_filtered: "filtered = dual_ord.directed"
  and dual_upset_set: "upset_set = dual_ord.downset_set"
  and dual_upset: "upset = dual_ord.downset"
  and dual_upsets: "upsets = dual_ord.downsets"
  and dual_filters: "filters = dual_ord.ideals"
       apply unfold_locales
  unfolding max_set_def ord.min_set_def fun_eq_iff apply blast
  unfolding filtered_def ord.directed_def apply simp
  unfolding upset_set_def ord.downset_set_def apply simp
  apply (simp add: ord.downset_def ord.downset_set_def ord.upset_def ord.upset_set_def)
  unfolding upsets_def ord.downsets_def apply (metis ord.downset_set_def upset_set_def)
  unfolding filters_def ord.ideals_def Fix_def ord.downsets_def upsets_def ord.downset_set_def upset_set_def ord.directed_def filtered_def
  by simp

sublocale preorder \<subseteq> dual_preorder: preorder "(\<ge>)" "(>)"
  apply unfold_locales
  apply (simp add: less_le_not_le)
  apply simp
  using order_trans by blast

sublocale order \<subseteq> dual_order: order "(\<ge>)" "(>)"
  by (unfold_locales, simp)

sublocale lattice \<subseteq> dual_lattice: lattice sup "(\<ge>)" "(>)" inf
  by (unfold_locales, simp_all)

sublocale bounded_lattice \<subseteq> dual_bounded_lattice: bounded_lattice sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  by (unfold_locales, simp_all)

sublocale boolean_algebra \<subseteq> dual_boolean_algebra: boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  by (unfold_locales, simp_all add: inf_sup_distrib1)

sublocale complete_lattice \<subseteq> dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  rewrites dual_gfp: "gfp = dual_complete_lattice.lfp"
proof-
  show "class.complete_lattice Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
    by (unfold_locales, simp_all add: Sup_upper Sup_least Inf_lower Inf_greatest)
  then interpret dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>.
  show "gfp = dual_complete_lattice.lfp"
    unfolding gfp_def dual_complete_lattice.lfp_def fun_eq_iff by simp
qed

context ord
begin

lemma dual_min_set: "min_set = dual_ord.max_set"
  by (simp add: dual_ord.dual_max_set)

lemma dual_directed: "directed = dual_ord.filtered"
  by (simp add:dual_ord.dual_filtered)

lemma dual_downset: "downset = dual_ord.upset"
  by (simp add: dual_ord.dual_upset)

lemma dual_downset_set: "downset_set = dual_ord.upset_set"
  by (simp add: dual_ord.dual_upset_set)

lemma dual_downsets: "downsets = dual_ord.upsets"
  by (simp add: dual_ord.dual_upsets)

lemma dual_ideals: "ideals = dual_ord.filters"
  by (simp add: dual_ord.dual_filters)

end

context complete_lattice
begin

lemma dual_lfp: "lfp = dual_complete_lattice.gfp"
  by (simp add: dual_complete_lattice.dual_gfp)

end

subsection \<open>Properties of Orderings, Again\<close>

context ord
begin

lemma directed_nonempty: "directed X \<Longrightarrow> X \<noteq> {}"
  unfolding directed_def by fastforce

lemma directed_ub: "directed X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z)"
  by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl)

lemma downset_set_prop: "\<Down> = Union \<circ> (`) \<down>"
  unfolding downset_set_def downset_def fun_eq_iff by fastforce

lemma downset_set_prop_var: "\<Down>X = (\<Union>x \<in> X. \<down>x)"
  by (simp add: downset_set_prop)

lemma downset_prop: "\<down>x = {y. y \<le> x}"
  unfolding downset_def downset_set_def fun_eq_iff comp_def by fastforce

end

context preorder
begin

lemma directed_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z) \<Longrightarrow> directed X"
proof-
  assume h1: "X \<noteq> {}"
  and h2: "\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z"
  {fix Y
  have "finite Y \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x)"
  proof (induct rule: finite_induct)
    case empty
    then show ?case
      using h1 by blast
  next
    case (insert x F)
    then show ?case
      by (metis h2 insert_iff insert_subset order_trans)
  qed}
  thus ?thesis
    by (simp add: directed_def)
qed

lemma directed_alt: "directed X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z))"
  by (metis directed_prop directed_nonempty directed_ub)

lemma downset_set_ext: "id \<le> \<Down>"
  unfolding le_fun_def id_def downset_set_def by auto

lemma downset_set_iso: "mono \<Down>"
  unfolding mono_def downset_set_def by blast

lemma downset_set_idem [simp]: "\<Down> \<circ> \<Down> = \<Down>"
  unfolding fun_eq_iff downset_set_def comp_def using order_trans by auto

lemma downset_faithful: "\<down>x \<subseteq> \<down>y \<Longrightarrow> x \<le> y"
  by (simp add: downset_prop subset_eq)

lemma downset_iso_iff: "(\<down>x \<subseteq> \<down>y) = (x \<le> y)"
  using atMost_iff downset_prop order_trans by blast

lemma downset_directed_downset_var [simp]: "directed (\<Down>X) = directed X"
proof
  assume h1: "directed X"
  {fix Y
  assume h2: "finite Y" and h3: "Y \<subseteq> \<Down>X"
  hence "\<forall>y. \<exists>x. y \<in> Y \<longrightarrow> x \<in> X \<and>  y \<le> x"
    by (force simp: downset_set_def)
  hence "\<exists>f. \<forall>y. y \<in> Y \<longrightarrow>  f y \<in> X \<and> y \<le> f y"
    by (rule choice)
  hence "\<exists>f. finite (f ` Y) \<and> f ` Y \<subseteq> X \<and> (\<forall>y \<in> Y. y \<le> f y)"
    by (metis finite_imageI h2 image_subsetI)
  hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z)"
    by fastforce
  hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z) \<and> (\<exists>x \<in> X. \<forall> z \<in> Z. z \<le> x)"
    by (metis directed_def h1)
  hence "\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x"
    by (meson order_trans)}
  thus "directed (\<Down>X)"
    unfolding directed_def downset_set_def by fastforce
next
  assume "directed (\<Down>X)"
  thus "directed X"
    unfolding directed_def downset_set_def
    apply clarsimp
    by (smt Ball_Collect order_refl order_trans subsetCE)
qed

lemma downset_directed_downset [simp]: "directed \<circ> \<Down> = directed"
  unfolding fun_eq_iff comp_def by simp

lemma directed_downset_ideals: "directed (\<Down>X) = (\<Down>X \<in> ideals)"
  by (metis (mono_tags, lifting) Fix_def comp_apply directed_alt downset_set_idem downsets_def ideals_def mem_Collect_eq)

end

lemma downset_iso: "mono (\<down>::'a::order \<Rightarrow> 'a set)"
  by (simp add: downset_iso_iff mono_def)

context order
begin

lemma downset_inj: "inj \<down>"
  by (metis injI downset_iso_iff eq_iff)

end

context lattice
begin

lemma lat_ideals: "X \<in> ideals = (X \<noteq> {} \<and> X \<in> downsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<squnion> y \<in> X))"
  unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def
  by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq)

end

context bounded_lattice
begin

lemma bot_ideal: "X \<in> ideals \<Longrightarrow> \<bottom> \<in> X"
  unfolding ideals_def downsets_def Fix_def downset_set_def by fastforce

end

context complete_lattice
begin

lemma Sup_downset_id [simp]: "Sup \<circ> \<down> = id"
  using Sup_atMost atMost_def downset_prop by fastforce

lemma downset_Sup_id: "id \<le> \<down> \<circ> Sup"
  by (simp add: Sup_upper downset_prop le_funI subsetI)

lemma Inf_Sup_var: "\<Squnion>(\<Inter>x \<in> X. \<down>x) = \<Sqinter>X"
  unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup)

lemma Inf_pres_downset_var: "(\<Inter>x \<in> X. \<down>x) = \<down>(\<Sqinter>X)"
  unfolding downset_prop by (safe, simp_all add: le_Inf_iff)

end

lemma lfp_in_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> lfp f \<in> Fix f"
  using Fix_def lfp_unfold by fastforce

lemma gfp_in_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> gfp f \<in> Fix f"
  using Fix_def gfp_unfold by fastforce

lemma nonempty_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> Fix f \<noteq> {}"
  using lfp_in_Fix by fastforce

subsection \<open>Dual Properties of Orderings from Locales\<close>

text \<open>These properties can be proved very smoothly overall. But only within the context of a class
or locale!\<close>

context ord
begin

lemma filtered_lb: "filtered X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y)"
  by (simp add: dual_filtered dual_ord.directed_ub)

lemma upset_set_prop: "\<Up> = Union \<circ> (`) \<up>"
  by (simp add: dual_ord.downset_set_prop dual_upset dual_upset_set)

lemma upset_set_prop_var: "\<Up>X = (\<Union>x \<in> X. \<up>x)"
  by (simp add: dual_ord.downset_set_prop_var dual_upset dual_upset_set)

lemma upset_prop: "\<up>x = {y. x \<le> y}"
  by (simp add: dual_ord.downset_prop dual_upset)

end

context preorder
begin

lemma filtered_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y) \<Longrightarrow> filtered X"
  by (simp add: dual_filtered dual_preorder.directed_prop)

lemma filtered_alt: "filtered X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y))"
  by (simp add: dual_filtered dual_preorder.directed_alt)

lemma upset_set_ext: "id \<le> \<Up>"
  by (simp add: dual_preorder.downset_set_ext dual_upset_set)

lemma upset_set_anti: "mono \<Up>"
  by (simp add: dual_preorder.downset_set_iso dual_upset_set)

lemma up_set_idem [simp]: "\<Up> \<circ> \<Up> = \<Up>"
  by (simp add: dual_upset_set)

lemma upset_faithful: "\<up>x \<subseteq> \<up>y \<Longrightarrow> y \<le> x"
  by (metis dual_preorder.downset_faithful dual_upset)

lemma upset_anti_iff: "(\<up>y \<subseteq> \<up>x) = (x \<le> y)"
  by (simp add: dual_preorder.downset_iso_iff dual_upset)

lemma upset_filtered_upset [simp]: "filtered \<circ> \<Up> = filtered"
  by (simp add: dual_filtered dual_upset_set)

lemma filtered_upset_filters: "filtered (\<Up>X) = (\<Up>X \<in> filters)"
  using dual_filtered dual_preorder.directed_downset_ideals dual_upset_set ord.dual_filters by fastforce

end

context order
begin

lemma upset_inj: "inj \<up>"
  by (simp add: dual_order.downset_inj dual_upset)

end

context lattice
begin

end

context bounded_lattice
begin

lemma top_filter: "X \<in> filters \<Longrightarrow> \<top> \<in> X"
  by (simp add: dual_bounded_lattice.bot_ideal dual_filters)

end

context complete_lattice
begin

lemma Inf_upset_id [simp]: "Inf \<circ> \<up> = id"
  by (simp add:  dual_upset)

lemma upset_Inf_id: "id \<le> \<up> \<circ> Inf"
  by (simp add: dual_complete_lattice.downset_Sup_id dual_upset)

lemma Sup_Inf_var: " \<Sqinter>(\<Inter>x \<in> X. \<up>x) = \<Squnion>X"
  by (simp add: dual_complete_lattice.Inf_Sup_var dual_upset)

lemma Sup_dual_upset_var: "(\<Inter>x \<in> X. \<up>x) = \<up>(\<Squnion>X)"
  by (simp add: dual_complete_lattice.Inf_pres_downset_var dual_upset)

end

subsection \<open>Examples that Do Not Dualise\<close>

lemma upset_anti: "antimono (\<up>::'a::order \<Rightarrow> 'a set)"
  by (simp add: antimono_def upset_anti_iff)

context complete_lattice
begin

lemma fSup_unfold: "(f::nat \<Rightarrow> 'a) 0 \<squnion> (\<Squnion>n. f (Suc n)) = (\<Squnion>n. f n)"
  apply (intro antisym sup_least)
    apply (rule Sup_upper, force)
   apply (rule Sup_mono, force)
  apply (safe intro!: Sup_least)
 by (case_tac n, simp_all add: Sup_upper le_supI2)

lemma fInf_unfold: "(f::nat \<Rightarrow> 'a) 0 \<sqinter> (\<Sqinter>n. f (Suc n)) = (\<Sqinter>n. f n)"
  apply (intro antisym inf_greatest)
  apply (rule Inf_greatest, safe)
  apply (case_tac n)
   apply simp_all
  using Inf_lower inf.coboundedI2 apply force
   apply (simp add: Inf_lower)
  by (auto intro: Inf_mono)

end

lemma fun_isol: "mono f \<Longrightarrow> mono ((\<circ>) f)"
  by (simp add: le_fun_def mono_def)

lemma fun_isor: "mono f \<Longrightarrow> mono (\<lambda>x. x \<circ> f)"
  by (simp add: le_fun_def mono_def)

lemma Sup_sup_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> sup_pres f"
  by (metis (no_types, hide_lams) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral)

lemma Inf_inf_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows"Inf_pres f \<Longrightarrow> inf_pres f"
  by (smt INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral)

lemma Sup_bot_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> bot_pres f"
  by (metis SUP_empty Sup_empty comp_eq_elim)

lemma Inf_top_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres f \<Longrightarrow> top_pres f"
  by (metis INF_empty comp_eq_elim dual_complete_lattice.Sup_empty)

context complete_lattice
begin

lemma iso_Inf_subdistl:
  assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
  shows "f \<circ> Inf \<le> Inf \<circ> (`) f"
  by (simp add: assms complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD)

lemma iso_Sup_supdistl:
  assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
  shows "Sup \<circ> (`) f \<le> f \<circ> Sup"
  by (simp add: assms complete_lattice_class.SUP_le_iff le_funI dual_complete_lattice.Inf_lower monoD)

lemma Inf_subdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "f \<circ> Inf \<le> Inf \<circ> (`) f \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)

lemma Sup_supdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)

lemma supdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "(Sup \<circ> (`) f \<le> f \<circ> Sup) = mono f"
  using Sup_supdistl_iso iso_Sup_supdistl by force

lemma subdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "(f \<circ> Inf \<le> Inf \<circ> (`) f) = mono f"
  using Inf_subdistl_iso iso_Inf_subdistl by force

end

lemma fSup_distr: "Sup_pres (\<lambda>x. x \<circ> f)"
  unfolding fun_eq_iff comp_def
  by (smt Inf.INF_cong SUP_apply Sup_apply)

lemma fSup_distr_var: "\<Squnion>F \<circ> g = (\<Squnion>f \<in> F. f \<circ> g)"
  unfolding fun_eq_iff comp_def
  by (smt Inf.INF_cong SUP_apply Sup_apply)

lemma fInf_distr: "Inf_pres (\<lambda>x. x \<circ> f)"
  unfolding fun_eq_iff comp_def
  by (smt INF_apply Inf.INF_cong Inf_apply)

lemma fInf_distr_var: "\<Sqinter>F \<circ> g = (\<Sqinter>f \<in> F. f \<circ> g)"
  unfolding fun_eq_iff comp_def
  by (smt INF_apply Inf.INF_cong Inf_apply)

lemma fSup_subdistl:
  assumes "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattice)"
  shows "Sup \<circ> (`) ((\<circ>) f) \<le> (\<circ>) f \<circ> Sup"
  using assms by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)

lemma fSup_subdistl_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows  "mono f \<Longrightarrow> (\<Squnion>g \<in> G. f \<circ> g) \<le> f \<circ> \<Squnion>G"
  by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)

lemma fInf_subdistl:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows  "mono f \<Longrightarrow> (\<circ>) f \<circ> Inf \<le> Inf \<circ> (`) ((\<circ>) f)"
  by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)

lemma fInf_subdistl_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> f \<circ> \<Sqinter>G \<le> (\<Sqinter>g \<in> G. f \<circ> g)"
  by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)

lemma Inf_pres_downset: "Inf_pres (\<down>::'a::complete_lattice \<Rightarrow> 'a set)"
  unfolding downset_prop fun_eq_iff comp_def
  by (safe, simp_all add: le_Inf_iff)

text \<open>This approach could probably be combined with the explicit functor-based one. This may be good for proofs, but seems conceptually rather ugly.\<close>

end


(*  Title:      ZF/UNITY/FP.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

From Misra, "A Logic for Concurrent Programming", 1994

Theory ported from HOL.
*)

section\<open>Fixed Point of a Program\<close>

theory FP imports UNITY begin

definition
  FP_Orig :: "i=>i"  where
    "FP_Orig(F) == \<Union>({A \<in> Pow(state). \<forall>B. F \<in> stable(A \<inter> B)})"

definition
  FP :: "i=>i"  where
    "FP(F) == {s\<in>state. F \<in> stable({s})}"

lemma FP_Orig_type: "FP_Orig(F) \<subseteq> state"
by (unfold FP_Orig_def, blast)

lemma st_set_FP_Orig [iff]: "st_set(FP_Orig(F))"
apply (unfold st_set_def)
apply (rule FP_Orig_type)
done

lemma FP_type: "FP(F) \<subseteq> state"
by (unfold FP_def, blast)

lemma st_set_FP [iff]: "st_set(FP(F))"
apply (unfold st_set_def)
apply (rule FP_type)
done

lemma stable_FP_Orig_Int: "F \<in> program ==> F \<in> stable(FP_Orig(F) \<inter> B)"
apply (simp only: FP_Orig_def stable_def Int_Union2)
apply (blast intro: constrains_UN)
done

lemma FP_Orig_weakest2:
    "[| \<forall>B. F \<in> stable (A \<inter> B); st_set(A) |]  ==> A \<subseteq> FP_Orig(F)"
by (unfold FP_Orig_def stable_def st_set_def, blast)

lemmas FP_Orig_weakest = allI [THEN FP_Orig_weakest2]

lemma stable_FP_Int: "F \<in> program ==> F \<in> stable (FP(F) \<inter> B)"
apply (subgoal_tac "FP (F) \<inter> B = (\<Union>x\<in>B. FP (F) \<inter> {x}) ")
 prefer 2 apply blast
apply (simp (no_asm_simp) add: Int_cons_right)
apply (unfold FP_def stable_def)
apply (rule constrains_UN)
apply (auto simp add: cons_absorb)
done

lemma FP_subset_FP_Orig: "F \<in> program ==> FP(F) \<subseteq> FP_Orig(F)"
by (rule stable_FP_Int [THEN FP_Orig_weakest], auto)

lemma FP_Orig_subset_FP: "F \<in> program ==> FP_Orig(F) \<subseteq> FP(F)"
apply (unfold FP_Orig_def FP_def, clarify)
apply (drule_tac x = "{x}" in spec)
apply (simp add: Int_cons_right)
apply (frule stableD2)
apply (auto simp add: cons_absorb st_set_def)
done

lemma FP_equivalence: "F \<in> program ==> FP(F) = FP_Orig(F)"
by (blast intro!: FP_Orig_subset_FP FP_subset_FP_Orig)

lemma FP_weakest [rule_format]:
     "[| \<forall>B. F \<in> stable(A \<inter> B); F \<in> program; st_set(A) |] ==> A \<subseteq> FP(F)"
by (simp add: FP_equivalence FP_Orig_weakest)

lemma Diff_FP:
     "[| F \<in> program;  st_set(A) |]
      ==> A-FP(F) = (\<Union>act \<in> Acts(F). A - {s \<in> state. act``{s} \<subseteq> {s}})"
by (unfold FP_def stable_def constrains_def st_set_def, blast)

end


(*  Title:      HOL/ex/Lagrange.thy
    Author:     Tobias Nipkow
    Copyright   1996 TU Muenchen
*)

section \<open>A lemma for Lagrange's theorem\<close>

theory Lagrange imports MainRLT begin

text \<open>This theory only contains a single theorem, which is a lemma
in Lagrange's proof that every natural number is the sum of 4 squares.
Its sole purpose is to demonstrate ordered rewriting for commutative
rings.

The enterprising reader might consider proving all of Lagrange's
theorem.\<close>

definition sq :: "'a::times => 'a" where "sq x == x*x"

text \<open>The following lemma essentially shows that every natural
number is the sum of four squares, provided all prime numbers are.
However, this is an abstract theorem about commutative rings.  It has,
a priori, nothing to do with nat.\<close>

lemma Lagrange_lemma: fixes x1 :: "'a::comm_ring" shows
  "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
   sq (x1*y1 - x2*y2 - x3*y3 - x4*y4)  +
   sq (x1*y2 + x2*y1 + x3*y4 - x4*y3)  +
   sq (x1*y3 - x2*y4 + x3*y1 + x4*y2)  +
   sq (x1*y4 + x2*y3 - x3*y2 + x4*y1)"
by (simp only: sq_def algebra_simps)

text \<open>A challenge by John Harrison. Takes about 12s on a 1.6GHz machine.\<close>

lemma fixes p1 :: "'a::comm_ring" shows
  "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
   (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)
    = sq (p1*p2 - q1*q2 - r1*r2 - s1*s2 - t1*t2 - u1*u2 - v1*v2 - w1*w2) +
      sq (p1*q2 + q1*p2 + r1*s2 - s1*r2 + t1*u2 - u1*t2 - v1*w2 + w1*v2) +
      sq (p1*r2 - q1*s2 + r1*p2 + s1*q2 + t1*v2 + u1*w2 - v1*t2 - w1*u2) +
      sq (p1*s2 + q1*r2 - r1*q2 + s1*p2 + t1*w2 - u1*v2 + v1*u2 - w1*t2) +
      sq (p1*t2 - q1*u2 - r1*v2 - s1*w2 + t1*p2 + u1*q2 + v1*r2 + w1*s2) +
      sq (p1*u2 + q1*t2 - r1*w2 + s1*v2 - t1*q2 + u1*p2 - v1*s2 + w1*r2) +
      sq (p1*v2 + q1*w2 + r1*t2 - s1*u2 - t1*r2 + u1*s2 + v1*p2 - w1*q2) +
      sq (p1*w2 - q1*v2 + r1*u2 + s1*t2 - t1*s2 - u1*r2 + v1*q2 + w1*p2)"
by (simp only: sq_def algebra_simps)

end


(*  Title:      HOL/MicroJava/BV/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Products as semilattices.
*)

header {* \isaheader{Products as Semilattices} *}

theory Product
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a \<times> 'b) ord"
where
  "le r\<^sub>A r\<^sub>B = (\<lambda>(a\<^sub>1,b\<^sub>1) (a\<^sub>2,b\<^sub>2). a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 \<and> b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"

definition sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a \<times> 'b) ebinop"
where
  "sup f g = (\<lambda>(a\<^sub>1,b\<^sub>1)(a\<^sub>2,b\<^sub>2). Err.sup Pair (a\<^sub>1 \<squnion>\<^sub>f a\<^sub>2) (b\<^sub>1 \<squnion>\<^sub>g b\<^sub>2))"

definition esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a \<times> 'b ) esl"
where
  "esl = (\<lambda>(A,r\<^sub>A,f\<^sub>A) (B,r\<^sub>B,f\<^sub>B). (A \<times> B, le r\<^sub>A r\<^sub>B, sup f\<^sub>A f\<^sub>B))"

(*<*)
abbreviation
  lesubprod1 :: "'a \<times> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
    ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50) where
  "p <=(rA,rB) q == p \<sqsubseteq>\<^bsub>Product.le rA rB\<^esub> q"
(*>*)

abbreviation (xsymbols)
  lesubprod :: "'a \<times> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
    ("(_ /\<sqsubseteq>'(_,_') _)" [50, 0, 0, 51] 50) where
  "p \<sqsubseteq>(rA,rB) q == p \<sqsubseteq>\<^bsub>Product.le rA rB\<^esub> q"

lemma unfold_lesub_prod: "x \<sqsubseteq>(r\<^sub>A,r\<^sub>B) y = le r\<^sub>A r\<^sub>B x y"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_prod_Pair_conv [iff]: "((a\<^sub>1,b\<^sub>1) \<sqsubseteq>(r\<^sub>A,r\<^sub>B) (a\<^sub>2,b\<^sub>2)) = (a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*) by (simp add: lesub_def le_def) (*>*)

lemma less_prod_Pair_conv:
  "((a\<^sub>1,b\<^sub>1) \<sqsubset>\<^bsub>Product.le r\<^sub>A r\<^sub>B\<^esub> (a\<^sub>2,b\<^sub>2)) =
  (a\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2 | a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*)
apply (unfold lesssub_def)
apply simp
apply blast
done
(*>*)

lemma order_le_prod [iff]: "order(Product.le r\<^sub>A r\<^sub>B) = (order r\<^sub>A & order r\<^sub>B)"
(*<*)
apply (unfold order_def)
apply simp
apply safe
apply blast+
done
(*>*)

lemma acc_le_prodI [intro!]:
  "\<lbrakk> acc A r\<^sub>A; acc B r\<^sub>B \<rbrakk> \<Longrightarrow> acc (A \<times> B) (Product.le r\<^sub>A r\<^sub>B)"
(*<*)
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
(*>*)

lemma unfold_plussub_lift2: "e\<^sub>1 \<squnion>\<^bsub>lift2 f\<^esub> e\<^sub>2 = lift2 f e\<^sub>1 e\<^sub>2"
(*<*) by (simp add: plussub_def) (*>*)

lemma plus_eq_Err_conv [simp]:
  assumes "x\<in>A"  "y\<in>A"  "semilat(err A, Err.le r, lift2 f)"
  shows "(x \<squnion>\<^sub>f y = Err) = (\<not>(\<exists>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z))"
(*<*)
proof -
  have plus_le_conv2:
    "\<And>r f z. \<lbrakk> z \<in> err A; semilat (err A, r, f); OK x \<in> err A; OK y \<in> err A;
                 OK x \<squnion>\<^sub>f OK y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> OK x \<sqsubseteq>\<^sub>r z \<and> OK y \<sqsubseteq>\<^sub>r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x \<squnion>\<^sub>f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def' closed_def)
  apply simp
  done
qed
(*>*)

lemma err_semilat_Product_esl:
  "\<And>L\<^sub>1 L\<^sub>2. \<lbrakk> err_semilat L\<^sub>1; err_semilat L\<^sub>2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L\<^sub>1 L\<^sub>2)"
(*<*)
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)

end