(*  Title:      Sequents/LK/Hard_Quantifiers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Hard examples with quantifiers.  Can be read to test the LK system.
From  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.

Uses pc_tac rather than fast_tac when the former is significantly faster.
*)

theory Hard_Quantifiers
imports "../LK"
begin

lemma "\<turnstile> (\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))"
  by fast

lemma "\<turnstile> (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))"
  by fast

lemma "\<turnstile> (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q"
  by fast

lemma "\<turnstile> (\<forall>x. P(x)) \<or> Q \<longleftrightarrow> (\<forall>x. P(x) \<or> Q)"
  by fast

text "Problems requiring quantifier duplication"

(*Not provable by fast: needs multiple instantiation of \<forall>*)
lemma "\<turnstile> (\<forall>x. P(x) \<longrightarrow> P(f(x))) \<and> P(d) \<longrightarrow> P(f(f(f(d))))"
  by best_dup

(*Needs double instantiation of the quantifier*)
lemma "\<turnstile> \<exists>x. P(x) \<longrightarrow> P(a) \<and> P(b)"
  by fast_dup

lemma "\<turnstile> \<exists>z. P(z) \<longrightarrow> (\<forall>x. P(x))"
  by best_dup

text "Hard examples with quantifiers"

text "Problem 18"
lemma "\<turnstile> \<exists>y. \<forall>x. P(y)\<longrightarrow>P(x)"
  by best_dup

text "Problem 19"
lemma "\<turnstile> \<exists>x. \<forall>y z. (P(y)\<longrightarrow>Q(z)) \<longrightarrow> (P(x)\<longrightarrow>Q(x))"
  by best_dup

text "Problem 20"
lemma "\<turnstile> (\<forall>x y. \<exists>z. \<forall>w. (P(x) \<and> Q(y)\<longrightarrow>R(z) \<and> S(w)))
    \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))"
  by fast

text "Problem 21"
lemma "\<turnstile> (\<exists>x. P \<longrightarrow> Q(x)) \<and> (\<exists>x. Q(x) \<longrightarrow> P) \<longrightarrow> (\<exists>x. P \<longleftrightarrow> Q(x))"
  by best_dup

text "Problem 22"
lemma "\<turnstile> (\<forall>x. P \<longleftrightarrow> Q(x)) \<longrightarrow> (P \<longleftrightarrow> (\<forall>x. Q(x)))"
  by fast

text "Problem 23"
lemma "\<turnstile> (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> (P \<or> (\<forall>x. Q(x)))"
  by best

text "Problem 24"
lemma "\<turnstile> \<not> (\<exists>x. S(x) \<and> Q(x)) \<and> (\<forall>x. P(x) \<longrightarrow> Q(x) \<or> R(x)) \<and>
     \<not> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x)) \<and> (\<forall>x. Q(x) \<or> R(x) \<longrightarrow> S(x))
    \<longrightarrow> (\<exists>x. P(x) \<and> R(x))"
  by pc

text "Problem 25"
lemma "\<turnstile> (\<exists>x. P(x)) \<and>
        (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
        (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
        ((\<forall>x. P(x)\<longrightarrow>Q(x)) \<or> (\<exists>x. P(x) \<and> R(x)))
    \<longrightarrow> (\<exists>x. Q(x) \<and> P(x))"
  by best

text "Problem 26"
lemma "\<turnstile> ((\<exists>x. p(x)) \<longleftrightarrow> (\<exists>x. q(x))) \<and>
      (\<forall>x. \<forall>y. p(x) \<and> q(y) \<longrightarrow> (r(x) \<longleftrightarrow> s(y)))
  \<longrightarrow> ((\<forall>x. p(x)\<longrightarrow>r(x)) \<longleftrightarrow> (\<forall>x. q(x)\<longrightarrow>s(x)))"
  by pc

text "Problem 27"
lemma "\<turnstile> (\<exists>x. P(x) \<and> \<not> Q(x)) \<and>
              (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
              (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
              ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
          \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not> L(x))"
  by pc

text "Problem 28.  AMENDED"
lemma "\<turnstile> (\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
        ((\<forall>x. Q(x) \<or> R(x)) \<longrightarrow> (\<exists>x. Q(x) \<and> S(x))) \<and>
        ((\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
    \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))"
  by pc

text "Problem 29.  Essentially the same as Principia Mathematica *11.71"
lemma "\<turnstile> (\<exists>x. P(x)) \<and> (\<exists>y. Q(y))
    \<longrightarrow> ((\<forall>x. P(x) \<longrightarrow> R(x)) \<and> (\<forall>y. Q(y) \<longrightarrow> S(y)) \<longleftrightarrow>
         (\<forall>x y. P(x) \<and> Q(y) \<longrightarrow> R(x) \<and> S(y)))"
  by pc

text "Problem 30"
lemma "\<turnstile> (\<forall>x. P(x) \<or> Q(x) \<longrightarrow> \<not> R(x)) \<and>
        (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
    \<longrightarrow> (\<forall>x. S(x))"
  by fast

text "Problem 31"
lemma "\<turnstile> \<not> (\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
        (\<exists>x. L(x) \<and> P(x)) \<and>
        (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
    \<longrightarrow> (\<exists>x. L(x) \<and> M(x))"
  by fast

text "Problem 32"
lemma "\<turnstile> (\<forall>x. P(x) \<and> (Q(x) \<or> R(x)) \<longrightarrow> S(x)) \<and>
        (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
        (\<forall>x. M(x) \<longrightarrow> R(x))
    \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))"
  by best

text "Problem 33"
lemma "\<turnstile> (\<forall>x. P(a) \<and> (P(x) \<longrightarrow> P(b)) \<longrightarrow> P(c)) \<longleftrightarrow>
     (\<forall>x. (\<not> P(a) \<or> P(x) \<or> P(c)) \<and> (\<not> P(a) \<or> \<not> P(b) \<or> P(c)))"
  by fast

text "Problem 34  AMENDED (TWICE!!)"
(*Andrews's challenge*)
lemma "\<turnstile> ((\<exists>x. \<forall>y. p(x) \<longleftrightarrow> p(y))  \<longleftrightarrow>
               ((\<exists>x. q(x)) \<longleftrightarrow> (\<forall>y. p(y))))     \<longleftrightarrow>
              ((\<exists>x. \<forall>y. q(x) \<longleftrightarrow> q(y))  \<longleftrightarrow>
               ((\<exists>x. p(x)) \<longleftrightarrow> (\<forall>y. q(y))))"
  by best_dup

text "Problem 35"
lemma "\<turnstile> \<exists>x y. P(x,y) \<longrightarrow> (\<forall>u v. P(u,v))"
  by best_dup

text "Problem 36"
lemma "\<turnstile> (\<forall>x. \<exists>y. J(x,y)) \<and>
         (\<forall>x. \<exists>y. G(x,y)) \<and>
         (\<forall>x y. J(x,y) \<or> G(x,y) \<longrightarrow>
         (\<forall>z. J(y,z) \<or> G(y,z) \<longrightarrow> H(x,z)))
         \<longrightarrow> (\<forall>x. \<exists>y. H(x,y))"
  by fast

text "Problem 37"
lemma "\<turnstile> (\<forall>z. \<exists>w. \<forall>x. \<exists>y.
           (P(x,z)\<longrightarrow>P(y,w)) \<and> P(y,z) \<and> (P(y,w) \<longrightarrow> (\<exists>u. Q(u,w)))) \<and>
        (\<forall>x z. \<not> P(x,z) \<longrightarrow> (\<exists>y. Q(y,z))) \<and>
        ((\<exists>x y. Q(x,y)) \<longrightarrow> (\<forall>x. R(x,x)))
    \<longrightarrow> (\<forall>x. \<exists>y. R(x,y))"
  by pc

text "Problem 38"
lemma "\<turnstile> (\<forall>x. p(a) \<and> (p(x) \<longrightarrow> (\<exists>y. p(y) \<and> r(x,y))) \<longrightarrow>
                 (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z)))  \<longleftrightarrow>
         (\<forall>x. (\<not> p(a) \<or> p(x) \<or> (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))) \<and>
                 (\<not> p(a) \<or> \<not> (\<exists>y. p(y) \<and> r(x,y)) \<or>
                 (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))))"
  by pc

text "Problem 39"
lemma "\<turnstile> \<not> (\<exists>x. \<forall>y. F(y,x) \<longleftrightarrow> \<not> F(y,y))"
  by fast

text "Problem 40.  AMENDED"
lemma "\<turnstile> (\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> F(x,x)) \<longrightarrow>
         \<not> (\<forall>x. \<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not> F(z,x))"
  by fast

text "Problem 41"
lemma "\<turnstile> (\<forall>z. \<exists>y. \<forall>x. f(x,y) \<longleftrightarrow> f(x,z) \<and> \<not> f(x,x))
         \<longrightarrow> \<not> (\<exists>z. \<forall>x. f(x,z))"
  by fast

text "Problem 42"
lemma "\<turnstile> \<not> (\<exists>y. \<forall>x. p(x,y) \<longleftrightarrow> \<not> (\<exists>z. p(x,z) \<and> p(z,x)))"
  oops

text "Problem 43"
lemma "\<turnstile> (\<forall>x. \<forall>y. q(x,y) \<longleftrightarrow> (\<forall>z. p(z,x) \<longleftrightarrow> p(z,y)))
          \<longrightarrow> (\<forall>x. (\<forall>y. q(x,y) \<longleftrightarrow> q(y,x)))"
  oops

text "Problem 44"
lemma "\<turnstile> (\<forall>x. f(x) \<longrightarrow>
                 (\<exists>y. g(y) \<and> h(x,y) \<and> (\<exists>y. g(y) \<and> \<not> h(x,y)))) \<and>
         (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h(x,y)))
         \<longrightarrow> (\<exists>x. j(x) \<and> \<not> f(x))"
  by fast

text "Problem 45"
lemma "\<turnstile> (\<forall>x. f(x) \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y))
                      \<longrightarrow> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> k(y))) \<and>
      \<not> (\<exists>y. l(y) \<and> k(y)) \<and>
      (\<exists>x. f(x) \<and> (\<forall>y. h(x,y) \<longrightarrow> l(y))
                   \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y)))
      \<longrightarrow> (\<exists>x. f(x) \<and> \<not> (\<exists>y. g(y) \<and> h(x,y)))"
  by best

text "Problems (mainly) involving equality or functions"

text "Problem 48"
lemma "\<turnstile> (a = b \<or> c = d) \<and> (a = c \<or> b = d) \<longrightarrow> a = d \<or> b = c"
  by (fast add!: subst)

text "Problem 50"
lemma "\<turnstile> (\<forall>x. P(a,x) \<or> (\<forall>y. P(x,y))) \<longrightarrow> (\<exists>x. \<forall>y. P(x,y))"
  by best_dup

text "Problem 51"
lemma "\<turnstile> (\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
         (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P(x,y) \<longleftrightarrow> y = w) \<longleftrightarrow> x = z)"
  by (fast add!: subst)

text "Problem 52"  (*Almost the same as 51. *)
lemma "\<turnstile> (\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
         (\<exists>w. \<forall>y. \<exists>z. (\<forall>x. P(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w)"
  by (fast add!: subst)

text "Problem 56"
lemma "\<turnstile> (\<forall>x.(\<exists>y. P(y) \<and> x = f(y)) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> P(f(x)))"
  by (best add: symL subst)
  (*requires tricker to orient the equality properly*)

text "Problem 57"
lemma "\<turnstile> P(f(a,b), f(b,c)) \<and> P(f(b,c), f(a,c)) \<and>
         (\<forall>x y z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<longrightarrow> P(f(a,b), f(a,c))"
  by fast

text "Problem 58!"
lemma "\<turnstile> (\<forall>x y. f(x) = g(y)) \<longrightarrow> (\<forall>x y. f(f(x)) = f(g(y)))"
  by (fast add!: subst)

text "Problem 59"
(*Unification works poorly here -- the abstraction %sobj prevents efficient
  operation of the occurs check*)
lemma "\<turnstile> (\<forall>x. P(x) \<longleftrightarrow> \<not> P(f(x))) \<longrightarrow> (\<exists>x. P(x) \<and> \<not> P(f(x)))"
  using [[unify_trace_bound = 50]]
  by best_dup

text "Problem 60"
lemma "\<turnstile> \<forall>x. P(x,f(x)) \<longleftrightarrow> (\<exists>y. (\<forall>z. P(z,y) \<longrightarrow> P(z,f(x))) \<and> P(x,y))"
  by fast

text "Problem 62 as corrected in JAR 18 (1997), page 135"
lemma "\<turnstile> (\<forall>x. p(a) \<and> (p(x) \<longrightarrow> p(f(x))) \<longrightarrow> p(f(f(x)))) \<longleftrightarrow>
      (\<forall>x. (\<not> p(a) \<or> p(x) \<or> p(f(f(x)))) \<and>
              (\<not> p(a) \<or> \<not> p(f(x)) \<or> p(f(f(x)))))"
  by fast

(*18 June 92: loaded in 372 secs*)
(*19 June 92: loaded in 166 secs except #34, using repeat_goal_tac*)
(*29 June 92: loaded in 370 secs*)
(*18 September 2005: loaded in 1.809 secs*)

end


section \<open>Extra theorems on prefixes of Lists and their coinductive counterparts\<close>

theory MorePrefix
  imports MoreCoinductiveList2 (* for notation and lemmas like infinite_small_llength *)
begin

subsection \<open> Reasoning about prefixes \<close>
lemma head_prefixes [simp]:
  "prefixes list ! 0 = []"
  by (metis hd_conv_nth hd_prefixes prefixes_not_Nil)

lemma non_head_prefixes [simp]:
  assumes "n < length p" shows "(prefixes p ! Suc n) \<noteq> []"
proof -
  have "0 < length (prefixes p)" "Suc n < length (prefixes p)" by (auto simp: assms)
  then show ?thesis by (metis Zero_not_Suc distinct_prefixes head_prefixes nth_eq_iff_index_eq)
qed

lemma last_prefixes:
  assumes "i < length p"
  shows "last (tl (prefixes p) ! i) = p ! i"
  using assms
proof(induct p arbitrary:i)
  case (Cons a p i)
  show ?case proof(cases i)
    case (Suc nat)
    with Cons have "p ! nat = last (tl (prefixes p) ! nat)" "nat < length p" by auto
    then show ?thesis unfolding Suc by(auto simp:nth_tl)
  qed auto
qed force

lemma take_1_prefixes[simp]:
  "take (Suc 0) (prefixes list) = [[]]"
  by (simp add: take_Suc)

lemma map_last_prefixes [simp]:
  shows "map last (tl (prefixes p)) = p"
  unfolding list_eq_iff_nth_eq
  using last_prefixes by auto

lemma ltake_zero[simp]: "ltake (enat (0::nat)) lst = LNil"
  (* nitpick finds a counterexample in Isabelle2021*)
  by (simp add: zero_enat_def)

lemma ltakes_one_iterates:
  "ltake (enat (Suc 0)) (iterates f p) = LCons p LNil"
  by (metis One_nat_def iterates_lmap ltake_eSuc_LCons ltake_zero one_eSuc one_enat_def zero_enat_def)

lemma ltakes_suc_iterates[simp]:
  "ltake (enat (Suc n)) (iterates f p) = LCons p (ltake (enat n) (iterates f (f p)))"
  by (induct n,force simp:ltakes_one_iterates,metis eSuc_enat iterates.code ltake_eSuc_LCons)

lemma prefixes_nth_take[simp]:
  assumes "i \<le> length p"
  shows "prefixes p ! i = take i p"
  using assms proof(induct p arbitrary:i)
  case (Cons a p i) thus ?case by (cases i, auto)
qed auto

lemma tl_prefixes_idx:
  assumes "i < length p"
  shows "tl (prefixes p) ! i = take (Suc i) p"
  using assms by(induct p,auto)

lemma list_of_lappend_llist_of[simp]:
  assumes "lfinite q"
  shows "list_of (lappend (llist_of p) q) = append p (list_of q)"
  using assms by(induct p,auto)

lemma nth_prefixes:
  "n < length p \<Longrightarrow> \<not> Suc n < length p \<Longrightarrow> tl (prefixes p) ! n = p"
  by(induct p arbitrary:n,auto)

lemma take_Suc_prefix:
  "prefix (take n p) (take (Suc n) p)"
proof(induct p arbitrary:n)
  case (Cons a p n)
  then show ?case by(cases n,auto)
qed auto

lemma nth_prefixes_is_prefix:
  "n < length p  \<Longrightarrow> prefix ((prefixes p) ! n) ((prefixes p) ! Suc n)"
  by(induct "length p" n arbitrary:p rule:diff_induct,auto simp:take_Suc_prefix)

lemma nth_prefixes_is_prefix_tl:
  "Suc n < length p  \<Longrightarrow> prefix (tl (prefixes p) ! n) (tl (prefixes p) ! Suc n)"
  by (cases p) (auto simp:nth_prefixes_is_prefix take_Suc_prefix)

lemma prefix_same_length_eq:
  shows "(prefix a b \<and> length a = length b) \<longleftrightarrow> a = b"
  by (metis prefix_length_le prefix_length_prefix prefix_order.antisym prefix_order.order_refl)

lemma prefix_takeI:
  assumes "prefix a b" "n \<ge> length a"
  shows "prefix a (take n b)"
  using assms
  by (smt (verit) prefix_length_prefix length_take min.absorb2 nat_le_linear take_all take_is_prefix)

thm prefix_length_prefix (* compare to *)
lemma lprefix_llength_lprefix:
  assumes "lprefix a c" "lprefix b c" "llength a \<le> llength b"
  shows "lprefix a b"
  using assms
  by (metis dual_order.antisym lprefix_down_linear lprefix_llength_eq_imp_eq lprefix_llength_le)

thm prefix_takeI (* compare to *)
lemma lprefix_ltakeI:
  assumes "lprefix a b" "llength a \<le> n"
  shows "lprefix a (ltake n b)"
  by (smt (verit, best) dual_order.antisym lappend_eq_lappend_conv lappend_ltake_ldrop llength_ltake
                        assms lprefix_conv_lappend lprefix_down_linear lprefix_llength_le min_def)

abbreviation augment_list where
  "augment_list \<sigma> p \<equiv> p @ [\<sigma> p]"

lemma length_augment_list:
  "length ((augment_list f ^^ n) p) = n + length p"
  by(induct n,auto)

lemma augment_list_nonempty:
  assumes "p\<noteq>[]" shows "(augment_list f ^^ i) p \<noteq> []"
  using assms by(cases i,auto)

lemma augment_list_Suc_prefix:
  "prefix ((augment_list f ^^ n) p) ((augment_list f ^^ Suc n) p)"
  by(cases n,auto simp:take_Suc_prefix)

lemma augment_list_prefix:
  "n \<le> m \<Longrightarrow> prefix ((augment_list f ^^ n) p) ((augment_list f ^^ m) p)"
proof(induct "m-n" arbitrary:m n)
  case (Suc x)
  hence [simp]:"Suc (x + n) = m" by auto
  from Suc.hyps(2)
    prefix_order.trans[OF Suc.hyps(1)[of "x + n" n] augment_list_Suc_prefix[of "x+n" f p]]
  show ?case by auto
qed auto

lemma augment_list_nonsense[dest]:
assumes "(augment_list \<sigma> ^^ n) p = []"
shows "n=0" "p=[]"
using assms by(induct n,auto)

lemma prefix_augment:
  shows "prefix p ((augment_list s ^^ n) p)"
  by (induct n,auto simp:prefix_def)

end


(*  Title:      HOL/ZF/HOLZF.thy
    Author:     Steven Obua

Axiomatizes the ZFC universe as an HOL type.  See "Partizan Games in
Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory HOLZF
imports Main
begin

typedecl ZF

axiomatization
  Empty :: ZF and
  Elem :: "ZF \<Rightarrow> ZF \<Rightarrow> bool" and
  Sum :: "ZF \<Rightarrow> ZF" and
  Power :: "ZF \<Rightarrow> ZF" and
  Repl :: "ZF \<Rightarrow> (ZF \<Rightarrow> ZF) \<Rightarrow> ZF" and
  Inf :: ZF

definition Upair :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "Upair a b == Repl (Power (Power Empty)) (% x. if x = Empty then a else b)"

definition Singleton:: "ZF \<Rightarrow> ZF" where
  "Singleton x == Upair x x"

definition union :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "union A B == Sum (Upair A B)"

definition SucNat:: "ZF \<Rightarrow> ZF" where
  "SucNat x == union x (Singleton x)"

definition subset :: "ZF \<Rightarrow> ZF \<Rightarrow> bool" where
  "subset A B == ! x. Elem x A \<longrightarrow> Elem x B"

axiomatization where
  Empty: "Not (Elem x Empty)" and
  Ext: "(x = y) = (! z. Elem z x = Elem z y)" and
  Sum: "Elem z (Sum x) = (? y. Elem z y & Elem y x)" and
  Power: "Elem y (Power x) = (subset y x)" and
  Repl: "Elem b (Repl A f) = (? a. Elem a A & b = f a)" and
  Regularity: "A \<noteq> Empty \<longrightarrow> (? x. Elem x A & (! y. Elem y x \<longrightarrow> Not (Elem y A)))" and
  Infinity: "Elem Empty Inf & (! x. Elem x Inf \<longrightarrow> Elem (SucNat x) Inf)"

definition Sep :: "ZF \<Rightarrow> (ZF \<Rightarrow> bool) \<Rightarrow> ZF" where
  "Sep A p == (if (!x. Elem x A \<longrightarrow> Not (p x)) then Empty else
  (let z = (\<some> x. Elem x A & p x) in
   let f = % x. (if p x then x else z) in Repl A f))"

thm Power[unfolded subset_def]

theorem Sep: "Elem b (Sep A p) = (Elem b A & p b)"
  apply (auto simp add: Sep_def Empty)
  apply (auto simp add: Let_def Repl)
  apply (rule someI2, auto)+
  done

lemma subset_empty: "subset Empty A"
  by (simp add: subset_def Empty)

theorem Upair: "Elem x (Upair a b) = (x = a | x = b)"
  apply (auto simp add: Upair_def Repl)
  apply (rule exI[where x=Empty])
  apply (simp add: Power subset_empty)
  apply (rule exI[where x="Power Empty"])
  apply (auto)
  apply (auto simp add: Ext Power subset_def Empty)
  apply (drule spec[where x=Empty], simp add: Empty)+
  done

lemma Singleton: "Elem x (Singleton y) = (x = y)"
  by (simp add: Singleton_def Upair)

definition Opair :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "Opair a b == Upair (Upair a a) (Upair a b)"

lemma Upair_singleton: "(Upair a a = Upair c d) = (a = c & a = d)"
  by (auto simp add: Ext[where x="Upair a a"] Upair)

lemma Upair_fsteq: "(Upair a b = Upair a c) = ((a = b & a = c) | (b = c))"
  by (auto simp add: Ext[where x="Upair a b"] Upair)

lemma Upair_comm: "Upair a b = Upair b a"
  by (auto simp add: Ext Upair)

theorem Opair: "(Opair a b = Opair c d) = (a = c & b = d)"
  proof -
    have fst: "(Opair a b = Opair c d) \<Longrightarrow> a = c"
      apply (simp add: Opair_def)
      apply (simp add: Ext[where x="Upair (Upair a a) (Upair a b)"])
      apply (drule spec[where x="Upair a a"])
      apply (auto simp add: Upair Upair_singleton)
      done
    show ?thesis
      apply (auto)
      apply (erule fst)
      apply (frule fst)
      apply (auto simp add: Opair_def Upair_fsteq)
      done
  qed

definition Replacement :: "ZF \<Rightarrow> (ZF \<Rightarrow> ZF option) \<Rightarrow> ZF" where
  "Replacement A f == Repl (Sep A (% a. f a \<noteq> None)) (the o f)"

theorem Replacement: "Elem y (Replacement A f) = (? x. Elem x A & f x = Some y)"
  by (auto simp add: Replacement_def Repl Sep)

definition Fst :: "ZF \<Rightarrow> ZF" where
  "Fst q == SOME x. ? y. q = Opair x y"

definition Snd :: "ZF \<Rightarrow> ZF" where
  "Snd q == SOME y. ? x. q = Opair x y"

theorem Fst: "Fst (Opair x y) = x"
  apply (simp add: Fst_def)
  apply (rule someI2)
  apply (simp_all add: Opair)
  done

theorem Snd: "Snd (Opair x y) = y"
  apply (simp add: Snd_def)
  apply (rule someI2)
  apply (simp_all add: Opair)
  done

definition isOpair :: "ZF \<Rightarrow> bool" where
  "isOpair q == ? x y. q = Opair x y"

lemma isOpair: "isOpair (Opair x y) = True"
  by (auto simp add: isOpair_def)

lemma FstSnd: "isOpair x \<Longrightarrow> Opair (Fst x) (Snd x) = x"
  by (auto simp add: isOpair_def Fst Snd)

definition CartProd :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "CartProd A B == Sum(Repl A (% a. Repl B (% b. Opair a b)))"

lemma CartProd: "Elem x (CartProd A B) = (? a b. Elem a A & Elem b B & x = (Opair a b))"
  apply (auto simp add: CartProd_def Sum Repl)
  apply (rule_tac x="Repl B (Opair a)" in exI)
  apply (auto simp add: Repl)
  done

definition explode :: "ZF \<Rightarrow> ZF set" where
  "explode z == { x. Elem x z }"

lemma explode_Empty: "(explode x = {}) = (x = Empty)"
  by (auto simp add: explode_def Ext Empty)

lemma explode_Elem: "(x \<in> explode X) = (Elem x X)"
  by (simp add: explode_def)

lemma Elem_explode_in: "\<lbrakk> Elem a A; explode A \<subseteq> B\<rbrakk> \<Longrightarrow> a \<in> B"
  by (auto simp add: explode_def)

lemma explode_CartProd_eq: "explode (CartProd a b) = (% (x,y). Opair x y) ` ((explode a) \<times> (explode b))"
  by (simp add: explode_def set_eq_iff CartProd image_def)

lemma explode_Repl_eq: "explode (Repl A f) = image f (explode A)"
  by (simp add: explode_def Repl image_def)

definition Domain :: "ZF \<Rightarrow> ZF" where
  "Domain f == Replacement f (% p. if isOpair p then Some (Fst p) else None)"

definition Range :: "ZF \<Rightarrow> ZF" where
  "Range f == Replacement f (% p. if isOpair p then Some (Snd p) else None)"

theorem Domain: "Elem x (Domain f) = (? y. Elem (Opair x y) f)"
  apply (auto simp add: Domain_def Replacement)
  apply (rule_tac x="Snd xa" in exI)
  apply (simp add: FstSnd)
  apply (rule_tac x="Opair x y" in exI)
  apply (simp add: isOpair Fst)
  done

theorem Range: "Elem y (Range f) = (? x. Elem (Opair x y) f)"
  apply (auto simp add: Range_def Replacement)
  apply (rule_tac x="Fst x" in exI)
  apply (simp add: FstSnd)
  apply (rule_tac x="Opair x y" in exI)
  apply (simp add: isOpair Snd)
  done

theorem union: "Elem x (union A B) = (Elem x A | Elem x B)"
  by (auto simp add: union_def Sum Upair)

definition Field :: "ZF \<Rightarrow> ZF" where
  "Field A == union (Domain A) (Range A)"

definition app :: "ZF \<Rightarrow> ZF => ZF" (infixl "\<acute>" 90) \<comment>\<open>function application\<close> where
  "f \<acute> x == (THE y. Elem (Opair x y) f)"

definition isFun :: "ZF \<Rightarrow> bool" where
  "isFun f == (! x y1 y2. Elem (Opair x y1) f & Elem (Opair x y2) f \<longrightarrow> y1 = y2)"

definition Lambda :: "ZF \<Rightarrow> (ZF \<Rightarrow> ZF) \<Rightarrow> ZF" where
  "Lambda A f == Repl A (% x. Opair x (f x))"

lemma Lambda_app: "Elem x A \<Longrightarrow> (Lambda A f)\<acute>x = f x"
  by (simp add: app_def Lambda_def Repl Opair)

lemma isFun_Lambda: "isFun (Lambda A f)"
  by (auto simp add: isFun_def Lambda_def Repl Opair)

lemma domain_Lambda: "Domain (Lambda A f) = A"
  apply (auto simp add: Domain_def)
  apply (subst Ext)
  apply (auto simp add: Replacement)
  apply (simp add: Lambda_def Repl)
  apply (auto simp add: Fst)
  apply (simp add: Lambda_def Repl)
  apply (rule_tac x="Opair z (f z)" in exI)
  apply (auto simp add: Fst isOpair_def)
  done

lemma Lambda_ext: "(Lambda s f = Lambda t g) = (s = t & (! x. Elem x s \<longrightarrow> f x = g x))"
proof -
  have "Lambda s f = Lambda t g \<Longrightarrow> s = t"
    apply (subst domain_Lambda[where A = s and f = f, symmetric])
    apply (subst domain_Lambda[where A = t and f = g, symmetric])
    apply auto
    done
  then show ?thesis
    apply auto
    apply (subst Lambda_app[where f=f, symmetric], simp)
    apply (subst Lambda_app[where f=g, symmetric], simp)
    apply auto
    apply (auto simp add: Lambda_def Repl Ext)
    apply (auto simp add: Ext[symmetric])
    done
qed

definition PFun :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "PFun A B == Sep (Power (CartProd A B)) isFun"

definition Fun :: "ZF \<Rightarrow> ZF \<Rightarrow> ZF" where
  "Fun A B == Sep (PFun A B) (\<lambda> f. Domain f = A)"

lemma Fun_Range: "Elem f (Fun U V) \<Longrightarrow> subset (Range f) V"
  apply (simp add: Fun_def Sep PFun_def Power subset_def CartProd)
  apply (auto simp add: Domain Range)
  apply (erule_tac x="Opair xa x" in allE)
  apply (auto simp add: Opair)
  done

lemma Elem_Elem_PFun: "Elem F (PFun U V) \<Longrightarrow> Elem p F \<Longrightarrow> isOpair p & Elem (Fst p) U & Elem (Snd p) V"
  apply (simp add: PFun_def Sep Power subset_def, clarify)
  apply (erule_tac x=p in allE)
  apply (auto simp add: CartProd isOpair Fst Snd)
  done

lemma Fun_implies_PFun[simp]: "Elem f (Fun U V) \<Longrightarrow> Elem f (PFun U V)"
  by (simp add: Fun_def Sep)

lemma Elem_Elem_Fun: "Elem F (Fun U V) \<Longrightarrow> Elem p F \<Longrightarrow> isOpair p & Elem (Fst p) U & Elem (Snd p) V"
  by (auto simp add: Elem_Elem_PFun dest: Fun_implies_PFun)

lemma PFun_inj: "Elem F (PFun U V) \<Longrightarrow> Elem x F \<Longrightarrow> Elem y F \<Longrightarrow> Fst x = Fst y \<Longrightarrow> Snd x = Snd y"
  apply (frule Elem_Elem_PFun[where p=x], simp)
  apply (frule Elem_Elem_PFun[where p=y], simp)
  apply (subgoal_tac "isFun F")
  apply (simp add: isFun_def isOpair_def)
  apply (auto simp add: Fst Snd)
  apply (auto simp add: PFun_def Sep)
  done

lemma Fun_total: "\<lbrakk>Elem F (Fun U V); Elem a U\<rbrakk> \<Longrightarrow> \<exists>x. Elem (Opair a x) F"
  using [[simp_depth_limit = 2]]
  by (auto simp add: Fun_def Sep Domain)

lemma unique_fun_value: "\<lbrakk>isFun f; Elem x (Domain f)\<rbrakk> \<Longrightarrow> \<exists>!y. Elem (Opair x y) f"
  by (auto simp add: Domain isFun_def)

lemma fun_value_in_range: "\<lbrakk>isFun f; Elem x (Domain f)\<rbrakk> \<Longrightarrow> Elem (f\<acute>x) (Range f)"
  apply (auto simp add: Range)
  apply (drule unique_fun_value)
  apply simp
  apply (simp add: app_def)
  apply (rule exI[where x=x])
  apply (auto simp add: the_equality)
  done

lemma fun_range_witness: "\<lbrakk>isFun f; Elem y (Range f)\<rbrakk> \<Longrightarrow> ? x. Elem x (Domain f) & f\<acute>x = y"
  apply (auto simp add: Range)
  apply (rule_tac x="x" in exI)
  apply (auto simp add: app_def the_equality isFun_def Domain)
  done

lemma Elem_Fun_Lambda: "Elem F (Fun U V) \<Longrightarrow> ? f. F = Lambda U f"
  apply (rule exI[where x= "% x. (THE y. Elem (Opair x y) F)"])
  apply (simp add: Ext Lambda_def Repl Domain)
  apply (simp add: Ext[symmetric])
  apply auto
  apply (frule Elem_Elem_Fun)
  apply auto
  apply (rule_tac x="Fst z" in exI)
  apply (simp add: isOpair_def)
  apply (auto simp add: Fst Snd Opair)
  apply (rule the1I2)
  apply auto
  apply (drule Fun_implies_PFun)
  apply (drule_tac x="Opair x ya" and y="Opair x yb" in PFun_inj)
  apply (auto simp add: Fst Snd)
  apply (drule Fun_implies_PFun)
  apply (drule_tac x="Opair x y" and y="Opair x ya" in PFun_inj)
  apply (auto simp add: Fst Snd)
  apply (rule the1I2)
  apply (auto simp add: Fun_total)
  apply (drule Fun_implies_PFun)
  apply (drule_tac x="Opair a x" and y="Opair a y" in PFun_inj)
  apply (auto simp add: Fst Snd)
  done

lemma Elem_Lambda_Fun: "Elem (Lambda A f) (Fun U V) = (A = U & (! x. Elem x A \<longrightarrow> Elem (f x) V))"
proof -
  have "Elem (Lambda A f) (Fun U V) \<Longrightarrow> A = U"
    by (simp add: Fun_def Sep domain_Lambda)
  then show ?thesis
    apply auto
    apply (drule Fun_Range)
    apply (subgoal_tac "f x = ((Lambda U f) \<acute> x)")
    prefer 2
    apply (simp add: Lambda_app)
    apply simp
    apply (subgoal_tac "Elem (Lambda U f \<acute> x) (Range (Lambda U f))")
    apply (simp add: subset_def)
    apply (rule fun_value_in_range)
    apply (simp_all add: isFun_Lambda domain_Lambda)
    apply (simp add: Fun_def Sep PFun_def Power domain_Lambda isFun_Lambda)
    apply (auto simp add: subset_def CartProd)
    apply (rule_tac x="Fst x" in exI)
    apply (auto simp add: Lambda_def Repl Fst)
    done
qed

definition is_Elem_of :: "(ZF * ZF) set" where
  "is_Elem_of == { (a,b) | a b. Elem a b }"

lemma cond_wf_Elem:
  assumes hyps:"\<forall>x. (\<forall>y. Elem y x \<longrightarrow> Elem y U \<longrightarrow> P y) \<longrightarrow> Elem x U \<longrightarrow> P x" "Elem a U"
  shows "P a"
proof -
  {
    fix P
    fix U
    fix a
    assume P_induct: "(\<forall>x. (\<forall>y. Elem y x \<longrightarrow> Elem y U \<longrightarrow> P y) \<longrightarrow> (Elem x U \<longrightarrow> P x))"
    assume a_in_U: "Elem a U"
    have "P a"
      proof -
        term "P"
        term Sep
        let ?Z = "Sep U (Not o P)"
        have "?Z = Empty \<longrightarrow> P a" by (simp add: Ext Sep Empty a_in_U)
        moreover have "?Z \<noteq> Empty \<longrightarrow> False"
          proof
            assume not_empty: "?Z \<noteq> Empty"
            note thereis_x = Regularity[where A="?Z", simplified not_empty, simplified]
            then obtain x where x_def: "Elem x ?Z & (! y. Elem y x \<longrightarrow> Not (Elem y ?Z))" ..
            then have x_induct:"! y. Elem y x \<longrightarrow> Elem y U \<longrightarrow> P y" by (simp add: Sep)
            have "Elem x U \<longrightarrow> P x"
              by (rule impE[OF spec[OF P_induct, where x=x], OF x_induct], assumption)
            moreover have "Elem x U & Not(P x)"
              apply (insert x_def)
              apply (simp add: Sep)
              done
            ultimately show "False" by auto
          qed
        ultimately show "P a" by auto
      qed
  }
  with hyps show ?thesis by blast
qed

lemma cond2_wf_Elem:
  assumes
     special_P: "? U. ! x. Not(Elem x U) \<longrightarrow> (P x)"
     and P_induct: "\<forall>x. (\<forall>y. Elem y x \<longrightarrow> P y) \<longrightarrow> P x"
  shows
     "P a"
proof -
  have "? U Q. P = (\<lambda> x. (Elem x U \<longrightarrow> Q x))"
  proof -
    from special_P obtain U where U:"! x. Not(Elem x U) \<longrightarrow> (P x)" ..
    show ?thesis
      apply (rule_tac exI[where x=U])
      apply (rule exI[where x="P"])
      apply (rule ext)
      apply (auto simp add: U)
      done
  qed
  then obtain U where "? Q. P = (\<lambda> x. (Elem x U \<longrightarrow> Q x))" ..
  then obtain Q where UQ: "P = (\<lambda> x. (Elem x U \<longrightarrow> Q x))" ..
  show ?thesis
    apply (auto simp add: UQ)
    apply (rule cond_wf_Elem)
    apply (rule P_induct[simplified UQ])
    apply simp
    done
qed

primrec nat2Nat :: "nat \<Rightarrow> ZF" where
  nat2Nat_0[intro]:  "nat2Nat 0 = Empty"
| nat2Nat_Suc[intro]:  "nat2Nat (Suc n) = SucNat (nat2Nat n)"

definition Nat2nat :: "ZF \<Rightarrow> nat" where
  "Nat2nat == inv nat2Nat"

lemma Elem_nat2Nat_inf[intro]: "Elem (nat2Nat n) Inf"
  apply (induct n)
  apply (simp_all add: Infinity)
  done

definition Nat :: ZF
 where  "Nat == Sep Inf (\<lambda> N. ? n. nat2Nat n = N)"

lemma Elem_nat2Nat_Nat[intro]: "Elem (nat2Nat n) Nat"
  by (auto simp add: Nat_def Sep)

lemma Elem_Empty_Nat: "Elem Empty Nat"
  by (auto simp add: Nat_def Sep Infinity)

lemma Elem_SucNat_Nat: "Elem N Nat \<Longrightarrow> Elem (SucNat N) Nat"
  by (auto simp add: Nat_def Sep Infinity)

lemma no_infinite_Elem_down_chain:
  "Not (? f. isFun f & Domain f = Nat & (! N. Elem N Nat \<longrightarrow> Elem (f\<acute>(SucNat N)) (f\<acute>N)))"
proof -
  {
    fix f
    assume f:"isFun f & Domain f = Nat & (! N. Elem N Nat \<longrightarrow> Elem (f\<acute>(SucNat N)) (f\<acute>N))"
    let ?r = "Range f"
    have "?r \<noteq> Empty"
      apply (auto simp add: Ext Empty)
      apply (rule exI[where x="f\<acute>Empty"])
      apply (rule fun_value_in_range)
      apply (auto simp add: f Elem_Empty_Nat)
      done
    then have "? x. Elem x ?r & (! y. Elem y x \<longrightarrow> Not(Elem y ?r))"
      by (simp add: Regularity)
    then obtain x where x: "Elem x ?r & (! y. Elem y x \<longrightarrow> Not(Elem y ?r))" ..
    then have "? N. Elem N (Domain f) & f\<acute>N = x"
      apply (rule_tac fun_range_witness)
      apply (simp_all add: f)
      done
    then have "? N. Elem N Nat & f\<acute>N = x"
      by (simp add: f)
    then obtain N where N: "Elem N Nat & f\<acute>N = x" ..
    from N have N': "Elem N Nat" by auto
    let ?y = "f\<acute>(SucNat N)"
    have Elem_y_r: "Elem ?y ?r"
      by (simp_all add: f Elem_SucNat_Nat N fun_value_in_range)
    have "Elem ?y (f\<acute>N)" by (auto simp add: f N')
    then have "Elem ?y x" by (simp add: N)
    with x have "Not (Elem ?y ?r)" by auto
    with Elem_y_r have "False" by auto
  }
  then show ?thesis by auto
qed

lemma Upair_nonEmpty: "Upair a b \<noteq> Empty"
  by (auto simp add: Ext Empty Upair)

lemma Singleton_nonEmpty: "Singleton x \<noteq> Empty"
  by (auto simp add: Singleton_def Upair_nonEmpty)

lemma notsym_Elem: "Not(Elem a b & Elem b a)"
proof -
  {
    fix a b
    assume ab: "Elem a b"
    assume ba: "Elem b a"
    let ?Z = "Upair a b"
    have "?Z \<noteq> Empty" by (simp add: Upair_nonEmpty)
    then have "? x. Elem x ?Z & (! y. Elem y x \<longrightarrow> Not(Elem y ?Z))"
      by (simp add: Regularity)
    then obtain x where x:"Elem x ?Z & (! y. Elem y x \<longrightarrow> Not(Elem y ?Z))" ..
    then have "x = a \<or> x = b" by (simp add: Upair)
    moreover have "x = a \<longrightarrow> Not (Elem b ?Z)"
      by (auto simp add: x ba)
    moreover have "x = b \<longrightarrow> Not (Elem a ?Z)"
      by (auto simp add: x ab)
    ultimately have "False"
      by (auto simp add: Upair)
  }
  then show ?thesis by auto
qed

lemma irreflexiv_Elem: "Not(Elem a a)"
  by (simp add: notsym_Elem[of a a, simplified])

lemma antisym_Elem: "Elem a b \<Longrightarrow> Not (Elem b a)"
  apply (insert notsym_Elem[of a b])
  apply auto
  done

primrec NatInterval :: "nat \<Rightarrow> nat \<Rightarrow> ZF" where
  "NatInterval n 0 = Singleton (nat2Nat n)"
| "NatInterval n (Suc m) = union (NatInterval n m) (Singleton (nat2Nat (n+m+1)))"

lemma n_Elem_NatInterval[rule_format]: "! q. q <= m \<longrightarrow> Elem (nat2Nat (n+q)) (NatInterval n m)"
  apply (induct m)
  apply (auto simp add: Singleton union)
  apply (case_tac "q <= m")
  apply auto
  apply (subgoal_tac "q = Suc m")
  apply auto
  done

lemma NatInterval_not_Empty: "NatInterval n m \<noteq> Empty"
  by (auto intro:   n_Elem_NatInterval[where q = 0, simplified] simp add: Empty Ext)

lemma increasing_nat2Nat[rule_format]: "0 < n \<longrightarrow> Elem (nat2Nat (n - 1)) (nat2Nat n)"
  apply (case_tac "? m. n = Suc m")
  apply (auto simp add: SucNat_def union Singleton)
  apply (drule spec[where x="n - 1"])
  apply arith
  done

lemma represent_NatInterval[rule_format]: "Elem x (NatInterval n m) \<longrightarrow> (? u. n \<le> u & u \<le> n+m & nat2Nat u = x)"
  apply (induct m)
  apply (auto simp add: Singleton union)
  apply (rule_tac x="Suc (n+m)" in exI)
  apply auto
  done

lemma inj_nat2Nat: "inj nat2Nat"
proof -
  {
    fix n m :: nat
    assume nm: "nat2Nat n = nat2Nat (n+m)"
    assume mg0: "0 < m"
    let ?Z = "NatInterval n m"
    have "?Z \<noteq> Empty" by (simp add: NatInterval_not_Empty)
    then have "? x. (Elem x ?Z) & (! y. Elem y x \<longrightarrow> Not (Elem y ?Z))"
      by (auto simp add: Regularity)
    then obtain x where x:"Elem x ?Z & (! y. Elem y x \<longrightarrow> Not (Elem y ?Z))" ..
    then have "? u. n \<le> u & u \<le> n+m & nat2Nat u = x"
      by (simp add: represent_NatInterval)
    then obtain u where u: "n \<le> u & u \<le> n+m & nat2Nat u = x" ..
    have "n < u \<longrightarrow> False"
    proof
      assume n_less_u: "n < u"
      let ?y = "nat2Nat (u - 1)"
      have "Elem ?y (nat2Nat u)"
        apply (rule increasing_nat2Nat)
        apply (insert n_less_u)
        apply arith
        done
      with u have "Elem ?y x" by auto
      with x have "Not (Elem ?y ?Z)" by auto
      moreover have "Elem ?y ?Z"
        apply (insert n_Elem_NatInterval[where q = "u - n - 1" and n=n and m=m])
        apply (insert n_less_u)
        apply (insert u)
        apply auto
        done
      ultimately show False by auto
    qed
    moreover have "u = n \<longrightarrow> False"
    proof
      assume "u = n"
      with u have "nat2Nat n = x" by auto
      then have nm_eq_x: "nat2Nat (n+m) = x" by (simp add: nm)
      let ?y = "nat2Nat (n+m - 1)"
      have "Elem ?y (nat2Nat (n+m))"
        apply (rule increasing_nat2Nat)
        apply (insert mg0)
        apply arith
        done
      with nm_eq_x have "Elem ?y x" by auto
      with x have "Not (Elem ?y ?Z)" by auto
      moreover have "Elem ?y ?Z"
        apply (insert n_Elem_NatInterval[where q = "m - 1" and n=n and m=m])
        apply (insert mg0)
        apply auto
        done
      ultimately show False by auto
    qed
    ultimately have "False" using u by arith
  }
  note lemma_nat2Nat = this
  have th:"\<And>x y. \<not> (x < y \<and> (\<forall>(m::nat). y \<noteq> x + m))" by presburger
  have th': "\<And>x y. \<not> (x \<noteq> y \<and> (\<not> x < y) \<and> (\<forall>(m::nat). x \<noteq> y + m))" by presburger
  show ?thesis
    apply (auto simp add: inj_on_def)
    apply (case_tac "x = y")
    apply auto
    apply (case_tac "x < y")
    apply (case_tac "? m. y = x + m & 0 < m")
    apply (auto intro: lemma_nat2Nat)
    apply (case_tac "y < x")
    apply (case_tac "? m. x = y + m & 0 < m")
    apply simp
    apply simp
    using th apply blast
    apply (case_tac "? m. x = y + m")
    apply (auto intro: lemma_nat2Nat)
    apply (drule sym)
    using lemma_nat2Nat apply blast
    using th' apply blast
    done
qed

lemma Nat2nat_nat2Nat[simp]: "Nat2nat (nat2Nat n) = n"
  by (simp add: Nat2nat_def inv_f_f[OF inj_nat2Nat])

lemma nat2Nat_Nat2nat[simp]: "Elem n Nat \<Longrightarrow> nat2Nat (Nat2nat n) = n"
  apply (simp add: Nat2nat_def)
  apply (rule_tac f_inv_into_f)
  apply (auto simp add: image_def Nat_def Sep)
  done

lemma Nat2nat_SucNat: "Elem N Nat \<Longrightarrow> Nat2nat (SucNat N) = Suc (Nat2nat N)"
  apply (auto simp add: Nat_def Sep Nat2nat_def)
  apply (auto simp add: inv_f_f[OF inj_nat2Nat])
  apply (simp only: nat2Nat.simps[symmetric])
  apply (simp only: inv_f_f[OF inj_nat2Nat])
  done

(*lemma Elem_induct: "(\<And>x. \<forall>y. Elem y x \<longrightarrow> P y \<Longrightarrow> P x) \<Longrightarrow> P a"
  by (erule wf_induct[OF wf_is_Elem_of, simplified is_Elem_of_def, simplified])*)

lemma Elem_Opair_exists: "? z. Elem x z & Elem y z & Elem z (Opair x y)"
  apply (rule exI[where x="Upair x y"])
  by (simp add: Upair Opair_def)

lemma UNIV_is_not_in_ZF: "UNIV \<noteq> explode R"
proof
  let ?Russell = "{ x. Not(Elem x x) }"
  have "?Russell = UNIV" by (simp add: irreflexiv_Elem)
  moreover assume "UNIV = explode R"
  ultimately have russell: "?Russell = explode R" by simp
  then show "False"
  proof(cases "Elem R R")
    case True
    then show ?thesis
      by (insert irreflexiv_Elem, auto)
  next
    case False
    then have "R \<in> ?Russell" by auto
    then have "Elem R R" by (simp add: russell explode_def)
    with False show ?thesis by auto
  qed
qed

definition SpecialR :: "(ZF * ZF) set" where
  "SpecialR \<equiv> { (x, y) . x \<noteq> Empty \<and> y = Empty}"

lemma "wf SpecialR"
  apply (subst wf_def)
  apply (auto simp add: SpecialR_def)
  done

definition Ext :: "('a * 'b) set \<Rightarrow> 'b \<Rightarrow> 'a set" where
  "Ext R y \<equiv> { x . (x, y) \<in> R }"

lemma Ext_Elem: "Ext is_Elem_of = explode"
  by (auto simp add: Ext_def is_Elem_of_def explode_def)

lemma "Ext SpecialR Empty \<noteq> explode z"
proof
  have "Ext SpecialR Empty = UNIV - {Empty}"
    by (auto simp add: Ext_def SpecialR_def)
  moreover assume "Ext SpecialR Empty = explode z"
  ultimately have "UNIV = explode(union z (Singleton Empty)) "
    by (auto simp add: explode_def union Singleton)
  then show "False" by (simp add: UNIV_is_not_in_ZF)
qed

definition implode :: "ZF set \<Rightarrow> ZF" where
  "implode == inv explode"

lemma inj_explode: "inj explode"
  by (auto simp add: inj_on_def explode_def Ext)

lemma implode_explode[simp]: "implode (explode x) = x"
  by (simp add: implode_def inj_explode)

definition regular :: "(ZF * ZF) set \<Rightarrow> bool" where
  "regular R == ! A. A \<noteq> Empty \<longrightarrow> (? x. Elem x A & (! y. (y, x) \<in> R \<longrightarrow> Not (Elem y A)))"

definition set_like :: "(ZF * ZF) set \<Rightarrow> bool" where
  "set_like R == ! y. Ext R y \<in> range explode"

definition wfzf :: "(ZF * ZF) set \<Rightarrow> bool" where
  "wfzf R == regular R & set_like R"

lemma regular_Elem: "regular is_Elem_of"
  by (simp add: regular_def is_Elem_of_def Regularity)

lemma set_like_Elem: "set_like is_Elem_of"
  by (auto simp add: set_like_def image_def Ext_Elem)

lemma wfzf_is_Elem_of: "wfzf is_Elem_of"
  by (auto simp add: wfzf_def regular_Elem set_like_Elem)

definition SeqSum :: "(nat \<Rightarrow> ZF) \<Rightarrow> ZF" where
  "SeqSum f == Sum (Repl Nat (f o Nat2nat))"

lemma SeqSum: "Elem x (SeqSum f) = (? n. Elem x (f n))"
  apply (auto simp add: SeqSum_def Sum Repl)
  apply (rule_tac x = "f n" in exI)
  apply auto
  done

definition Ext_ZF :: "(ZF * ZF) set \<Rightarrow> ZF \<Rightarrow> ZF" where
  "Ext_ZF R s == implode (Ext R s)"

lemma Elem_implode: "A \<in> range explode \<Longrightarrow> Elem x (implode A) = (x \<in> A)"
  apply (auto)
  apply (simp_all add: explode_def)
  done

lemma Elem_Ext_ZF: "set_like R \<Longrightarrow> Elem x (Ext_ZF R s) = ((x,s) \<in> R)"
  apply (simp add: Ext_ZF_def)
  apply (subst Elem_implode)
  apply (simp add: set_like_def)
  apply (simp add: Ext_def)
  done

primrec Ext_ZF_n :: "(ZF * ZF) set \<Rightarrow> ZF \<Rightarrow> nat \<Rightarrow> ZF" where
  "Ext_ZF_n R s 0 = Ext_ZF R s"
| "Ext_ZF_n R s (Suc n) = Sum (Repl (Ext_ZF_n R s n) (Ext_ZF R))"

definition Ext_ZF_hull :: "(ZF * ZF) set \<Rightarrow> ZF \<Rightarrow> ZF" where
  "Ext_ZF_hull R s == SeqSum (Ext_ZF_n R s)"

lemma Elem_Ext_ZF_hull:
  assumes set_like_R: "set_like R"
  shows "Elem x (Ext_ZF_hull R S) = (? n. Elem x (Ext_ZF_n R S n))"
  by (simp add: Ext_ZF_hull_def SeqSum)

lemma Elem_Elem_Ext_ZF_hull:
  assumes set_like_R: "set_like R"
          and x_hull: "Elem x (Ext_ZF_hull R S)"
          and y_R_x: "(y, x) \<in> R"
  shows "Elem y (Ext_ZF_hull R S)"
proof -
  from Elem_Ext_ZF_hull[OF set_like_R] x_hull
  have "? n. Elem x (Ext_ZF_n R S n)" by auto
  then obtain n where n:"Elem x (Ext_ZF_n R S n)" ..
  with y_R_x have "Elem y (Ext_ZF_n R S (Suc n))"
    apply (auto simp add: Repl Sum)
    apply (rule_tac x="Ext_ZF R x" in exI)
    apply (auto simp add: Elem_Ext_ZF[OF set_like_R])
    done
  with Elem_Ext_ZF_hull[OF set_like_R, where x=y] show ?thesis
    by (auto simp del: Ext_ZF_n.simps)
qed

lemma wfzf_minimal:
  assumes hyps: "wfzf R" "C \<noteq> {}"
  shows "\<exists>x. x \<in> C \<and> (\<forall>y. (y, x) \<in> R \<longrightarrow> y \<notin> C)"
proof -
  from hyps have "\<exists>S. S \<in> C" by auto
  then obtain S where S:"S \<in> C" by auto
  let ?T = "Sep (Ext_ZF_hull R S) (\<lambda> s. s \<in> C)"
  from hyps have set_like_R: "set_like R" by (simp add: wfzf_def)
  show ?thesis
  proof (cases "?T = Empty")
    case True
    then have "\<forall> z. \<not> (Elem z (Sep (Ext_ZF R S) (\<lambda> s. s \<in> C)))"
      apply (auto simp add: Ext Empty Sep Ext_ZF_hull_def SeqSum)
      apply (erule_tac x="z" in allE, auto)
      apply (erule_tac x=0 in allE, auto)
      done
    then show ?thesis
      apply (rule_tac exI[where x=S])
      apply (auto simp add: Sep Empty S)
      apply (erule_tac x=y in allE)
      apply (simp add: set_like_R Elem_Ext_ZF)
      done
  next
    case False
    from hyps have regular_R: "regular R" by (simp add: wfzf_def)
    from
      regular_R[simplified regular_def, rule_format, OF False, simplified Sep]
      Elem_Elem_Ext_ZF_hull[OF set_like_R]
    show ?thesis by blast
  qed
qed

lemma wfzf_implies_wf: "wfzf R \<Longrightarrow> wf R"
proof (subst wf_def, rule allI)
  assume wfzf: "wfzf R"
  fix P :: "ZF \<Rightarrow> bool"
  let ?C = "{x. P x}"
  {
    assume induct: "(\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x)"
    let ?C = "{x. \<not> (P x)}"
    have "?C = {}"
    proof (rule ccontr)
      assume C: "?C \<noteq> {}"
      from
        wfzf_minimal[OF wfzf C]
      obtain x where x: "x \<in> ?C \<and> (\<forall>y. (y, x) \<in> R \<longrightarrow> y \<notin> ?C)" ..
      then have "P x"
        apply (rule_tac induct[rule_format])
        apply auto
        done
      with x show "False" by auto
    qed
    then have "! x. P x" by auto
  }
  then show "(\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (! x. P x)" by blast
qed

lemma wf_is_Elem_of: "wf is_Elem_of"
  by (auto simp add: wfzf_is_Elem_of wfzf_implies_wf)

lemma in_Ext_RTrans_implies_Elem_Ext_ZF_hull:
  "set_like R \<Longrightarrow> x \<in> (Ext (R^+) s) \<Longrightarrow> Elem x (Ext_ZF_hull R s)"
  apply (simp add: Ext_def Elem_Ext_ZF_hull)
  apply (erule converse_trancl_induct[where r="R"])
  apply (rule exI[where x=0])
  apply (simp add: Elem_Ext_ZF)
  apply auto
  apply (rule_tac x="Suc n" in exI)
  apply (simp add: Sum Repl)
  apply (rule_tac x="Ext_ZF R z" in exI)
  apply (auto simp add: Elem_Ext_ZF)
  done

lemma implodeable_Ext_trancl: "set_like R \<Longrightarrow> set_like (R^+)"
  apply (subst set_like_def)
  apply (auto simp add: image_def)
  apply (rule_tac x="Sep (Ext_ZF_hull R y) (\<lambda> z. z \<in> (Ext (R^+) y))" in exI)
  apply (auto simp add: explode_def Sep set_eqI
    in_Ext_RTrans_implies_Elem_Ext_ZF_hull)
  done

lemma Elem_Ext_ZF_hull_implies_in_Ext_RTrans[rule_format]:
  "set_like R \<Longrightarrow> ! x. Elem x (Ext_ZF_n R s n) \<longrightarrow> x \<in> (Ext (R^+) s)"
  apply (induct_tac n)
  apply (auto simp add: Elem_Ext_ZF Ext_def Sum Repl)
  done

lemma "set_like R \<Longrightarrow> Ext_ZF (R^+) s = Ext_ZF_hull R s"
  apply (frule implodeable_Ext_trancl)
  apply (auto simp add: Ext)
  apply (erule in_Ext_RTrans_implies_Elem_Ext_ZF_hull)
  apply (simp add: Elem_Ext_ZF Ext_def)
  apply (auto simp add: Elem_Ext_ZF Elem_Ext_ZF_hull)
  apply (erule Elem_Ext_ZF_hull_implies_in_Ext_RTrans[simplified Ext_def, simplified], assumption)
  done

lemma wf_implies_regular: "wf R \<Longrightarrow> regular R"
proof (simp add: regular_def, rule allI)
  assume wf: "wf R"
  fix A
  show "A \<noteq> Empty \<longrightarrow> (\<exists>x. Elem x A \<and> (\<forall>y. (y, x) \<in> R \<longrightarrow> \<not> Elem y A))"
  proof
    assume A: "A \<noteq> Empty"
    then have "? x. x \<in> explode A"
      by (auto simp add: explode_def Ext Empty)
    then obtain x where x:"x \<in> explode A" ..
    from iffD1[OF wf_eq_minimal wf, rule_format, where Q="explode A", OF x]
    obtain z where "z \<in> explode A \<and> (\<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> explode A)" by auto
    then show "\<exists>x. Elem x A \<and> (\<forall>y. (y, x) \<in> R \<longrightarrow> \<not> Elem y A)"
      apply (rule_tac exI[where x = z])
      apply (simp add: explode_def)
      done
  qed
qed

lemma wf_eq_wfzf: "(wf R \<and> set_like R) = wfzf R"
  apply (auto simp add: wfzf_implies_wf)
  apply (auto simp add: wfzf_def wf_implies_regular)
  done

lemma wfzf_trancl: "wfzf R \<Longrightarrow> wfzf (R^+)"
  by (auto simp add: wf_eq_wfzf[symmetric] implodeable_Ext_trancl wf_trancl)

lemma Ext_subset_mono: "R \<subseteq> S \<Longrightarrow> Ext R y \<subseteq> Ext S y"
  by (auto simp add: Ext_def)

lemma set_like_subset: "set_like R \<Longrightarrow> S \<subseteq> R \<Longrightarrow> set_like S"
  apply (auto simp add: set_like_def)
  apply (erule_tac x=y in allE)
  apply (drule_tac y=y in Ext_subset_mono)
  apply (auto simp add: image_def)
  apply (rule_tac x="Sep x (% z. z \<in> (Ext S y))" in exI)
  apply (auto simp add: explode_def Sep)
  done

lemma wfzf_subset: "wfzf S \<Longrightarrow> R \<subseteq> S \<Longrightarrow> wfzf R"
  by (auto intro: set_like_subset wf_subset simp add: wf_eq_wfzf[symmetric])

end


theory Utilities
imports Main
begin

primrec collect_map :: "('a => 'b option) => 'a list => 'b list option"
where "collect_map f [] = Some []"
    | "collect_map f (a # as) = (case f a of
          None => None
        | Some b => case collect_map f as of
            None => None
          | Some bs => Some (b # bs))"

primrec mapsum :: "('a => nat) => 'a list => nat"
where "mapsum f [] = 0"
    | "mapsum f (a # as) = f a + mapsum f as"

lemma [simp]: "length xs = length ys ==> (!!n. f (xs ! n) <= f (ys ! n)) ==>
        mapsum f xs <= mapsum f ys"
proof (induction xs arbitrary: ys)
case Nil
  thus ?case by (induction ys, simp_all)
next case (Cons x xs)
  thus ?case
  proof (induction ys)
  case Nil
    thus ?case by simp
  next case (Cons y ys)
    moreover hence "f x <= f y" by (metis eq_Nil_appendI nth_append_length)
    moreover from Cons have "!!n. f (xs ! n) <= f (ys ! n)" by (metis (full_types) nth_Cons_Suc)
    ultimately show ?case by fastforce
  qed
qed

end


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

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

datatype Nat = Z | S "Nat"

datatype Tree = TNode "Tree" "Nat" "Tree" | TNil

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

fun flatten :: "Tree => Nat list => Nat list" where
"flatten (TNode q z r) y = flatten q (cons2 z (flatten r y))"
| "flatten (TNil) y = y"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun add :: "Nat => Tree => Tree" where
"add x (TNode q z r) =
   (if le x z then TNode (add x q) z r else TNode q z (add x r))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "Nat list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "Nat list => Nat list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "isPermutation (tsort xs) xs"
  oops

end


(*
   Title: Theory  inout.thy
   Author:    Maria Spichkova <maria.spichkova at rmit.edu.au>, 2014
*)

header {*Correctness of the relations between sets of Input/Output channels*}

theory  inout
imports Secrecy_types
begin

consts
  subcomponents ::  "specID \<Rightarrow> specID set"

-- "Mappings, defining sets of input, local, and output channels"
-- "of a component"
consts
  ins :: "specID \<Rightarrow> chanID set"
  loc :: "specID \<Rightarrow> chanID set"
  out :: "specID \<Rightarrow> chanID set"

-- "Predicate insuring the correct mapping from the component identifier"
-- "to the set of input channels of a component"
definition
  inStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "inStream x y  \<equiv> (ins x = y)"

-- "Predicate insuring the correct mapping from the component identifier"
-- "to the set of local channels of a component"
definition
  locStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "locStream x y \<equiv> (loc x = y)"

-- "Predicate insuring the correct mapping from the component identifier"
-- "to the set of output channels of a component"
definition
  outStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "outStream x y \<equiv> (out x = y)"

-- "Predicate insuring the correct relations between"
-- "to the set of input, output and local channels of a component"
definition
  correctInOutLoc :: "specID \<Rightarrow> bool"
where
  "correctInOutLoc x \<equiv>
   (ins x) \<inter> (out x) = {}
    \<and> (ins x) \<inter> (loc x) = {}
    \<and> (loc x) \<inter> (out x) = {} "

-- "Predicate insuring the correct relations between"
-- "sets of input channels within a composed component"
definition
  correctCompositionIn :: "specID \<Rightarrow> bool"
where
  "correctCompositionIn x \<equiv>
  (ins x) = (\<Union> (ins ` (subcomponents x)) - (loc x))
  \<and> (ins x) \<inter> (\<Union> (out ` (subcomponents x))) = {}"

-- "Predicate insuring the correct relations between"
-- "sets of output channels within a composed component"
definition
  correctCompositionOut :: "specID \<Rightarrow> bool"
where
  "correctCompositionOut x \<equiv>
  (out x) = (\<Union> (out ` (subcomponents x))- (loc x))
  \<and> (out x) \<inter> (\<Union> (ins ` (subcomponents x))) = {} "

-- "Predicate insuring the correct relations between"
-- "sets of local channels within a composed component"
definition
  correctCompositionLoc :: "specID \<Rightarrow> bool"
where
  "correctCompositionLoc x \<equiv>
   (loc x) = \<Union> (ins ` (subcomponents x))
           \<inter> \<Union> (out ` (subcomponents x))"

-- "If a component is an elementary one (has no subcomponents)"
-- "its set of local channels should be empty"
lemma subcomponents_loc:
assumes "correctCompositionLoc x"
       and "subcomponents x = {}"
shows "loc x = {}"
using assms by (simp add: correctCompositionLoc_def)

end


theory Submission
  imports Defs
begin

text \<open>Illustration:
\<open>n\<close>:        0 | 1 | 2  | 3
\<open>S(n)\<close>:     2 | 6 | 42 | 1806 = 42 * 43
\<open>pf(S(n)+1)\<close>: 3 | 7 | 43 | 13 (13 * 139 = 1807)
\<close>

lemma S_gt_1: "S n > 1"
  by (induction n) auto

lemma pf_is_factor:
  assumes "n > (1::nat)"
  shows   "pf n \<in> prime_factors n"
proof -
  have "prime_factors n \<noteq> {}"
    using assms by (auto simp: prime_factorization_empty_iff)
  from Min_in[OF _ this, folded pf_def] have "pf n \<in> prime_factors n"
    by auto
  thus ?thesis by auto
qed

theorem prime_pf_Suc_S: "prime (pf (S n + 1))"
  using pf_is_factor[of "S n + 1"] S_gt_1[of n] by auto

lemma S_dvd:
  assumes "m < n"
  shows   "(S m + 1) dvd S n"
  using assms
proof (induction n)
  case (Suc n)
  show ?case
  proof (cases "m = n")
    case True
    thus ?thesis
      by (metis S.simps(2) dvd_triv_right)
  qed (use Suc.prems Suc.IH in auto)
qed (use assms in auto)

lemma coprime_S:
  assumes "m \<noteq> n"
  shows   "coprime (S m + 1) (S n + 1)"
  using assms
proof (induction m n rule: linorder_wlog)
  case (le m n)
  hence "(S m + 1) dvd S n"
    by (intro S_dvd) auto
  thus "coprime (S m + 1) (S n + 1)"
    by (metis coprime_add_one_right coprime_mult_left_iff dvd_def)
qed (auto simp: coprime_commute)

theorem pf_S_inj:
  assumes "pf (S n + 1) = pf (S m + 1)"
  shows "n = m"
proof (rule ccontr)
  assume "n \<noteq> m"
  define p where "p = pf (S n + 1)"
  have p1: "p \<in> prime_factors (S n + 1)"
    unfolding p_def using S_gt_1[of n] by (intro pf_is_factor) auto
  have p2: "p \<in> prime_factors (S m + 1)"
    unfolding p_def assms using S_gt_1[of m] by (intro pf_is_factor) auto
  hence "prime p" by auto

  from \<open>n \<noteq> m\<close> have "coprime (S m + 1) (S n + 1)"
    using coprime_S[of m n] by auto
  with p1 and p2 have "is_unit p"
    using not_coprimeI by blast
  with \<open>prime p\<close> show False
    using not_prime_unit by blast
qed

theorem infinitely_many_primes:
  "infinite {p :: nat. prime p}"
proof -
  let ?S = "(\<lambda>n. pf(S(n)+1)) ` UNIV" let ?P = "{p :: nat. prime p}"
  have "?S \<subseteq> ?P"
    using prime_pf_Suc_S by auto
  moreover have "infinite ?S"
    by (intro range_inj_infinite inj_onI, rule pf_S_inj)
  ultimately show ?thesis
    by (rule infinite_super)
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.*)
  theory TIP_prop_82
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

theorem property0 :
  "((take n (zip xs ys)) = (zip (take n xs) (take n ys)))"
  oops

end


theory Realisation
  imports HereditarilyFinite.Finitary Graph_Theory.Graph_Theory
begin

section \<open>The Realisation Function\<close>
text \<open>
  This theory contains an abstract formulation of a model
  for membership relations.
\<close>

abbreviation parents :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "parents G s \<equiv> {u. u \<rightarrow>\<^bsub>G\<^esub> s}"

abbreviation ancestors :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "ancestors G s \<equiv> {u. u \<rightarrow>\<^sup>+\<^bsub>G\<^esub> s}"

lemma (in fin_digraph) parents_subs_verts: "parents G s \<subseteq> verts G"
  using reachable_in_verts by blast

lemma (in fin_digraph) finite_parents[intro]: "finite (parents G s)"
  using finite_subset[OF parents_subs_verts finite_verts] .

lemma (in fin_digraph) finite_ancestors[intro]: "finite (ancestors G s)"
  using reachable_in_verts
  by (auto intro: rev_finite_subset[where ?A="ancestors G s", OF finite_verts])

lemma (in wf_digraph) in_ancestors_if_dominates[simp, intro]:
  assumes "s \<rightarrow>\<^bsub>G\<^esub> t"
  shows "s \<in> ancestors G t"
  using assms by blast

lemma (in wf_digraph) ancestors_mono:
  assumes "s \<in> ancestors G t"
  shows "ancestors G s \<subseteq> ancestors G t"
  using assms by fastforce

locale dag = digraph G for G +
  assumes acyclic: "\<nexists>c. cycle c"
begin

lemma ancestors_asym:
  assumes "s \<in> ancestors G t"
  shows "t \<notin> ancestors G s"
proof
  assume "t \<in> ancestors G s"
  then obtain p1 p2 where "awalk t p1 s" "p1 \<noteq> []" "awalk s p2 t" "p2 \<noteq> []"
    using assms reachable1_awalk by auto
  then have "closed_w (p1 @ p2)"
    unfolding closed_w_def by auto
  with closed_w_imp_cycle acyclic show False
    by blast
qed

lemma ancestors_strict_mono:
  assumes "s \<in> ancestors G t"
  shows "ancestors G s \<subset> ancestors G t"
  using assms ancestors_mono ancestors_asym by blast

lemma card_ancestors_strict_mono:
  assumes "s \<rightarrow>\<^bsub>G\<^esub> t"
  shows "card (ancestors G s) < card (ancestors G t)"
  using assms finite_ancestors ancestors_strict_mono
  by (metis in_ancestors_if_dominates psubset_card_mono)

end

text \<open>
  The realisation assumes that the terms can be split into
  a set of base terms \<open>B\<close> that are realised with the function \<open>I\<close>
  and set terms \<open>T\<close> that are realised according to the structure
  of the membership relation (represented as a graph \<open>G\<close>).
\<close>
locale realisation = dag G for G +
  fixes B T :: "'a set"
  fixes I :: "'a \<Rightarrow> hf"
  fixes eq :: "'a rel"
  assumes B_T_partition_verts: "B \<inter> T = {}" "verts G = B \<union> T"
  assumes P_urelems: "\<And>p t. p \<in> B \<Longrightarrow> \<not> t \<rightarrow>\<^bsub>G\<^esub> p"
begin

lemma
  shows finite_B: "finite B"
    and finite_T: "finite T"
    and finite_B_un_T: "finite (B \<union> T)"
  using finite_verts B_T_partition_verts by auto

abbreviation "eq_class x \<equiv> eq `` {x}"

function realise :: "'a \<Rightarrow> hf" where
  "x \<in> B \<Longrightarrow> realise x = HF (realise ` parents G x) \<squnion> HF (I ` eq_class x)"
| "t \<in> T \<Longrightarrow> realise t = HF (realise ` parents G t)"
| "x \<notin> B \<union> T \<Longrightarrow> realise x = 0"
  using B_T_partition_verts by auto
termination
  by (relation "measure (\<lambda>t. card (ancestors G t))") (simp_all add: card_ancestors_strict_mono)

lemma finite_realisation_parents[simp, intro!]: "finite (realise ` parents G t)"
  by auto

function height :: "'a \<Rightarrow> nat" where
  "\<forall>s. \<not> s \<rightarrow>\<^bsub>G\<^esub> t \<Longrightarrow> height t = 0"
| "s \<rightarrow>\<^bsub>G\<^esub> t \<Longrightarrow> height t = Max (height ` parents G t) + 1"
  using P_urelems by force+
termination
  by (relation "measure (\<lambda>t. card (ancestors G t))") (simp_all add: card_ancestors_strict_mono)

lemma height_cases':
  obtains
      (Zero) "height t = 0"
    | (Suc_Max) s where "s \<rightarrow>\<^bsub>G\<^esub> t" "height t = height s + 1"
  apply(cases t rule: height.cases)
  using Max_in[OF finite_imageI[where ?h=height, OF finite_parents]]
  by auto

lemma lemma1_1:
  assumes "s \<rightarrow>\<^bsub>G\<^esub> t"
  shows "height s < height t"
proof(cases t rule: height_cases')
  case Zero
  with assms show ?thesis by simp
next
  case (Suc_Max s')
  note finite_imageI[where ?h=height, OF finite_parents]
  note Max_ge[OF this, of "height s" t]
  with assms Suc_Max show ?thesis
    by simp
qed

lemma dominates_if_mem_realisation:
  assumes "\<And>x y. I x \<noteq> realise y"
  assumes "realise s \<^bold>\<in> realise t"
  obtains s' where "s' \<rightarrow>\<^bsub>G\<^esub> t" "realise s = realise s'"
  using assms(2-)
proof(induction t rule: realise.induct)
  case (1 x)
  with assms(1) show ?case
    by simp (metis (no_types, lifting) image_iff mem_Collect_eq)
qed auto

lemma (in -) Max_le_if_All_Ex_le:
  assumes "finite A" "finite B"
      and "A \<noteq> {}"
      and "\<forall>a \<in> A. \<exists>b \<in> B. a \<le> b"
    shows "Max A \<le> Max B"
  using assms
proof(induction rule: finite_induct)
  case (insert a A)
  then obtain b B' where "B = insert b B'"
    by (metis equals0I insert_absorb)
  with insert show ?case
    by (meson Max_ge_iff Max_in finite.insertI insert_not_empty)
qed blast

lemma lemma1_2':
  assumes "\<And>x y. I x \<noteq> realise y"
  assumes "t1 \<in> B \<union> T" "t2 \<in> B \<union> T" "realise t1 = realise t2"
  shows "height t1 \<le> height t2"
  using assms(2-)
proof(induction "height t1" arbitrary: t1 t2 rule: less_induct)
  case less
  then show ?case
  proof(cases "height t1")
    case (Suc h)
    then obtain s1 where "s1 \<rightarrow>\<^bsub>G\<^esub> t1"
      by (cases t1 rule: height.cases) auto
    have Ex_approx: "\<exists>v. v \<rightarrow>\<^bsub>G\<^esub> t2 \<and> realise w = realise v" if "w \<rightarrow>\<^bsub>G\<^esub> t1" for w
    proof -
      from that less(2) have "realise w \<^bold>\<in> realise t1"
        by (induction t1 rule: realise.induct) auto
      with "less.prems" have "realise w \<^bold>\<in> realise t2"
        by metis
      with dominates_if_mem_realisation assms(1) obtain v
        where "v \<rightarrow>\<^bsub>G\<^esub> t2" "realise w = realise v"
        by blast
      with less.prems show ?thesis
        by auto
    qed
    moreover
    have "height w \<le> height v"
      if "w \<rightarrow>\<^bsub>G\<^esub> t1" "v \<in> B \<union> T" "realise w = realise v" for w v
    proof -
      have "w \<in> B \<union> T"
        using adj_in_verts[OF that(1)] B_T_partition_verts(2) by blast
      from "less.hyps"[OF lemma1_1, OF that(1) this that(2,3)] show ?thesis .
    qed
    ultimately have IH': "\<exists>v \<in> parents G t2. height w \<le> height v"
      if "w \<in> parents G t1" for w
      by (metis that adj_in_verts(1) mem_Collect_eq B_T_partition_verts(2))
    then have Max_le: "Max (height ` parents G t1) \<le> Max (height ` parents G t2)"
    proof -
      have "finite (height ` parents G t1)"
           "finite (height ` parents G t2)"
           "height ` parents G t1 \<noteq> {}"
        using finite_parents \<open>s1 \<rightarrow>\<^bsub>G\<^esub> t1\<close> by blast+
      with Max_le_if_All_Ex_le[OF this] IH' show ?thesis by blast
    qed
    show ?thesis
    proof -
      note s1 = \<open>s1 \<rightarrow>\<^bsub>G\<^esub> t1\<close>
      with Ex_approx obtain s2 where "s2 \<rightarrow>\<^bsub>G\<^esub> t2"
        by blast
      with s1 Max_le show ?thesis by simp
    qed
  qed simp
qed

lemma lemma1_2:
  assumes "\<And>x y. I x \<noteq> realise y"
  assumes "t1 \<in> B \<union> T" "t2 \<in> B \<union> T" "realise t1 = realise t2"
  shows "height t1 = height t2"
  using assms lemma1_2' le_antisym by metis

lemma lemma1_3:
  assumes "\<And>x y. I x \<noteq> realise y"
  assumes "s \<in> B \<union> T" "t \<in> B \<union> T" "realise s \<^bold>\<in> realise t"
  shows "height s < height t"
proof -
  from dominates_if_mem_realisation[OF assms(1,4)] obtain s'
    where "s' \<rightarrow>\<^bsub>G\<^esub> t" "realise s' = realise s"
    by metis
  then have "height s = height s'"
    using lemma1_2[OF assms(1,2)]
    by (metis adj_in_verts(1) B_T_partition_verts(2))
  also have "\<dots> < height t"
    using \<open>s' \<rightarrow>\<^bsub>G\<^esub> t\<close> lemma1_1 by blast
  finally show ?thesis .
qed

end

end


theory BalancedTraces
imports Main
begin

locale traces =
  fixes step :: "'c => 'c => bool"  (infix "\<Rightarrow>" 50)
begin

abbreviation steps (infix "\<Rightarrow>\<^sup>*" 50) where "steps \<equiv> step\<^sup>*\<^sup>*"

inductive trace :: "'c \<Rightarrow> 'c list \<Rightarrow> 'c \<Rightarrow> bool"  where
  trace_nil[iff]: "trace final [] final"
| trace_cons[intro]: "trace conf' T final \<Longrightarrow> conf \<Rightarrow> conf' \<Longrightarrow> trace conf (conf'#T) final"

inductive_cases trace_consE: "trace conf (conf'#T) final"

lemma trace_induct_final[consumes 1, case_names trace_nil trace_cons]:
  "trace x1 x2 final \<Longrightarrow> P final [] final \<Longrightarrow> (\<And>conf' T  conf. trace conf' T final \<Longrightarrow> P conf' T final \<Longrightarrow> conf \<Rightarrow> conf' \<Longrightarrow> P conf (conf' # T) final) \<Longrightarrow> P x1 x2 final"
  by (induction rule:trace.induct) auto

lemma build_trace:
  "c \<Rightarrow>\<^sup>* c' \<Longrightarrow> \<exists> T. trace c T c'"
proof(induction rule: converse_rtranclp_induct)
  have "trace c' [] c'"..
  thus "\<exists>T. trace c' T c'"..
next
  fix y z
  assume "y \<Rightarrow> z"
  assume "\<exists>T. trace z T c'"
  then obtain T where "trace z T c'"..
  with \<open>y \<Rightarrow> z\<close>
  have "trace y (z#T) c'" by auto
  thus "\<exists>T. trace y T c'" by blast
qed

lemma destruct_trace:  "trace c T c' \<Longrightarrow> c \<Rightarrow>\<^sup>* c'"
  by (induction rule:trace.induct) auto

lemma traceWhile:
  assumes "trace c\<^sub>1 T c\<^sub>4"
  assumes "P c\<^sub>1"
  assumes "\<not> P c\<^sub>4"
  obtains  T\<^sub>1 c\<^sub>2 c\<^sub>3 T\<^sub>2
  where "T = T\<^sub>1 @ c\<^sub>3 # T\<^sub>2"  and "trace c\<^sub>1 T\<^sub>1 c\<^sub>2" and "\<forall>x\<in>set T\<^sub>1.  P x" and "P c\<^sub>2" and "c\<^sub>2 \<Rightarrow> c\<^sub>3" and "\<not> P c\<^sub>3" and "trace c\<^sub>3 T\<^sub>2 c\<^sub>4"
proof-
  from assms
  have "\<exists> T\<^sub>1 c\<^sub>2 c\<^sub>3 T\<^sub>2 . (T = T\<^sub>1 @ c\<^sub>3 # T\<^sub>2 \<and> trace c\<^sub>1 T\<^sub>1 c\<^sub>2 \<and> (\<forall>x\<in>set T\<^sub>1. P x) \<and> P c\<^sub>2 \<and> c\<^sub>2 \<Rightarrow> c\<^sub>3 \<and> \<not> P c\<^sub>3 \<and> trace c\<^sub>3 T\<^sub>2 c\<^sub>4)"
  proof(induction)
    case trace_nil thus ?case by auto
  next
    case (trace_cons conf' T "end" conf)
    thus ?case
    proof (cases "P conf'")
    case True
      from trace_cons.IH[OF True \<open>\<not> P end\<close>]
      obtain T\<^sub>1 c\<^sub>2 c\<^sub>3 T\<^sub>2 where "T = T\<^sub>1 @ c\<^sub>3 # T\<^sub>2 \<and> trace conf' T\<^sub>1 c\<^sub>2 \<and> (\<forall>x\<in>set T\<^sub>1. P x) \<and> P c\<^sub>2 \<and> c\<^sub>2 \<Rightarrow> c\<^sub>3 \<and> \<not> P c\<^sub>3 \<and> trace c\<^sub>3 T\<^sub>2 end" by auto
      with True
      have "conf' # T = (conf' # T\<^sub>1) @ c\<^sub>3 # T\<^sub>2 \<and> trace conf (conf' # T\<^sub>1) c\<^sub>2 \<and> (\<forall>x\<in>set (conf' # T\<^sub>1). P x)  \<and> P c\<^sub>2 \<and> c\<^sub>2 \<Rightarrow> c\<^sub>3 \<and> \<not> P c\<^sub>3  \<and> trace c\<^sub>3 T\<^sub>2 end" by (auto intro: trace_cons)
      thus ?thesis by blast
    next
    case False with trace_cons
      have "conf' # T = [] @ conf' # T \<and> (\<forall>x\<in>set []. P x) \<and> P conf \<and> conf \<Rightarrow> conf' \<and> \<not> P conf' \<and> trace conf' T end" by auto
      thus ?thesis by blast
    qed
  qed
  thus ?thesis by (auto intro: that)
qed

lemma traces_list_all:
  "trace c T c' \<Longrightarrow> P c' \<Longrightarrow> (\<And> c c'. c \<Rightarrow> c' \<Longrightarrow> P c' \<Longrightarrow> P c) \<Longrightarrow> (\<forall> x\<in>set T. P x) \<and> P c"
  by (induction rule:trace.induct) auto

lemma trace_nil[simp]: "trace c [] c' \<longleftrightarrow> c = c'"
  by (metis list.distinct(1) trace.cases traces.trace_nil)

end

definition extends :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "\<lesssim>" 50) where
  "S \<lesssim> S' = (\<exists> S''. S' = S'' @ S)"

lemma extends_refl[simp]: "S \<lesssim> S" unfolding extends_def by auto
lemma extends_cons[simp]: "S \<lesssim> x # S" unfolding extends_def by auto
lemma extends_append[simp]: "S \<lesssim> L @ S" unfolding extends_def by auto
lemma extends_not_cons[simp]: "\<not> (x # S) \<lesssim> S" unfolding extends_def by auto
lemma extends_trans[trans]: "S \<lesssim> S' \<Longrightarrow> S' \<lesssim> S'' \<Longrightarrow> S \<lesssim> S''" unfolding extends_def by auto

locale balance_trace = traces +
  fixes stack :: "'a \<Rightarrow> 's list"
  assumes one_step_only: "c \<Rightarrow> c' \<Longrightarrow> (stack c) = (stack c') \<or> (\<exists> x.  stack c' = x # stack c) \<or>  (\<exists> x. stack c = x # stack c')"
begin

inductive bal :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  balI[intro]: "trace c T c' \<Longrightarrow> \<forall>c'\<in> set T. stack c \<lesssim> stack c' \<Longrightarrow> stack c' = stack c \<Longrightarrow> bal c T c'"

inductive_cases balE: "bal c T c'"

lemma bal_nil[simp]: "bal c [] c' \<longleftrightarrow> c = c'"
  by (auto elim: balE trace.cases)

lemma bal_stackD: "bal c T c' \<Longrightarrow> stack c' = stack c" by (auto dest: balE)

lemma stack_passes_lower_bound:
  assumes "c\<^sub>3 \<Rightarrow> c\<^sub>4"
  assumes "stack c\<^sub>2 \<lesssim> stack c\<^sub>3"
  assumes "\<not> stack c\<^sub>2 \<lesssim> stack c\<^sub>4"
  shows "stack c\<^sub>3 = stack c\<^sub>2" and "stack c\<^sub>4 = tl (stack c\<^sub>2)"
proof-
  from one_step_only[OF assms(1)]
  have "stack c\<^sub>3 = stack c\<^sub>2 \<and> stack c\<^sub>4 = tl (stack c\<^sub>2)"
  proof(elim disjE exE)
    assume "stack c\<^sub>3 = stack c\<^sub>4" with assms(2,3)
    have False by auto
    thus ?thesis..
  next
    fix x
    note \<open>stack c\<^sub>2 \<lesssim> stack c\<^sub>3\<close>
    also
    assume "stack c\<^sub>4 = x # stack c\<^sub>3"
    hence "stack c\<^sub>3 \<lesssim> stack c\<^sub>4" by simp
    finally
    have "stack c\<^sub>2 \<lesssim> stack c\<^sub>4".
    with assms(3) show ?thesis..
  next
    fix x
    assume c\<^sub>3: "stack c\<^sub>3 = x # stack c\<^sub>4"
    with assms(2)
    obtain L where L: "x # stack c\<^sub>4 = L @ stack c\<^sub>2" unfolding extends_def by auto
    show ?thesis
    proof(cases L)
      case Nil with c\<^sub>3 L have "stack c\<^sub>3 = stack c\<^sub>2" by simp
      moreover
      from  Nil  c\<^sub>3 L have "stack c\<^sub>4 = tl (stack c\<^sub>2)" by (cases "stack c\<^sub>2") auto
      ultimately
      show ?thesis..
    next
      case (Cons y L')
      with L have "stack c\<^sub>4 = L' @ stack c\<^sub>2" by simp
      hence "stack c\<^sub>2 \<lesssim> stack c\<^sub>4" by simp
      with assms(3) show ?thesis..
    qed
  qed
  thus "stack c\<^sub>3 = stack c\<^sub>2" and "stack c\<^sub>4 = tl (stack c\<^sub>2)" by auto
qed

lemma bal_consE:
  assumes "bal c\<^sub>1 (c\<^sub>2 # T) c\<^sub>5"
  and c\<^sub>2: "stack c\<^sub>2 = s # stack c\<^sub>1"
  obtains T\<^sub>1 c\<^sub>3 c\<^sub>4 T\<^sub>2
  where "T = T\<^sub>1 @ c\<^sub>4 # T\<^sub>2" and  "bal c\<^sub>2 T\<^sub>1 c\<^sub>3" and "c\<^sub>3 \<Rightarrow> c\<^sub>4" "bal c\<^sub>4 T\<^sub>2 c\<^sub>5"
using assms(1)
proof(rule balE)

  assume c\<^sub>5: "stack c\<^sub>5 = stack c\<^sub>1"
  assume T: "\<forall> c' \<in> set (c\<^sub>2 # T). stack c\<^sub>1 \<lesssim> stack c'"

  assume "trace c\<^sub>1 (c\<^sub>2 # T) c\<^sub>5"
  hence "c\<^sub>1 \<Rightarrow> c\<^sub>2" and "trace c\<^sub>2 T c\<^sub>5" by (auto elim: trace_consE)

  note \<open>trace c\<^sub>2 T c\<^sub>5\<close>
  moreover
  have "stack c\<^sub>2 \<lesssim> stack c\<^sub>2" by simp
  moreover
  have "\<not> (stack c\<^sub>2 \<lesssim> stack c\<^sub>5)" unfolding c\<^sub>5 c\<^sub>2  by simp
  ultimately
  obtain T\<^sub>1 c\<^sub>3 c\<^sub>4 T\<^sub>2
    where "T = T\<^sub>1 @ c\<^sub>4 # T\<^sub>2" and "trace c\<^sub>2 T\<^sub>1 c\<^sub>3" and "\<forall> c' \<in> set T\<^sub>1. stack c\<^sub>2 \<lesssim> stack c'"
     and "stack c\<^sub>2 \<lesssim> stack c\<^sub>3" and "c\<^sub>3 \<Rightarrow> c\<^sub>4" and "\<not> stack c\<^sub>2 \<lesssim> stack c\<^sub>4" and "trace c\<^sub>4 T\<^sub>2 c\<^sub>5"
     by (rule traceWhile)

  show ?thesis
  proof (rule that)
    show "T = T\<^sub>1 @ c\<^sub>4 # T\<^sub>2" by fact

    from \<open>c\<^sub>3 \<Rightarrow> c\<^sub>4\<close> \<open>stack c\<^sub>2 \<lesssim> stack c\<^sub>3\<close> \<open>\<not> stack c\<^sub>2 \<lesssim> stack c\<^sub>4\<close>
    have "stack c\<^sub>3 = stack c\<^sub>2" and c\<^sub>2': "stack c\<^sub>4 = tl (stack c\<^sub>2)" by (rule stack_passes_lower_bound)+

    from  \<open>trace c\<^sub>2 T\<^sub>1 c\<^sub>3\<close> \<open>\<forall> a \<in> set T\<^sub>1. stack c\<^sub>2 \<lesssim> stack a\<close> this(1)
    show "bal c\<^sub>2 T\<^sub>1 c\<^sub>3"..

    show "c\<^sub>3 \<Rightarrow> c\<^sub>4" by fact

    have c\<^sub>4: "stack c\<^sub>4 = stack c\<^sub>1" using c\<^sub>2 c\<^sub>2' by simp

    note  \<open>trace c\<^sub>4 T\<^sub>2 c\<^sub>5\<close>
    moreover
    have "\<forall> a\<in>set T\<^sub>2. stack c\<^sub>4 \<lesssim> stack a" using c\<^sub>4 T \<open>T = _\<close>  by auto
    moreover
    have "stack c\<^sub>5 = stack c\<^sub>4" unfolding c\<^sub>4 c\<^sub>5..
    ultimately
    show "bal c\<^sub>4 T\<^sub>2 c\<^sub>5"..
  qed
qed

end

end


theory Sorted_Less
imports Less_False
begin

hide_const sorted

text \<open>Is a list sorted without duplicates, i.e., wrt \<open><\<close>?.\<close>

abbreviation sorted :: "'a::linorder list \<Rightarrow> bool" where
"sorted \<equiv> sorted_wrt (<)"

lemmas sorted_wrt_Cons = sorted_wrt.simps(2)

declare
  sorted_wrt.simps(2)[simp del]
  sorted_wrt1[simp] sorted_wrt2[OF transp_less, simp]

lemma sorted_cons: "sorted (x#xs) \<Longrightarrow> sorted xs"
by(simp add: sorted_wrt_Cons)

lemma sorted_cons': "ASSUMPTION (sorted (x#xs)) \<Longrightarrow> sorted xs"
by(rule ASSUMPTION_D [THEN sorted_cons])

lemma sorted_snoc: "sorted (xs @ [y]) \<Longrightarrow> sorted xs"
by(simp add: sorted_wrt_append)

lemma sorted_snoc': "ASSUMPTION (sorted (xs @ [y])) \<Longrightarrow> sorted xs"
by(rule ASSUMPTION_D [THEN sorted_snoc])

lemma sorted_mid_iff:
  "sorted(xs @ y # ys) = (sorted(xs @ [y]) \<and> sorted(y # ys))"
by(fastforce simp add: sorted_wrt_Cons sorted_wrt_append)

lemma sorted_mid_iff2:
  "sorted(x # xs @ y # ys) =
  (sorted(x # xs) \<and> x < y \<and> sorted(xs @ [y]) \<and> sorted(y # ys))"
by(fastforce simp add: sorted_wrt_Cons sorted_wrt_append)

lemma sorted_mid_iff': "NO_MATCH [] ys \<Longrightarrow>
  sorted(xs @ y # ys) = (sorted(xs @ [y]) \<and> sorted(y # ys))"
by(rule sorted_mid_iff)

lemmas sorted_lems = sorted_mid_iff' sorted_mid_iff2 sorted_cons' sorted_snoc'

text\<open>Splay trees need two additional \<^const>\<open>sorted\<close> lemmas:\<close>

lemma sorted_snoc_le:
  "ASSUMPTION(sorted(xs @ [x])) \<Longrightarrow> x \<le> y \<Longrightarrow> sorted (xs @ [y])"
by (auto simp add: sorted_wrt_append ASSUMPTION_def)

lemma sorted_Cons_le:
  "ASSUMPTION(sorted(x # xs)) \<Longrightarrow> y \<le> x \<Longrightarrow> sorted (y # xs)"
by (auto simp add: sorted_wrt_Cons ASSUMPTION_def)

end


(*  Title:      HOL/Library/Option_ord.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Canonical order on option type\<close>

theory Option_ord
imports Option Main
begin

notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  Inf  ("\<Sqinter>_" [900] 900) and
  Sup  ("\<Squnion>_" [900] 900)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

instantiation option :: (preorder) preorder
begin

definition less_eq_option where
  "x \<le> y \<longleftrightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> x \<le> y))"

definition less_option where
  "x < y \<longleftrightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> x < y))"

lemma less_eq_option_None [simp]: "None \<le> x"
  by (simp add: less_eq_option_def)

lemma less_eq_option_None_code [code]: "None \<le> x \<longleftrightarrow> True"
  by simp

lemma less_eq_option_None_is_None: "x \<le> None \<Longrightarrow> x = None"
  by (cases x) (simp_all add: less_eq_option_def)

lemma less_eq_option_Some_None [simp, code]: "Some x \<le> None \<longleftrightarrow> False"
  by (simp add: less_eq_option_def)

lemma less_eq_option_Some [simp, code]: "Some x \<le> Some y \<longleftrightarrow> x \<le> y"
  by (simp add: less_eq_option_def)

lemma less_option_None [simp, code]: "x < None \<longleftrightarrow> False"
  by (simp add: less_option_def)

lemma less_option_None_is_Some: "None < x \<Longrightarrow> \<exists>z. x = Some z"
  by (cases x) (simp_all add: less_option_def)

lemma less_option_None_Some [simp]: "None < Some x"
  by (simp add: less_option_def)

lemma less_option_None_Some_code [code]: "None < Some x \<longleftrightarrow> True"
  by simp

lemma less_option_Some [simp, code]: "Some x < Some y \<longleftrightarrow> x < y"
  by (simp add: less_option_def)

instance
  by standard
    (auto simp add: less_eq_option_def less_option_def less_le_not_le
      elim: order_trans split: option.splits)

end

instance option :: (order) order
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instance option :: (linorder) linorder
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instantiation option :: (order) order_bot
begin

definition bot_option where "\<bottom> = None"

instance
  by standard (simp add: bot_option_def)

end

instantiation option :: (order_top) order_top
begin

definition top_option where "\<top> = Some \<top>"

instance
  by standard (simp add: top_option_def less_eq_option_def split: option.split)

end

instance option :: (wellorder) wellorder
proof
  fix P :: "'a option \<Rightarrow> bool"
  fix z :: "'a option"
  assume H: "\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  have "P None" by (rule H) simp
  then have P_Some [case_names Some]: "P z" if "\<And>x. z = Some x \<Longrightarrow> (P o Some) x" for z
    using \<open>P None\<close> that by (cases z) simp_all
  show "P z"
  proof (cases z rule: P_Some)
    case (Some w)
    show "(P o Some) w"
    proof (induct rule: less_induct)
      case (less x)
      have "P (Some x)"
      proof (rule H)
        fix y :: "'a option"
        assume "y < Some x"
        show "P y"
        proof (cases y rule: P_Some)
          case (Some v)
          with \<open>y < Some x\<close> have "v < x" by simp
          with less show "(P o Some) v" .
        qed
      qed
      then show ?case by simp
    qed
  qed
qed

instantiation option :: (inf) inf
begin

definition inf_option where
  "x \<sqinter> y = (case x of None \<Rightarrow> None | Some x \<Rightarrow> (case y of None \<Rightarrow> None | Some y \<Rightarrow> Some (x \<sqinter> y)))"

lemma inf_None_1 [simp, code]: "None \<sqinter> y = None"
  by (simp add: inf_option_def)

lemma inf_None_2 [simp, code]: "x \<sqinter> None = None"
  by (cases x) (simp_all add: inf_option_def)

lemma inf_Some [simp, code]: "Some x \<sqinter> Some y = Some (x \<sqinter> y)"
  by (simp add: inf_option_def)

instance ..

end

instantiation option :: (sup) sup
begin

definition sup_option where
  "x \<squnion> y = (case x of None \<Rightarrow> y | Some x' \<Rightarrow> (case y of None \<Rightarrow> x | Some y \<Rightarrow> Some (x' \<squnion> y)))"

lemma sup_None_1 [simp, code]: "None \<squnion> y = y"
  by (simp add: sup_option_def)

lemma sup_None_2 [simp, code]: "x \<squnion> None = x"
  by (cases x) (simp_all add: sup_option_def)

lemma sup_Some [simp, code]: "Some x \<squnion> Some y = Some (x \<squnion> y)"
  by (simp add: sup_option_def)

instance ..

end

instance option :: (semilattice_inf) semilattice_inf
proof
  fix x y z :: "'a option"
  show "x \<sqinter> y \<le> x"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<sqinter> y \<le> y"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all)
qed

instance option :: (semilattice_sup) semilattice_sup
proof
  fix x y z :: "'a option"
  show "x \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  show "y \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  fix x y z :: "'a option"
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases y, simp_all, cases z, simp_all, cases x, simp_all)
qed

instance option :: (lattice) lattice ..

instance option :: (lattice) bounded_lattice_bot ..

instance option :: (bounded_lattice_top) bounded_lattice_top ..

instance option :: (bounded_lattice_top) bounded_lattice ..

instance option :: (distrib_lattice) distrib_lattice
proof
  fix x y z :: "'a option"
  show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all add: sup_inf_distrib1 inf_commute)
qed

instantiation option :: (complete_lattice) complete_lattice
begin

definition Inf_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Sqinter>A = (if None \<in> A then None else Some (\<Sqinter>Option.these A))"

lemma None_in_Inf [simp]: "None \<in> A \<Longrightarrow> \<Sqinter>A = None"
  by (simp add: Inf_option_def)

definition Sup_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Squnion>A = (if A = {} \<or> A = {None} then None else Some (\<Squnion>Option.these A))"

lemma empty_Sup [simp]: "\<Squnion>{} = None"
  by (simp add: Sup_option_def)

lemma singleton_None_Sup [simp]: "\<Squnion>{None} = None"
  by (simp add: Sup_option_def)

instance
proof
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "\<Sqinter>A \<le> x"
    by (cases x) (auto simp add: Inf_option_def in_these_eq intro: Inf_lower)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  show "z \<le> \<Sqinter>A"
  proof (cases z)
    case None then show ?thesis by simp
  next
    case (Some y)
    show ?thesis
      by (auto simp add: Inf_option_def in_these_eq Some intro!: Inf_greatest dest!: *)
  qed
next
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "x \<le> \<Squnion>A"
    by (cases x) (auto simp add: Sup_option_def in_these_eq intro: Sup_upper)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z "
  proof (cases z)
    case None
    with * have "\<And>x. x \<in> A \<Longrightarrow> x = None" by (auto dest: less_eq_option_None_is_None)
    then have "A = {} \<or> A = {None}" by blast
    then show ?thesis by (simp add: Sup_option_def)
  next
    case (Some y)
    from * have "\<And>w. Some w \<in> A \<Longrightarrow> Some w \<le> z" .
    with Some have "\<And>w. w \<in> Option.these A \<Longrightarrow> w \<le> y"
      by (simp add: in_these_eq)
    then have "\<Squnion>Option.these A \<le> y" by (rule Sup_least)
    with Some show ?thesis by (simp add: Sup_option_def)
  qed
next
  show "\<Squnion>{} = (\<bottom>::'a option)"
    by (auto simp: bot_option_def)
  show "\<Sqinter>{} = (\<top>::'a option)"
    by (auto simp: top_option_def Inf_option_def)
qed

end

lemma Some_Inf:
  "Some (\<Sqinter>A) = \<Sqinter>(Some ` A)"
  by (auto simp add: Inf_option_def)

lemma Some_Sup:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>A) = \<Squnion>(Some ` A)"
  by (auto simp add: Sup_option_def)

lemma Some_INF:
  "Some (\<Sqinter>x\<in>A. f x) = (\<Sqinter>x\<in>A. Some (f x))"
  using Some_Inf [of "f ` A"] by (simp add: comp_def)

lemma Some_SUP:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>x\<in>A. f x) = (\<Squnion>x\<in>A. Some (f x))"
  using Some_Sup [of "f ` A"] by (simp add: comp_def)

instance option :: (complete_distrib_lattice) complete_distrib_lattice
proof
  fix a :: "'a option" and B
  show "a \<squnion> \<Sqinter>B = (\<Sqinter>b\<in>B. a \<squnion> b)"
  proof (cases a)
    case None
    then show ?thesis by simp
  next
    case (Some c)
    show ?thesis
    proof (cases "None \<in> B")
      case True
      then have "Some c = (\<Sqinter>b\<in>B. Some c \<squnion> b)"
        by (auto intro!: antisym INF_lower2 INF_greatest)
      with True Some show ?thesis by simp
    next
      case False then have B: "{x \<in> B. \<exists>y. x = Some y} = B" by auto (metis not_Some_eq)
      from sup_Inf have "Some c \<squnion> Some (\<Sqinter>Option.these B) = Some (\<Sqinter>b\<in>Option.these B. c \<squnion> b)" by simp
      then have "Some c \<squnion> \<Sqinter>(Some ` Option.these B) = (\<Sqinter>x\<in>Some ` Option.these B. Some c \<squnion> x)"
        by (simp add: Some_INF Some_Inf comp_def)
      with Some B show ?thesis by (simp add: Some_image_these_eq cong del: strong_INF_cong)
    qed
  qed
  show "a \<sqinter> \<Squnion>B = (\<Squnion>b\<in>B. a \<sqinter> b)"
  proof (cases a)
    case None
    then show ?thesis by (simp add: image_constant_conv bot_option_def cong del: strong_SUP_cong)
  next
    case (Some c)
    show ?thesis
    proof (cases "B = {} \<or> B = {None}")
      case True
      then show ?thesis by auto
    next
      have B: "B = {x \<in> B. \<exists>y. x = Some y} \<union> {x \<in> B. x = None}"
        by auto
      then have Sup_B: "\<Squnion>B = \<Squnion>({x \<in> B. \<exists>y. x = Some y} \<union> {x \<in> B. x = None})"
        and SUP_B: "\<And>f. (\<Squnion>x \<in> B. f x) = (\<Squnion>x \<in> {x \<in> B. \<exists>y. x = Some y} \<union> {x \<in> B. x = None}. f x)"
        by simp_all
      have Sup_None: "\<Squnion>{x. x = None \<and> x \<in> B} = None"
        by (simp add: bot_option_def [symmetric])
      have SUP_None: "(\<Squnion>x\<in>{x. x = None \<and> x \<in> B}. Some c \<sqinter> x) = None"
        by (simp add: bot_option_def [symmetric])
      case False then have "Option.these B \<noteq> {}" by (simp add: these_not_empty_eq)
      moreover from inf_Sup have "Some c \<sqinter> Some (\<Squnion>Option.these B) = Some (\<Squnion>b\<in>Option.these B. c \<sqinter> b)"
        by simp
      ultimately have "Some c \<sqinter> \<Squnion>(Some ` Option.these B) = (\<Squnion>x\<in>Some ` Option.these B. Some c \<sqinter> x)"
        by (simp add: Some_SUP Some_Sup comp_def)
      with Some show ?thesis
        by (simp add: Some_image_these_eq Sup_B SUP_B Sup_None SUP_None SUP_union Sup_union_distrib cong del: strong_SUP_cong)
    qed
  qed
qed

instance option :: (complete_linorder) complete_linorder ..

no_notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  Inf  ("\<Sqinter>_" [900] 900) and
  Sup  ("\<Squnion>_" [900] 900)

no_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

end


(*  Title:      HOL/Library/Subseq_Order.thy
    Author:     Peter Lammich, Uni Muenster <peter.lammich@uni-muenster.de>
    Author:     Florian Haftmann, TU Muenchen
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>Subsequence Ordering\<close>

theory Subseq_Order
imports Sublist
begin

text \<open>
  This theory defines subsequence ordering on lists. A list \<open>ys\<close> is a subsequence of a
  list \<open>xs\<close>, iff one obtains \<open>ys\<close> by erasing some elements from \<open>xs\<close>.
\<close>

subsection \<open>Definitions and basic lemmas\<close>

instantiation list :: (type) ord
begin

definition less_eq_list
  where \<open>xs \<le> ys \<longleftrightarrow> subseq xs ys\<close> for xs ys :: \<open>'a list\<close>

definition less_list
  where \<open>xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs\<close> for xs ys :: \<open>'a list\<close>

instance ..

end

instance list :: (type) order
proof
  fix xs ys zs :: "'a list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    unfolding less_list_def ..
  show "xs \<le> xs"
    by (simp add: less_eq_list_def)
  show "xs = ys" if "xs \<le> ys" and "ys \<le> xs"
    using that unfolding less_eq_list_def
    by (rule subseq_order.antisym)
  show "xs \<le> zs" if "xs \<le> ys" and "ys \<le> zs"
    using that unfolding less_eq_list_def
    by (rule subseq_order.order_trans)
qed

lemmas less_eq_list_induct [consumes 1, case_names empty drop take] =
  list_emb.induct [of "(=)", folded less_eq_list_def]

lemma less_eq_list_empty [code]:
  \<open>[] \<le> xs \<longleftrightarrow> True\<close>
  by (simp add: less_eq_list_def)

lemma less_eq_list_below_empty [code]:
  \<open>x # xs \<le> [] \<longleftrightarrow> False\<close>
  by (simp add: less_eq_list_def)

lemma le_list_Cons2_iff [simp, code]:
  \<open>x # xs \<le> y # ys \<longleftrightarrow> (if x = y then xs \<le> ys else x # xs \<le> ys)\<close>
  by (simp add: less_eq_list_def)

lemma less_list_empty [simp]:
  \<open>[] < xs \<longleftrightarrow> xs \<noteq> []\<close>
  by (metis less_eq_list_def list_emb_Nil order_less_le)

lemma less_list_empty_Cons [code]:
  \<open>[] < x # xs \<longleftrightarrow> True\<close>
  by simp_all

lemma less_list_below_empty [simp, code]:
  \<open>xs < [] \<longleftrightarrow> False\<close>
  by (metis list_emb_Nil less_eq_list_def less_list_def)

lemma less_list_Cons2_iff [code]:
  \<open>x # xs < y # ys \<longleftrightarrow> (if x = y then xs < ys else x # xs \<le> ys)\<close>
  by (simp add: less_le)

lemmas less_eq_list_drop = list_emb.list_emb_Cons [of "(=)", folded less_eq_list_def]
lemmas le_list_map = subseq_map [folded less_eq_list_def]
lemmas le_list_filter = subseq_filter [folded less_eq_list_def]
lemmas le_list_length = list_emb_length [of "(=)", folded less_eq_list_def]

lemma less_list_length: "xs < ys \<Longrightarrow> length xs < length ys"
  by (metis list_emb_length subseq_same_length le_neq_implies_less less_list_def less_eq_list_def)

lemma less_list_drop: "xs < ys \<Longrightarrow> xs < x # ys"
  by (unfold less_le less_eq_list_def) (auto)

lemma less_list_take_iff: "x # xs < x # ys \<longleftrightarrow> xs < ys"
  by (metis subseq_Cons2_iff less_list_def less_eq_list_def)

lemma less_list_drop_many: "xs < ys \<Longrightarrow> xs < zs @ ys"
  by (metis subseq_append_le_same_iff subseq_drop_many order_less_le
      self_append_conv2 less_eq_list_def)

lemma less_list_take_many_iff: "zs @ xs < zs @ ys \<longleftrightarrow> xs < ys"
  by (metis less_list_def less_eq_list_def subseq_append')

lemma less_list_rev_take: "xs @ zs < ys @ zs \<longleftrightarrow> xs < ys"
  by (unfold less_le less_eq_list_def) auto

end