section "Simple Language Definition"

(*<*)
theory Lang
imports Main LaTeXsugar
begin
(*>*)

subsection "Language Values"

text {*
An array is a list.
*}
type_synonym 'a array = "'a list"

subsection "Abstract Syntax Tree"

text {* Variable bindings are handled via strings for now. *}
type_synonym var = string

text {*
@{text exp } is the language abstract syntax tree data-type. It is
basically an extension of the lambda calculus with collective array
operations.
 *}
datatype exp =
    C int
  | Add exp exp         (infix "+" 70)
  | Sub exp exp         (infix "-" 70)
  | Mul exp exp         (infix "*" 70)
  | PrjL exp
  | PrjR exp
  | Lam var exp
  | App exp exp         (infix "$" 70)
  | Tup exp exp         (infix "\<times>" 70)
  | A "exp array"
  | Var var
  | Map exp exp         (infix "m\<Rightarrow>" 60)
  | Zip exp exp         (infix "z\<Rightarrow>" 60)
  | Fold exp exp exp    (infix "[_]f\<Rightarrow>" 60)
  | Split exp exp       (infix "s\<Rightarrow>" 60)
  | Join exp

(* I'm not sure how to represent iterate. *)

datatype ty =
    TyInt
  | TyTuple ty ty
  | TyA ty (* not tracking size yet *)
  | TyLam ty ty

subsection "Semantics"

fun subst :: "exp \<Rightarrow> var \<Rightarrow> exp \<Rightarrow> exp" (infix "[_]\<leadsto>" 70) where
    "(C c) [v]\<leadsto> e' = C c"
  | "(e1 + e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') + (e2 [v]\<leadsto> e')"
  | "(e1 - e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') - (e2 [v]\<leadsto> e')"
  | "(e1 * e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') * (e2 [v]\<leadsto> e')"
  | "(PrjL e) [v]\<leadsto> e' = PrjL (e [v]\<leadsto> e')"
  | "(PrjR e) [v]\<leadsto> e' = PrjR (e [v]\<leadsto> e')"
  | "(Lam v' e) [v]\<leadsto> e' =
      (if v' = v then (Lam v' e) else (Lam v' (e [v]\<leadsto> e')))"
  | "(e1 $ e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') $ (e2 [v]\<leadsto> e')"
  | "(e1 \<times> e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') \<times> (e2 [v]\<leadsto> e')"
  | "(A es) [v]\<leadsto> e' = A (map (\<lambda>i. i [v]\<leadsto> e') es)"
  | "(Var v') [v]\<leadsto> e' =
      (if v' = v then e' else (Var v'))"
  | "(e1 m\<Rightarrow> e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') m\<Rightarrow> (e2 [v]\<leadsto> e')"
  | "(e1 z\<Rightarrow> e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') z\<Rightarrow> (e2 [v]\<leadsto> e')"
  | "(e1 [e2]f\<Rightarrow> e3) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') [(e2 [v]\<leadsto> e')]f\<Rightarrow> (e3 [v]\<leadsto> e')"
  | "(e1 s\<Rightarrow> e2) [v]\<leadsto> e' = (e1 [v]\<leadsto> e') s\<Rightarrow> (e2 [v]\<leadsto> e')"
  | "(Join e) [v]\<leadsto> e' = Join (e [v]\<leadsto> e')"

text {*
The semantics of the language are given via an inductive relation
from @{text exp} to @{text result}, which is either @{text exp} or an error.
*}

datatype result =
    R exp
  | Error

inductive
  evalr :: "exp \<Rightarrow> result \<Rightarrow> bool" (infix "\<mapsto>" 70)
where
    Int[intro!]: "(C c) \<mapsto> R (C c)"
  | Add[intro!]: "\<lbrakk> e1 \<mapsto> R (C c1); e2 \<mapsto> R (C c2) \<rbrakk>
          \<Longrightarrow> (e1 + e2) \<mapsto> R (C (c1 + c2))"
  | Sub[intro!]: "\<lbrakk> e1 \<mapsto> R (C c1); e2 \<mapsto> R (C c2) \<rbrakk>
          \<Longrightarrow> (e1 - e2) \<mapsto> R (C (c1 - c2))"
  | Mul[intro!]: "\<lbrakk> e1 \<mapsto> R (C c1); e2 \<mapsto> R (C c2) \<rbrakk>
          \<Longrightarrow> (e1 * e2) \<mapsto> R (C (c1 * c2))"
  | PrjL[intro!]: "\<lbrakk> e \<mapsto> R (Tup c1 c2) \<rbrakk>
          \<Longrightarrow> (PrjL e) \<mapsto> R c1"
  | PrjR[intro!]: "\<lbrakk> e \<mapsto> R (Tup c1 c2) \<rbrakk>
          \<Longrightarrow> (PrjR e) \<mapsto> R c2"
  | Lam[intro!]: "(Lam v e) \<mapsto> R (Lam v e)"
  | App[intro!]: "\<lbrakk> e1 \<mapsto> R (Lam v e); e2 \<mapsto> R e2'; (e [v]\<leadsto> e2') \<mapsto> e' \<rbrakk>
          \<Longrightarrow> (e1 $ e2) \<mapsto> e'"
  | Tup[intro!]: "\<lbrakk> e1 \<mapsto> R e1'; e2 \<mapsto> R e2' \<rbrakk> \<Longrightarrow> (e1 \<times> e2) \<mapsto> R (e1' \<times> e2')"
  | Array1[intro!]: "(A []) \<mapsto> R (A [])"
  | Array2[intro!]: "\<lbrakk> (A es) \<mapsto> R (A as); e \<mapsto> R e' \<rbrakk>
          \<Longrightarrow> (A (e # es)) \<mapsto> R (A (e' # as))"
  | Var[intro!]: "(Var _) \<mapsto> Error"
  | Map1[intro!]: "\<lbrakk> e2 \<mapsto> R (A []) \<rbrakk>
          \<Longrightarrow> (e1 m\<Rightarrow> e2) \<mapsto> R (A [])"
  | Map2[intro!]: "\<lbrakk> e1 \<mapsto> R (Lam v e); e2 \<mapsto> R (A (a # as));
            ((Lam v e) m\<Rightarrow> (A as)) \<mapsto> R (A as'); ((Lam v e) $ a) \<mapsto> R a' \<rbrakk>
          \<Longrightarrow> (e1 m\<Rightarrow> e2) \<mapsto> R (A (a' # as'))"
  | Zip1[intro!]: "\<lbrakk> e2 \<mapsto> R (A []) \<rbrakk>
          \<Longrightarrow> (e1 z\<Rightarrow> e2) \<mapsto> R (A [])"
  | Zip2[intro!]: "\<lbrakk> e1 \<mapsto> R (A []) \<rbrakk>
          \<Longrightarrow> (e1 z\<Rightarrow> e2) \<mapsto> R (A [])"
  | Zip3[intro!]: "\<lbrakk> e1 \<mapsto> R (A (a1 # a1s)); e2 \<mapsto> R (A (a2 # a2s));
            ((A a1s) z\<Rightarrow> (A a2s)) \<mapsto> R (A as) \<rbrakk>
          \<Longrightarrow> (e1 z\<Rightarrow> e2) \<mapsto> R (A ((a1 \<times> a2) # as))"
(* TODO: Fold Split Join *)

lemma add_int[simp]:"(Add (C x) (C y)) \<mapsto> (R (C (x+y)))"
by (auto)
lemma sub_int[simp]:"(Sub (C x) (C y)) \<mapsto> (R (C (x-y)))"
by (auto)
lemma mul_int[simp]: "(Mul (C x) (C y)) \<mapsto> (R (C (x*y)))"
by (auto)

(* tests *)
lemma "(Mul (C 1) (C 2)) \<mapsto> R (C 2)"
by (metis mul_int mult.left_neutral)
lemma "(Add (C 1) (C 2)) \<mapsto> R (C 3)"
by (metis add_int one_plus_numeral semiring_norm(3))
lemma "(Map (Lam x (Add (Var x) (C 1))) (A [(C 1),(C 2),(C 3)])) \<mapsto> R (A [(C 2),(C 3),(C 4)])"
apply auto apply (smt add_int)+ done

text{*
\begin{figure}
@{thm[mode=Rule] App [no_vars]} {\sc App} \\[1ex]
\vspace{10 mm}
@{thm[mode=Axiom] Lam [no_vars]} {\sc Lam} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Add [no_vars]} {\sc Add} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Sub [no_vars]} {\sc Sub} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Mul [no_vars]} {\sc Mul} \\[1ex]
\vspace{10 mm}
@{thm[mode=Axiom] Int [no_vars]} {\sc Int} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] PrjL [no_vars]} {\sc Prj$_L$} \qquad
@{thm[mode=Rule] PrjR [no_vars]} {\sc Prj$_R$} \\[1ex]
\vspace{10 mm}
\end{figure}

\begin{figure}
@{thm[mode=Axiom] Array1 [no_vars]} {\sc Array$_1$} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Array2 [no_vars]} {\sc Array$_2$} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Map1 [no_vars]} {\sc Map$_1$} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Map2 [no_vars]} {\sc Map$_2$} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Zip1 [no_vars]} {\sc Zip$_1$} \qquad
@{thm[mode=Rule] Zip2 [no_vars]} {\sc Zip$_2$} \\[1ex]
\vspace{10 mm}
@{thm[mode=Rule] Zip3 [no_vars]} {\sc Zip$_3$} \\[1ex]
\end{figure}
*}

end


section \<open>Fresh identifier generation for strings\<close>

theory Fresh_String
  imports Fresh
begin

subsection \<open>A partial order on strings\<close>

text
\<open>The first criterion is the length, and the second the encoding of last character. \<close>

definition ordst :: "string \<Rightarrow> string \<Rightarrow> bool" where
"ordst X Y \<equiv>
 (length X \<le> length Y \<and> X \<noteq> [] \<and> Y \<noteq> [] \<and> of_char (last X) < (of_char(last Y) :: nat))
 \<or> (length X < length Y)"

definition ordstNS :: "string \<Rightarrow> string \<Rightarrow> bool" where
"ordstNS X Y \<equiv> X = Y \<or> ordst X Y"

lemma ordst_antirefl: "\<not> ordst X X"
by(auto simp add: ordst_def)

lemma ordst_trans:
assumes As1: "ordst X Y" and As2: "ordst Y Z"
shows "ordst X Z"
proof(cases "(length X < length Y) \<or> (length Y < length Z)")
  assume "(length X < length Y) \<or> (length Y < length Z)"
  moreover
  {assume "length X < length Y"
   moreover have "length Y \<le> length Z"
   using As2 ordst_def by force
   ultimately have "length X < length Z" by force
   hence ?thesis using ordst_def by force}
  moreover
  {assume "length Y < length Z"
   moreover have "length X \<le> length Y"
   using As1 ordst_def by force
   ultimately have "length X < length Z" by force
   hence ?thesis using ordst_def by force}
  ultimately show ?thesis by force
next
  assume "\<not> (length X < length Y \<or> length Y < length Z)"
  hence Ft: "\<not> length X < length Y  \<and> \<not> length Y < length Z" by force
  hence "(of_char(last X) :: nat) < of_char(last Y) \<and>
         (of_char(last Y) :: nat) < of_char(last Z) \<and>
         length X \<le> length Y \<and> length Y \<le> length Z"
  using As1 As2 ordst_def by force
  hence "(of_char(last X) :: nat) < of_char(last Z) \<and>
         length X \<le> length Z" by force
  moreover have "X \<noteq> [] \<and> Z \<noteq> []"
  using As1 As2 Ft ordst_def by force
  ultimately show ?thesis using ordst_def[of X Z] by force
qed

lemma ordstNS_refl: "ordstNS X X"
by(simp add: ordstNS_def)

lemma ordstNS_trans:
"ordstNS X Y \<Longrightarrow> ordstNS Y Z \<Longrightarrow> ordstNS X Z"
by (metis ordstNS_def ordst_trans)

lemma ordst_ordstNS_trans:
"ordst X Y \<Longrightarrow> ordstNS Y Z \<Longrightarrow> ordst X Z"
by (metis ordstNS_def ordst_trans)

lemma ordstNS_ordst_trans:
"ordstNS X Y \<Longrightarrow> ordst Y Z \<Longrightarrow> ordst X Z"
by (metis ordstNS_def ordst_trans)

subsection \<open>Incrementing a string \<close>

text \<open>If the last character is $\geq$ 'a' and $<$ 'z',
   then \<open>upChar\<close> increments this last character;
   otherwise \<open>upChar\<close> appends an 'a'.  \<close>

fun upChar :: "string \<Rightarrow> string" where
"upChar Y =
 (if (Y \<noteq> [] \<and> of_char(last Y) \<ge> (97 :: nat) \<and>
               of_char(last Y) < (122 :: nat))
    then (butlast Y) @
         [char_of(of_char(last Y) + (1 :: nat))]
    else Y @ ''a''
 )"

lemma upChar_ordst: "ordst Y (upChar Y)"
proof-
  {assume "\<not>(Y \<noteq> [] \<and> of_char(last Y) \<ge> (97 :: nat)
                       \<and> of_char(last Y) < (122 :: nat))"
   hence "upChar Y = Y @ ''a''" by force
   hence ?thesis using ordst_def by force
  }
  moreover
  {assume As: "Y \<noteq> [] \<and> of_char(last Y) \<ge> (97 :: nat)
                       \<and> of_char(last Y) < (122 :: nat)"
   hence Ft: "upChar Y = (butlast Y) @
                     [char_of(of_char(last Y) + (1 :: nat))]"
   by force
   hence Ft': "last (upChar Y) = char_of(of_char(last Y) + (1 :: nat))"
   by force
   hence "of_char(last (upChar Y)) mod (256 :: nat)  =
          (of_char(last Y) + 1) mod 256"
   by force
   moreover
   have "of_char(last(upChar Y))  < (256 :: nat) \<and>
         of_char(last Y) + 1 < (256 :: nat)"
   using As Ft' by force
   ultimately
   have "of_char (last Y) < (of_char (last(upChar Y)) :: nat)" by force
   moreover
   from Ft have "length Y \<le> length (upChar Y)" by force
   ultimately have ?thesis using ordst_def by force}
  ultimately show ?thesis by force
qed

subsection \<open>The fresh-identifier operator\<close>

text \<open>\<open>fresh Xs Y\<close> changes \<open>Y\<close> as little as possible so that
   it becomes disjoint from all strings in \<open>Xs\<close>. \<close>

function fresh_string :: "string set \<Rightarrow> string \<Rightarrow> string"
where
Up: "Y \<in> Xs \<Longrightarrow> finite Xs \<Longrightarrow> fresh_string Xs Y = fresh_string (Xs - {Y}) (upChar Y)"
|
Fresh: "Y \<notin> Xs \<or> infinite Xs \<Longrightarrow> fresh_string Xs Y = Y"
by auto
termination
  apply(relation "measure (\<lambda>(Xs,Y). card Xs)", simp_all)
  by (metis card_gt_0_iff diff_Suc_less empty_iff)

lemma fresh_string_ordstNS: "ordstNS Y (fresh_string Xs Y)"
proof (induction Xs Y rule: fresh_string.induct[case_names Up Fresh])
  case (Up Y Xs)
  hence "ordst Y (fresh_string (Xs - {Y}) (upChar Y))"
    using upChar_ordst[of Y] ordst_ordstNS_trans by force
  hence "ordstNS Y (fresh_string (Xs - {Y}) (upChar Y))"
    using ordstNS_def by auto
  thus ?case
    using Up.hyps by auto
next
  case (Fresh Y Xs)
  then show ?case
    by (auto intro: ordstNS_refl)
qed

lemma fresh_string_set: "finite Xs \<Longrightarrow> fresh_string Xs Y \<notin> Xs"
proof (induction Xs Y rule: fresh_string.induct[case_names Up Fresh])
  case (Up Y Xs)
  show ?case
  proof
    assume "fresh_string Xs Y \<in> Xs"
    then have "fresh_string (Xs - {Y}) (upChar Y) \<in> Xs"
      using Up.hyps by force
    then have "fresh_string (Xs - {Y}) (upChar Y) = Y"
      using Up.IH \<open>finite Xs\<close> by blast
    moreover have "ordst Y (fresh_string (Xs - {Y}) (upChar Y))"
      using upChar_ordst[of Y] fresh_string_ordstNS ordst_ordstNS_trans by auto
    ultimately show False
      using ordst_antirefl by auto
  qed
qed auto

text \<open>Code generation:\<close>

lemma fresh_string_if:
  "fresh_string Xs Y = (
     if Y \<in> Xs \<and> finite Xs then fresh_string (Xs - {Y}) (upChar Y)
     else Y)"
  by simp

lemmas fresh_string_list[code] = fresh_string_if[where Xs = "set Xs" for Xs, simplified]

text \<open>Some tests: \<close>

value "[fresh_string {} ''Abc'',
        fresh_string {''X'', ''Abc''} ''Abd'',
        fresh_string {''X'', ''Y''} ''Y'',
        fresh_string {''X'', ''Yaa'', ''Ya'', ''Yaa''} ''Ya'',
        fresh_string {''X'', ''Yaa'', ''Yz'', ''Yza''} ''Yz'',
        fresh_string {''X'', ''Y'', ''Yab'', ''Y''} ''Y'']"

text \<open>Here we do locale interpretation rather than class instantiation,
since \<^typ>\<open>string\<close> is a type synonym for \<^typ>\<open>char list\<close>.\<close>

interpretation fresh_string: fresh where fresh = fresh_string
  by standard (use fresh_string_set in auto)

subsection \<open>Lifting to string literals\<close>

abbreviation "is_ascii str \<equiv> (\<forall>c \<in> set str. \<not>digit7 c)"

lemma map_ascii_of_idem:
  "is_ascii str \<Longrightarrow> map String.ascii_of str = str"
  by (induction str) (auto simp: String.ascii_of_idem)

lemma is_ascii_butlast:
  "is_ascii str \<Longrightarrow> is_ascii (butlast str)"
  by (auto dest: in_set_butlastD)

lemma ascii_char_of:
  fixes c :: nat
  assumes "c < 128"
  shows "\<not>digit7 (char_of c)"
  using assms
  by (auto simp: char_of_def bit_iff_odd)

lemmas ascii_of_char_of_idem = ascii_char_of[THEN String.ascii_of_idem]

lemma is_ascii_upChar:
  "is_ascii str \<Longrightarrow> is_ascii (upChar str)"
  by (auto simp: ascii_char_of is_ascii_butlast)

lemma is_ascii_fresh_string:
  "is_ascii Y \<Longrightarrow> is_ascii (fresh_string Xs Y)"
proof (induction Xs Y rule: fresh_string.induct[case_names Up Fresh])
  case (Up Y Xs)
  show ?case
    using Up.IH[OF is_ascii_upChar[OF \<open>is_ascii Y\<close>]] Up.hyps
    by auto
qed auto

text \<open>For string literals we can properly instantiate the class.\<close>

instantiation String.literal :: fresh
begin

context
  includes literal.lifting
begin

lift_definition fresh_literal :: "String.literal set \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is fresh_string
  using is_ascii_fresh_string
  by blast

instance by (standard; transfer) (use fresh_string_set in auto)

end

end

text \<open>Code generation:\<close>

context
  includes literal.lifting
begin

lift_definition upChar_literal :: "String.literal \<Rightarrow> String.literal" is upChar
  using is_ascii_upChar
  by blast

lemma upChar_literal_upChar[code]:
  "upChar_literal s = String.implode (upChar (String.explode s))"
  by transfer (auto simp: map_ascii_of_idem is_ascii_butlast ascii_of_char_of_idem)

lemma fresh_literal_if:
  "fresh xs y = (if y \<in> xs \<and> finite xs then fresh (xs - {y}) (upChar_literal y) else y)"
  by transfer (intro fresh_string_if)

lemmas fresh_literal_list[code] = fresh_literal_if[where xs = "set xs" for xs, simplified]

end

text \<open>Some tests: \<close>

value "[fresh {} (STR ''Abc''),
        fresh {STR ''X'', STR ''Abc''} (STR ''Abd''),
        fresh {STR ''X'', STR ''Y''} (STR  ''Y''),
        fresh {STR ''X'', STR ''Yaa'', STR ''Ya'', STR ''Yaa''} (STR ''Ya''),
        fresh {STR ''X'', STR ''Yaa'', STR ''Yz'', STR ''Yza''} (STR ''Yz''),
        fresh {STR ''X'', STR ''Y'', STR ''Yab'', STR ''Y''} (STR ''Y'')]"

end


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

section \<open>The Mutilated Chess Board Problem, formalized inductively\<close>

theory Mutil imports Main begin

text \<open>
  Originator is Max Black, according to J A Robinson.  Popularized as
  the Mutilated Checkerboard Problem by J McCarthy.
\<close>

consts
  domino :: i
  tiling :: "i => i"

inductive
  domains "domino" \<subseteq> "Pow(nat \<times> nat)"
  intros
    horiz: "[| i \<in> nat;  j \<in> nat |] ==> {<i,j>, <i,succ(j)>} \<in> domino"
    vertl: "[| i \<in> nat;  j \<in> nat |] ==> {<i,j>, <succ(i),j>} \<in> domino"
  type_intros empty_subsetI cons_subsetI PowI SigmaI nat_succI

inductive
  domains "tiling(A)" \<subseteq> "Pow(\<Union>(A))"
  intros
    empty: "0 \<in> tiling(A)"
    Un: "[| a \<in> A;  t \<in> tiling(A);  a \<inter> t = 0 |] ==> a \<union> t \<in> tiling(A)"
  type_intros empty_subsetI Union_upper Un_least PowI
  type_elims PowD [elim_format]

definition
  evnodd :: "[i, i] => i"  where
  "evnodd(A,b) == {z \<in> A. \<exists>i j. z = <i,j> \<and> (i #+ j) mod 2 = b}"

subsection \<open>Basic properties of evnodd\<close>

lemma evnodd_iff: "<i,j>: evnodd(A,b) \<longleftrightarrow> <i,j>: A & (i#+j) mod 2 = b"
  by (unfold evnodd_def) blast

lemma evnodd_subset: "evnodd(A, b) \<subseteq> A"
  by (unfold evnodd_def) blast

lemma Finite_evnodd: "Finite(X) ==> Finite(evnodd(X,b))"
  by (rule lepoll_Finite, rule subset_imp_lepoll, rule evnodd_subset)

lemma evnodd_Un: "evnodd(A \<union> B, b) = evnodd(A,b) \<union> evnodd(B,b)"
  by (simp add: evnodd_def Collect_Un)

lemma evnodd_Diff: "evnodd(A - B, b) = evnodd(A,b) - evnodd(B,b)"
  by (simp add: evnodd_def Collect_Diff)

lemma evnodd_cons [simp]:
  "evnodd(cons(<i,j>,C), b) =
    (if (i#+j) mod 2 = b then cons(<i,j>, evnodd(C,b)) else evnodd(C,b))"
  by (simp add: evnodd_def Collect_cons)

lemma evnodd_0 [simp]: "evnodd(0, b) = 0"
  by (simp add: evnodd_def)

subsection \<open>Dominoes\<close>

lemma domino_Finite: "d \<in> domino ==> Finite(d)"
  by (blast intro!: Finite_cons Finite_0 elim: domino.cases)

lemma domino_singleton:
    "[| d \<in> domino; b<2 |] ==> \<exists>i' j'. evnodd(d,b) = {<i',j'>}"
  apply (erule domino.cases)
   apply (rule_tac [2] k1 = "i#+j" in mod2_cases [THEN disjE])
     apply (rule_tac k1 = "i#+j" in mod2_cases [THEN disjE])
       apply (rule add_type | assumption)+
      (*Four similar cases: case (i#+j) mod 2 = b, 2#-b, ...*)
      apply (auto simp add: mod_succ succ_neq_self dest: ltD)
  done

subsection \<open>Tilings\<close>

text \<open>The union of two disjoint tilings is a tiling\<close>

lemma tiling_UnI:
    "t \<in> tiling(A) ==> u \<in> tiling(A) ==> t \<inter> u = 0 ==> t \<union> u \<in> tiling(A)"
  apply (induct set: tiling)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc subset_empty_iff [THEN iff_sym])
  apply (blast intro: tiling.intros)
  done

lemma tiling_domino_Finite: "t \<in> tiling(domino) ==> Finite(t)"
  apply (induct set: tiling)
   apply (rule Finite_0)
  apply (blast intro!: Finite_Un intro: domino_Finite)
  done

lemma tiling_domino_0_1: "t \<in> tiling(domino) ==> |evnodd(t,0)| = |evnodd(t,1)|"
  apply (induct set: tiling)
   apply (simp add: evnodd_def)
  apply (rule_tac b1 = 0 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply (rule_tac b1 = 1 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply safe
  apply (subgoal_tac "\<forall>p b. p \<in> evnodd (a,b) \<longrightarrow> p\<notin>evnodd (t,b)")
   apply (simp add: evnodd_Un Un_cons tiling_domino_Finite
     evnodd_subset [THEN subset_Finite] Finite_imp_cardinal_cons)
  apply (blast dest!: evnodd_subset [THEN subsetD] elim: equalityE)
  done

lemma dominoes_tile_row:
    "[| i \<in> nat;  n \<in> nat |] ==> {i} * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac n)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc [symmetric] Sigma_succ2)
  apply (rule tiling.intros)
    prefer 2 apply assumption
   apply (rename_tac n')
   apply (subgoal_tac (*seems the easiest way of turning one to the other*)
     "{i}*{succ (n'#+n') } \<union> {i}*{n'#+n'} =
       {<i,n'#+n'>, <i,succ (n'#+n') >}")
    prefer 2 apply blast
  apply (simp add: domino.horiz)
  apply (blast elim: mem_irrefl mem_asym)
  done

lemma dominoes_tile_matrix:
    "[| m \<in> nat;  n \<in> nat |] ==> m * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac m)
   apply (simp add: tiling.intros)
  apply (simp add: Sigma_succ1)
  apply (blast intro: tiling_UnI dominoes_tile_row elim: mem_irrefl)
  done

lemma eq_lt_E: "[| x=y; x<y |] ==> P"
  by auto

theorem mutil_not_tiling: "[| m \<in> nat;  n \<in> nat;
         t = (succ(m)#+succ(m))*(succ(n)#+succ(n));
         t' = t - {<0,0>} - {<succ(m#+m), succ(n#+n)>} |]
      ==> t' \<notin> tiling(domino)"
  apply (rule notI)
  apply (drule tiling_domino_0_1)
  apply (erule_tac x = "|A|" for A in eq_lt_E)
  apply (subgoal_tac "t \<in> tiling (domino)")
   prefer 2 (*Requires a small simpset that won't move the succ applications*)
   apply (simp only: nat_succI add_type dominoes_tile_matrix)
  apply (simp add: evnodd_Diff mod2_add_self mod2_succ_succ
    tiling_domino_0_1 [symmetric])
  apply (rule lt_trans)
   apply (rule Finite_imp_cardinal_Diff,
     simp add: tiling_domino_Finite Finite_evnodd Finite_Diff,
     simp add: evnodd_iff nat_0_le [THEN ltD] mod2_add_self)+
  done

end


subsection \<open> Verification of Insertion Sort (with Local Variables) \<close>

theory insertion_sort
  imports "UTP.utp" "HOL-Library.Permutation"
begin recall_syntax

utp_lit_vars

alphabet global =
  arr :: "int list"

declare global.splits [alpha_splits del]

alphabet local = global +
  i   :: nat
  j   :: nat

declare global.splits [alpha_splits]

abbreviation lv :: "<global, _> \<Longleftrightarrow> local" where
"lv \<equiv> \<lparr> view = (global.base\<^sub>L :: (global \<Longrightarrow> local)), coview = global.more\<^sub>L \<rparr>"

lemma sym_lens_lv [simp]: "sym_lens lv"
  by (rule sym_lens.intro, simp_all)

abbreviation "I xs \<equiv> U(0 < i \<and> i < length arr \<and> j \<le> i \<and>
      sorted(nths arr {0..<j}) \<and> sorted(nths arr {j..i}) \<and>
      (0<j \<and> j<i  \<Rightarrow> arr!(j-1) \<le> arr!(j+1)) \<and>
      perm arr \<guillemotleft>xs\<guillemotright>)"

definition insert_elem :: "int list \<Rightarrow> local hrel" where
"insert_elem xs =
  while (0 < j \<and> arr!j < arr!(j-1)) invr @(I xs)
  do
    (arr[j-1], arr[j]) := (arr!j, arr!(j-1)) ;; j := j - 1
  od"

abbreviation insertion_sort :: "int list \<Rightarrow> global hrel" where
"insertion_sort xs \<equiv>
  arr := xs ;;
  open\<^bsub>lv\<^esub> ;;
  (i := 1 ;;
  while (i < length arr)
  invr 0 < i \<and> i \<le> length arr \<and> sorted(nths arr {0..i-1}) \<and> perm arr xs
  do
    j := i ;; insert_elem xs ;; i := i + 1
  od) ;;
  close\<^bsub>lv\<^esub>"

lemma insertion_sort_Nil: "insertion_sort [] = arr := []"
  apply (simp add: seqr_assoc[THEN sym] block_assign_open)
  apply (simp add: while_inv_def seqr_assoc)
  apply (subst while_unfold)
  apply (rel_auto)
  done

lemma insert_elem_correct: "
    \<^bold>{0 < i \<and> i < length arr \<and> j = i \<and> sorted(nths arr {0..i-1}) \<and> perm arr xs\<^bold>}
    insert_elem xs
    \<^bold>{0 < i \<and> i < length arr \<and> sorted(nths arr {0..i}) \<and> perm arr xs\<^bold>}"
proof -
  show ?thesis
  apply (simp add: insert_elem_def)
  apply (rule while_invr_hoare_r)
    apply (hoare_split)
    apply (rel_auto'; simp_all add: list_augment_as_update)
   apply (metis diff_le_self lessThan_iff linorder_not_less nths_atLeastLessThan_0_take nths_list_update_out nths_upt_eq_take order_less_irrefl sorted_nths_atLeastLessThan_0)
          apply (simp add: nths_uptoLessThan nths_single)
  apply (meson diff_le_self le_less_trans perm.trans perm_swap)
       apply (rename_tac arr i)
  apply (smt Suc_pred diff_Suc_Suc diff_le_self diff_less diff_zero le_less_trans less_imp_le_nat nths_upt_length nths_upt_nth sorted_iff_nth_mono zero_less_Suc)
  apply (metis atLeastLessThan_iff diff_le_self le_less le_less_trans less_irrefl nths_list_update_out sorted_nths_atLeastLessThan_0)
  apply (simp add: sorted_iff_nth_mono_less nths_upt_le_length nths_upt_le_nth)
      apply (auto)[1]
  apply (rename_tac arr i j m n)
     apply (case_tac "m>1")
      apply (simp)
      apply (drule_tac x="m-1" in spec) back
  apply (drule_tac x="n-1" in spec) back
      apply (simp)
     apply (simp)
     apply (subgoal_tac "m\<in>{0,1}")
      apply (case_tac "n>1")
  defer (* apply (smt Nat.add_diff_assoc2 Nat.diff_diff_right Suc_pred diff_Suc_Suc diff_commute diff_diff_cancel gr0I lessI less_nat_zero_code nat_le_linear nat_neq_iff zero_less_diff) *)
       apply (simp)
       apply (subgoal_tac "n=1")
  apply (simp)
       apply linarith
  apply (metis One_nat_def insert_iff less_one linorder_neqE_nat)
  apply (smt diff_le_self le_less_trans mset_eq_perm mset_swap)
  apply (rename_tac arr i j)
    apply (subgoal_tac " (nths arr {0..<j}) ! (j - Suc (Suc 0)) \<le> (nths arr {0..<j}) ! (j - Suc 0)")
         apply (simp add: nths_upt_nth)
    apply (rule sorted_nth_mono)
            apply (simp)
  apply linarith
  apply (metis Suc_le_lessD Suc_pred diff_zero eq_imp_le le_less_trans less_imp_le_nat nths_upt_length)
    apply (rel_auto')
  apply (simp add: nths_atLeastAtMost_0_take nths_atLeastLessThan_0_take)
  apply (simp add: nths_single)
  using neq0_conv apply blast
  apply (smt Suc_diff_le Suc_leI add.commute add.left_neutral atLeastLessThanSuc_atLeastAtMost diff_Suc_1 diff_Suc_less diff_is_0_eq' diff_zero le_add1 le_neq_implies_less less_imp_Suc_add less_imp_le_nat nths_upt_le_append_split nths_upt_le_nth nths_upt_length sorted_append_middle zero_less_one)
    apply (rename_tac arr i j)
  apply (subgoal_tac "sorted (nths arr {0..<j} @ nths arr {j..i})")
      apply (simp add: nths_upt_le_append_split)
     apply (simp add: sorted_append_middle)
  apply (auto)
     apply (simp add: nths_upt_length nths_upt_nth nths_upt_le_nth)
     apply (simp add: atLeast0LessThan)
   apply (drule_tac x="0" in spec) back
   apply (drule_tac x="n-1" in spec) back
   apply (simp)
  apply (subgoal_tac "arr ! Suc j \<le> arr ! (n + j - Suc 0)")
  apply (simp)
  apply (drule_tac x="1" in spec) back
  apply (drule_tac x="n-1" in spec) back
  apply (simp)
  by (metis (no_types, lifting) Nat.add_diff_assoc Nat.add_diff_assoc2 One_nat_def Suc_lessD Suc_lessI Suc_less_eq Suc_pred le_SucI less_imp_le_nat plus_1_eq_Suc) qed

lemma insertion_sort_correct:
  "\<^bold>{true\<^bold>} insertion_sort xs \<^bold>{sorted(arr) \<and> perm arr xs\<^bold>}"
proof -
  show ?thesis
proof (cases "xs = []")
  case True
  thus ?thesis
    by (simp add: insertion_sort_Nil, rel_auto)
next
  case False thus ?thesis
  apply (rule_tac hoare_safe) back
     apply (simp_all add: unrest)
  apply (rule hoare_block)
   apply (simp)
  apply (simp add: alpha)
  apply (rule hoare_safe) back
     apply (simp_all add: unrest)
  apply (rule while_invr_hoare_r)
  apply (rule hoare_safe) back back
       apply (simp_all add: unrest)
  apply (rule hoare_safe) back
    apply (rule hoare_r_conseq)
       apply (rule insert_elem_correct)
      apply (rel_auto')
  apply (simp add: Suc_leI)
    apply (simp add: nths_single)
   apply (simp add: nths_atLeastAtMost_0_take)
    done
qed qed

lemma "TRY(id\<^sub>s \<Turnstile> insertion_sort [4,3,7,1,12,8])"
  apply (unfold insert_elem_def)
  apply (sym_eval)
  apply (simp add: usubst unrest)
  oops

end


section \<open>Diophantine Equations\<close>

theory Parametric_Polynomials
  imports Main
  abbrevs ++ = "\<^bold>+" and
          -- = "\<^bold>-" and
          ** = "\<^bold>*" and
          00 = "\<^bold>0" and
          11 = "\<^bold>1"
begin

subsection \<open>Parametric Polynomials\<close>

text \<open>This section defines parametric polynomials and builds up the infrastructure to later prove
      that a given predicate or relation is Diophantine. The formalization follows
      \<^cite>\<open>"h10lecturenotes"\<close>.\<close>

type_synonym assignment = "nat \<Rightarrow> nat"

text \<open>Definition of parametric polynomials with natural number coefficients and their evaluation
      function\<close>

datatype ppolynomial =
    Const nat |
    Param nat |
    Var   nat |
    Sum  ppolynomial ppolynomial (infixl "\<^bold>+" 65) |
    NatDiff ppolynomial ppolynomial (infixl "\<^bold>-" 65) |
    Prod ppolynomial ppolynomial (infixl "\<^bold>*" 70)

fun ppeval :: "ppolynomial \<Rightarrow> assignment \<Rightarrow> assignment \<Rightarrow> nat"  where
    "ppeval (Const c) p v = c" |
    "ppeval (Param x) p v = p x" |
    "ppeval (Var x) p v = v x" |
    "ppeval (D1 \<^bold>+ D2) p v = (ppeval D1 p v) + (ppeval D2 p v)" |
    (* The next line lifts subtraction of type "nat \<Rightarrow> nat \<Rightarrow> nat" *)
    "ppeval (D1 \<^bold>- D2) p v = (ppeval D1 p v) - (ppeval D2 p v)" |
    "ppeval (D1 \<^bold>* D2) p v = (ppeval D1 p v) * (ppeval D2 p v)"

definition Sq_pp ("_ \<^bold>^\<^bold>2" [99] 75) where "Sq_pp P = P \<^bold>* P"

definition is_dioph_set :: "nat set \<Rightarrow> bool" where
    "is_dioph_set A = (\<exists>P1 P2::ppolynomial. \<forall>a. (a \<in> A)
                                            \<longleftrightarrow> (\<exists>v. ppeval P1 (\<lambda>x. a) v = ppeval P2 (\<lambda>x. a) v))"

datatype polynomial =
    Const nat |
    Param nat |
    Sum  polynomial polynomial (infixl "[+]" 65) |
    NatDiff polynomial polynomial (infixl "[-]" 65) |
    Prod polynomial polynomial (infixl "[*]" 70)

fun peval :: "polynomial \<Rightarrow> assignment \<Rightarrow> nat"  where
    "peval (Const c) p = c" |
    "peval (Param x) p = p x" |
    "peval (Sum D1 D2) p = (peval D1 p) + (peval D2 p)" |
    (* The next line lifts subtraction of type "nat \<Rightarrow> nat \<Rightarrow> nat" *)
    "peval (NatDiff D1 D2) p = (peval D1 p) - (peval D2 p)" |
    "peval (Prod D1 D2) p = (peval D1 p) * (peval D2 p)"

definition sq_p :: "polynomial \<Rightarrow> polynomial" ("_ [^2]" [99] 75) where "sq_p P = P [*] P"

definition zero_p :: "polynomial" ("\<^bold>0") where "zero_p = Const 0"
definition one_p :: "polynomial" ("\<^bold>1") where "one_p = Const 1"

lemma sq_p_eval: "peval (P[^2]) p = (peval P p)^2"
  unfolding sq_p_def by (simp add: power2_eq_square)

fun convert :: "polynomial \<Rightarrow> ppolynomial"  where
    "convert (Const c) = (ppolynomial.Const c)" |
    "convert (Param x) = (ppolynomial.Param x)" |
    "convert (D1 [+] D2) = (convert D1) \<^bold>+ (convert D2)" |
    "convert (D1 [-] D2) = (convert D1) \<^bold>- (convert D2)" |
    "convert (D1 [*] D2) = (convert D1) \<^bold>* (convert D2)"

lemma convert_eval: "peval P a = ppeval (convert P) a v" (* implicit for all v *)
  by (induction P, auto)

definition list_eval :: "polynomial list \<Rightarrow> assignment \<Rightarrow> (nat \<Rightarrow> nat)" where
    "list_eval PL a = nth (map (\<lambda>x. peval x a) PL)"

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_list_PairOdds
imports "../../Test_Base"
begin

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

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

fun pairs :: "'t list => (('t, 't) pair) list" where
"pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((map
       (% (x :: ('a, 'a) pair) => (case x of pair2 y z => z))
       (pairs xs)) =
      (odds xs))"
  oops

end


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

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

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

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

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

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (msorttd xs)) = (count x xs))"
  oops

end


chapter \<open>Homework 3\<close>
theory Homework3_2sol
imports
  Main
  "../IMP/AExp" (* Note: Replace this by your path to AExp *)
begin

  (*
    This file is intended to be viewed within the Isabelle/jEdit IDE.
    In a standard text-editor, it is pretty unreadable!
  *)

  (*
    HOMEWORK #3 PART II/II
    RELEASED: Tue, Aug 26 2017
    DUE:      Wed, Feb 4, 2017, 11:59pm

    To be submitted via canvas.
  *)

section \<open>General Hints\<close>
(*
  The best way to work on this homework is to fill in the missing gaps in this file.

  Try to go for simple function definitions, as simple definitions mean simple proofs!
  In particular, do not go for a more complicated definition only b/c it may be more efficient!

*)

section \<open>Absence of Stack-Overflows\<close>

text \<open>Model a stack machine that explicitly returns @{const \<open>None\<close>}
  on stack underflow, and @{term \<open>Some stk\<close>} otherwise.
\<close>

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1  :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
  "exec1 (LOADI n) _ stk  =  Some (n # stk)"
| "exec1 (LOAD x) s stk  =  Some (s(x) # stk)"
| "exec1 ADD _ (a#b#stk) = Some ((a+b)#stk)"
| "exec1 ADD _ _ = None"

(** The definition was straightforward, just inserting Some, and making the
  catch-all equation return None instead of undefined.
*)

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (
  case exec1 i s stk of    (** We first execute instruction i *)
    None \<Rightarrow> None           (** If this fails, we return None*)
  | Some stk \<Rightarrow> exec is s stk)" (** Otherwise, we call the new stack stk
      (hiding the binding of the old stack, which is intentional here, as
        it makes it impossible to accidentally access the old stack)
      and execute the remaining instructions on the new stack.
  *)

lemma exec_append[simp]:
  "exec (is1@is2) s stk = (case exec is1 s stk of None \<Rightarrow> None | Some stk \<Rightarrow> exec is2 s stk)"
apply(induction is1 arbitrary: stk)
apply (auto split: option.splits)
done

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

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

(** Actually, the correctness proof did not change at all for this sample solution --
  In some solutions, you might have to insert a split: option.splits.
*)

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 \<equiv> \<forall>x. Elem x A \<longrightarrow> Elem x B"

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

definition Sep :: "ZF \<Rightarrow> (ZF \<Rightarrow> bool) \<Rightarrow> ZF" where
  "Sep A p == (if (\<forall>x. Elem x A \<longrightarrow> Not (p x)) then Empty else
  (let z = (\<some> x. Elem x A & p x) in
   let f = \<lambda>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 \<and> 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 \<or> 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) = (\<exists>x. Elem x A \<and> f x = Some y)"
  by (auto simp add: Replacement_def Repl Sep)

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

definition Snd :: "ZF \<Rightarrow> ZF" where
  "Snd q == SOME y. \<exists>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 == \<exists>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) = (\<exists>a b. Elem a A \<and> Elem b B \<and> 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) = (\<exists>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) = (\<exists>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 == (\<forall>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 \<and> (\<forall>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> \<exists>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> \<exists>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 \<and> (\<forall>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 \<and> (\<forall>y. Elem y x \<longrightarrow> Not (Elem y ?Z))" ..
            then have x_induct:"\<forall>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: "\<exists>U. \<forall>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 "\<exists>U Q. P = (\<lambda> x. (Elem x U \<longrightarrow> Q x))"
  proof -
    from special_P obtain U where U: "\<forall>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 "\<exists>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. \<exists>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 (\<exists>f. isFun f \<and> Domain f = Nat \<and> (\<forall>N. Elem N Nat \<longrightarrow> Elem (f\<acute>(SucNat N)) (f\<acute>N)))"
proof -
  {
    fix f
    assume f: "isFun f \<and> Domain f = Nat \<and> (\<forall>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 "\<exists>x. Elem x ?r \<and> (\<forall>y. Elem y x \<longrightarrow> Not(Elem y ?r))"
      by (simp add: Regularity)
    then obtain x where x: "Elem x ?r \<and> (\<forall>y. Elem y x \<longrightarrow> Not(Elem y ?r))" ..
    then have "\<exists>N. Elem N (Domain f) & f\<acute>N = x"
      apply (rule_tac fun_range_witness)
      apply (simp_all add: f)
      done
    then have "\<exists>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 "\<exists>x. Elem x ?Z \<and> (\<forall>y. Elem y x \<longrightarrow> Not(Elem y ?Z))"
      by (simp add: Regularity)
    then obtain x where x:"Elem x ?Z \<and> (\<forall>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]: "\<forall>q. q \<le> 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 "\<exists>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> (\<exists>u. n \<le> u \<and> u \<le> n+m \<and> 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 "\<exists>x. (Elem x ?Z) \<and> (\<forall>y. Elem y x \<longrightarrow> Not (Elem y ?Z))"
      by (auto simp add: Regularity)
    then obtain x where x:"Elem x ?Z \<and> (\<forall>y. Elem y x \<longrightarrow> Not (Elem y ?Z))" ..
    then have "\<exists>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 \<and> 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 "\<exists>m. y = x + m & 0 < m")
    apply (auto intro: lemma_nat2Nat)
    apply (case_tac "y < x")
    apply (case_tac "\<exists>m. x = y + m & 0 < m")
    apply simp
    apply simp
    using th apply blast
    apply (case_tac "\<exists>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: "\<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 == \<forall>A. A \<noteq> Empty \<longrightarrow> (\<exists>x. Elem x A \<and> (\<forall>y. (y, x) \<in> R \<longrightarrow> Not (Elem y A)))"

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

definition wfzf :: "(ZF * ZF) set \<Rightarrow> bool" where
  "wfzf R == regular R \<and> 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) = (\<exists>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) = (\<exists>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 "\<exists>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 "\<forall>x. P x" by auto
  }
  then show "(\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (\<forall>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\<^sup>+) 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\<^sup>+)"
  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\<^sup>+) 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> \<forall>x. Elem x (Ext_ZF_n R s n) \<longrightarrow> x \<in> (Ext (R\<^sup>+) 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\<^sup>+) 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 "\<exists>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\<^sup>+)"
  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