(*  Title:      ZF/upair.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge

Observe the order of dependence:
    Upair is defined in terms of Replace
    \<union> is defined in terms of Upair and \<Union>(similarly for Int)
    cons is defined in terms of Upair and Un
    Ordered pairs and descriptions are defined using cons ("set notation")
*)

section\<open>Unordered Pairs\<close>

theory upair
imports ZF
keywords "print_tcset" :: diag
begin

ML_file "Tools/typechk.ML"

lemma atomize_ball [symmetric, rulify]:
     "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
by (simp add: Ball_def atomize_all atomize_imp)

subsection\<open>Unordered Pairs: constant @{term Upair}\<close>

lemma Upair_iff [simp]: "c \<in> Upair(a,b) \<longleftrightarrow> (c=a | c=b)"
by (unfold Upair_def, blast)

lemma UpairI1: "a \<in> Upair(a,b)"
by simp

lemma UpairI2: "b \<in> Upair(a,b)"
by simp

lemma UpairE: "[| a \<in> Upair(b,c);  a=b ==> P;  a=c ==> P |] ==> P"
by (simp, blast)

subsection\<open>Rules for Binary Union, Defined via @{term Upair}\<close>

lemma Un_iff [simp]: "c \<in> A \<union> B \<longleftrightarrow> (c \<in> A | c \<in> B)"
apply (simp add: Un_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma UnI1: "c \<in> A ==> c \<in> A \<union> B"
by simp

lemma UnI2: "c \<in> B ==> c \<in> A \<union> B"
by simp

declare UnI1 [elim?]  UnI2 [elim?]

lemma UnE [elim!]: "[| c \<in> A \<union> B;  c \<in> A ==> P;  c \<in> B ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma UnE': "[| c \<in> A \<union> B;  c \<in> A ==> P;  [| c \<in> B;  c\<notin>A |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI [intro!]: "(c \<notin> B ==> c \<in> A) ==> c \<in> A \<union> B"
by (simp, blast)

subsection\<open>Rules for Binary Intersection, Defined via @{term Upair}\<close>

lemma Int_iff [simp]: "c \<in> A \<inter> B \<longleftrightarrow> (c \<in> A & c \<in> B)"
apply (unfold Int_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma IntI [intro!]: "[| c \<in> A;  c \<in> B |] ==> c \<in> A \<inter> B"
by simp

lemma IntD1: "c \<in> A \<inter> B ==> c \<in> A"
by simp

lemma IntD2: "c \<in> A \<inter> B ==> c \<in> B"
by simp

lemma IntE [elim!]: "[| c \<in> A \<inter> B;  [| c \<in> A; c \<in> B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for Set Difference, Defined via @{term Upair}\<close>

lemma Diff_iff [simp]: "c \<in> A-B \<longleftrightarrow> (c \<in> A & c\<notin>B)"
by (unfold Diff_def, blast)

lemma DiffI [intro!]: "[| c \<in> A;  c \<notin> B |] ==> c \<in> A - B"
by simp

lemma DiffD1: "c \<in> A - B ==> c \<in> A"
by simp

lemma DiffD2: "c \<in> A - B ==> c \<notin> B"
by simp

lemma DiffE [elim!]: "[| c \<in> A - B;  [| c \<in> A; c\<notin>B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for @{term cons}\<close>

lemma cons_iff [simp]: "a \<in> cons(b,A) \<longleftrightarrow> (a=b | a \<in> A)"
apply (unfold cons_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

(*risky as a typechecking rule, but solves otherwise unconstrained goals of
the form x \<in> ?A*)
lemma consI1 [simp,TC]: "a \<in> cons(a,B)"
by simp

lemma consI2: "a \<in> B ==> a \<in> cons(b,B)"
by simp

lemma consE [elim!]: "[| a \<in> cons(b,A);  a=b ==> P;  a \<in> A ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma consE':
    "[| a \<in> cons(b,A);  a=b ==> P;  [| a \<in> A;  a\<noteq>b |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule*)
lemma consCI [intro!]: "(a\<notin>B ==> a=b) ==> a \<in> cons(b,B)"
by (simp, blast)

lemma cons_not_0 [simp]: "cons(a,B) \<noteq> 0"
by (blast elim: equalityE)

lemmas cons_neq_0 = cons_not_0 [THEN notE]

declare cons_not_0 [THEN not_sym, simp]

subsection\<open>Singletons\<close>

lemma singleton_iff: "a \<in> {b} \<longleftrightarrow> a=b"
by simp

lemma singletonI [intro!]: "a \<in> {a}"
by (rule consI1)

lemmas singletonE = singleton_iff [THEN iffD1, elim_format, elim!]

subsection\<open>Descriptions\<close>

lemma the_equality [intro]:
    "[| P(a);  !!x. P(x) ==> x=a |] ==> (THE x. P(x)) = a"
apply (unfold the_def)
apply (fast dest: subst)
done

(* Only use this if you already know \<exists>!x. P(x) *)
lemma the_equality2: "[| \<exists>!x. P(x);  P(a) |] ==> (THE x. P(x)) = a"
by blast

lemma theI: "\<exists>!x. P(x) ==> P(THE x. P(x))"
apply (erule ex1E)
apply (subst the_equality)
apply (blast+)
done

(*No congruence rule is necessary: if @{term"\<forall>y.P(y)\<longleftrightarrow>Q(y)"} then
  @{term "THE x.P(x)"}  rewrites to @{term "THE x.Q(x)"} *)

(*If it's "undefined", it's zero!*)
lemma the_0: "~ (\<exists>!x. P(x)) ==> (THE x. P(x))=0"
apply (unfold the_def)
apply (blast elim!: ReplaceE)
done

(*Easier to apply than theI: conclusion has only one occurrence of P*)
lemma theI2:
    assumes p1: "~ Q(0) ==> \<exists>!x. P(x)"
        and p2: "!!x. P(x) ==> Q(x)"
    shows "Q(THE x. P(x))"
apply (rule classical)
apply (rule p2)
apply (rule theI)
apply (rule classical)
apply (rule p1)
apply (erule the_0 [THEN subst], assumption)
done

lemma the_eq_trivial [simp]: "(THE x. x = a) = a"
by blast

lemma the_eq_trivial2 [simp]: "(THE x. a = x) = a"
by blast

subsection\<open>Conditional Terms: \<open>if-then-else\<close>\<close>

lemma if_true [simp]: "(if True then a else b) = a"
by (unfold if_def, blast)

lemma if_false [simp]: "(if False then a else b) = b"
by (unfold if_def, blast)

(*Never use with case splitting, or if P is known to be true or false*)
lemma if_cong:
    "[| P\<longleftrightarrow>Q;  Q ==> a=c;  ~Q ==> b=d |]
     ==> (if P then a else b) = (if Q then c else d)"
by (simp add: if_def cong add: conj_cong)

(*Prevents simplification of x and y \<in> faster and allows the execution
  of functional programs. NOW THE DEFAULT.*)
lemma if_weak_cong: "P\<longleftrightarrow>Q ==> (if P then x else y) = (if Q then x else y)"
by simp

(*Not needed for rewriting, since P would rewrite to True anyway*)
lemma if_P: "P ==> (if P then a else b) = a"
by (unfold if_def, blast)

(*Not needed for rewriting, since P would rewrite to False anyway*)
lemma if_not_P: "~P ==> (if P then a else b) = b"
by (unfold if_def, blast)

lemma split_if [split]:
     "P(if Q then x else y) \<longleftrightarrow> ((Q \<longrightarrow> P(x)) & (~Q \<longrightarrow> P(y)))"
by (case_tac Q, simp_all)

(** Rewrite rules for boolean case-splitting: faster than split_if [split]
**)

lemmas split_if_eq1 = split_if [of "%x. x = b"] for b
lemmas split_if_eq2 = split_if [of "%x. a = x"] for x

lemmas split_if_mem1 = split_if [of "%x. x \<in> b"] for b
lemmas split_if_mem2 = split_if [of "%x. a \<in> x"] for x

lemmas split_ifs = split_if_eq1 split_if_eq2 split_if_mem1 split_if_mem2

(*Logically equivalent to split_if_mem2*)
lemma if_iff: "a: (if P then x else y) \<longleftrightarrow> P & a \<in> x | ~P & a \<in> y"
by simp

lemma if_type [TC]:
    "[| P ==> a \<in> A;  ~P ==> b \<in> A |] ==> (if P then a else b): A"
by simp

(** Splitting IFs in the assumptions **)

lemma split_if_asm: "P(if Q then x else y) \<longleftrightarrow> (~((Q & ~P(x)) | (~Q & ~P(y))))"
by simp

lemmas if_splits = split_if split_if_asm

subsection\<open>Consequences of Foundation\<close>

(*was called mem_anti_sym*)
lemma mem_asym: "[| a \<in> b;  ~P ==> b \<in> a |] ==> P"
apply (rule classical)
apply (rule_tac A1 = "{a,b}" in foundation [THEN disjE])
apply (blast elim!: equalityE)+
done

(*was called mem_anti_refl*)
lemma mem_irrefl: "a \<in> a ==> P"
by (blast intro: mem_asym)

(*mem_irrefl should NOT be added to default databases:
      it would be tried on most goals, making proofs slower!*)

lemma mem_not_refl: "a \<notin> a"
apply (rule notI)
apply (erule mem_irrefl)
done

(*Good for proving inequalities by rewriting*)
lemma mem_imp_not_eq: "a \<in> A ==> a \<noteq> A"
by (blast elim!: mem_irrefl)

lemma eq_imp_not_mem: "a=A ==> a \<notin> A"
by (blast intro: elim: mem_irrefl)

subsection\<open>Rules for Successor\<close>

lemma succ_iff: "i \<in> succ(j) \<longleftrightarrow> i=j | i \<in> j"
by (unfold succ_def, blast)

lemma succI1 [simp]: "i \<in> succ(i)"
by (simp add: succ_iff)

lemma succI2: "i \<in> j ==> i \<in> succ(j)"
by (simp add: succ_iff)

lemma succE [elim!]:
    "[| i \<in> succ(j);  i=j ==> P;  i \<in> j ==> P |] ==> P"
apply (simp add: succ_iff, blast)
done

(*Classical introduction rule*)
lemma succCI [intro!]: "(i\<notin>j ==> i=j) ==> i \<in> succ(j)"
by (simp add: succ_iff, blast)

lemma succ_not_0 [simp]: "succ(n) \<noteq> 0"
by (blast elim!: equalityE)

lemmas succ_neq_0 = succ_not_0 [THEN notE, elim!]

declare succ_not_0 [THEN not_sym, simp]
declare sym [THEN succ_neq_0, elim!]

(* @{term"succ(c) \<subseteq> B ==> c \<in> B"} *)
lemmas succ_subsetD = succI1 [THEN [2] subsetD]

(* @{term"succ(b) \<noteq> b"} *)
lemmas succ_neq_self = succI1 [THEN mem_imp_not_eq, THEN not_sym]

lemma succ_inject_iff [simp]: "succ(m) = succ(n) \<longleftrightarrow> m=n"
by (blast elim: mem_asym elim!: equalityE)

lemmas succ_inject = succ_inject_iff [THEN iffD1, dest!]

subsection\<open>Miniscoping of the Bounded Universal Quantifier\<close>

lemma ball_simps1:
     "(\<forall>x\<in>A. P(x) & Q)   \<longleftrightarrow> (\<forall>x\<in>A. P(x)) & (A=0 | Q)"
     "(\<forall>x\<in>A. P(x) | Q)   \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) | Q)"
     "(\<forall>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x\<in>A. P(x))) \<longleftrightarrow> (\<exists>x\<in>A. ~P(x))"
     "(\<forall>x\<in>0.P(x)) \<longleftrightarrow> True"
     "(\<forall>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) & (\<forall>x\<in>i. P(x))"
     "(\<forall>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) & (\<forall>x\<in>B. P(x))"
     "(\<forall>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<forall>y\<in>A. P(f(y)))"
     "(\<forall>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P(x))"
by blast+

lemma ball_simps2:
     "(\<forall>x\<in>A. P & Q(x))   \<longleftrightarrow> (A=0 | P) & (\<forall>x\<in>A. Q(x))"
     "(\<forall>x\<in>A. P | Q(x))   \<longleftrightarrow> (P | (\<forall>x\<in>A. Q(x)))"
     "(\<forall>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x\<in>A. Q(x)))"
by blast+

lemma ball_simps3:
     "(\<forall>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<forall>x\<in>A. Q(x) \<longrightarrow> P(x))"
by blast+

lemmas ball_simps [simp] = ball_simps1 ball_simps2 ball_simps3

lemma ball_conj_distrib:
    "(\<forall>x\<in>A. P(x) & Q(x)) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) & (\<forall>x\<in>A. Q(x)))"
by blast

subsection\<open>Miniscoping of the Bounded Existential Quantifier\<close>

lemma bex_simps1:
     "(\<exists>x\<in>A. P(x) & Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) & Q)"
     "(\<exists>x\<in>A. P(x) | Q) \<longleftrightarrow> (\<exists>x\<in>A. P(x)) | (A\<noteq>0 & Q)"
     "(\<exists>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) \<longrightarrow> (A\<noteq>0 & Q))"
     "(\<exists>x\<in>0.P(x)) \<longleftrightarrow> False"
     "(\<exists>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) | (\<exists>x\<in>i. P(x))"
     "(\<exists>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) | (\<exists>x\<in>B. P(x))"
     "(\<exists>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<exists>y\<in>A. P(f(y)))"
     "(\<exists>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y.  P(x))"
     "(~(\<exists>x\<in>A. P(x))) \<longleftrightarrow> (\<forall>x\<in>A. ~P(x))"
by blast+

lemma bex_simps2:
     "(\<exists>x\<in>A. P & Q(x)) \<longleftrightarrow> (P & (\<exists>x\<in>A. Q(x)))"
     "(\<exists>x\<in>A. P | Q(x)) \<longleftrightarrow> (A\<noteq>0 & P) | (\<exists>x\<in>A. Q(x))"
     "(\<exists>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> ((A=0 | P) \<longrightarrow> (\<exists>x\<in>A. Q(x)))"
by blast+

lemma bex_simps3:
     "(\<exists>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<exists>x\<in>A. Q(x) & P(x))"
by blast

lemmas bex_simps [simp] = bex_simps1 bex_simps2 bex_simps3

lemma bex_disj_distrib:
    "(\<exists>x\<in>A. P(x) | Q(x)) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) | (\<exists>x\<in>A. Q(x)))"
by blast

(** One-point rule for bounded quantifiers: see HOL/Set.ML **)

lemma bex_triv_one_point1 [simp]: "(\<exists>x\<in>A. x=a) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_triv_one_point2 [simp]: "(\<exists>x\<in>A. a=x) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_one_point1 [simp]: "(\<exists>x\<in>A. x=a & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma bex_one_point2 [simp]: "(\<exists>x\<in>A. a=x & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma ball_one_point1 [simp]: "(\<forall>x\<in>A. x=a \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

lemma ball_one_point2 [simp]: "(\<forall>x\<in>A. a=x \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

subsection\<open>Miniscoping of the Replacement Operator\<close>

text\<open>These cover both @{term Replace} and @{term Collect}\<close>
lemma Rep_simps [simp]:
     "{x. y \<in> 0, R(x,y)} = 0"
     "{x \<in> 0. P(x)} = 0"
     "{x \<in> A. Q} = (if Q then A else 0)"
     "RepFun(0,f) = 0"
     "RepFun(succ(i),f) = cons(f(i), RepFun(i,f))"
     "RepFun(cons(a,B),f) = cons(f(a), RepFun(B,f))"
by (simp_all, blast+)

subsection\<open>Miniscoping of Unions\<close>

lemma UN_simps1:
     "(\<Union>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<union> B')   = (if C=0 then 0 else (\<Union>x\<in>C. A(x)) \<union> B')"
     "(\<Union>x\<in>C. A' \<union> B(x))   = (if C=0 then 0 else A' \<union> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<inter> B')  = ((\<Union>x\<in>C. A(x)) \<inter> B')"
     "(\<Union>x\<in>C. A' \<inter> B(x))  = (A' \<inter> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) - B')    = ((\<Union>x\<in>C. A(x)) - B')"
     "(\<Union>x\<in>C. A' - B(x))    = (if C=0 then 0 else A' - (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI )+
done

lemma UN_simps2:
      "(\<Union>x\<in>\<Union>(A). B(x)) = (\<Union>y\<in>A. \<Union>x\<in>y. B(x))"
      "(\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z\<in>B(x). C(z))"
      "(\<Union>x\<in>RepFun(A,f). B(x))     = (\<Union>a\<in>A. B(f(a)))"
by blast+

lemmas UN_simps [simp] = UN_simps1 UN_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma UN_extend_simps1:
     "(\<Union>x\<in>C. A(x)) \<union> B   = (if C=0 then B else (\<Union>x\<in>C. A(x) \<union> B))"
     "((\<Union>x\<in>C. A(x)) \<inter> B) = (\<Union>x\<in>C. A(x) \<inter> B)"
     "((\<Union>x\<in>C. A(x)) - B) = (\<Union>x\<in>C. A(x) - B)"
apply simp_all
apply blast+
done

lemma UN_extend_simps2:
     "cons(a, \<Union>x\<in>C. B(x)) = (if C=0 then {a} else (\<Union>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Union>x\<in>C. A \<union> B(x)))"
     "(A \<inter> (\<Union>x\<in>C. B(x))) = (\<Union>x\<in>C. A \<inter> B(x))"
     "A - (\<Inter>x\<in>C. B(x))    = (if C=0 then A else (\<Union>x\<in>C. A - B(x)))"
     "(\<Union>y\<in>A. \<Union>x\<in>y. B(x)) = (\<Union>x\<in>\<Union>(A). B(x))"
     "(\<Union>a\<in>A. B(f(a))) = (\<Union>x\<in>RepFun(A,f). B(x))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemma UN_UN_extend:
     "(\<Union>x\<in>A. \<Union>z\<in>B(x). C(z)) = (\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z))"
by blast

lemmas UN_extend_simps = UN_extend_simps1 UN_extend_simps2 UN_UN_extend

subsection\<open>Miniscoping of Intersections\<close>

lemma INT_simps1:
     "(\<Inter>x\<in>C. A(x) \<inter> B) = (\<Inter>x\<in>C. A(x)) \<inter> B"
     "(\<Inter>x\<in>C. A(x) - B)   = (\<Inter>x\<in>C. A(x)) - B"
     "(\<Inter>x\<in>C. A(x) \<union> B)  = (if C=0 then 0 else (\<Inter>x\<in>C. A(x)) \<union> B)"
by (simp_all add: Inter_def, blast+)

lemma INT_simps2:
     "(\<Inter>x\<in>C. A \<inter> B(x)) = A \<inter> (\<Inter>x\<in>C. B(x))"
     "(\<Inter>x\<in>C. A - B(x))   = (if C=0 then 0 else A - (\<Union>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Inter>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. A \<union> B(x))  = (if C=0 then 0 else A \<union> (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_simps [simp] = INT_simps1 INT_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma INT_extend_simps1:
     "(\<Inter>x\<in>C. A(x)) \<inter> B = (\<Inter>x\<in>C. A(x) \<inter> B)"
     "(\<Inter>x\<in>C. A(x)) - B = (\<Inter>x\<in>C. A(x) - B)"
     "(\<Inter>x\<in>C. A(x)) \<union> B  = (if C=0 then B else (\<Inter>x\<in>C. A(x) \<union> B))"
apply (simp_all add: Inter_def, blast+)
done

lemma INT_extend_simps2:
     "A \<inter> (\<Inter>x\<in>C. B(x)) = (\<Inter>x\<in>C. A \<inter> B(x))"
     "A - (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Inter>x\<in>C. A - B(x)))"
     "cons(a, \<Inter>x\<in>C. B(x)) = (if C=0 then {a} else (\<Inter>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Inter>x\<in>C. B(x))  = (if C=0 then A else (\<Inter>x\<in>C. A \<union> B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_extend_simps = INT_extend_simps1 INT_extend_simps2

subsection\<open>Other simprules\<close>

(*** Miniscoping: pushing in big Unions, Intersections, quantifiers, etc. ***)

lemma misc_simps [simp]:
     "0 \<union> A = A"
     "A \<union> 0 = A"
     "0 \<inter> A = 0"
     "A \<inter> 0 = 0"
     "0 - A = 0"
     "A - 0 = A"
     "\<Union>(0) = 0"
     "\<Union>(cons(b,A)) = b \<union> \<Union>(A)"
     "\<Inter>({b}) = b"
by blast+

end


(*  Title       : HOL/Hyperreal/StarDef.thy
    Author      : Jacques D. Fleuriot and Brian Huffman
*)

section {* Construction of Star Types Using Ultrafilters *}

theory StarDef
imports Filter
begin

subsection {* A Free Ultrafilter over the Naturals *}

definition
  FreeUltrafilterNat :: "nat set set"  ("\<U>") where
  "\<U> = (SOME U. freeultrafilter U)"

lemma freeultrafilter_FreeUltrafilterNat: "freeultrafilter \<U>"
apply (unfold FreeUltrafilterNat_def)
apply (rule someI_ex)
apply (rule freeultrafilter_Ex)
apply (rule infinite_UNIV_nat)
done

interpretation FreeUltrafilterNat: freeultrafilter FreeUltrafilterNat
by (rule freeultrafilter_FreeUltrafilterNat)

text {* This rule takes the place of the old ultra tactic *}

lemma ultra:
  "\<lbrakk>{n. P n} \<in> \<U>; {n. P n \<longrightarrow> Q n} \<in> \<U>\<rbrakk> \<Longrightarrow> {n. Q n} \<in> \<U>"
by (simp add: Collect_imp_eq
    FreeUltrafilterNat.Un_iff FreeUltrafilterNat.Compl_iff)

subsection {* Definition of @{text star} type constructor *}

definition
  starrel :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set" where
  "starrel = {(X,Y). {n. X n = Y n} \<in> \<U>}"

definition "star = (UNIV :: (nat \<Rightarrow> 'a) set) // starrel"

typedef 'a star = "star :: (nat \<Rightarrow> 'a) set set"
  unfolding star_def by (auto intro: quotientI)

definition
  star_n :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a star" where
  "star_n X = Abs_star (starrel `` {X})"

theorem star_cases [case_names star_n, cases type: star]:
  "(\<And>X. x = star_n X \<Longrightarrow> P) \<Longrightarrow> P"
by (cases x, unfold star_n_def star_def, erule quotientE, fast)

lemma all_star_eq: "(\<forall>x. P x) = (\<forall>X. P (star_n X))"
by (auto, rule_tac x=x in star_cases, simp)

lemma ex_star_eq: "(\<exists>x. P x) = (\<exists>X. P (star_n X))"
by (auto, rule_tac x=x in star_cases, auto)

text {* Proving that @{term starrel} is an equivalence relation *}

lemma starrel_iff [iff]: "((X,Y) \<in> starrel) = ({n. X n = Y n} \<in> \<U>)"
by (simp add: starrel_def)

lemma equiv_starrel: "equiv UNIV starrel"
proof (rule equivI)
  show "refl starrel" by (simp add: refl_on_def)
  show "sym starrel" by (simp add: sym_def eq_commute)
  show "trans starrel" by (auto intro: transI elim!: ultra)
qed

lemmas equiv_starrel_iff =
  eq_equiv_class_iff [OF equiv_starrel UNIV_I UNIV_I]

lemma starrel_in_star: "starrel``{x} \<in> star"
by (simp add: star_def quotientI)

lemma star_n_eq_iff: "(star_n X = star_n Y) = ({n. X n = Y n} \<in> \<U>)"
by (simp add: star_n_def Abs_star_inject starrel_in_star equiv_starrel_iff)

subsection {* Transfer principle *}

text {* This introduction rule starts each transfer proof. *}
lemma transfer_start:
  "P \<equiv> {n. Q} \<in> \<U> \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
by (subgoal_tac "P \<equiv> Q", simp, simp add: atomize_eq)

text {*Initialize transfer tactic.*}
ML_file "transfer.ML"

method_setup transfer = {*
  Attrib.thms >> (fn ths => fn ctxt =>
    SIMPLE_METHOD' (Transfer_Principle.transfer_tac ctxt ths))
*} "transfer principle"

text {* Transfer introduction rules. *}

lemma transfer_ex [transfer_intro]:
  "\<lbrakk>\<And>X. p (star_n X) \<equiv> {n. P n (X n)} \<in> \<U>\<rbrakk>
    \<Longrightarrow> \<exists>x::'a star. p x \<equiv> {n. \<exists>x. P n x} \<in> \<U>"
by (simp only: ex_star_eq FreeUltrafilterNat.Collect_ex)

lemma transfer_all [transfer_intro]:
  "\<lbrakk>\<And>X. p (star_n X) \<equiv> {n. P n (X n)} \<in> \<U>\<rbrakk>
    \<Longrightarrow> \<forall>x::'a star. p x \<equiv> {n. \<forall>x. P n x} \<in> \<U>"
by (simp only: all_star_eq FreeUltrafilterNat.Collect_all)

lemma transfer_not [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>\<rbrakk> \<Longrightarrow> \<not> p \<equiv> {n. \<not> P n} \<in> \<U>"
by (simp only: FreeUltrafilterNat.Collect_not)

lemma transfer_conj [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; q \<equiv> {n. Q n} \<in> \<U>\<rbrakk>
    \<Longrightarrow> p \<and> q \<equiv> {n. P n \<and> Q n} \<in> \<U>"
by (simp only: FreeUltrafilterNat.Collect_conj)

lemma transfer_disj [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; q \<equiv> {n. Q n} \<in> \<U>\<rbrakk>
    \<Longrightarrow> p \<or> q \<equiv> {n. P n \<or> Q n} \<in> \<U>"
by (simp only: FreeUltrafilterNat.Collect_disj)

lemma transfer_imp [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; q \<equiv> {n. Q n} \<in> \<U>\<rbrakk>
    \<Longrightarrow> p \<longrightarrow> q \<equiv> {n. P n \<longrightarrow> Q n} \<in> \<U>"
by (simp only: imp_conv_disj transfer_disj transfer_not)

lemma transfer_iff [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; q \<equiv> {n. Q n} \<in> \<U>\<rbrakk>
    \<Longrightarrow> p = q \<equiv> {n. P n = Q n} \<in> \<U>"
by (simp only: iff_conv_conj_imp transfer_conj transfer_imp)

lemma transfer_if_bool [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; x \<equiv> {n. X n} \<in> \<U>; y \<equiv> {n. Y n} \<in> \<U>\<rbrakk>
    \<Longrightarrow> (if p then x else y) \<equiv> {n. if P n then X n else Y n} \<in> \<U>"
by (simp only: if_bool_eq_conj transfer_conj transfer_imp transfer_not)

lemma transfer_eq [transfer_intro]:
  "\<lbrakk>x \<equiv> star_n X; y \<equiv> star_n Y\<rbrakk> \<Longrightarrow> x = y \<equiv> {n. X n = Y n} \<in> \<U>"
by (simp only: star_n_eq_iff)

lemma transfer_if [transfer_intro]:
  "\<lbrakk>p \<equiv> {n. P n} \<in> \<U>; x \<equiv> star_n X; y \<equiv> star_n Y\<rbrakk>
    \<Longrightarrow> (if p then x else y) \<equiv> star_n (\<lambda>n. if P n then X n else Y n)"
apply (rule eq_reflection)
apply (auto simp add: star_n_eq_iff transfer_not elim!: ultra)
done

lemma transfer_fun_eq [transfer_intro]:
  "\<lbrakk>\<And>X. f (star_n X) = g (star_n X)
    \<equiv> {n. F n (X n) = G n (X n)} \<in> \<U>\<rbrakk>
      \<Longrightarrow> f = g \<equiv> {n. F n = G n} \<in> \<U>"
by (simp only: fun_eq_iff transfer_all)

lemma transfer_star_n [transfer_intro]: "star_n X \<equiv> star_n (\<lambda>n. X n)"
by (rule reflexive)

lemma transfer_bool [transfer_intro]: "p \<equiv> {n. p} \<in> \<U>"
by (simp add: atomize_eq)

subsection {* Standard elements *}

definition
  star_of :: "'a \<Rightarrow> 'a star" where
  "star_of x == star_n (\<lambda>n. x)"

definition
  Standard :: "'a star set" where
  "Standard = range star_of"

text {* Transfer tactic should remove occurrences of @{term star_of} *}
setup {* Transfer_Principle.add_const @{const_name star_of} *}

declare star_of_def [transfer_intro]

lemma star_of_inject: "(star_of x = star_of y) = (x = y)"
by (transfer, rule refl)

lemma Standard_star_of [simp]: "star_of x \<in> Standard"
by (simp add: Standard_def)

subsection {* Internal functions *}

definition
  Ifun :: "('a \<Rightarrow> 'b) star \<Rightarrow> 'a star \<Rightarrow> 'b star" ("_ \<star> _" [300,301] 300) where
  "Ifun f \<equiv> \<lambda>x. Abs_star
       (\<Union>F\<in>Rep_star f. \<Union>X\<in>Rep_star x. starrel``{\<lambda>n. F n (X n)})"

lemma Ifun_congruent2:
  "congruent2 starrel starrel (\<lambda>F X. starrel``{\<lambda>n. F n (X n)})"
by (auto simp add: congruent2_def equiv_starrel_iff elim!: ultra)

lemma Ifun_star_n: "star_n F \<star> star_n X = star_n (\<lambda>n. F n (X n))"
by (simp add: Ifun_def star_n_def Abs_star_inverse starrel_in_star
    UN_equiv_class2 [OF equiv_starrel equiv_starrel Ifun_congruent2])

text {* Transfer tactic should remove occurrences of @{term Ifun} *}
setup {* Transfer_Principle.add_const @{const_name Ifun} *}

lemma transfer_Ifun [transfer_intro]:
  "\<lbrakk>f \<equiv> star_n F; x \<equiv> star_n X\<rbrakk> \<Longrightarrow> f \<star> x \<equiv> star_n (\<lambda>n. F n (X n))"
by (simp only: Ifun_star_n)

lemma Ifun_star_of [simp]: "star_of f \<star> star_of x = star_of (f x)"
by (transfer, rule refl)

lemma Standard_Ifun [simp]:
  "\<lbrakk>f \<in> Standard; x \<in> Standard\<rbrakk> \<Longrightarrow> f \<star> x \<in> Standard"
by (auto simp add: Standard_def)

text {* Nonstandard extensions of functions *}

definition
  starfun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a star \<Rightarrow> 'b star)"  ("*f* _" [80] 80) where
  "starfun f == \<lambda>x. star_of f \<star> x"

definition
  starfun2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a star \<Rightarrow> 'b star \<Rightarrow> 'c star)"
    ("*f2* _" [80] 80) where
  "starfun2 f == \<lambda>x y. star_of f \<star> x \<star> y"

declare starfun_def [transfer_unfold]
declare starfun2_def [transfer_unfold]

lemma starfun_star_n: "( *f* f) (star_n X) = star_n (\<lambda>n. f (X n))"
by (simp only: starfun_def star_of_def Ifun_star_n)

lemma starfun2_star_n:
  "( *f2* f) (star_n X) (star_n Y) = star_n (\<lambda>n. f (X n) (Y n))"
by (simp only: starfun2_def star_of_def Ifun_star_n)

lemma starfun_star_of [simp]: "( *f* f) (star_of x) = star_of (f x)"
by (transfer, rule refl)

lemma starfun2_star_of [simp]: "( *f2* f) (star_of x) = *f* f x"
by (transfer, rule refl)

lemma Standard_starfun [simp]: "x \<in> Standard \<Longrightarrow> starfun f x \<in> Standard"
by (simp add: starfun_def)

lemma Standard_starfun2 [simp]:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> starfun2 f x y \<in> Standard"
by (simp add: starfun2_def)

lemma Standard_starfun_iff:
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "(starfun f x \<in> Standard) = (x \<in> Standard)"
proof
  assume "x \<in> Standard"
  thus "starfun f x \<in> Standard" by simp
next
  have inj': "\<And>x y. starfun f x = starfun f y \<Longrightarrow> x = y"
    using inj by transfer
  assume "starfun f x \<in> Standard"
  then obtain b where b: "starfun f x = star_of b"
    unfolding Standard_def ..
  hence "\<exists>x. starfun f x = star_of b" ..
  hence "\<exists>a. f a = b" by transfer
  then obtain a where "f a = b" ..
  hence "starfun f (star_of a) = star_of b" by transfer
  with b have "starfun f x = starfun f (star_of a)" by simp
  hence "x = star_of a" by (rule inj')
  thus "x \<in> Standard"
    unfolding Standard_def by auto
qed

lemma Standard_starfun2_iff:
  assumes inj: "\<And>a b a' b'. f a b = f a' b' \<Longrightarrow> a = a' \<and> b = b'"
  shows "(starfun2 f x y \<in> Standard) = (x \<in> Standard \<and> y \<in> Standard)"
proof
  assume "x \<in> Standard \<and> y \<in> Standard"
  thus "starfun2 f x y \<in> Standard" by simp
next
  have inj': "\<And>x y z w. starfun2 f x y = starfun2 f z w \<Longrightarrow> x = z \<and> y = w"
    using inj by transfer
  assume "starfun2 f x y \<in> Standard"
  then obtain c where c: "starfun2 f x y = star_of c"
    unfolding Standard_def ..
  hence "\<exists>x y. starfun2 f x y = star_of c" by auto
  hence "\<exists>a b. f a b = c" by transfer
  then obtain a b where "f a b = c" by auto
  hence "starfun2 f (star_of a) (star_of b) = star_of c"
    by transfer
  with c have "starfun2 f x y = starfun2 f (star_of a) (star_of b)"
    by simp
  hence "x = star_of a \<and> y = star_of b"
    by (rule inj')
  thus "x \<in> Standard \<and> y \<in> Standard"
    unfolding Standard_def by auto
qed

subsection {* Internal predicates *}

definition unstar :: "bool star \<Rightarrow> bool" where
  "unstar b \<longleftrightarrow> b = star_of True"

lemma unstar_star_n: "unstar (star_n P) = ({n. P n} \<in> \<U>)"
by (simp add: unstar_def star_of_def star_n_eq_iff)

lemma unstar_star_of [simp]: "unstar (star_of p) = p"
by (simp add: unstar_def star_of_inject)

text {* Transfer tactic should remove occurrences of @{term unstar} *}
setup {* Transfer_Principle.add_const @{const_name unstar} *}

lemma transfer_unstar [transfer_intro]:
  "p \<equiv> star_n P \<Longrightarrow> unstar p \<equiv> {n. P n} \<in> \<U>"
by (simp only: unstar_star_n)

definition
  starP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> bool"  ("*p* _" [80] 80) where
  "*p* P = (\<lambda>x. unstar (star_of P \<star> x))"

definition
  starP2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> 'b star \<Rightarrow> bool"  ("*p2* _" [80] 80) where
  "*p2* P = (\<lambda>x y. unstar (star_of P \<star> x \<star> y))"

declare starP_def [transfer_unfold]
declare starP2_def [transfer_unfold]

lemma starP_star_n: "( *p* P) (star_n X) = ({n. P (X n)} \<in> \<U>)"
by (simp only: starP_def star_of_def Ifun_star_n unstar_star_n)

lemma starP2_star_n:
  "( *p2* P) (star_n X) (star_n Y) = ({n. P (X n) (Y n)} \<in> \<U>)"
by (simp only: starP2_def star_of_def Ifun_star_n unstar_star_n)

lemma starP_star_of [simp]: "( *p* P) (star_of x) = P x"
by (transfer, rule refl)

lemma starP2_star_of [simp]: "( *p2* P) (star_of x) = *p* P x"
by (transfer, rule refl)

subsection {* Internal sets *}

definition
  Iset :: "'a set star \<Rightarrow> 'a star set" where
  "Iset A = {x. ( *p2* op \<in>) x A}"

lemma Iset_star_n:
  "(star_n X \<in> Iset (star_n A)) = ({n. X n \<in> A n} \<in> \<U>)"
by (simp add: Iset_def starP2_star_n)

text {* Transfer tactic should remove occurrences of @{term Iset} *}
setup {* Transfer_Principle.add_const @{const_name Iset} *}

lemma transfer_mem [transfer_intro]:
  "\<lbrakk>x \<equiv> star_n X; a \<equiv> Iset (star_n A)\<rbrakk>
    \<Longrightarrow> x \<in> a \<equiv> {n. X n \<in> A n} \<in> \<U>"
by (simp only: Iset_star_n)

lemma transfer_Collect [transfer_intro]:
  "\<lbrakk>\<And>X. p (star_n X) \<equiv> {n. P n (X n)} \<in> \<U>\<rbrakk>
    \<Longrightarrow> Collect p \<equiv> Iset (star_n (\<lambda>n. Collect (P n)))"
by (simp add: atomize_eq set_eq_iff all_star_eq Iset_star_n)

lemma transfer_set_eq [transfer_intro]:
  "\<lbrakk>a \<equiv> Iset (star_n A); b \<equiv> Iset (star_n B)\<rbrakk>
    \<Longrightarrow> a = b \<equiv> {n. A n = B n} \<in> \<U>"
by (simp only: set_eq_iff transfer_all transfer_iff transfer_mem)

lemma transfer_ball [transfer_intro]:
  "\<lbrakk>a \<equiv> Iset (star_n A); \<And>X. p (star_n X) \<equiv> {n. P n (X n)} \<in> \<U>\<rbrakk>
    \<Longrightarrow> \<forall>x\<in>a. p x \<equiv> {n. \<forall>x\<in>A n. P n x} \<in> \<U>"
by (simp only: Ball_def transfer_all transfer_imp transfer_mem)

lemma transfer_bex [transfer_intro]:
  "\<lbrakk>a \<equiv> Iset (star_n A); \<And>X. p (star_n X) \<equiv> {n. P n (X n)} \<in> \<U>\<rbrakk>
    \<Longrightarrow> \<exists>x\<in>a. p x \<equiv> {n. \<exists>x\<in>A n. P n x} \<in> \<U>"
by (simp only: Bex_def transfer_ex transfer_conj transfer_mem)

lemma transfer_Iset [transfer_intro]:
  "\<lbrakk>a \<equiv> star_n A\<rbrakk> \<Longrightarrow> Iset a \<equiv> Iset (star_n (\<lambda>n. A n))"
by simp

text {* Nonstandard extensions of sets. *}

definition
  starset :: "'a set \<Rightarrow> 'a star set" ("*s* _" [80] 80) where
  "starset A = Iset (star_of A)"

declare starset_def [transfer_unfold]

lemma starset_mem: "(star_of x \<in> *s* A) = (x \<in> A)"
by (transfer, rule refl)

lemma starset_UNIV: "*s* (UNIV::'a set) = (UNIV::'a star set)"
by (transfer UNIV_def, rule refl)

lemma starset_empty: "*s* {} = {}"
by (transfer empty_def, rule refl)

lemma starset_insert: "*s* (insert x A) = insert (star_of x) ( *s* A)"
by (transfer insert_def Un_def, rule refl)

lemma starset_Un: "*s* (A \<union> B) = *s* A \<union> *s* B"
by (transfer Un_def, rule refl)

lemma starset_Int: "*s* (A \<inter> B) = *s* A \<inter> *s* B"
by (transfer Int_def, rule refl)

lemma starset_Compl: "*s* -A = -( *s* A)"
by (transfer Compl_eq, rule refl)

lemma starset_diff: "*s* (A - B) = *s* A - *s* B"
by (transfer set_diff_eq, rule refl)

lemma starset_image: "*s* (f ` A) = ( *f* f) ` ( *s* A)"
by (transfer image_def, rule refl)

lemma starset_vimage: "*s* (f -` A) = ( *f* f) -` ( *s* A)"
by (transfer vimage_def, rule refl)

lemma starset_subset: "( *s* A \<subseteq> *s* B) = (A \<subseteq> B)"
by (transfer subset_eq, rule refl)

lemma starset_eq: "( *s* A = *s* B) = (A = B)"
by (transfer, rule refl)

lemmas starset_simps [simp] =
  starset_mem     starset_UNIV
  starset_empty   starset_insert
  starset_Un      starset_Int
  starset_Compl   starset_diff
  starset_image   starset_vimage
  starset_subset  starset_eq

subsection {* Syntactic classes *}

instantiation star :: (zero) zero
begin

definition
  star_zero_def:    "0 \<equiv> star_of 0"

instance ..

end

instantiation star :: (one) one
begin

definition
  star_one_def:     "1 \<equiv> star_of 1"

instance ..

end

instantiation star :: (plus) plus
begin

definition
  star_add_def:     "(op +) \<equiv> *f2* (op +)"

instance ..

end

instantiation star :: (times) times
begin

definition
  star_mult_def:    "(op *) \<equiv> *f2* (op *)"

instance ..

end

instantiation star :: (uminus) uminus
begin

definition
  star_minus_def:   "uminus \<equiv> *f* uminus"

instance ..

end

instantiation star :: (minus) minus
begin

definition
  star_diff_def:    "(op -) \<equiv> *f2* (op -)"

instance ..

end

instantiation star :: (abs) abs
begin

definition
  star_abs_def:     "abs \<equiv> *f* abs"

instance ..

end

instantiation star :: (sgn) sgn
begin

definition
  star_sgn_def:     "sgn \<equiv> *f* sgn"

instance ..

end

instantiation star :: (inverse) inverse
begin

definition
  star_divide_def:  "(op /) \<equiv> *f2* (op /)"

definition
  star_inverse_def: "inverse \<equiv> *f* inverse"

instance ..

end

instance star :: (Rings.dvd) Rings.dvd ..

instantiation star :: (Divides.div) Divides.div
begin

definition
  star_div_def:     "(op div) \<equiv> *f2* (op div)"

definition
  star_mod_def:     "(op mod) \<equiv> *f2* (op mod)"

instance ..

end

instantiation star :: (ord) ord
begin

definition
  star_le_def:      "(op \<le>) \<equiv> *p2* (op \<le>)"

definition
  star_less_def:    "(op <) \<equiv> *p2* (op <)"

instance ..

end

lemmas star_class_defs [transfer_unfold] =
  star_zero_def     star_one_def
  star_add_def      star_diff_def     star_minus_def
  star_mult_def     star_divide_def   star_inverse_def
  star_le_def       star_less_def     star_abs_def       star_sgn_def
  star_div_def      star_mod_def

text {* Class operations preserve standard elements *}

lemma Standard_zero: "0 \<in> Standard"
by (simp add: star_zero_def)

lemma Standard_one: "1 \<in> Standard"
by (simp add: star_one_def)

lemma Standard_add: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x + y \<in> Standard"
by (simp add: star_add_def)

lemma Standard_diff: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x - y \<in> Standard"
by (simp add: star_diff_def)

lemma Standard_minus: "x \<in> Standard \<Longrightarrow> - x \<in> Standard"
by (simp add: star_minus_def)

lemma Standard_mult: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x * y \<in> Standard"
by (simp add: star_mult_def)

lemma Standard_divide: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x / y \<in> Standard"
by (simp add: star_divide_def)

lemma Standard_inverse: "x \<in> Standard \<Longrightarrow> inverse x \<in> Standard"
by (simp add: star_inverse_def)

lemma Standard_abs: "x \<in> Standard \<Longrightarrow> abs x \<in> Standard"
by (simp add: star_abs_def)

lemma Standard_div: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x div y \<in> Standard"
by (simp add: star_div_def)

lemma Standard_mod: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x mod y \<in> Standard"
by (simp add: star_mod_def)

lemmas Standard_simps [simp] =
  Standard_zero  Standard_one
  Standard_add  Standard_diff  Standard_minus
  Standard_mult  Standard_divide  Standard_inverse
  Standard_abs  Standard_div  Standard_mod

text {* @{term star_of} preserves class operations *}

lemma star_of_add: "star_of (x + y) = star_of x + star_of y"
by transfer (rule refl)

lemma star_of_diff: "star_of (x - y) = star_of x - star_of y"
by transfer (rule refl)

lemma star_of_minus: "star_of (-x) = - star_of x"
by transfer (rule refl)

lemma star_of_mult: "star_of (x * y) = star_of x * star_of y"
by transfer (rule refl)

lemma star_of_divide: "star_of (x / y) = star_of x / star_of y"
by transfer (rule refl)

lemma star_of_inverse: "star_of (inverse x) = inverse (star_of x)"
by transfer (rule refl)

lemma star_of_div: "star_of (x div y) = star_of x div star_of y"
by transfer (rule refl)

lemma star_of_mod: "star_of (x mod y) = star_of x mod star_of y"
by transfer (rule refl)

lemma star_of_abs: "star_of (abs x) = abs (star_of x)"
by transfer (rule refl)

text {* @{term star_of} preserves numerals *}

lemma star_of_zero: "star_of 0 = 0"
by transfer (rule refl)

lemma star_of_one: "star_of 1 = 1"
by transfer (rule refl)

text {* @{term star_of} preserves orderings *}

lemma star_of_less: "(star_of x < star_of y) = (x < y)"
by transfer (rule refl)

lemma star_of_le: "(star_of x \<le> star_of y) = (x \<le> y)"
by transfer (rule refl)

lemma star_of_eq: "(star_of x = star_of y) = (x = y)"
by transfer (rule refl)

text{*As above, for 0*}

lemmas star_of_0_less = star_of_less [of 0, simplified star_of_zero]
lemmas star_of_0_le   = star_of_le   [of 0, simplified star_of_zero]
lemmas star_of_0_eq   = star_of_eq   [of 0, simplified star_of_zero]

lemmas star_of_less_0 = star_of_less [of _ 0, simplified star_of_zero]
lemmas star_of_le_0   = star_of_le   [of _ 0, simplified star_of_zero]
lemmas star_of_eq_0   = star_of_eq   [of _ 0, simplified star_of_zero]

text{*As above, for 1*}

lemmas star_of_1_less = star_of_less [of 1, simplified star_of_one]
lemmas star_of_1_le   = star_of_le   [of 1, simplified star_of_one]
lemmas star_of_1_eq   = star_of_eq   [of 1, simplified star_of_one]

lemmas star_of_less_1 = star_of_less [of _ 1, simplified star_of_one]
lemmas star_of_le_1   = star_of_le   [of _ 1, simplified star_of_one]
lemmas star_of_eq_1   = star_of_eq   [of _ 1, simplified star_of_one]

lemmas star_of_simps [simp] =
  star_of_add     star_of_diff    star_of_minus
  star_of_mult    star_of_divide  star_of_inverse
  star_of_div     star_of_mod     star_of_abs
  star_of_zero    star_of_one
  star_of_less    star_of_le      star_of_eq
  star_of_0_less  star_of_0_le    star_of_0_eq
  star_of_less_0  star_of_le_0    star_of_eq_0
  star_of_1_less  star_of_1_le    star_of_1_eq
  star_of_less_1  star_of_le_1    star_of_eq_1

subsection {* Ordering and lattice classes *}

instance star :: (order) order
apply (intro_classes)
apply (transfer, rule less_le_not_le)
apply (transfer, rule order_refl)
apply (transfer, erule (1) order_trans)
apply (transfer, erule (1) order_antisym)
done

instantiation star :: (semilattice_inf) semilattice_inf
begin

definition
  star_inf_def [transfer_unfold]: "inf \<equiv> *f2* inf"

instance
  by default (transfer star_inf_def, auto)+

end

instantiation star :: (semilattice_sup) semilattice_sup
begin

definition
  star_sup_def [transfer_unfold]: "sup \<equiv> *f2* sup"

instance
  by default (transfer star_sup_def, auto)+

end

instance star :: (lattice) lattice ..

instance star :: (distrib_lattice) distrib_lattice
  by default (transfer, auto simp add: sup_inf_distrib1)

lemma Standard_inf [simp]:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> inf x y \<in> Standard"
by (simp add: star_inf_def)

lemma Standard_sup [simp]:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> sup x y \<in> Standard"
by (simp add: star_sup_def)

lemma star_of_inf [simp]: "star_of (inf x y) = inf (star_of x) (star_of y)"
by transfer (rule refl)

lemma star_of_sup [simp]: "star_of (sup x y) = sup (star_of x) (star_of y)"
by transfer (rule refl)

instance star :: (linorder) linorder
by (intro_classes, transfer, rule linorder_linear)

lemma star_max_def [transfer_unfold]: "max = *f2* max"
apply (rule ext, rule ext)
apply (unfold max_def, transfer, fold max_def)
apply (rule refl)
done

lemma star_min_def [transfer_unfold]: "min = *f2* min"
apply (rule ext, rule ext)
apply (unfold min_def, transfer, fold min_def)
apply (rule refl)
done

lemma Standard_max [simp]:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> max x y \<in> Standard"
by (simp add: star_max_def)

lemma Standard_min [simp]:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> min x y \<in> Standard"
by (simp add: star_min_def)

lemma star_of_max [simp]: "star_of (max x y) = max (star_of x) (star_of y)"
by transfer (rule refl)

lemma star_of_min [simp]: "star_of (min x y) = min (star_of x) (star_of y)"
by transfer (rule refl)

subsection {* Ordered group classes *}

instance star :: (semigroup_add) semigroup_add
by (intro_classes, transfer, rule add.assoc)

instance star :: (ab_semigroup_add) ab_semigroup_add
by (intro_classes, transfer, rule add.commute)

instance star :: (semigroup_mult) semigroup_mult
by (intro_classes, transfer, rule mult.assoc)

instance star :: (ab_semigroup_mult) ab_semigroup_mult
by (intro_classes, transfer, rule mult.commute)

instance star :: (comm_monoid_add) comm_monoid_add
by (intro_classes, transfer, rule comm_monoid_add_class.add_0)

instance star :: (monoid_mult) monoid_mult
apply (intro_classes)
apply (transfer, rule mult_1_left)
apply (transfer, rule mult_1_right)
done

instance star :: (comm_monoid_mult) comm_monoid_mult
by (intro_classes, transfer, rule mult_1)

instance star :: (cancel_semigroup_add) cancel_semigroup_add
apply (intro_classes)
apply (transfer, erule add_left_imp_eq)
apply (transfer, erule add_right_imp_eq)
done

instance star :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
by (intro_classes, transfer, rule add_imp_eq)

instance star :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance star :: (ab_group_add) ab_group_add
apply (intro_classes)
apply (transfer, rule left_minus)
apply (transfer, rule diff_conv_add_uminus)
done

instance star :: (ordered_ab_semigroup_add) ordered_ab_semigroup_add
by (intro_classes, transfer, rule add_left_mono)

instance star :: (ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..

instance star :: (ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
by (intro_classes, transfer, rule add_le_imp_le_left)

instance star :: (ordered_comm_monoid_add) ordered_comm_monoid_add ..
instance star :: (ordered_ab_group_add) ordered_ab_group_add ..

instance star :: (ordered_ab_group_add_abs) ordered_ab_group_add_abs
  by intro_classes (transfer,
    simp add: abs_ge_self abs_leI abs_triangle_ineq)+

instance star :: (linordered_cancel_ab_semigroup_add) linordered_cancel_ab_semigroup_add ..

subsection {* Ring and field classes *}

instance star :: (semiring) semiring
apply (intro_classes)
apply (transfer, rule distrib_right)
apply (transfer, rule distrib_left)
done

instance star :: (semiring_0) semiring_0
by intro_classes (transfer, simp)+

instance star :: (semiring_0_cancel) semiring_0_cancel ..

instance star :: (comm_semiring) comm_semiring
by (intro_classes, transfer, rule distrib_right)

instance star :: (comm_semiring_0) comm_semiring_0 ..
instance star :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

instance star :: (zero_neq_one) zero_neq_one
by (intro_classes, transfer, rule zero_neq_one)

instance star :: (semiring_1) semiring_1 ..
instance star :: (comm_semiring_1) comm_semiring_1 ..

instance star :: (no_zero_divisors) no_zero_divisors
by (intro_classes, transfer, rule no_zero_divisors)

instance star :: (semiring_1_cancel) semiring_1_cancel ..
instance star :: (comm_semiring_1_cancel) comm_semiring_1_cancel ..
instance star :: (ring) ring ..
instance star :: (comm_ring) comm_ring ..
instance star :: (ring_1) ring_1 ..
instance star :: (comm_ring_1) comm_ring_1 ..
instance star :: (ring_no_zero_divisors) ring_no_zero_divisors ..
instance star :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors ..
instance star :: (idom) idom ..

instance star :: (division_ring) division_ring
apply (intro_classes)
apply (transfer, erule left_inverse)
apply (transfer, erule right_inverse)
apply (transfer, fact divide_inverse)
done

instance star :: (division_ring_inverse_zero) division_ring_inverse_zero
by (intro_classes, transfer, rule inverse_zero)

instance star :: (field) field
apply (intro_classes)
apply (transfer, erule left_inverse)
apply (transfer, rule divide_inverse)
done

instance star :: (field_inverse_zero) field_inverse_zero
apply intro_classes
apply (rule inverse_zero)
done

instance star :: (ordered_semiring) ordered_semiring
apply (intro_classes)
apply (transfer, erule (1) mult_left_mono)
apply (transfer, erule (1) mult_right_mono)
done

instance star :: (ordered_cancel_semiring) ordered_cancel_semiring ..

instance star :: (linordered_semiring_strict) linordered_semiring_strict
apply (intro_classes)
apply (transfer, erule (1) mult_strict_left_mono)
apply (transfer, erule (1) mult_strict_right_mono)
done

instance star :: (ordered_comm_semiring) ordered_comm_semiring
by (intro_classes, transfer, rule mult_left_mono)

instance star :: (ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..

instance star :: (linordered_comm_semiring_strict) linordered_comm_semiring_strict
by (intro_classes, transfer, rule mult_strict_left_mono)

instance star :: (ordered_ring) ordered_ring ..
instance star :: (ordered_ring_abs) ordered_ring_abs
  by intro_classes  (transfer, rule abs_eq_mult)

instance star :: (abs_if) abs_if
by (intro_classes, transfer, rule abs_if)

instance star :: (sgn_if) sgn_if
by (intro_classes, transfer, rule sgn_if)

instance star :: (linordered_ring_strict) linordered_ring_strict ..
instance star :: (ordered_comm_ring) ordered_comm_ring ..

instance star :: (linordered_semidom) linordered_semidom
by (intro_classes, transfer, rule zero_less_one)

instance star :: (linordered_idom) linordered_idom ..
instance star :: (linordered_field) linordered_field ..
instance star :: (linordered_field_inverse_zero) linordered_field_inverse_zero ..

subsection {* Power *}

lemma star_power_def [transfer_unfold]:
  "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
proof (rule eq_reflection, rule ext, rule ext)
  fix n :: nat
  show "\<And>x::'a star. x ^ n = ( *f* (\<lambda>x. x ^ n)) x"
  proof (induct n)
    case 0
    have "\<And>x::'a star. ( *f* (\<lambda>x. 1)) x = 1"
      by transfer simp
    then show ?case by simp
  next
    case (Suc n)
    have "\<And>x::'a star. x * ( *f* (\<lambda>x\<Colon>'a. x ^ n)) x = ( *f* (\<lambda>x\<Colon>'a. x * x ^ n)) x"
      by transfer simp
    with Suc show ?case by simp
  qed
qed

lemma Standard_power [simp]: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
  by (simp add: star_power_def)

lemma star_of_power [simp]: "star_of (x ^ n) = star_of x ^ n"
  by transfer (rule refl)

subsection {* Number classes *}

instance star :: (numeral) numeral ..

lemma star_numeral_def [transfer_unfold]:
  "numeral k = star_of (numeral k)"
by (induct k, simp_all only: numeral.simps star_of_one star_of_add)

lemma Standard_numeral [simp]: "numeral k \<in> Standard"
by (simp add: star_numeral_def)

lemma star_of_numeral [simp]: "star_of (numeral k) = numeral k"
by transfer (rule refl)

lemma star_of_nat_def [transfer_unfold]: "of_nat n = star_of (of_nat n)"
by (induct n, simp_all)

lemmas star_of_compare_numeral [simp] =
  star_of_less [of "numeral k", simplified star_of_numeral]
  star_of_le   [of "numeral k", simplified star_of_numeral]
  star_of_eq   [of "numeral k", simplified star_of_numeral]
  star_of_less [of _ "numeral k", simplified star_of_numeral]
  star_of_le   [of _ "numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "numeral k", simplified star_of_numeral]
  star_of_less [of "- numeral k", simplified star_of_numeral]
  star_of_le   [of "- numeral k", simplified star_of_numeral]
  star_of_eq   [of "- numeral k", simplified star_of_numeral]
  star_of_less [of _ "- numeral k", simplified star_of_numeral]
  star_of_le   [of _ "- numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "- numeral k", simplified star_of_numeral] for k

lemma Standard_of_nat [simp]: "of_nat n \<in> Standard"
by (simp add: star_of_nat_def)

lemma star_of_of_nat [simp]: "star_of (of_nat n) = of_nat n"
by transfer (rule refl)

lemma star_of_int_def [transfer_unfold]: "of_int z = star_of (of_int z)"
by (rule_tac z=z in int_diff_cases, simp)

lemma Standard_of_int [simp]: "of_int z \<in> Standard"
by (simp add: star_of_int_def)

lemma star_of_of_int [simp]: "star_of (of_int z) = of_int z"
by transfer (rule refl)

instance star :: (semiring_char_0) semiring_char_0 proof
  have "inj (star_of :: 'a \<Rightarrow> 'a star)" by (rule injI) simp
  then have "inj (star_of \<circ> of_nat :: nat \<Rightarrow> 'a star)" using inj_of_nat by (rule inj_comp)
  then show "inj (of_nat :: nat \<Rightarrow> 'a star)" by (simp add: comp_def)
qed

instance star :: (ring_char_0) ring_char_0 ..

subsection {* Finite class *}

lemma starset_finite: "finite A \<Longrightarrow> *s* A = star_of ` A"
by (erule finite_induct, simp_all)

instance star :: (finite) finite
apply (intro_classes)
apply (subst starset_UNIV [symmetric])
apply (subst starset_finite [OF finite])
apply (rule finite_imageI [OF finite])
done

end


(* Title:      Containers/Examples/TwoSat_Ex.thy
   Author:     Andreas Lochbihler, ETH Zurich
   Author:     Peter Lammich, TU Munich *)

section \<open>Formalisation of 2SAT independent of an implementation\<close>

theory TwoSat_Ex imports
  Main
  "HOL-Library.Uprod"
  "Deriving.Compare_Instances"
begin

type_synonym var = nat
datatype lit = Lit (pos: bool) (var: var)
abbreviation Pos :: "var \<Rightarrow> lit" where "Pos \<equiv> Lit True"
abbreviation Neg :: "var \<Rightarrow> lit" where "Neg \<equiv> Lit False"
type_synonym clause = "lit uprod"
type_synonym cnf = "clause set"

primrec negate :: "lit \<Rightarrow> lit"
where "negate (Lit b v) = Lit (\<not> b) v"

lemma negate_inject [simp]: "negate x = negate y \<longleftrightarrow> x = y"
by(cases x; cases y) simp

lemma double_negate[simp]: "negate (negate l) = l"
  by (cases l) auto

lemma var_negate[simp]: "var (negate l) = var l"
  by (cases l) auto

type_synonym valuation = "var \<Rightarrow> bool"

definition sat_lit :: "valuation \<Rightarrow> lit \<Rightarrow> bool"
  where "sat_lit \<sigma> l \<longleftrightarrow> (\<sigma> (var l) \<longleftrightarrow> pos l)"

lemma sat_lit_alt: "sat_lit \<sigma> (Lit p v) \<longleftrightarrow> \<sigma> v = p"
  by (auto simp: sat_lit_def)

function sat_clause where
  "sat_clause \<sigma> (Upair l1 l2) \<longleftrightarrow> sat_lit \<sigma> l1 \<or> sat_lit \<sigma> l2"
  apply (metis surj_pair uprod_exhaust)
  by auto
termination by lexicographic_order

definition sat_cnf :: "valuation \<Rightarrow> cnf \<Rightarrow> bool"
  where "sat_cnf \<sigma> cnf \<longleftrightarrow> (\<forall>cl\<in>cnf. sat_clause \<sigma> cl)"

definition satisfiable :: "cnf \<Rightarrow> bool"
where "satisfiable cnf \<longleftrightarrow> (\<exists>\<sigma>. sat_cnf \<sigma> cnf)"

definition is_2sat :: "cnf \<Rightarrow> bool"
where "is_2sat cnf \<longleftrightarrow> (\<forall>cl\<in>cnf. proper_uprod cl)"

lemma is_2sat_simps [simp]: "is_2sat {}" "is_2sat (insert cl cnf) \<longleftrightarrow> proper_uprod cl \<and> is_2sat cnf"
by(simp_all add: is_2sat_def)

lemma negate_sat[simp]: "sat_lit \<sigma> (negate l) \<longleftrightarrow> \<not> sat_lit \<sigma> l"
  by (cases l) (auto simp: sat_lit_def)

function edges_of_clause where
  "edges_of_clause (Upair l1 l2) = {(negate l1, l2), (negate l2, l1)}"
  by (rule uprod_exhaust) auto
termination by lexicographic_order

definition imp_graph :: "cnf \<Rightarrow> (lit \<times> lit) set" where
  "imp_graph cnf = \<Union>(edges_of_clause ` cnf)"

lemma imp_graph_alt: "imp_graph cnf = {(negate l1,l2) | l1 l2. Upair l1 l2 \<in> cnf}"
  unfolding imp_graph_def apply safe
  subgoal for l1 l2 cl by (cases cl; clarsimp; metis Upair_inject)
  using edges_of_clause.simps by blast

lemma imp_graph_empty [simp]: "imp_graph {} = {}"
  by (simp add: imp_graph_def)

lemma imp_graph_insert [simp]:
  "imp_graph (insert cl cls) = edges_of_clause cl \<union> imp_graph cls"
  by (auto simp: imp_graph_def)

lemma imp_graph_skew_sym:
  "(l\<^sub>1,l\<^sub>2) \<in> imp_graph cnf \<Longrightarrow> (negate l\<^sub>2, negate l\<^sub>1) \<in> imp_graph cnf"
  unfolding imp_graph_def apply clarsimp
  subgoal for cl by (cases cl) (auto 4 3 intro: rev_bexI)
  done

lemma imp_graph_rtrancl_skew_sym:
  "(l\<^sub>1, l\<^sub>2) \<in> (imp_graph cnf)\<^sup>* \<Longrightarrow> (negate l\<^sub>2, negate l\<^sub>1) \<in> (imp_graph cnf)\<^sup>*"
  by (induction rule: rtrancl.induct)(auto dest: imp_graph_skew_sym)

context
  fixes \<sigma> cnf
  assumes sat: "sat_cnf \<sigma> cnf"
begin
  lemma imp_step:
    assumes S: "sat_lit \<sigma> l\<^sub>1"
    assumes I: "(l\<^sub>1, l\<^sub>2) \<in> imp_graph cnf"
    shows "sat_lit \<sigma> l\<^sub>2"
  proof -
    from I sat have "\<not> sat_lit \<sigma> l\<^sub>1 \<or> sat_lit \<sigma> l\<^sub>2"
      unfolding sat_cnf_def imp_graph_def
      apply clarsimp
      subgoal for x by(cases x)(auto split: if_split_asm)
      done
    with S show ?thesis by simp
  qed

  lemma imp_steps:
    assumes S: "sat_lit \<sigma> l\<^sub>1"
    assumes I: "(l\<^sub>1, l\<^sub>2) \<in> (imp_graph cnf)\<^sup>*"
    shows "sat_lit \<sigma> l\<^sub>2"
    using assms(2,1)
    by (induction) (auto intro: imp_step)

  lemma ln_loop:
    assumes "(l, negate l) \<in> (imp_graph cnf)\<^sup>*"
    shows "\<not> sat_lit \<sigma> l"
    using imp_steps[OF _ assms]
    by (cases "sat_lit \<sigma> l") auto

end

lemma loop_imp_unsat:
  assumes "(Pos x, Neg x) \<in> (imp_graph cnf)\<^sup>*"
  assumes "(Neg x, Pos x) \<in> (imp_graph cnf)\<^sup>*"
  shows "\<not> satisfiable cnf"
  using assms ln_loop[of _ cnf "Pos x"] ln_loop[of _ cnf "Neg x"]
  unfolding satisfiable_def by(auto simp add: sat_lit_def)

(*
  Informal argument why we can find satisfying valuation if
  there are no cycles Pos x \<rightarrow>\<^sup>* Neg x \<rightarrow>\<^sup>* Pos x.

  Assign all variables as follows:
    Let current assignment be A. By assumption, closed and consistent.
    Choose unassigned variable x
    Try to assign Pos x, form transitive closure.
    If this yields a conflict, assign Neg x

    Assume both Pos x and Neg x would yield conflict:
      As current assignment is always closed, we have
        G\<^sup>*``Pos x \<inter> negate``A = {} and G\<^sup>*``Neg x \<inter> negate``A = {}
        (Otherwise:
          Pos x \<rightarrow>\<^sup>* negate l, l\<in>A
          \<Longrightarrow> l \<rightarrow>\<^sup>* Neg x (skew sym)
          \<Longrightarrow> Neg x \<in> A (A closed, l\<in>A)
          \<Longrightarrow> x not unassigned, contr!
        )
      Thus, conflict must be of form:
        Pos x \<rightarrow>\<^sup>* Pos y, Pos x \<rightarrow>\<^sup>* Neg y
        Neg x \<rightarrow>\<^sup>* Pos z, Neg x \<rightarrow>\<^sup>* Neg z

        \<Longrightarrow> (skew sym)
          Pos y \<rightarrow>\<^sup>* Neg x \<Longrightarrow> Pos x \<rightarrow>\<^sup>* Neg x
          Pos z \<rightarrow>\<^sup>* Pos x \<Longrightarrow> Neg x \<rightarrow>\<^sup>* Pos x
          contr to no-cycle assm
*)

definition consistent :: "lit set \<Rightarrow> bool" where
  "consistent ls \<longleftrightarrow> (\<nexists>x. Pos x \<in> ls \<and> Neg x \<in> ls)"

  function extend :: "lit set \<Rightarrow> lit set" where
    "extend ls = (
      if vars_of_cnf cnf \<subseteq> var ` ls then ls
      else let
        x = SOME x. x \<in> vars_of_cnf cnf - var ` ls
      in
        if consistent (ls \<union> G\<^sup>* `` {Pos x}) then
          extend (ls \<union> G\<^sup>* `` {Pos x})
        else
          extend (ls \<union> G\<^sup>* `` {Neg x})
    )"
    by pat_completeness auto
  termination
    apply (relation "inv_image finite_psubset (\<lambda>ls. vars_of_cnf cnf - var`ls)")
    apply simp
    apply (drule eq_SomeD; auto simp: FIN)
    apply (drule eq_SomeD; auto simp: FIN)
    done

  declare extend.simps[simp del]

  lemma extend_vars: "vars_of_cnf cnf \<subseteq> var ` extend ls"
    apply (induction ls rule: extend.induct)
    apply (subst extend.simps)
    apply (auto split: if_splits simp: Let_def)
    done

  lemma extend_cons_closed_aux:
    assumes "consistent ls"
    assumes "G `` ls \<subseteq> ls"
    shows "consistent (extend ls) \<and> G `` extend ls \<subseteq> extend ls"
    using assms(1,2)
  proof (induction ls rule: extend.induct)
    case (1 ls)

    show ?case
    proof (cases "vars_of_cnf cnf \<subseteq> var`ls")
      case True thus ?thesis using "1.prems"
        by(subst (1 2 3) extend.simps) auto
    next
      case [simp]: False
      define x where "x = (SOME x. x \<in> vars_of_cnf cnf - var ` ls)"
      with False have XI: "x \<in> vars_of_cnf cnf - var ` ls"
        by (metis (full_types) DiffI someI_ex subsetI)

      show ?thesis proof (cases "consistent (ls \<union> G\<^sup>*``{Pos x})")
        case CPOS [simp]: True
        from "1.prems" have CL: "G `` (ls \<union> G\<^sup>* `` {Pos x}) \<subseteq> ls \<union> G\<^sup>* `` {Pos x}"
          by auto

        show ?thesis
          using "1.IH"(1)[OF False x_def CPOS CPOS CL]
          unfolding extend.simps[of ls]
          unfolding x_def[symmetric]
          by auto
      next
        case NCPOS: False

        from "1.prems" have CL: "G `` (ls \<union> G\<^sup>* `` {Neg x}) \<subseteq> ls \<union> G\<^sup>* `` {Neg x}"
          by auto

        show ?thesis
        proof (cases "consistent (ls \<union> G\<^sup>* `` {Neg x})")
          case CNEG[simp]: True
          show ?thesis
            using "1.IH"(2)[OF False x_def NCPOS CNEG CL] NCPOS
            unfolding extend.simps[of ls] x_def[symmetric]
            by auto
        next
          case NCNEG: False

          have X1: "(l, negate l)\<in> G\<^sup>*"
            if UNASS: "var l \<notin> var ` ls" and "\<not> consistent (ls \<union> G\<^sup>* `` {l})" for l
          proof -
            from that(2) obtain y where X1: "Pos y \<in> ls \<union> G\<^sup>*``{l}" "Neg y \<in> ls \<union> G\<^sup>*``{l}"
              unfolding consistent_def by auto
            with "1.prems" have "(l, Pos y) \<in> G\<^sup>* \<or> (l, Neg y) \<in> G\<^sup>*"
              unfolding consistent_def by auto
            hence X2: "(l, Pos y) \<in> G\<^sup>* \<and> (l, Neg y) \<in> G\<^sup>*"
            proof (safe; rule_tac ccontr)
              assume "(l, Pos y) \<in> G\<^sup>*" "(l, Neg y)\<notin>G\<^sup>*"
              hence "(Neg y,negate l)\<in>G\<^sup>*" "Neg y \<in> ls"
                using X1 by (auto dest: imp_graph_rtrancl_skew_sym)
              with CL have "negate l \<in> ls"
                by (metis "1.prems"(2) ImageI Image_closed_trancl)
              with UNASS show False by (cases l) force+
            next
              assume "(l, Neg y) \<in> G\<^sup>*" "(l, Pos y) \<notin> G\<^sup>*"
              hence "(Pos y, negate l) \<in> G\<^sup>*" "Pos y \<in> ls"
                using X1 by (auto dest: imp_graph_rtrancl_skew_sym)
              with CL have "negate l \<in> ls"
                by (metis "1.prems"(2) ImageI Image_closed_trancl)
              with UNASS show False by (cases l) force+
            qed
            from X2 imp_graph_rtrancl_skew_sym[of _ _ cnf] have "(Neg y, negate l) \<in> G\<^sup>*"
              by force
            with X2 show ?thesis by auto
          qed

          from X1[of "Pos x", OF _ NCPOS] XI have "(Pos x, Neg x)\<in>G\<^sup>*" by auto
          moreover from X1[of "Neg x", OF _ NCNEG] XI have "(Neg x, Pos x)\<in>G\<^sup>*" by auto
          ultimately have False using NO_CYC by blast
          thus ?thesis by blast
        qed
      qed
    qed
  qed

  lemma extend_cons_closed:
    "consistent (extend {})"
    "G `` extend {} \<subseteq> extend {}"
    using extend_cons_closed_aux[of "{}"]
    by auto

  lemma CCV_sat:
    assumes CONS: "consistent ls"
    assumes CLOSED: "G``ls \<subseteq> ls"
    assumes VARS: "vars_of_cnf cnf \<subseteq> var`ls"
    shows "sat_cnf (\<lambda>x. Pos x \<in> ls) cnf"
    unfolding sat_cnf_def
  proof (rule, rule ccontr)
    fix cl
    assume "cl\<in>cnf"
    with TSAT obtain l1 l2 where [simp]: "cl = Upair l1 l2" "l1 \<noteq> l2"
      unfolding is_2sat_def
      by(fastforce simp add: proper_uprod_def dest!: bspec split: uprod_split_asm)

    assume "\<not> sat_clause (\<lambda>x. Pos x \<in> ls) cl"
    hence "l1 \<notin> ls" "l2 \<notin> ls" using \<open>consistent ls\<close>
      apply (auto simp: sat_lit_def consistent_def)
      apply (cases l1; cases l2; auto)+
      done

    from VARS \<open>cl \<in> cnf\<close> have "var l1 \<in> var ` ls"
      by (auto 4 3 simp: vars_of_cnf_def)
    with \<open>l1 \<notin> ls\<close> have "negate l1 \<in> ls"
    proof -
      have "\<forall>L n f. \<exists>l. ((n::nat) \<notin> f ` L \<or> (l::lit) \<in> L) \<and> (n \<notin> f ` L \<or> f l = n)"
        by blast
      then show ?thesis
        by (metis (no_types) \<open>l1 \<notin> ls\<close> \<open>var l1 \<in> var ` ls\<close> lit.expand negate_sat var_negate)
    qed

    moreover from \<open>cl \<in> cnf\<close> have "(negate l1, l2) \<in> G"
      unfolding imp_graph_def by(auto intro: rev_bexI)
    ultimately have "l2 \<in> ls" using CLOSED by auto
    thus False using \<open>l2 \<notin> ls\<close> by auto
  qed

  lemma sat: "satisfiable cnf"
    using CCV_sat[OF extend_cons_closed extend_vars]
    by(auto   simp add: satisfiable_def)

end

lemma imp_graph_vars:
  assumes "(l, l') \<in> imp_graph cnf"
  shows "var l \<in> vars_of_cnf cnf"
  using assms unfolding imp_graph_def vars_of_cnf_def
  apply (clarsimp elim!: rev_bexI)
  subgoal for x by(cases x)(auto split: uprod_split_asm if_split_asm)
  done

theorem finite_2sat_iff:
  assumes FIN: "finite (vars_of_cnf cnf)"
  assumes TSAT: "is_2sat cnf"
  shows "satisfiable cnf
    \<longleftrightarrow> (\<forall>x\<in>vars_of_cnf cnf.
          \<not> ((Pos x, Neg x) \<in> (imp_graph cnf)\<^sup>* \<and> (Neg x, Pos x) \<in> (imp_graph cnf)\<^sup>* ))"
  apply (safe;clarsimp?; (auto dest: loop_imp_unsat;fail)?)
proof -
  assume " \<forall>x\<in>vars_of_cnf cnf.
     (Pos x, Neg x) \<in> (imp_graph cnf)\<^sup>* \<longrightarrow> (Neg x, Pos x) \<notin> (imp_graph cnf)\<^sup>*"
  then interpret construct_sa cnf
    apply (unfold_locales)
    using FIN TSAT apply auto
    by (metis converse_rtranclE imp_graph_vars lit.inject lit.sel(2))

  from sat show "satisfiable cnf" .
qed

derive linorder lit

subsection \<open>Finiteness\<close>
definition "lits_of_cnf cnf = Pos`vars_of_cnf cnf \<union> Neg`vars_of_cnf cnf"

lemma inj_on_Pos [simp]: "inj_on Pos A"
  and inj_on_Neg [simp]: "inj_on Neg A"
by(auto simp add: inj_on_def)

lemma lits_of_cnf_finite[iff]:
  "finite (lits_of_cnf cnf) \<longleftrightarrow> finite (vars_of_cnf cnf)"
proof -
  show ?thesis
    unfolding lits_of_cnf_def
    by (auto simp: finite_image_iff)
qed

lemma vars_of_cnf_finite[simp, intro]:
  "finite cnf \<Longrightarrow> finite (vars_of_cnf cnf)"
  unfolding vars_of_cnf_def by auto

lemma lit_eq_negate_conv[simp]:
  "Lit p v = negate l \<longleftrightarrow> l = Lit (\<not>p) v"
  "negate l = Lit p v \<longleftrightarrow> l = Lit (\<not>p) v"
  by (cases l; auto)+

lemma imp_graph_nodes: "imp_graph cnf \<subseteq> lits_of_cnf cnf \<times> lits_of_cnf cnf"
  unfolding imp_graph_def
  apply clarsimp
  subgoal for l1 l2 cl
    by (cases cl; cases l1; cases l2)(fastforce simp: lits_of_cnf_def vars_of_cnf_def)
  done

lemma imp_graph_finite[simp, intro]: "finite (vars_of_cnf cnf) \<Longrightarrow> finite (imp_graph cnf)"
  using finite_subset[OF imp_graph_nodes] by blast

end


(* Author: Hauke Brinkop and Tobias Nipkow *)

section \<open>Pairing Heaps\<close>

subsection \<open>Binary Tree Representation\<close>

theory Pairing_Heap_Tree_Analysis
imports
  Pairing_Heap.Pairing_Heap_Tree
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Verification of logarithmic bounds on the amortized complexity of
pairing heaps \cite{FredmanSST86,Brinkop}.\<close>

fun len :: "'a tree \<Rightarrow> nat" where
  "len Leaf = 0"
| "len (Node _ _ r) = 1 + len r"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
  "\<Phi> Leaf = 0"
| "\<Phi> (Node l x r) = log 2 (size (Node l x r)) + \<Phi> l + \<Phi> r"

lemma link_size[simp]: "size (link hp) = size hp"
  by (cases hp rule: link.cases) simp_all

lemma size_pass\<^sub>1: "size (pass\<^sub>1 hp) = size hp"
  by (induct hp rule: pass\<^sub>1.induct) simp_all

lemma size_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> size (merge h1 h2) = size h1 + size h2"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_insert: "is_root hp \<Longrightarrow> \<Phi> (insert x hp) - \<Phi> hp \<le> log 2  (size hp + 1)"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_merge:
  assumes "h1 = Node hs1 x1 Leaf" "h2 = Node hs2 x2 Leaf"
  shows "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (size h1 + size h2) + 1"
proof -
  let ?hs = "Node hs1 x1 (Node hs2 x2 Leaf)"
  have "\<Phi> (merge h1 h2) = \<Phi> (link ?hs)" using assms by simp
  also have "\<dots> = \<Phi> hs1 + \<Phi> hs2 + log 2 (size hs1 + size hs2 + 1) + log 2 (size hs1 + size hs2 + 2)"
    by (simp add: algebra_simps)
  also have "\<dots> = \<Phi> hs1 + \<Phi> hs2 + log 2 (size hs1 + size hs2 + 1) + log 2 (size h1 + size h2)"
     using assms by simp
  finally have "\<Phi> (merge h1 h2) = \<dots>" .
  have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 =
   log 2 (size hs1 + size hs2 + 1) + log 2 (size h1 + size h2)
   - log 2 (size hs1 + 1) - log 2 (size hs2 + 1)"
     using assms by (simp add: algebra_simps)
  also have "\<dots> \<le> log 2 (size h1 + size h2) + 1"
    using ld_le_2ld[of "size hs1" "size hs2"] assms by (simp add: algebra_simps)
  finally show ?thesis .
qed

fun ub_pass\<^sub>1 :: "'a tree \<Rightarrow> real" where
  "ub_pass\<^sub>1 (Node _ _ Leaf) = 0"
| "ub_pass\<^sub>1 (Node hs1 _ (Node hs2 _ Leaf)) = 2*log 2 (size hs1 + size hs2 + 2)"
| "ub_pass\<^sub>1 (Node hs1 _ (Node hs2 _ hs)) = 2*log 2 (size hs1 + size hs2 + size hs + 2)
    - 2*log 2 (size hs) - 2 + ub_pass\<^sub>1 hs"

lemma \<Delta>\<Phi>_pass1_ub_pass1: "hs \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>1 hs) - \<Phi> hs  \<le> ub_pass\<^sub>1 hs"
proof (induction hs rule: ub_pass\<^sub>1.induct)
  case (2 lx x ly y)
  have "log 2  (size lx + size ly + 1) - log 2  (size ly + 1)
    \<le> log 2 (size lx + size ly + 1)" by simp
  also have "\<dots> \<le> log 2 (size lx + size ly + 2)" by simp
  also have "\<dots> \<le> 2*\<dots>" by simp
  finally show ?case by (simp add: algebra_simps)
next
  case (3 lx x ly y lz z rz)
  let ?ry = "Node lz z rz"
  let ?rx = "Node ly y ?ry"
  let ?h = "Node lx x ?rx"
  let ?t ="log 2 (size lx + size ly + 1) - log 2 (size ly + size ?ry + 1)"
  have "\<Phi> (pass\<^sub>1 ?h) - \<Phi> ?h \<le> ?t + ub_pass\<^sub>1 ?ry"
    using "3.IH" by (simp add: size_pass\<^sub>1 algebra_simps)
  moreover have "log 2 (size lx + size ly + 1) + 2 * log 2 (size ?ry) + 2
    \<le> 2 * log 2 (size ?h) + log 2 (size ly + size ?ry + 1)" (is "?l \<le> ?r")
  proof -
    have "?l \<le> 2 * log 2 (size lx + size ly + size ?ry + 1) + log 2 (size ?ry)"
      using ld_sum_inequality [of "size lx + size ly + 1" "size ?ry"] by simp
    also have "\<dots> \<le> 2 * log 2 (size lx + size ly + size ?ry + 2) + log 2 (size ?ry)"
      by simp
    also have "\<dots> \<le> ?r" by simp
    finally show ?thesis .
  qed
  ultimately show ?case by simp
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs \<le> 2*log 2 (size hs) - len hs + 2"
proof -
  from assms have "ub_pass\<^sub>1 hs \<le> 2*log 2 (size hs) - len hs + 2"
    by (induct hs rule: ub_pass\<^sub>1.induct) (simp_all add: algebra_simps)
  thus ?thesis using \<Delta>\<Phi>_pass1_ub_pass1 [OF assms] order_trans by blast
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>2 hs) - \<Phi> hs \<le> log 2 (size hs)"
proof (induction hs)
  case (Node lx x rx)
  thus ?case
  proof (cases rx)
    case 1: (Node ly y ry)
    let ?h = "Node lx x rx"
    obtain la a where 2: "pass\<^sub>2 rx = Node la a Leaf"
      using pass\<^sub>2_struct 1 by force
    hence 3: "size rx = size \<dots>" using size_pass\<^sub>2 by metis
    have link: "\<Phi>(link(Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> (pass\<^sub>2 rx) =
          log 2 (size lx + size rx + 1) + log 2 (size lx + size rx) - log 2 (size rx)"
      using 2 3 by (simp add: algebra_simps)
    have "\<Phi> (pass\<^sub>2 ?h) - \<Phi> ?h =
        \<Phi> (link (Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> rx - log 2 (size lx + size rx + 1)"
      by (simp)
    also have "\<dots> = \<Phi> (pass\<^sub>2 rx) - \<Phi> rx + log 2 (size lx + size rx) - log 2 (size rx)"
      using link by linarith
    also have "\<dots> \<le> log 2 (size lx + size rx)"
      using Node.IH 1 by simp
    also have "\<dots> \<le> log 2 (size ?h)" using 1 by simp
    finally show ?thesis .
  qed simp
qed simp
(*
lemma \<Delta>\<Phi>_mergepairs: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (merge_pairs hs) - \<Phi> hs \<le> 3 * log 2 (size hs) - len hs + 2"
proof -
  have "pass\<^sub>1 hs \<noteq> Leaf" by (metis assms eq_size_0 size_pass\<^sub>1)
  with assms \<Delta>\<Phi>_pass1[of hs] \<Delta>\<Phi>_pass2[of "pass\<^sub>1 hs"]
  show ?thesis by (auto simp add: size_pass\<^sub>1 pass12_merge_pairs)
qed
*)
lemma \<Delta>\<Phi>_del_min: assumes "hs \<noteq> Leaf"
shows "\<Phi> (del_min (Node hs x Leaf)) - \<Phi> (Node hs x Leaf)
  \<le> 3*log 2 (size hs) - len hs + 2"
proof -
  let ?h = "Node hs x Leaf"
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi> hs - \<Phi> ?h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 hs)) - \<Phi> hs"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min ?h) - \<Phi> ?h"
  have "\<Phi>(pass\<^sub>2(pass\<^sub>1 hs)) - \<Phi> (pass\<^sub>1 hs) \<le> log 2  (size hs)"
    using \<Delta>\<Phi>_pass2 [of "pass\<^sub>1 hs"] assms by(metis eq_size_0 size_pass\<^sub>1)
  moreover have "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs \<le>  2*\<dots> - len hs + 2"
    by(rule \<Delta>\<Phi>_pass1[OF assms])
  moreover have "?\<Delta>\<Phi> \<le> ?\<Delta>\<Phi>\<^sub>2" by simp
  ultimately show ?thesis using assms by linarith
qed

lemma is_root_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> is_root (merge h1 h2)"
by (simp split: tree.splits)

lemma is_root_insert: "is_root h \<Longrightarrow> is_root (insert x h)"
by (simp split: tree.splits)

lemma is_root_del_min:
  assumes "is_root h" shows "is_root (del_min h)"
proof (cases h)
  case [simp]: (Node lx x rx)
  have "rx = Leaf" using assms by simp
  thus ?thesis
  proof (cases lx)
    case (Node ly y ry)
    then obtain la a ra where "pass\<^sub>1 lx = Node a la ra"
      using pass\<^sub>1_struct by blast
    moreover obtain lb b where "pass\<^sub>2 \<dots> = Node b lb Leaf"
      using pass\<^sub>2_struct by blast
    ultimately show ?thesis using assms by simp
  qed simp
qed simp

lemma pass\<^sub>1_len: "len (pass\<^sub>1 h) \<le> len h"
by (induct h rule: pass\<^sub>1.induct) simp_all

fun exec :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a tree \<Rightarrow> nat" where
  "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 Leaf = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ Leaf) = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ (Node _ _ ry)) = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 ry + 1"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a tree \<Rightarrow> nat" where
  "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 Leaf = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (Node _ _ rx) = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 rx + 1"

fun cost :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
  "cost Empty [] = 1"
| "cost Del_min [Leaf] = 1"
| "cost Del_min [Node lx _  _] = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx"
| "cost (Insert a) _ = 1"
| "cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> real" where
  "U Empty [] = 1"
| "U (Insert a) [h] = log 2 (size h + 1) + 1"
| "U Del_min [h] = 3*log 2 (size h + 1) + 4"
| "U Merge [h1,h2] = log 2 (size h1 + size h2 + 1) + 2"

interpretation Amortized
where arity = arity and exec = exec and cost = cost and inv = is_root
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 _ f) thus ?case using is_root_insert is_root_del_min is_root_merge
    by (cases f) (auto simp: numeral_eq_Suc)
next
  case (2 s) show ?case by (induct s) simp_all
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case (Insert x)
    then obtain h where "ss = [h]" "is_root h" using 3 by auto
    thus ?thesis using Insert \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: (Del_min)
    then obtain h where [simp]: "ss = [h]" using 3 by auto
    show ?thesis
    proof (cases h)
      case [simp]: (Node lx x rx)
      have "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx \<le> len lx + 2"
        by (induct lx rule: pass\<^sub>1.induct) simp_all
      hence "cost f ss \<le> \<dots>" by simp
      moreover have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size h + 1) - len lx + 2"
      proof (cases lx)
        case [simp]: (Node ly y ry)
        have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size lx) - len lx + 2"
          using  \<Delta>\<Phi>_del_min[of "lx" "x"] 3 by simp
        also have "\<dots> \<le> 3*log 2 (size h + 1) - len lx + 2" by fastforce
        finally show ?thesis by blast
      qed (insert 3, simp)
      ultimately show ?thesis by auto
    qed simp
  next
    case [simp]: Merge
    then obtain h1 h2 where [simp]: "ss = [h1,h2]" and 1: "is_root h1" "is_root h2"
      using 3 by (auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases h1)
      case Leaf thus ?thesis by (cases h2) auto
    next
      case h1: Node
      show ?thesis
      proof (cases h2)
        case Leaf thus ?thesis using h1 by simp
      next
        case h2: Node
        have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (real (size h1 + size h2)) + 1"
          apply(rule \<Delta>\<Phi>_merge) using h1 h2 1 by auto
        also have "\<dots> \<le> log 2 (size h1 + size h2 + 1) + 1" by (simp add: h1)
        finally show ?thesis by(simp add: algebra_simps)
      qed
    qed
  qed
qed

end


section "Tabulating the Balanced Predicate"

theory Root_Balanced_Tree_Tab
imports
  Root_Balanced_Tree
  "HOL-Decision_Procs.Approximation"
  "HOL-Library.IArray"
begin

locale Min_tab =
fixes p :: "nat \<Rightarrow> nat \<Rightarrow> bool"
fixes tab :: "nat list"
assumes mono_p: "n \<le> n' \<Longrightarrow> p n h \<Longrightarrow> p n' h"
assumes p: "\<exists>n. p n h"
assumes tab_LEAST: "h < length tab \<Longrightarrow> tab!h = (LEAST n. p n h)"
begin

lemma tab_correct: "h < length tab \<Longrightarrow> p n h = (n \<ge> tab ! h)"
  apply auto
  using not_le_imp_less not_less_Least tab_LEAST apply auto[1]
  by (metis LeastI mono_p p tab_LEAST)

end

definition bal_tab :: "nat list" where
"bal_tab = [0, 1, 1, 2, 4, 6, 10, 16, 25, 40, 64, 101, 161, 256, 406, 645, 1024,
  1625, 2580, 4096, 6501, 10321, 16384, 26007, 41285, 65536, 104031, 165140,
  262144, 416127, 660561, 1048576, 1664510, 2642245, 4194304, 6658042, 10568983,
  16777216, 26632170, 42275935, 67108864, 106528681, 169103740, 268435456,
  426114725, 676414963, 1073741824, 1704458900, 2705659852, 4294967296\<^cancel>\<open>,
  6817835603\<close>]"
(*ML\<open>floor (Math.pow(2.0,5.0/1.5))\<close>*)

axiomatization where c_def: "c = 3/2"

fun is_floor :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"is_floor n h = (let m = floor((2::real) powr ((real(h)-1)/c)) in n \<le> m \<and> m \<le> n)"
text\<open>Note that @{prop"n \<le> m \<and> m \<le> n"} avoids the technical restriction of the
\<open>approximation\<close> method which does not support \<open>=\<close>, even on integers.\<close>

lemma bal_tab_correct:
  "\<forall>i < length bal_tab. is_floor (bal_tab!i) i"
apply(simp add: bal_tab_def c_def All_less_Suc)
apply (approximation 50)
done

(* FIXME mv *)
lemma ceiling_least_real: "ceiling(r::real) = (LEAST i. r \<le> i)"
by (metis Least_equality ceiling_le le_of_int_ceiling)

lemma floor_greatest_real: "floor(r::real) = (GREATEST i. i \<le> r)"
by (metis Greatest_equality le_floor_iff of_int_floor_le)

lemma LEAST_eq_floor:
  "(LEAST n. int h \<le> \<lceil>c * log 2 (real n + 1)\<rceil>) = floor((2::real) powr ((real(h)-1)/c))"
proof -
  have "int h \<le> \<lceil>c * log 2 (real n + 1)\<rceil>
      \<longleftrightarrow> 2 powr ((real(h)-1)/c) < real(n)+1" (is "?L = ?R") for n
  proof -
    have "?L \<longleftrightarrow> h < c * log 2 (real n + 1) + 1" by linarith
    also have "\<dots> \<longleftrightarrow> (real h-1)/c < log 2 (real n + 1)"
      using c1 by(simp add: field_simps)
    also have "\<dots> \<longleftrightarrow> 2 powr ((real h-1)/c) < 2 powr (log 2 (real n + 1))"
      by(simp del: powr_log_cancel)
    also have "\<dots> \<longleftrightarrow> ?R"
      by(simp)
    finally show ?thesis .
  qed
  moreover have "((LEAST n::nat. r < n+1) = nat(floor r))" for r :: real
    by(rule Least_equality) linarith+
  ultimately show ?thesis by simp
qed

interpretation Min_tab
where p = bal_i and tab = bal_tab
proof(unfold bal_i_def, standard, goal_cases)
  case (1 n n' h)
  have "int h \<le> ceiling(c * log 2 (real n + 1))" by(rule 1[unfolded bal_i_def])
  also have "\<dots> \<le> ceiling(c * log 2 (real n' + 1))"
    using c1 "1"(1) by (simp add: ceiling_mono)
  finally show ?case .
next
  case (2 h)
  show ?case
  proof
    show "int h \<le> \<lceil>c * log 2 (real (2 ^ h - 1) + 1)\<rceil>"
      apply(simp add: of_nat_diff log_nat_power) using c1
      by (metis ceiling_mono ceiling_of_nat order.order_iff_strict mult.left_neutral mult_eq_0_iff of_nat_0_le_iff real_mult_le_cancel_iff1)
  qed
next
  case 3
  thus ?case using bal_tab_correct LEAST_eq_floor
     by (simp add: eq_iff[symmetric]) (metis nat_int)
qed

text\<open>Now we replace the list by an immutable array:\<close>

definition bal_array :: "nat iarray" where
"bal_array = IArray bal_tab"

text\<open>A trick for code generation: how to get rid of the precondition:\<close>

lemma bal_i_code:
  "bal_i n h =
  (if h < IArray.length bal_array then IArray.sub bal_array h \<le> n else bal_i n h)"
by (simp add: bal_array_def tab_correct)

end