theory SOS_Misc_Add
imports Main "HOL-Library.Monad_Syntax"
begin

lemma finite_ImageI:
  assumes "finite A"
  assumes "\<And>a. a\<in>A \<Longrightarrow> finite (R``{a})"
  shows "finite (R``A)"
proof -
  note [[simproc add: finite_Collect]]
  have "R``A = \<Union>{R``{a} | a. a:A}"
    by auto
  also have "finite (\<Union>{R``{a} | a. a:A})"
    apply (rule finite_Union)
    apply (simp add: assms)
    apply (clarsimp simp: assms)
    done
  finally show ?thesis .
qed

  (* Set monad utilities *)

  lemma do_set_push_Image:
    "\<And>g f m. g`(do {x\<leftarrow>m; f x}) = do {x\<leftarrow>m; g`f x}"
    "\<And>g f m. g`(do {let x = m; f x}) = (do {let x=m; g`f x})"
    by fastforce+

  lemma case_option_distrib: "f (case x of Some v \<Rightarrow> fs v | None \<Rightarrow> fn)
    = (case x of Some v \<Rightarrow> f (fs v) | None \<Rightarrow> f fn)"
    by (auto split: option.split)

  lemma case_sum_distrib: "f (case x of Inl x \<Rightarrow> fl x | Inr x \<Rightarrow> fr x) =
    (case x of Inl x \<Rightarrow> f (fl x) | Inr x \<Rightarrow> f (fr x))"
    by (auto split: sum.split)

  lemma do_set_eq_bind:
    assumes "m'=m"
    assumes "\<And>x. x\<in>m \<Longrightarrow> f x = g x"
    shows "do {x\<leftarrow>m; f x} = do {x\<leftarrow>m'; g x}"
    using assms by auto

  lemma finite_bindI[intro]:
    assumes "finite m"
    assumes "\<And>x. x\<in>m \<Longrightarrow> finite (f x)"
    shows "finite (do { x\<leftarrow>m; f x })"
  proof -
    have S: "do { x\<leftarrow>m; f x } = \<Union>(f`m)"
      by auto

    show ?thesis
      apply (subst S)
      using assms
      by blast
  qed

(* Option monad utilities *)

  primrec assert_option :: "bool \<Rightarrow> unit option" where
    "assert_option True = Some ()" | "assert_option False = None"

  lemma assert_option_eqs[simp]:
    "assert_option \<Phi> = Some x \<longleftrightarrow> \<Phi>"
    "assert_option \<Phi> = None \<longleftrightarrow> \<not>\<Phi>"
    by (cases \<Phi>) auto

  (* TODO: Move *)
  lemma disj_eq_nota_conv[simp]:
    "(a \<or> b \<longleftrightarrow> \<not>a) \<longleftrightarrow> (a=False \<and> b=True)"
    "(b \<or> a \<longleftrightarrow> \<not>a) \<longleftrightarrow> (a=False \<and> b=True)"
    "(\<not>a \<or> b \<longleftrightarrow> a) \<longleftrightarrow> (a=True \<and> b=True)"
    "(b \<or> \<not>a \<longleftrightarrow> a) \<longleftrightarrow> (a=True \<and> b=True)"
    by auto

  lemma all_disjx_conv[simp]:
    "(\<forall>x. x \<or> P x) \<longleftrightarrow> P False"
    "(\<forall>x. x \<or> P (\<not>x)) \<longleftrightarrow> P True"
    apply safe
    apply (drule spec[where x=False], simp)
    apply (case_tac x, auto) []
    apply (drule spec[where x=False], simp)
    apply (case_tac x, auto) []
    done

  lemma neq_Some_bool_cases[consumes 1, case_names None Some]:
    assumes "a\<noteq>Some x"
    obtains "a=None" | "a = Some (\<not>x)"
    using assms by auto

  primrec find_min_idx :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<rightharpoonup> nat" where
    "find_min_idx P [] = None"
  | "find_min_idx P (x#xs) = (
      if P x then Some 0 else
      map_option Suc (find_min_idx P xs)
    )"

  lemma find_min_idx_None_conv:
    "find_min_idx P l = None \<longleftrightarrow> (\<forall>a\<in>set l. \<not>P a)"
    apply (induction l)
    apply auto
    done

  lemma find_min_idx_SomeD:
    "find_min_idx P l = Some i \<Longrightarrow> P (l!i) \<and> i < length l"
    by (induction l arbitrary: i) (auto split: if_split_asm)

  lemma find_min_idx_SomeD_complete:
    "find_min_idx P l = Some i \<Longrightarrow> (P (l!i) \<and> i < length l \<and> (\<forall>j<i. \<not>P (l!j)))"
    apply (induction l arbitrary: i)
    apply (auto split: if_split_asm)
    apply (case_tac j)
    apply auto
    done

end


(*  Title:      HOL/Nonstandard_Analysis/HLog.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2000, 2001 University of Edinburgh
*)

section\<open>Logarithms: Non-Standard Version\<close>

theory HLog
imports HTranscendental
begin

(* should be in NSA.ML *)
lemma epsilon_ge_zero [simp]: "0 \<le> \<epsilon>"
by (simp add: epsilon_def star_n_zero_num star_n_le)

lemma hpfinite_witness: "\<epsilon> : {x. 0 \<le> x & x : HFinite}"
by auto

definition
  powhr  :: "[hypreal,hypreal] => hypreal"     (infixr "powhr" 80) where
  [transfer_unfold]: "x powhr a = starfun2 (op powr) x a"

definition
  hlog :: "[hypreal,hypreal] => hypreal" where
  [transfer_unfold]: "hlog a x = starfun2 log a x"

lemma powhr: "(star_n X) powhr (star_n Y) = star_n (%n. (X n) powr (Y n))"
by (simp add: powhr_def starfun2_star_n)

lemma powhr_one_eq_one [simp]: "!!a. 1 powhr a = 1"
by (transfer, simp)

lemma powhr_mult:
  "!!a x y. [| 0 < x; 0 < y |] ==> (x * y) powhr a = (x powhr a) * (y powhr a)"
by (transfer, simp add: powr_mult)

lemma powhr_gt_zero [simp]: "!!a x. 0 < x powhr a \<longleftrightarrow> x \<noteq> 0"
by (transfer, simp)

lemma powhr_not_zero [simp]: "\<And>a x. x powhr a \<noteq> 0 \<longleftrightarrow> x \<noteq> 0"
by transfer simp

lemma powhr_divide:
  "!!a x y. [| 0 < x; 0 < y |] ==> (x / y) powhr a = (x powhr a)/(y powhr a)"
by (transfer, rule powr_divide)

lemma powhr_add: "!!a b x. x powhr (a + b) = (x powhr a) * (x powhr b)"
by (transfer, rule powr_add)

lemma powhr_powhr: "!!a b x. (x powhr a) powhr b = x powhr (a * b)"
by (transfer, rule powr_powr)

lemma powhr_powhr_swap: "!!a b x. (x powhr a) powhr b = (x powhr b) powhr a"
by (transfer, rule powr_powr_swap)

lemma powhr_minus: "!!a x. x powhr (-a) = inverse (x powhr a)"
by (transfer, rule powr_minus)

lemma powhr_minus_divide: "x powhr (-a) = 1/(x powhr a)"
by (simp add: divide_inverse powhr_minus)

lemma powhr_less_mono: "!!a b x. [| a < b; 1 < x |] ==> x powhr a < x powhr b"
by (transfer, simp)

lemma powhr_less_cancel: "!!a b x. [| x powhr a < x powhr b; 1 < x |] ==> a < b"
by (transfer, simp)

lemma powhr_less_cancel_iff [simp]:
     "1 < x ==> (x powhr a < x powhr b) = (a < b)"
by (blast intro: powhr_less_cancel powhr_less_mono)

lemma powhr_le_cancel_iff [simp]:
     "1 < x ==> (x powhr a \<le> x powhr b) = (a \<le> b)"
by (simp add: linorder_not_less [symmetric])

lemma hlog:
     "hlog (star_n X) (star_n Y) =
      star_n (%n. log (X n) (Y n))"
by (simp add: hlog_def starfun2_star_n)

lemma hlog_starfun_ln: "!!x. ( *f* ln) x = hlog (( *f* exp) 1) x"
by (transfer, rule log_ln)

lemma powhr_hlog_cancel [simp]:
     "!!a x. [| 0 < a; a \<noteq> 1; 0 < x |] ==> a powhr (hlog a x) = x"
by (transfer, simp)

lemma hlog_powhr_cancel [simp]:
     "!!a y. [| 0 < a; a \<noteq> 1 |] ==> hlog a (a powhr y) = y"
by (transfer, simp)

lemma hlog_mult:
     "!!a x y. [| 0 < a; a \<noteq> 1; 0 < x; 0 < y  |]
      ==> hlog a (x * y) = hlog a x + hlog a y"
by (transfer, rule log_mult)

lemma hlog_as_starfun:
     "!!a x. [| 0 < a; a \<noteq> 1 |] ==> hlog a x = ( *f* ln) x / ( *f* ln) a"
by (transfer, simp add: log_def)

lemma hlog_eq_div_starfun_ln_mult_hlog:
     "!!a b x. [| 0 < a; a \<noteq> 1; 0 < b; b \<noteq> 1; 0 < x |]
      ==> hlog a x = (( *f* ln) b/( *f*ln) a) * hlog b x"
by (transfer, rule log_eq_div_ln_mult_log)

lemma powhr_as_starfun: "!!a x. x powhr a = (if x=0 then 0 else ( *f* exp) (a * ( *f* real_ln) x))"
  by (transfer, simp add: powr_def)

lemma HInfinite_powhr:
     "[| x : HInfinite; 0 < x; a : HFinite - Infinitesimal;
         0 < a |] ==> x powhr a : HInfinite"
apply (auto intro!: starfun_ln_ge_zero starfun_ln_HInfinite HInfinite_HFinite_not_Infinitesimal_mult2 starfun_exp_HInfinite
       simp add: order_less_imp_le HInfinite_gt_zero_gt_one powhr_as_starfun zero_le_mult_iff)
done

lemma hlog_hrabs_HInfinite_Infinitesimal:
     "[| x : HFinite - Infinitesimal; a : HInfinite; 0 < a |]
      ==> hlog a \<bar>x\<bar> : Infinitesimal"
apply (frule HInfinite_gt_zero_gt_one)
apply (auto intro!: starfun_ln_HFinite_not_Infinitesimal
            HInfinite_inverse_Infinitesimal Infinitesimal_HFinite_mult2
        simp add: starfun_ln_HInfinite not_Infinitesimal_not_zero
          hlog_as_starfun divide_inverse)
done

lemma hlog_HInfinite_as_starfun:
     "[| a : HInfinite; 0 < a |] ==> hlog a x = ( *f* ln) x / ( *f* ln) a"
by (rule hlog_as_starfun, auto)

lemma hlog_one [simp]: "!!a. hlog a 1 = 0"
by (transfer, simp)

lemma hlog_eq_one [simp]: "!!a. [| 0 < a; a \<noteq> 1 |] ==> hlog a a = 1"
by (transfer, rule log_eq_one)

lemma hlog_inverse:
     "[| 0 < a; a \<noteq> 1; 0 < x |] ==> hlog a (inverse x) = - hlog a x"
apply (rule add_left_cancel [of "hlog a x", THEN iffD1])
apply (simp add: hlog_mult [symmetric])
done

lemma hlog_divide:
     "[| 0 < a; a \<noteq> 1; 0 < x; 0 < y|] ==> hlog a (x/y) = hlog a x - hlog a y"
by (simp add: hlog_mult hlog_inverse divide_inverse)

lemma hlog_less_cancel_iff [simp]:
     "!!a x y. [| 1 < a; 0 < x; 0 < y |] ==> (hlog a x < hlog a y) = (x < y)"
by (transfer, simp)

lemma hlog_le_cancel_iff [simp]:
     "[| 1 < a; 0 < x; 0 < y |] ==> (hlog a x \<le> hlog a y) = (x \<le> y)"
by (simp add: linorder_not_less [symmetric])

end


(*  Title:      ZF/Constructible/Formula.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {* First-Order Formulas and the Definition of the Class L *}

theory Formula imports Main begin

subsection{*Internalized formulas of FOL*}

text{*De Bruijn representation.
  Unbound variables get their denotations from an environment.*}

consts   formula :: i
datatype
  "formula" = Member ("x \<in> nat", "y \<in> nat")
            | Equal  ("x \<in> nat", "y \<in> nat")
            | Nand ("p \<in> formula", "q \<in> formula")
            | Forall ("p \<in> formula")

declare formula.intros [TC]

definition
  Neg :: "i=>i" where
  "Neg(p) == Nand(p,p)"

definition
  And :: "[i,i]=>i" where
  "And(p,q) == Neg(Nand(p,q))"

definition
  Or :: "[i,i]=>i" where
  "Or(p,q) == Nand(Neg(p),Neg(q))"

definition
  Implies :: "[i,i]=>i" where
  "Implies(p,q) == Nand(p,Neg(q))"

definition
  Iff :: "[i,i]=>i" where
  "Iff(p,q) == And(Implies(p,q), Implies(q,p))"

definition
  Exists :: "i=>i" where
  "Exists(p) == Neg(Forall(Neg(p)))"

lemma Neg_type [TC]: "p \<in> formula ==> Neg(p) \<in> formula"
by (simp add: Neg_def)

lemma And_type [TC]: "[| p \<in> formula; q \<in> formula |] ==> And(p,q) \<in> formula"
by (simp add: And_def)

lemma Or_type [TC]: "[| p \<in> formula; q \<in> formula |] ==> Or(p,q) \<in> formula"
by (simp add: Or_def)

lemma Implies_type [TC]:
     "[| p \<in> formula; q \<in> formula |] ==> Implies(p,q) \<in> formula"
by (simp add: Implies_def)

lemma Iff_type [TC]:
     "[| p \<in> formula; q \<in> formula |] ==> Iff(p,q) \<in> formula"
by (simp add: Iff_def)

lemma Exists_type [TC]: "p \<in> formula ==> Exists(p) \<in> formula"
by (simp add: Exists_def)

consts   satisfies :: "[i,i]=>i"
primrec (*explicit lambda is required because the environment varies*)
  "satisfies(A,Member(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) \<in> nth(y,env)))"

  "satisfies(A,Equal(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) = nth(y,env)))"

  "satisfies(A,Nand(p,q)) =
      (\<lambda>env \<in> list(A). not ((satisfies(A,p)`env) and (satisfies(A,q)`env)))"

  "satisfies(A,Forall(p)) =
      (\<lambda>env \<in> list(A). bool_of_o (\<forall>x\<in>A. satisfies(A,p) ` (Cons(x,env)) = 1))"

lemma "p \<in> formula ==> satisfies(A,p) \<in> list(A) -> bool"
by (induct set: formula) simp_all

abbreviation
  sats :: "[i,i,i] => o" where
  "sats(A,p,env) == satisfies(A,p)`env = 1"

lemma [simp]:
  "env \<in> list(A)
   ==> sats(A, Equal(x,y), env) \<longleftrightarrow> nth(x,env) = nth(y,env)"
by simp

lemma sats_Nand_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Nand(p,q), env)) \<longleftrightarrow> ~ (sats(A,p,env) & sats(A,q,env))"
by (simp add: Bool.and_def Bool.not_def cond_def)

lemma sats_Forall_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Forall(p), env) \<longleftrightarrow> (\<forall>x\<in>A. sats(A, p, Cons(x,env)))"
by simp

declare satisfies.simps [simp del]

subsection{*Dividing line between primitive and derived connectives*}

lemma sats_Neg_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Neg(p), env) \<longleftrightarrow> ~ sats(A,p,env)"
by (simp add: Neg_def)

lemma sats_And_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, And(p,q), env)) \<longleftrightarrow> sats(A,p,env) & sats(A,q,env)"
by (simp add: And_def)

lemma sats_Or_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Or(p,q), env)) \<longleftrightarrow> sats(A,p,env) | sats(A,q,env)"
by (simp add: Or_def)

lemma sats_Implies_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Implies(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longrightarrow> sats(A,q,env))"
by (simp add: Implies_def, blast)

lemma sats_Iff_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Iff(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longleftrightarrow> sats(A,q,env))"
by (simp add: Iff_def, blast)

lemma sats_Exists_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Exists(p), env) \<longleftrightarrow> (\<exists>x\<in>A. sats(A, p, Cons(x,env)))"
by (simp add: Exists_def)

subsubsection{*Derived rules to help build up formulas*}

lemma mem_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; env \<in> list(A)|]
       ==> (x\<in>y) \<longleftrightarrow> sats(A, Member(i,j), env)"
by (simp add: satisfies.simps)

lemma equal_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; env \<in> list(A)|]
       ==> (x=y) \<longleftrightarrow> sats(A, Equal(i,j), env)"
by (simp add: satisfies.simps)

lemma not_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); env \<in> list(A)|]
       ==> (~P) \<longleftrightarrow> sats(A, Neg(p), env)"
by simp

lemma conj_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P & Q) \<longleftrightarrow> sats(A, And(p,q), env)"
by (simp add: sats_And_iff)

lemma disj_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P | Q) \<longleftrightarrow> sats(A, Or(p,q), env)"
by (simp add: sats_Or_iff)

lemma iff_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P \<longleftrightarrow> Q) \<longleftrightarrow> sats(A, Iff(p,q), env)"
by (simp add: sats_Forall_iff)

lemma imp_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P \<longrightarrow> Q) \<longleftrightarrow> sats(A, Implies(p,q), env)"
by (simp add: sats_Forall_iff)

lemma ball_iff_sats:
      "[| !!x. x\<in>A ==> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)|]
       ==> (\<forall>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Forall(p), env)"
by (simp add: sats_Forall_iff)

lemma bex_iff_sats:
      "[| !!x. x\<in>A ==> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)|]
       ==> (\<exists>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Exists(p), env)"
by (simp add: sats_Exists_iff)

lemmas FOL_iff_sats =
        mem_iff_sats equal_iff_sats not_iff_sats conj_iff_sats
        disj_iff_sats imp_iff_sats iff_iff_sats imp_iff_sats ball_iff_sats
        bex_iff_sats

subsection{*Arity of a Formula: Maximum Free de Bruijn Index*}

consts   arity :: "i=>i"
primrec
  "arity(Member(x,y)) = succ(x) \<union> succ(y)"

  "arity(Equal(x,y)) = succ(x) \<union> succ(y)"

  "arity(Nand(p,q)) = arity(p) \<union> arity(q)"

  "arity(Forall(p)) = Arith.pred(arity(p))"

lemma arity_type [TC]: "p \<in> formula ==> arity(p) \<in> nat"
by (induct_tac p, simp_all)

lemma arity_Neg [simp]: "arity(Neg(p)) = arity(p)"
by (simp add: Neg_def)

lemma arity_And [simp]: "arity(And(p,q)) = arity(p) \<union> arity(q)"
by (simp add: And_def)

lemma arity_Or [simp]: "arity(Or(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Or_def)

lemma arity_Implies [simp]: "arity(Implies(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Implies_def)

lemma arity_Iff [simp]: "arity(Iff(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Iff_def, blast)

lemma arity_Exists [simp]: "arity(Exists(p)) = Arith.pred(arity(p))"
by (simp add: Exists_def)

lemma arity_sats_iff [rule_format]:
  "[| p \<in> formula; extra \<in> list(A) |]
   ==> \<forall>env \<in> list(A).
           arity(p) \<le> length(env) \<longrightarrow>
           sats(A, p, env @ extra) \<longleftrightarrow> sats(A, p, env)"
apply (induct_tac p)
apply (simp_all add: Arith.pred_def nth_append Un_least_lt_iff nat_imp_quasinat
                split: split_nat_case, auto)
done

lemma arity_sats1_iff:
  "[| arity(p) \<le> succ(length(env)); p \<in> formula; x \<in> A; env \<in> list(A);
      extra \<in> list(A) |]
   ==> sats(A, p, Cons(x, env @ extra)) \<longleftrightarrow> sats(A, p, Cons(x, env))"
apply (insert arity_sats_iff [of p extra A "Cons(x,env)"])
apply simp
done

subsection{*Renaming Some de Bruijn Variables*}

definition
  incr_var :: "[i,i]=>i" where
  "incr_var(x,nq) == if x<nq then x else succ(x)"

lemma incr_var_lt: "x<nq ==> incr_var(x,nq) = x"
by (simp add: incr_var_def)

lemma incr_var_le: "nq\<le>x ==> incr_var(x,nq) = succ(x)"
apply (simp add: incr_var_def)
apply (blast dest: lt_trans1)
done

consts   incr_bv :: "i=>i"
primrec
  "incr_bv(Member(x,y)) =
      (\<lambda>nq \<in> nat. Member (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Equal(x,y)) =
      (\<lambda>nq \<in> nat. Equal (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Nand(p,q)) =
      (\<lambda>nq \<in> nat. Nand (incr_bv(p)`nq, incr_bv(q)`nq))"

  "incr_bv(Forall(p)) =
      (\<lambda>nq \<in> nat. Forall (incr_bv(p) ` succ(nq)))"

lemma [TC]: "x \<in> nat ==> incr_var(x,nq) \<in> nat"
by (simp add: incr_var_def)

lemma incr_bv_type [TC]: "p \<in> formula ==> incr_bv(p) \<in> nat -> formula"
by (induct_tac p, simp_all)

text{*Obviously, @{term DPow} is closed under complements and finite
intersections and unions.  Needs an inductive lemma to allow two lists of
parameters to be combined.*}

lemma sats_incr_bv_iff [rule_format]:
  "[| p \<in> formula; env \<in> list(A); x \<in> A |]
   ==> \<forall>bvs \<in> list(A).
           sats(A, incr_bv(p) ` length(bvs), bvs @ Cons(x,env)) \<longleftrightarrow>
           sats(A, p, bvs@env)"
apply (induct_tac p)
apply (simp_all add: incr_var_def nth_append succ_lt_iff length_type)
apply (auto simp add: diff_succ not_lt_iff_le)
done

(*the following two lemmas prevent huge case splits in arity_incr_bv_lemma*)
lemma incr_var_lemma:
     "[| x \<in> nat; y \<in> nat; nq \<le> x |]
      ==> succ(x) \<union> incr_var(y,nq) = succ(x \<union> y)"
apply (simp add: incr_var_def Ord_Un_if, auto)
  apply (blast intro: leI)
 apply (simp add: not_lt_iff_le)
 apply (blast intro: le_anti_sym)
apply (blast dest: lt_trans2)
done

lemma incr_And_lemma:
     "y < x ==> y \<union> succ(x) = succ(x \<union> y)"
apply (simp add: Ord_Un_if lt_Ord lt_Ord2 succ_lt_iff)
apply (blast dest: lt_asym)
done

lemma arity_incr_bv_lemma [rule_format]:
  "p \<in> formula
   ==> \<forall>n \<in> nat. arity (incr_bv(p) ` n) =
                 (if n < arity(p) then succ(arity(p)) else arity(p))"
apply (induct_tac p)
apply (simp_all add: imp_disj not_lt_iff_le Un_least_lt_iff lt_Un_iff le_Un_iff
                     succ_Un_distrib [symmetric] incr_var_lt incr_var_le
                     Un_commute incr_var_lemma Arith.pred_def nat_imp_quasinat
            split: split_nat_case)
 txt{*the Forall case reduces to linear arithmetic*}
 prefer 2
 apply clarify
 apply (blast dest: lt_trans1)
txt{*left with the And case*}
apply safe
 apply (blast intro: incr_And_lemma lt_trans1)
apply (subst incr_And_lemma)
 apply (blast intro: lt_trans1)
apply (simp add: Un_commute)
done

subsection{*Renaming all but the First de Bruijn Variable*}

definition
  incr_bv1 :: "i => i" where
  "incr_bv1(p) == incr_bv(p)`1"

lemma incr_bv1_type [TC]: "p \<in> formula ==> incr_bv1(p) \<in> formula"
by (simp add: incr_bv1_def)

(*For renaming all but the bound variable at level 0*)
lemma sats_incr_bv1_iff:
  "[| p \<in> formula; env \<in> list(A); x \<in> A; y \<in> A |]
   ==> sats(A, incr_bv1(p), Cons(x, Cons(y, env))) \<longleftrightarrow>
       sats(A, p, Cons(x,env))"
apply (insert sats_incr_bv_iff [of p env A y "Cons(x,Nil)"])
apply (simp add: incr_bv1_def)
done

lemma formula_add_params1 [rule_format]:
  "[| p \<in> formula; n \<in> nat; x \<in> A |]
   ==> \<forall>bvs \<in> list(A). \<forall>env \<in> list(A).
          length(bvs) = n \<longrightarrow>
          sats(A, iterates(incr_bv1, n, p), Cons(x, bvs@env)) \<longleftrightarrow>
          sats(A, p, Cons(x,env))"
apply (induct_tac n, simp, clarify)
apply (erule list.cases)
apply (simp_all add: sats_incr_bv1_iff)
done

lemma arity_incr_bv1_eq:
  "p \<in> formula
   ==> arity(incr_bv1(p)) =
        (if 1 < arity(p) then succ(arity(p)) else arity(p))"
apply (insert arity_incr_bv_lemma [of p 1])
apply (simp add: incr_bv1_def)
done

lemma arity_iterates_incr_bv1_eq:
  "[| p \<in> formula; n \<in> nat |]
   ==> arity(incr_bv1^n(p)) =
         (if 1 < arity(p) then n #+ arity(p) else arity(p))"
apply (induct_tac n)
apply (simp_all add: arity_incr_bv1_eq)
apply (simp add: not_lt_iff_le)
apply (blast intro: le_trans add_le_self2 arity_type)
done

subsection{*Definable Powerset*}

text{*The definable powerset operation: Kunen's definition VI 1.1, page 165.*}
definition
  DPow :: "i => i" where
  "DPow(A) == {X \<in> Pow(A).
               \<exists>env \<in> list(A). \<exists>p \<in> formula.
                 arity(p) \<le> succ(length(env)) &
                 X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPowI:
  "[|env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))|]
   ==> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (simp add: DPow_def, blast)

text{*With this rule we can specify @{term p} later.*}
lemma DPowI2 [rule_format]:
  "[|\<forall>x\<in>A. P(x) \<longleftrightarrow> sats(A, p, Cons(x,env));
     env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))|]
   ==> {x\<in>A. P(x)} \<in> DPow(A)"
by (simp add: DPow_def, blast)

lemma DPowD:
  "X \<in> DPow(A)
   ==> X \<subseteq> A &
       (\<exists>env \<in> list(A).
        \<exists>p \<in> formula. arity(p) \<le> succ(length(env)) &
                      X = {x\<in>A. sats(A, p, Cons(x,env))})"
by (simp add: DPow_def)

lemmas DPow_imp_subset = DPowD [THEN conjunct1]

(*Kunen's Lemma VI 1.2*)
lemma "[| p \<in> formula; env \<in> list(A); arity(p) \<le> succ(length(env)) |]
       ==> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (blast intro: DPowI)

lemma DPow_subset_Pow: "DPow(A) \<subseteq> Pow(A)"
by (simp add: DPow_def, blast)

lemma empty_in_DPow: "0 \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Neg(Equal(0,0))" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Compl_in_DPow: "X \<in> DPow(A) ==> (A-X) \<in> DPow(A)"
apply (simp add: DPow_def, clarify, auto)
apply (rule bexI)
 apply (rule_tac x="Neg(p)" in bexI)
  apply auto
done

lemma Int_in_DPow: "[| X \<in> DPow(A); Y \<in> DPow(A) |] ==> X \<inter> Y \<in> DPow(A)"
apply (simp add: DPow_def, auto)
apply (rename_tac envp p envq q)
apply (rule_tac x="envp@envq" in bexI)
 apply (rule_tac x="And(p, iterates(incr_bv1,length(envp),q))" in bexI)
  apply typecheck
apply (rule conjI)
(*finally check the arity!*)
 apply (simp add: arity_iterates_incr_bv1_eq length_app Un_least_lt_iff)
 apply (force intro: add_le_self le_trans)
apply (simp add: arity_sats1_iff formula_add_params1, blast)
done

lemma Un_in_DPow: "[| X \<in> DPow(A); Y \<in> DPow(A) |] ==> X \<union> Y \<in> DPow(A)"
apply (subgoal_tac "X \<union> Y = A - ((A-X) \<inter> (A-Y))")
apply (simp add: Int_in_DPow Compl_in_DPow)
apply (simp add: DPow_def, blast)
done

lemma singleton_in_DPow: "a \<in> A ==> {a} \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x="Cons(a,Nil)" in bexI)
 apply (rule_tac x="Equal(0,1)" in bexI)
  apply typecheck
apply (force simp add: succ_Un_distrib [symmetric])
done

lemma cons_in_DPow: "[| a \<in> A; X \<in> DPow(A) |] ==> cons(a,X) \<in> DPow(A)"
apply (rule cons_eq [THEN subst])
apply (blast intro: singleton_in_DPow Un_in_DPow)
done

(*Part of Lemma 1.3*)
lemma Fin_into_DPow: "X \<in> Fin(A) ==> X \<in> DPow(A)"
apply (erule Fin.induct)
 apply (rule empty_in_DPow)
apply (blast intro: cons_in_DPow)
done

text{*@{term DPow} is not monotonic.  For example, let @{term A} be some
non-constructible set of natural numbers, and let @{term B} be @{term nat}.
Then @{term "A<=B"} and obviously @{term "A \<in> DPow(A)"} but @{term "A \<notin>
DPow(B)"}.*}

(*This may be true but the proof looks difficult, requiring relativization
lemma DPow_insert: "DPow (cons(a,A)) = DPow(A) \<union> {cons(a,X) . X \<in> DPow(A)}"
apply (rule equalityI, safe)
oops
*)

lemma Finite_Pow_subset_Pow: "Finite(A) ==> Pow(A) \<subseteq> DPow(A)"
by (blast intro: Fin_into_DPow Finite_into_Fin Fin_subset)

lemma Finite_DPow_eq_Pow: "Finite(A) ==> DPow(A) = Pow(A)"
apply (rule equalityI)
apply (rule DPow_subset_Pow)
apply (erule Finite_Pow_subset_Pow)
done

subsection{*Internalized Formulas for the Ordinals*}

text{*The @{text sats} theorems below differ from the usual form in that they
include an element of absoluteness.  That is, they relate internalized
formulas to real concepts such as the subset relation, rather than to the
relativized concepts defined in theory @{text Relative}.  This lets us prove
the theorem as @{text Ords_in_DPow} without first having to instantiate the
locale @{text M_trivial}.  Note that the present theory does not even take
@{text Relative} as a parent.*}

subsubsection{*The subset relation*}

definition
  subset_fm :: "[i,i]=>i" where
  "subset_fm(x,y) == Forall(Implies(Member(0,succ(x)), Member(0,succ(y))))"

lemma subset_type [TC]: "[| x \<in> nat; y \<in> nat |] ==> subset_fm(x,y) \<in> formula"
by (simp add: subset_fm_def)

lemma arity_subset_fm [simp]:
     "[| x \<in> nat; y \<in> nat |] ==> arity(subset_fm(x,y)) = succ(x) \<union> succ(y)"
by (simp add: subset_fm_def succ_Un_distrib [symmetric])

lemma sats_subset_fm [simp]:
   "[|x < length(env); y \<in> nat; env \<in> list(A); Transset(A)|]
    ==> sats(A, subset_fm(x,y), env) \<longleftrightarrow> nth(x,env) \<subseteq> nth(y,env)"
apply (frule lt_length_in_nat, assumption)
apply (simp add: subset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection{*Transitive sets*}

definition
  transset_fm :: "i=>i" where
  "transset_fm(x) == Forall(Implies(Member(0,succ(x)), subset_fm(0,succ(x))))"

lemma transset_type [TC]: "x \<in> nat ==> transset_fm(x) \<in> formula"
by (simp add: transset_fm_def)

lemma arity_transset_fm [simp]:
     "x \<in> nat ==> arity(transset_fm(x)) = succ(x)"
by (simp add: transset_fm_def succ_Un_distrib [symmetric])

lemma sats_transset_fm [simp]:
   "[|x < length(env); env \<in> list(A); Transset(A)|]
    ==> sats(A, transset_fm(x), env) \<longleftrightarrow> Transset(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: transset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection{*Ordinals*}

definition
  ordinal_fm :: "i=>i" where
  "ordinal_fm(x) ==
    And(transset_fm(x), Forall(Implies(Member(0,succ(x)), transset_fm(0))))"

lemma ordinal_type [TC]: "x \<in> nat ==> ordinal_fm(x) \<in> formula"
by (simp add: ordinal_fm_def)

lemma arity_ordinal_fm [simp]:
     "x \<in> nat ==> arity(ordinal_fm(x)) = succ(x)"
by (simp add: ordinal_fm_def succ_Un_distrib [symmetric])

lemma sats_ordinal_fm:
   "[|x < length(env); env \<in> list(A); Transset(A)|]
    ==> sats(A, ordinal_fm(x), env) \<longleftrightarrow> Ord(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: ordinal_fm_def Ord_def Transset_def)
apply (blast intro: nth_type)
done

text{*The subset consisting of the ordinals is definable.  Essential lemma for
@{text Ord_in_Lset}.  This result is the objective of the present subsection.*}
theorem Ords_in_DPow: "Transset(A) ==> {x \<in> A. Ord(x)} \<in> DPow(A)"
apply (simp add: DPow_def Collect_subset)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="ordinal_fm(0)" in bexI)
apply (simp_all add: sats_ordinal_fm)
done

subsection{* Constant Lset: Levels of the Constructible Universe *}

definition
  Lset :: "i=>i" where
  "Lset(i) == transrec(i, %x f. \<Union>y\<in>x. DPow(f`y))"

definition
  L :: "i=>o" where --{*Kunen's definition VI 1.5, page 167*}
  "L(x) == \<exists>i. Ord(i) & x \<in> Lset(i)"

text{*NOT SUITABLE FOR REWRITING -- RECURSIVE!*}
lemma Lset: "Lset(i) = (\<Union>j\<in>i. DPow(Lset(j)))"
by (subst Lset_def [THEN def_transrec], simp)

lemma LsetI: "[|y\<in>x; A \<in> DPow(Lset(y))|] ==> A \<in> Lset(x)"
by (subst Lset, blast)

lemma LsetD: "A \<in> Lset(x) ==> \<exists>y\<in>x. A \<in> DPow(Lset(y))"
apply (insert Lset [of x])
apply (blast intro: elim: equalityE)
done

subsubsection{* Transitivity *}

lemma elem_subset_in_DPow: "[|X \<in> A; X \<subseteq> A|] ==> X \<in> DPow(A)"
apply (simp add: Transset_def DPow_def)
apply (rule_tac x="[X]" in bexI)
 apply (rule_tac x="Member(0,1)" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Transset_subset_DPow: "Transset(A) ==> A \<subseteq> DPow(A)"
apply clarify
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow)
done

lemma Transset_DPow: "Transset(A) ==> Transset(DPow(A))"
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow dest: DPowD)
done

text{*Kunen's VI 1.6 (a)*}
lemma Transset_Lset: "Transset(Lset(i))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (blast intro!: Transset_Union_family Transset_Un Transset_DPow)
done

lemma mem_Lset_imp_subset_Lset: "a \<in> Lset(i) ==> a \<subseteq> Lset(i)"
apply (insert Transset_Lset)
apply (simp add: Transset_def)
done

subsubsection{* Monotonicity *}

text{*Kunen's VI 1.6 (b)*}
lemma Lset_mono [rule_format]:
     "\<forall>j. i<=j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<subseteq> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<subseteq> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of x] Lset [of j])
qed

text{*This version lets us remove the premise @{term "Ord(i)"} sometimes.*}
lemma Lset_mono_mem [rule_format]:
     "\<forall>j. i \<in> j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<in> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<in> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of j]
              intro!: bexI intro: elem_subset_in_DPow dest: LsetD DPowD)
qed

text{*Useful with Reflection to bump up the ordinal*}
lemma subset_Lset_ltD: "[|A \<subseteq> Lset(i); i < j|] ==> A \<subseteq> Lset(j)"
by (blast dest: ltD [THEN Lset_mono_mem])

subsubsection{* 0, successor and limit equations for Lset *}

lemma Lset_0 [simp]: "Lset(0) = 0"
by (subst Lset, blast)

lemma Lset_succ_subset1: "DPow(Lset(i)) \<subseteq> Lset(succ(i))"
by (subst Lset, rule succI1 [THEN RepFunI, THEN Union_upper])

lemma Lset_succ_subset2: "Lset(succ(i)) \<subseteq> DPow(Lset(i))"
apply (subst Lset, rule UN_least)
apply (erule succE)
 apply blast
apply clarify
apply (rule elem_subset_in_DPow)
 apply (subst Lset)
 apply blast
apply (blast intro: dest: DPowD Lset_mono_mem)
done

lemma Lset_succ: "Lset(succ(i)) = DPow(Lset(i))"
by (intro equalityI Lset_succ_subset1 Lset_succ_subset2)

lemma Lset_Union [simp]: "Lset(\<Union>(X)) = (\<Union>y\<in>X. Lset(y))"
apply (subst Lset)
apply (rule equalityI)
 txt{*first inclusion*}
 apply (rule UN_least)
 apply (erule UnionE)
 apply (rule subset_trans)
  apply (erule_tac [2] UN_upper, subst Lset, erule UN_upper)
txt{*opposite inclusion*}
apply (rule UN_least)
apply (subst Lset, blast)
done

subsubsection{* Lset applied to Limit ordinals *}

lemma Limit_Lset_eq:
    "Limit(i) ==> Lset(i) = (\<Union>y\<in>i. Lset(y))"
by (simp add: Lset_Union [symmetric] Limit_Union_eq)

lemma lt_LsetI: "[| a \<in> Lset(j);  j<i |] ==> a \<in> Lset(i)"
by (blast dest: Lset_mono [OF le_imp_subset [OF leI]])

lemma Limit_LsetE:
    "[| a \<in> Lset(i);  ~R ==> Limit(i);
        !!x. [| x<i;  a \<in> Lset(x) |] ==> R
     |] ==> R"
apply (rule classical)
apply (rule Limit_Lset_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI  Limit_is_Ord)
done

subsubsection{* Basic closure properties *}

lemma zero_in_Lset: "y \<in> x ==> 0 \<in> Lset(x)"
by (subst Lset, blast intro: empty_in_DPow)

lemma notin_Lset: "x \<notin> Lset(x)"
apply (rule_tac a=x in eps_induct)
apply (subst Lset)
apply (blast dest: DPowD)
done

subsection{*Constructible Ordinals: Kunen's VI 1.9 (b)*}

lemma Ords_of_Lset_eq: "Ord(i) ==> {x\<in>Lset(i). Ord(x)} = i"
apply (erule trans_induct3)
  apply (simp_all add: Lset_succ Limit_Lset_eq Limit_Union_eq)
txt{*The successor case remains.*}
apply (rule equalityI)
txt{*First inclusion*}
 apply clarify
 apply (erule Ord_linear_lt, assumption)
   apply (blast dest: DPow_imp_subset ltD notE [OF notin_Lset])
  apply blast
 apply (blast dest: ltD)
txt{*Opposite inclusion, @{term "succ(x) \<subseteq> DPow(Lset(x)) \<inter> ON"}*}
apply auto
txt{*Key case: *}
  apply (erule subst, rule Ords_in_DPow [OF Transset_Lset])
 apply (blast intro: elem_subset_in_DPow dest: OrdmemD elim: equalityE)
apply (blast intro: Ord_in_Ord)
done

lemma Ord_subset_Lset: "Ord(i) ==> i \<subseteq> Lset(i)"
by (subst Ords_of_Lset_eq [symmetric], assumption, fast)

lemma Ord_in_Lset: "Ord(i) ==> i \<in> Lset(succ(i))"
apply (simp add: Lset_succ)
apply (subst Ords_of_Lset_eq [symmetric], assumption,
       rule Ords_in_DPow [OF Transset_Lset])
done

lemma Ord_in_L: "Ord(i) ==> L(i)"
by (simp add: L_def, blast intro: Ord_in_Lset)

subsubsection{* Unions *}

lemma Union_in_Lset:
     "X \<in> Lset(i) ==> \<Union>(X) \<in> Lset(succ(i))"
apply (insert Transset_Lset)
apply (rule LsetI [OF succI1])
apply (simp add: Transset_def DPow_def)
apply (intro conjI, blast)
txt{*Now to create the formula @{term "\<exists>y. y \<in> X \<and> x \<in> y"} *}
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="Exists(And(Member(0,2), Member(1,0)))" in bexI)
  apply typecheck
apply (simp add: succ_Un_distrib [symmetric], blast)
done

theorem Union_in_L: "L(X) ==> L(\<Union>(X))"
by (simp add: L_def, blast dest: Union_in_Lset)

subsubsection{* Finite sets and ordered pairs *}

lemma singleton_in_Lset: "a \<in> Lset(i) ==> {a} \<in> Lset(succ(i))"
by (simp add: Lset_succ singleton_in_DPow)

lemma doubleton_in_Lset:
     "[| a \<in> Lset(i);  b \<in> Lset(i) |] ==> {a,b} \<in> Lset(succ(i))"
by (simp add: Lset_succ empty_in_DPow cons_in_DPow)

lemma Pair_in_Lset:
    "[| a \<in> Lset(i);  b \<in> Lset(i); Ord(i) |] ==> <a,b> \<in> Lset(succ(succ(i)))"
apply (unfold Pair_def)
apply (blast intro: doubleton_in_Lset)
done

lemmas Lset_UnI1 = Un_upper1 [THEN Lset_mono [THEN subsetD]]
lemmas Lset_UnI2 = Un_upper2 [THEN Lset_mono [THEN subsetD]]

text{*Hard work is finding a single @{term"j \<in> i"} such that @{term"{a,b} \<subseteq> Lset(j)"}*}
lemma doubleton_in_LLimit:
    "[| a \<in> Lset(i);  b \<in> Lset(i);  Limit(i) |] ==> {a,b} \<in> Lset(i)"
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
apply (blast intro: lt_LsetI [OF doubleton_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

theorem doubleton_in_L: "[| L(a); L(b) |] ==> L({a, b})"
apply (simp add: L_def, clarify)
apply (drule Ord2_imp_greater_Limit, assumption)
apply (blast intro: lt_LsetI doubleton_in_LLimit Limit_is_Ord)
done

lemma Pair_in_LLimit:
    "[| a \<in> Lset(i);  b \<in> Lset(i);  Limit(i) |] ==> <a,b> \<in> Lset(i)"
txt{*Infer that a, b occur at ordinals x,xa < i.*}
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
txt{*Infer that @{term"succ(succ(x \<union> xa)) < i"} *}
apply (blast intro: lt_Ord lt_LsetI [OF Pair_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

text{*The rank function for the constructible universe*}
definition
  lrank :: "i=>i" where --{*Kunen's definition VI 1.7*}
  "lrank(x) == \<mu> i. x \<in> Lset(succ(i))"

lemma L_I: "[|x \<in> Lset(i); Ord(i)|] ==> L(x)"
by (simp add: L_def, blast)

lemma L_D: "L(x) ==> \<exists>i. Ord(i) & x \<in> Lset(i)"
by (simp add: L_def)

lemma Ord_lrank [simp]: "Ord(lrank(a))"
by (simp add: lrank_def)

lemma Lset_lrank_lt [rule_format]: "Ord(i) ==> x \<in> Lset(i) \<longrightarrow> lrank(x) < i"
apply (erule trans_induct3)
  apply simp
 apply (simp only: lrank_def)
 apply (blast intro: Least_le)
apply (simp_all add: Limit_Lset_eq)
apply (blast intro: ltI Limit_is_Ord lt_trans)
done

text{*Kunen's VI 1.8.  The proof is much harder than the text would
suggest.  For a start, it needs the previous lemma, which is proved by
induction.*}
lemma Lset_iff_lrank_lt: "Ord(i) ==> x \<in> Lset(i) \<longleftrightarrow> L(x) & lrank(x) < i"
apply (simp add: L_def, auto)
 apply (blast intro: Lset_lrank_lt)
 apply (unfold lrank_def)
apply (drule succI1 [THEN Lset_mono_mem, THEN subsetD])
apply (drule_tac P="\<lambda>i. x \<in> Lset(succ(i))" in LeastI, assumption)
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

lemma Lset_succ_lrank_iff [simp]: "x \<in> Lset(succ(lrank(x))) \<longleftrightarrow> L(x)"
by (simp add: Lset_iff_lrank_lt)

text{*Kunen's VI 1.9 (a)*}
lemma lrank_of_Ord: "Ord(i) ==> lrank(i) = i"
apply (unfold lrank_def)
apply (rule Least_equality)
  apply (erule Ord_in_Lset)
 apply assumption
apply (insert notin_Lset [of i])
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

text{*This is lrank(lrank(a)) = lrank(a) *}
declare Ord_lrank [THEN lrank_of_Ord, simp]

text{*Kunen's VI 1.10 *}
lemma Lset_in_Lset_succ: "Lset(i) \<in> Lset(succ(i))"
apply (simp add: Lset_succ DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Equal(0,0)" in bexI)
apply auto
done

lemma lrank_Lset: "Ord(i) ==> lrank(Lset(i)) = i"
apply (unfold lrank_def)
apply (rule Least_equality)
  apply (rule Lset_in_Lset_succ)
 apply assumption
apply clarify
apply (subgoal_tac "Lset(succ(ia)) \<subseteq> Lset(i)")
 apply (blast dest: mem_irrefl)
apply (blast intro!: le_imp_subset Lset_mono)
done

text{*Kunen's VI 1.11 *}
lemma Lset_subset_Vset: "Ord(i) ==> Lset(i) \<subseteq> Vset(i)"
apply (erule trans_induct)
apply (subst Lset)
apply (subst Vset)
apply (rule UN_mono [OF subset_refl])
apply (rule subset_trans [OF DPow_subset_Pow])
apply (rule Pow_mono, blast)
done

text{*Kunen's VI 1.12 *}
lemma Lset_subset_Vset': "i \<in> nat ==> Lset(i) = Vset(i)"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Lset_succ Vset_succ Finite_Vset Finite_DPow_eq_Pow)
done

text{*Every set of constructible sets is included in some @{term Lset}*}
lemma subset_Lset:
     "(\<forall>x\<in>A. L(x)) ==> \<exists>i. Ord(i) & A \<subseteq> Lset(i)"
by (rule_tac x = "\<Union>x\<in>A. succ(lrank(x))" in exI, force)

lemma subset_LsetE:
     "[|\<forall>x\<in>A. L(x);
        !!i. [|Ord(i); A \<subseteq> Lset(i)|] ==> P|]
      ==> P"
by (blast dest: subset_Lset)

subsubsection{*For L to satisfy the Powerset axiom *}

lemma LPow_env_typing:
    "[| y \<in> Lset(i); Ord(i); y \<subseteq> X |]
     ==> \<exists>z \<in> Pow(X). y \<in> Lset(succ(lrank(z)))"
by (auto intro: L_I iff: Lset_succ_lrank_iff)

lemma LPow_in_Lset:
     "[|X \<in> Lset(i); Ord(i)|] ==> \<exists>j. Ord(j) & {y \<in> Pow(X). L(y)} \<in> Lset(j)"
apply (rule_tac x="succ(\<Union>y \<in> Pow(X). succ(lrank(y)))" in exI)
apply simp
apply (rule LsetI [OF succI1])
apply (simp add: DPow_def)
apply (intro conjI, clarify)
 apply (rule_tac a=x in UN_I, simp+)
txt{*Now to create the formula @{term "y \<subseteq> X"} *}
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="subset_fm(0,1)" in bexI)
  apply typecheck
 apply (rule conjI)
apply (simp add: succ_Un_distrib [symmetric])
apply (rule equality_iffI)
apply (simp add: Transset_UN [OF Transset_Lset] LPow_env_typing)
apply (auto intro: L_I iff: Lset_succ_lrank_iff)
done

theorem LPow_in_L: "L(X) ==> L({y \<in> Pow(X). L(y)})"
by (blast intro: L_I dest: L_D LPow_in_Lset)

subsection{*Eliminating @{term arity} from the Definition of @{term Lset}*}

lemma nth_zero_eq_0: "n \<in> nat ==> nth(n,[0]) = 0"
by (induct_tac n, auto)

lemma sats_app_0_iff [rule_format]:
  "[| p \<in> formula; 0 \<in> A |]
   ==> \<forall>env \<in> list(A). sats(A,p, env@[0]) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac p)
apply (simp_all del: app_Cons add: app_Cons [symmetric]
                add: nth_zero_eq_0 nth_append not_lt_iff_le nth_eq_0)
done

lemma sats_app_zeroes_iff:
  "[| p \<in> formula; 0 \<in> A; env \<in> list(A); n \<in> nat |]
   ==> sats(A,p,env @ repeat(0,n)) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac n, simp)
apply (simp del: repeat.simps
            add: repeat_succ_app sats_app_0_iff app_assoc [symmetric])
done

lemma exists_bigger_env:
  "[| p \<in> formula; 0 \<in> A; env \<in> list(A) |]
   ==> \<exists>env' \<in> list(A). arity(p) \<le> succ(length(env')) &
              (\<forall>a\<in>A. sats(A,p,Cons(a,env')) \<longleftrightarrow> sats(A,p,Cons(a,env)))"
apply (rule_tac x="env @ repeat(0,arity(p))" in bexI)
apply (simp del: app_Cons add: app_Cons [symmetric]
            add: length_repeat sats_app_zeroes_iff, typecheck)
done

text{*A simpler version of @{term DPow}: no arity check!*}
definition
  DPow' :: "i => i" where
  "DPow'(A) == {X \<in> Pow(A).
                \<exists>env \<in> list(A). \<exists>p \<in> formula.
                    X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPow_subset_DPow': "DPow(A) \<subseteq> DPow'(A)"
by (simp add: DPow_def DPow'_def, blast)

lemma DPow'_0: "DPow'(0) = {0}"
by (auto simp add: DPow'_def)

lemma DPow'_subset_DPow: "0 \<in> A ==> DPow'(A) \<subseteq> DPow(A)"
apply (auto simp add: DPow'_def DPow_def)
apply (frule exists_bigger_env, assumption+, force)
done

lemma DPow_eq_DPow': "Transset(A) ==> DPow(A) = DPow'(A)"
apply (drule Transset_0_disj)
apply (erule disjE)
 apply (simp add: DPow'_0 Finite_DPow_eq_Pow)
apply (rule equalityI)
 apply (rule DPow_subset_DPow')
apply (erule DPow'_subset_DPow)
done

text{*And thus we can relativize @{term Lset} without bothering with
      @{term arity} and @{term length}*}
lemma Lset_eq_transrec_DPow': "Lset(i) = transrec(i, %x f. \<Union>y\<in>x. DPow'(f`y))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (subst transrec)
apply (simp only: DPow_eq_DPow' [OF Transset_Lset], simp)
done

text{*With this rule we can specify @{term p} later and don't worry about
      arities at all!*}
lemma DPow_LsetI [rule_format]:
  "[|\<forall>x\<in>Lset(i). P(x) \<longleftrightarrow> sats(Lset(i), p, Cons(x,env));
     env \<in> list(Lset(i));  p \<in> formula|]
   ==> {x\<in>Lset(i). P(x)} \<in> DPow(Lset(i))"
by (simp add: DPow_eq_DPow' [OF Transset_Lset] DPow'_def, blast)

end


theory Mergeable_Facts imports Mergeable
begin

(* Assorted useful extra lemmas about Pord and Mergeable.
 *)

lemma ub_union1 :
  assumes Hsup1 : "is_ub S1 x1"
  assumes Hsup2 : "is_ub S2 x2"
  assumes HsupU : "is_ub {x1, x2} x'"
  shows "is_ub (S1 \<union> S2) x'"
proof(rule is_ubI)
  fix x
  assume Hx : "x \<in> S1 \<union> S2"
  then consider (1) "x \<in> S1" | (2) "x \<in> S2" by auto
  then show "x <[ x'"
  proof cases
    case 1
    then have Leq1 : "x <[ x1" using Hsup1 by(auto simp add: is_ub_def)
    have Leq2 : "x1 <[ x'" using HsupU by(auto simp add: is_ub_def)
    then show ?thesis using leq_trans[OF Leq1 Leq2] by auto
  next
    case 2
    then have Leq1 : "x <[ x2" using Hsup2 by(auto simp add: is_ub_def)
    have Leq2 : "x2 <[ x'" using HsupU by(auto simp add: is_ub_def)
    then show ?thesis using leq_trans[OF Leq1 Leq2] by auto
  qed
qed

lemma sup_union1 :
  assumes Hsup1 : "is_sup S1 x1"
  assumes Hsup2 : "is_sup S2 x2"
  assumes HsupU : "is_sup {x1, x2} x'"
  shows "is_sup (S1 \<union> S2) x'"
proof(rule is_supI)
  fix x
  assume Hx : "x \<in> S1 \<union> S2"
  consider (1) "x \<in> S1" |
           (2) "x \<in> S2" using Hx by auto
  then show "x <[ x'"
  proof cases
    case 1
    then show ?thesis using is_supD1[OF Hsup1 1] is_supD1[OF HsupU, of x1]
      by(auto simp add: leq_trans[of x x1])
  next
    case 2
    then show ?thesis using is_supD1[OF Hsup2 2] is_supD1[OF HsupU, of x2]
      by(auto simp add: leq_trans[of x x2])
  qed
next
  fix x'a
  assume Hx'a : "is_ub (S1 \<union> S2) x'a"

  have "is_ub S1 x'a" using Hx'a
    by(auto simp add: is_ub_def)

  hence Ub1: "x1 <[ x'a"
    using is_supD2[OF Hsup1] by auto

  have "is_ub S2 x'a" using Hx'a
    by(auto simp add: is_ub_def)

  hence Ub2: "x2 <[ x'a"
    using is_supD2[OF Hsup2] by auto

  have "is_ub {x1, x2} x'a" using Ub1 Ub2
    by(auto simp add: is_ub_def)

  thus "x' <[ x'a"
    using is_supD2[OF HsupU] by auto
qed

lemma ub_union2 :
  assumes Hsup1 : "is_sup S1 x1"
  assumes Hsup2 : "is_sup S2 x2"
  assumes HsupU : "is_ub (S1 \<union> S2) x'"
  shows HsupU : "is_ub {x1, x2} x'"
proof(rule is_ubI)
  fix x

  assume Hx : "x \<in> {x1, x2}"

  then consider (1) "x = x1" | (2) "x = x2"
    by auto

  then show "x <[ x'"
  proof cases
    case 1
    have "is_ub S1 x'"
      using HsupU by(auto simp add: is_ub_def)
    thus ?thesis using is_supD2[OF Hsup1] 1 by auto
  next
    case 2
    have "is_ub S2 x'"
      using HsupU by(auto simp add: is_ub_def)
    thus ?thesis using is_supD2[OF Hsup2] 2 by auto
  qed
qed

lemma sup_union2 :
  assumes Hsup1 : "is_sup S1 x1"
  assumes Hsup2 : "is_sup S2 x2"
  assumes HsupU : "is_sup (S1 \<union> S2) x'"
  shows "is_sup {x1, x2} x'"
proof(rule is_supI)
  fix x
  assume Hx : "x \<in> {x1, x2}"

  then consider (1) "x = x1" | (2) "x = x2"
    by auto

  then show "x <[ x'"
  proof cases
    case 1
    have "is_ub S1 x'"
      using is_supD1[OF HsupU] by(auto simp add: is_ub_def)
    thus ?thesis using is_supD2[OF Hsup1] 1 by auto
  next
    case 2
    have "is_ub S2 x'"
      using is_supD1[OF HsupU] by(auto simp add: is_ub_def)
    thus ?thesis using is_supD2[OF Hsup2] 2 by auto
  qed
next
  fix x'a
  assume Hx'a : "is_ub {x1, x2} x'a"

  have "is_ub (S1 \<union> S2) x'a"
  proof(rule is_ubI)
    fix x
    assume Hx : "x \<in> S1 \<union> S2"
    then consider (1) "x \<in> S1" | (2) "x \<in> S2" by auto
    then show "x <[ x'a"
    proof cases
      case 1
      hence Leq1 : "x <[ x1" using is_supD1[OF Hsup1] by auto
      have Leq2 : "x1 <[ x'a" using Hx'a by(auto simp add: is_ub_def)
      show ?thesis
        using leq_trans[OF Leq1 Leq2] by auto
    next
      case 2
      hence Leq1 : "x <[ x2" using is_supD1[OF Hsup2] by auto
      have Leq2 : "x2 <[ x'a" using Hx'a by(auto simp add: is_ub_def)
      show ?thesis
        using leq_trans[OF Leq1 Leq2] by auto
    qed
  qed

  thus "x' <[ x'a"
    using is_supD2[OF HsupU] by auto
qed

lemma finite_complete :
  fixes S :: "('b :: Pordc) set"
  fixes x :: "'b"
  assumes Hfin : "finite S"
  assumes Hx : "x \<in> S"
  assumes Hub : "is_ub S sub"
  shows "\<exists> ssup . is_sup S ssup" using assms
proof(induction S arbitrary: x sub)
  case empty
  then show ?case
    by auto
next
  case (insert x1 S')
  show ?case
  proof(cases "S' = {}")
    case True
    then have "is_sup (insert x1 S') x1"
      by(auto simp add: is_sup_def is_ub_def is_least_def leq_refl)
    thus ?thesis by auto
  next
    case False
    then obtain x' where X': "x' \<in> S'" by auto
    have Ub1 : "is_ub S' sub" using insert
      by(auto simp add: is_ub_def)
    have Union : "is_ub ({x1} \<union> S') sub" using insert by auto

    obtain s'sup where S'sup : "is_sup S' s'sup"
      using insert.IH[OF X' Ub1] by auto

    have X1sup : "is_sup {x1} x1" by(auto simp add: is_sup_def is_least_def is_ub_def leq_refl)

    have Pair : "has_ub ({x1, s'sup})"
      using ub_union2[OF X1sup S'sup Union]
      by(auto simp add: has_ub_def)

    obtain ssup where Ssup : "is_sup {x1, s'sup} ssup"
      using complete2[OF Pair] by(auto simp add: has_sup_def)

    show ?thesis using sup_union1[OF X1sup S'sup Ssup] by auto
  qed
qed
(*
lemma ub_finite_all :
  fixes S :: "('b :: Pordc_all) set"
  fixes x :: "'b"
  assumes Hfin : "finite S"
  assumes Hx : "x \<in> S"
  shows "\<exists> sub . is_ub S sub" using assms
proof(induction S arbitrary: x)
  case empty
  then show ?case
    by auto
next
  case (insert x1 S')
  show ?case
  proof(cases "S' = {}")
    case True
    then have "is_ub (insert x1 S') x1"
      by(auto simp add: is_sup_def is_ub_def is_least_def leq_refl)
    thus ?thesis by auto
  next
    case False
    then obtain x' where X': "x' \<in> S'" by auto
    have Ub1 : "is_ub S' sub" using insert
      by(auto simp add: is_ub_def)
    have Union : "is_ub ({x1} \<union> S') sub" using insert by auto

    obtain s'sup where S'sup : "is_sup S' s'sup"
      using insert.IH[OF X' Ub1] by auto

    have X1sup : "is_sup {x1} x1" by(auto simp add: is_sup_def is_least_def is_ub_def leq_refl)

    have Pair : "has_ub ({x1, s'sup})"
      using ub_union2[OF X1sup S'sup Union]
      by(auto simp add: has_ub_def)

    obtain ssup where Ssup : "is_sup {x1, s'sup} ssup"
      using complete2[OF Pair] by(auto simp add: has_sup_def)

    show ?thesis using sup_union1[OF X1sup S'sup Ssup] by auto
  qed
qed
*)

(*
lemma sup_finite_all :
  fixes S :: "('b :: Pordc_all) set"
  fixes x :: "'b"
  assumes Hfin : "finite S"
  assumes Hx : "x \<in> S"
  shows "\<exists> ssup . is_sup S ssup" using assms
proof(induction S arbitrary: x)
  case empty
  then show ?case
    by auto
next
  case (insert x1 S')
  show ?case
  proof(cases "S' = {}")
    case True
    then have "is_ub (insert x1 S') x1"
      by(auto simp add: is_sup_def is_ub_def is_least_def leq_refl)
    thus ?thesis by auto
  next
    case False
    then obtain x' where X': "x' \<in> S'" by auto
    have Ub1 : "is_ub S' sub" using insert
      by(auto simp add: is_ub_def)
    have Union : "is_ub ({x1} \<union> S') sub" using insert by auto

    obtain s'sup where S'sup : "is_sup S' s'sup"
      using insert.IH[OF X' Ub1] by auto

    have X1sup : "is_sup {x1} x1" by(auto simp add: is_sup_def is_least_def is_ub_def leq_refl)

    have Pair : "has_ub ({x1, s'sup})"
      using ub_union2[OF X1sup S'sup Union]
      by(auto simp add: has_ub_def)

    obtain ssup where Ssup : "is_sup {x1, s'sup} ssup"
      using complete2[OF Pair] by(auto simp add: has_sup_def)

    show ?thesis using sup_union1[OF X1sup S'sup Ssup] by auto
  qed
qed

*)

lemma has_sup_subset :
  fixes S S' :: "('b :: Pordc) set"
  assumes Hfin : "finite S"
  assumes H : "is_sup S s"
  assumes Hsub : "S' \<subseteq> S"
  assumes Hnemp : "x \<in> S'"
  shows "has_sup S'"
proof(-)
  have Fin' : "finite S'" using rev_finite_subset[OF Hfin Hsub]
    by(auto)

  have Ub' : "is_ub S' s"
  proof(rule is_ubI)
    fix x
    assume "x \<in> S'"
    hence "x \<in> S" using Hsub by auto
    thus "x <[ s"
      using is_supD1[OF H] by auto
  qed

  obtain s' where "is_sup S' s'"
    using finite_complete[OF Fin' Hnemp Ub'] by auto

  thus "has_sup S'" by(auto simp add: has_sup_def)
qed

lemma bsup_idem :
  "[^ x, x ^] = x"
proof-
  have 0: "is_sup {x, x} x"
    by(auto simp add: is_sup_def is_ub_def is_least_def leq_refl)
  have 1: "is_bsup x x [^x, x^]" using bsup_spec by auto

  show "[^ x, x ^] = x"
    using is_sup_unique[OF 0 bsup_sup[OF 0 1]] by auto
qed

lemma bsup_base_leq :
  assumes H : "x <[ y"
  shows "[^ x, y ^] = y"
proof-
  have 0 : "is_sup {x, y} y" using H
    by(auto simp add: has_sup_def is_sup_def is_least_def is_ub_def leq_refl)

  have 1: "is_bsup x y [^ x, y ^]" using bsup_spec by auto

  have 2 : "is_sup {x, y} [^ x, y ^]" using bsup_sup[OF 0 1] by auto

  show "[^ x, y ^] = y"
    using is_sup_unique[OF 0 2] by auto
qed

lemma bsup_base_leq2 :
  assumes H : "y <[ x"
  shows "[^ x, y ^] = x"
proof-
  have 0 : "is_sup {x, y} x" using H
    by(auto simp add: has_sup_def is_sup_def is_least_def is_ub_def leq_refl)

  have 1: "is_bsup x y [^ x, y ^]" using bsup_spec by auto

  have 2 : "is_sup {x, y} [^ x, y ^]" using bsup_sup[OF 0 1] by auto

  show "[^ x, y ^] = x"
    using is_sup_unique[OF 0 2] by auto
qed

lemma bsup_base_eq :
  "[^ x, [^ x, y ^]^] = [^ x, y ^]"
proof-
  have 0: "x <[ [^ x, y ^]"
    using is_bsupD1[OF bsup_spec[of x y]] by auto

  show "[^ x, [^ x, y ^]^] = [^ x, y ^]"
    using bsup_base_leq[OF 0] by auto
qed

lemma bsup_arg_eq :
  "[^ [^ x, y ^], y ^] = [^ x, y ^]"
proof-
  have Eq1 : "[^ x, y ^] <[ [^ [^ x, y ^], y ^]"
    using is_bsupD1[OF bsup_spec] by auto

  have Eq2 : "[^ [^ x, y ^], y ^] <[ [^ x, y ^]"
    using bsup_assoc_fact2[of x y y] unfolding bsup_idem[of "[^ x, y ^]"] by auto

  show "[^ [^ x, y ^], y ^] = [^ x, y ^]"
    using leq_antisym[OF Eq2 Eq1] by auto
qed

lemma sup_singleton :
  "is_sup {x} x"
  by(auto simp add: is_sup_def is_least_def is_ub_def leq_refl)

lemma bsup_assoc3 :
  assumes H : "has_sup {a, b, c}"
  shows "[^ [^ a, b ^], c ^] = [^ a, [^ b, c ^]^]"
proof-
  obtain s_abc where ABC : "is_sup {a, b, c} s_abc" using H by (auto simp add: has_sup_def)

  obtain s_ab where AB : "is_sup {a, b} s_ab" using has_sup_subset[OF _ ABC, of "{a, b}"]
    by(auto simp add: has_sup_def)

  have bAB : "s_ab = [^ a, b ^]"
    using is_sup_unique[OF bsup_sup[OF AB bsup_spec] AB] by auto

  obtain s_bc where BC : "is_sup {b, c} s_bc" using has_sup_subset[OF _ ABC, of "{b, c}"]
    by(auto simp add: has_sup_def)

  have bBC : "s_bc = [^ b, c ^]"
    using is_sup_unique[OF bsup_sup[OF BC bsup_spec] BC] by auto

  have Help1 : "{a, b} \<union> {c} = {a, b, c}" by auto

  have "is_sup {s_ab, c} s_abc"
    using  sup_union2[OF AB sup_singleton[of c], of s_abc] ABC unfolding Help1 by auto

  hence LHS': "is_sup {[^ a, b ^], c} s_abc"
    unfolding bAB by auto

  have LHS : "[^ [^ a, b ^], c ^] = s_abc"
    using is_sup_unique[OF bsup_sup[OF LHS' bsup_spec] LHS'] by auto

  have Help2 : "{b, c} \<union> {a} = {a, b, c}" by auto

  have Help3 : "{[^ b, c ^], a} = {a, [^ b, c ^]}" by auto

  have "is_sup {s_bc, a} s_abc"
    using  sup_union2[OF BC sup_singleton[of a], of s_abc] ABC unfolding Help2 by auto

  hence RHS': "is_sup {a, [^ b, c ^]} s_abc"
    unfolding bBC Help3 by auto

  have RHS : "[^ a, [^ b, c ^] ^] = s_abc"
    using is_sup_unique[OF bsup_sup[OF RHS' bsup_spec] RHS'] by auto

  show "[^ [^ a, b ^], c ^] = [^ a, [^ b, c ^] ^]" using LHS RHS by auto
qed

lemma ub_subset :
  assumes H : "is_ub S x"
  assumes H' : "S' \<subseteq> S"
  shows "is_ub S' x"
proof
  fix z
  assume Zin : "z \<in> S'"

  hence Zin' : "z \<in> S"
    using Zin H' by blast

  then show "z <[ x"
    using is_ubE[OF H Zin'] by simp
qed

lemma sup_subset_ub :
  assumes H : "is_sup S x"
  assumes H' : "S' \<subseteq> S"
  shows "is_ub S' x"
proof
  fix z
  assume Zin : "z \<in> S'"

  hence Zin' : "z \<in> S"
    using Zin H' by blast

  then show "z <[ x"
    using is_supD1[OF H Zin'] by simp
qed

lemma sup_ub :
  assumes H : "is_sup S x"
  shows "is_ub S x"
  using sup_subset_ub[OF H, of S]
  by auto

lemma is_sup_pair :
  assumes "a <[ b"
  shows "is_sup {a, b} b" using assms
  by(auto simp add: is_sup_def is_least_def is_ub_def leq_refl)

lemma sup_finite_all :
  assumes X_fin : "finite (X :: ('a :: Pordc_all) set)"
  assumes X_nemp : "x \<in> X"
  shows "has_sup X"
proof-
  obtain l where L: "set l = X"
    using finite_list[OF X_fin]
    by auto

  then show "has_sup X"
    using X_fin X_nemp
  proof(induction l arbitrary: X x)
    case Nil
    then show ?case by auto
  next
    case (Cons lh lt)
    then show ?case
    proof(cases lt)
      case Nil' : Nil

      have "is_sup X lh"
        using Cons.prems Nil' sup_singleton[of "lh"]
        by(auto)

      then show ?thesis
        by(auto simp add: has_sup_def)
    next
      case Cons' : (Cons lh' lt')

      have Sub1 : "set lt' \<subseteq> insert lh' (set lt')"
        by auto

      have Sub2 : "insert lh' (set lt') \<subseteq> insert lh (insert lh' (set lt'))"
        by auto

      have Sub3 : "set lt' \<subseteq> insert lh (insert lh' (set lt'))"
        using Sub1 Sub2 by auto

      obtain slt where Slt: "is_sup (set lt) slt"
        using Cons.IH[OF refl _, of lh'] Cons'
        by(auto simp add: has_sup_def)

      obtain sl where Sl_alt : "is_sup {lh, slt} sl"
        using sup2_all[of lh slt]
        by(auto simp add: has_sup_def)

      have Lh_sup : "is_sup {lh} lh"
        using sup_singleton by auto

      have Conc' : "is_sup ({lh} \<union> (set lt)) sl"
        using sup_union1[OF Lh_sup Slt Sl_alt]
        by simp

      then have Conc'' : "is_sup (set (lh#lt)) sl"
        by auto

      then have Conc' : "is_sup X sl"
        using Cons.prems(1) Cons'
        by auto

      then show ?thesis
        by(auto simp add: has_sup_def)
    qed
  qed
qed

(* make sure we really need this before spending any more time trying to prove it *)

lemma sup_finite_pairwise :
  assumes X_fin : "finite (X :: ('a :: Pordpsc) set)"
  assumes X_nemp : "x \<in> X"
  assumes Nwise : "\<And> a b . a \<in> X \<Longrightarrow> b \<in> X \<Longrightarrow> has_sup {a, b}"
  shows "has_sup X"
proof-

  obtain c where C: "c = card X"
    by auto

  show "has_sup X"
    using C X_fin X_nemp Nwise
  proof(induction c  arbitrary: X x rule: full_nat_induct)
    case (1 c)

    have IH :
      "\<And> m (x :: 'a set) xa. Suc m \<le> c \<Longrightarrow>
        m = card x \<Longrightarrow>
        finite x \<Longrightarrow>
        xa \<in> x \<Longrightarrow>
        (\<And> xa. xa \<in> x \<Longrightarrow>  (\<And> xb. xb \<in> x \<Longrightarrow> has_sup {xa, xb})) \<Longrightarrow>
                   has_sup x"
    proof-
      fix m :: nat
      fix x :: "'a set"
      fix xa :: 'a

      assume H1 :"Suc m \<le> c"
      assume H2 :"m = card (x :: 'a set)"
      assume H3 :"finite x"
      assume H4: "xa \<in> x"
      assume H5: "(\<And>xa. xa \<in> x \<Longrightarrow> (\<And>xb. xb \<in> x \<Longrightarrow> has_sup {xa, xb}))"
      show "has_sup x"
        using mp[OF spec[OF mp[OF mp[OF spec[OF mp[OF spec[OF 1(1), of m] H1]] H2] H3]] H4] H5
        by auto
    qed

    show ?case
    proof(cases c)
      case 0

      then have False using 1
        by auto

      then show ?thesis by auto
    next
      case (Suc c1)
      show ?thesis
      proof(cases c1)
        case Z1 : 0

        then have "card X = Suc 0"
          using 1 Suc
          by auto

        then obtain x1 where "X = {x1}"
          unfolding card_1_singleton_iff
          by(auto)

        then have "X = {x}"
          using 1
          by auto

        then have "is_sup X x"
          using sup_singleton[of x]
          by auto

        then show ?thesis
          by(auto simp add: has_sup_def)
      next
        case Suc1 : (Suc c2)

        then have Card_suc1 : "card X = Suc (Suc c2)"
          using 1 Suc
          by auto

        have Card_rest0 : "c1 = card (X - {x})"
          using card_Diff_singleton[OF 1(3) 1(4)]
            1 Suc Suc1
          by auto

        then have "0 < card (X - {x})"
          using Suc1 by auto

        then have "\<exists> x' . x' \<in> (X - {x})"
          unfolding card_gt_0_iff
          by(auto)

        then obtain x1 where X1 : "x1 \<in> (X)" "x1 \<noteq> x" "x1 \<in> (X - {x})"
          by(auto)

        have X_in_x1 : "x \<in> (X - {x1})"
          using 1(4) X1(2)
          by auto

        have Card_rest1 : "c1 = card (X - {x1})"
          using card_Diff_singleton[OF 1(3) X1(1)] Suc Suc1
            1
          by auto

        have Nwise0 :
          "(\<And>a b. a \<in> (X - {x})\<Longrightarrow>
            b \<in> (X - {x}) \<Longrightarrow>
            has_sup {a, b})"
          using 1(5)
          by auto

        have Nwise1 :
          "(\<And>a b. a \<in> (X - {x1})\<Longrightarrow>
            b \<in> (X - {x1}) \<Longrightarrow>
            has_sup {a, b})"
          using 1(5)
          by auto

        show ?thesis
        proof(cases c2)
          case Z2 : 0

          then have "card X = 2"
            using 1(2) Suc Suc1
            by auto

          then obtain w1 w2 where W: "X = {w1, w2}" "w1 \<noteq> w2"
            unfolding card_2_iff
            by auto

          then show ?thesis
            using 1(5)[of w1 w2]
            by(auto)
        next
          case Suc2 : (Suc c3)

          then have Card_suc2 : "card X = Suc (Suc (Suc c3))"
            using 1 Suc Suc1
            by auto

          have Card_rest01 : "c2 = card ((X - {x}) - {x1})"
            using card_Diff_singleton[OF _ X1(3)]
              1 Suc Suc1 Suc2
            by auto

          then have "0 < card ((X - {x}) - {x1})"
            using Suc1 Suc2 by auto

          then have "\<exists> x' . x' \<in> ((X - {x}) - {x1})"
            unfolding card_gt_0_iff
            by(auto)

          then obtain x2 where X2 : "x2 \<in> (X)" "x2 \<noteq> x1" "x2 \<in> ((X - {x}) - {x1})"
            by(auto)

          have X2_x0 : "x2 \<noteq> x"
            using X2(3)
            by auto

          have Nwise2 :
            "(\<And>a b. a \<in> ((X - {x}) - {x1})\<Longrightarrow>
              b \<in> ((X - {x}) - {x1}) \<Longrightarrow>
              has_sup {a, b})"
            using 1(5)
            by auto

          have Nwise2' :
            "(\<And>a b. a \<in> (X - {x2})\<Longrightarrow>
              b \<in> (X - {x2}) \<Longrightarrow>
              has_sup {a, b})"
            using 1(5)
            by auto

          have "has_sup (X - {x})"
            using IH[OF _ Card_rest0 _ X1(3) Nwise0]
              Suc Suc1 1(3)
            by(auto)

          then obtain sup0 where Sup0 : "is_sup (X - {x}) sup0"
            by(auto simp add: has_sup_def)

          then obtain sup01 where Sup01: "is_sup ((X - {x}) - {x1}) sup01"
            using has_sup_subset[OF _ Sup0 _ X2(3)]
              1(3)
            by(auto simp add: has_sup_def)

          have X2_in_x1 : "x2 \<in> X - {x1}"
            using X2 X1 X2_x0
            by auto

          have "has_sup (X - {x1})"
            using IH[OF _ Card_rest1 _ X2_in_x1 Nwise1] 1(3)
              Suc Suc1 Suc2
            by auto

          then obtain sup1 where Sup1 : "is_sup (X - {x1}) sup1"
            by(auto simp add: has_sup_def)

          have X_in_x12 : "x \<in> X - {x1} - {x2}"
            using X2 X1 X2_x0 1(4)
            by auto

          then obtain sup12 where Sup12 : "is_sup ((X - {x1}) - {x2}) sup12"
            using has_sup_subset[OF _ Sup1 _ X_in_x12] 1(3)
            by(auto simp add: has_sup_def)

          have Card_rest2 : "c1 = card (X - {x2})"
            using card_Diff_singleton[OF 1(3) X2(1)] Suc Suc1
              1
            by auto

          have X1_x2 : "x1 \<in> X - {x2}"
            using X2 X1
            by auto

          have X1_in_x20 : "x1 \<in> X - {x2} - {x}"
            using X2 X1 X2_x0 1(4)
            by auto

          have "has_sup (X - {x2})"
            using IH[OF _ Card_rest2 _ X1_x2 Nwise2']
              Suc Suc1 Suc2 1(3)
            by(auto)

          then obtain sup2 where Sup2 : "is_sup (X - {x2}) sup2"
            by(auto simp add: has_sup_def)

          then obtain sup20 where Sup20: "is_sup ((X - {x2}) - {x}) sup20"
            using has_sup_subset[OF _ Sup2 _ X1_in_x20] 1(3)
            by(auto simp add: has_sup_def)

          have Unfold1 : "(X - {x} - {x1} \<union> (X - {x1} - {x2})) = (X - {x1})"
            using X2(2) X2_x0 X1(2)
            by(auto)

          have Sup0112 : "is_sup {sup01, sup12} sup1"
            using sup_union2[OF Sup01 Sup12, unfolded Unfold1, OF Sup1]
            by auto

          hence Hsup0112 : "has_sup {sup01, sup12}"
            by(auto simp add: has_sup_def)

          have Unfold2 : "(X - {x1} - {x2} \<union> (X - {x2} - {x})) = (X - {x2})"
            using X2(2) X2_x0 X1(2)
            by(auto)

          have Sup1220 : "is_sup {sup12, sup20} sup2"
            using sup_union2[OF Sup12 Sup20, unfolded Unfold2, OF Sup2]
            by auto

          hence Hsup1220 : "has_sup {sup12, sup20}"
            by(auto simp add: has_sup_def)

          have Unfold0 : "(X - {x} - {x1} \<union> (X - {x2} - {x})) = X - {x}"
            using X2(2) X2_x0 X1(2)
            by(auto)

          have Sup0120 : "is_sup {sup01, sup20} sup0"
            using sup_union2[OF Sup01 Sup20, unfolded Unfold0, OF Sup0]
            by auto

          hence Hsup0120 : "has_sup {sup01, sup20}"
            by(auto simp add: has_sup_def)

          obtain sup_final where Final :
            "is_sup {sup01, sup12, sup20} sup_final"
            using pairwise_sup[OF Hsup0112 Hsup1220 Hsup0120]
            by(auto simp add: has_sup_def)

          have Unfold_final0 : "({sup12, sup20} \<union> {sup01}) = {sup01, sup12, sup20}"
            by auto

          have Unfold_final :
            "(X - {x2} \<union> (X - {x} - {x1})) = X"
            using X2(2) X2_x0 X1(2)
            by(auto)

          have Combine: "is_sup {sup2, sup01} sup_final"
            using sup_union2[OF Sup1220 sup_singleton[of sup01], unfolded Unfold_final0, OF Final]
            by auto

          have "is_sup X sup_final"
            using sup_union1[OF Sup2 Sup01 Combine]
            unfolding Unfold_final
            by auto

          then show ?thesis
            by(auto simp add: has_sup_def)
        qed
      qed
    qed
  qed
qed
end


(*  Title:      HOL/Isar_Examples/Cantor.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Cantor's Theorem\<close>

theory Cantor
imports Main
begin

text_raw \<open>\footnote{This is an Isar version of the final example of
  the Isabelle/HOL manual @{cite "isabelle-HOL"}.}\<close>

text \<open>Cantor's Theorem states that every set has more subsets than
  it has elements.  It has become a favorite basic example in pure
  higher-order logic since it is so easily expressed: \[\all{f::\alpha
  \To \alpha \To \idt{bool}} \ex{S::\alpha \To \idt{bool}}
  \all{x::\alpha} f \ap x \not= S\]

  Viewing types as sets, $\alpha \To \idt{bool}$ represents the
  powerset of $\alpha$.  This version of the theorem states that for
  every function from $\alpha$ to its powerset, some subset is outside
  its range.  The Isabelle/Isar proofs below uses HOL's set theory,
  with the type $\alpha \ap \idt{set}$ and the operator
  $\idt{range}::(\alpha \To \beta) \To \beta \ap \idt{set}$.\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where "?S = f y" ..
    then show False
    proof (rule equalityCE)
      assume "y \<in> f y"
      assume "y \<in> ?S"
      then have "y \<notin> f y" ..
      with \<open>y : f y\<close> show ?thesis by contradiction
    next
      assume "y \<notin> ?S"
      assume "y \<notin> f y"
      then have "y \<in> ?S" ..
      with \<open>y \<notin> ?S\<close> show ?thesis by contradiction
    qed
  qed
qed

text \<open>How much creativity is required?  As it happens, Isabelle can
  prove this theorem automatically using best-first search.
  Depth-first search would diverge, but best-first search successfully
  navigates through the large search space.  The context of Isabelle's
  classical prover contains rules for the relevant constructs of HOL's
  set theory.\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  by best

text \<open>While this establishes the same theorem internally, we do not
  get any idea of how the proof actually works.  There is currently no
  way to transform internal system-level representations of Isabelle
  proofs back into Isar text.  Writing intelligible proof documents
  really is a creative process, after all.\<close>

end


chapter \<open>Names as a unique datatype\<close>

theory Name
imports Main
begin

text \<open>
  I would like to model names as @{typ string}s. Unfortunately, there is no default order on lists,
  as there could be multiple reasonable implementations: e.g.\ lexicographic and point-wise.
  For both choices, users can import the corresponding instantiation.

  In Isabelle, only at most one implementation of a given type class for a given type may be present
  in the same theory. Consequently, I avoided importing a list ordering from the library, because it
  may cause conflicts with users who use another ordering. The general approach for these situations
  is to introduce a type copy.

  The full flexibility of strings (i.e.\ string manipulations) is only required where fresh names
  are being produced. Otherwise, only a linear order on terms is needed. Conveniently, Sternagel and
  Thiemann \<^cite>\<open>sternagel2015deriving\<close> provide tooling to automatically generate such a
  lexicographic order.
\<close>

datatype name = Name (as_string: string)

\<comment> \<open>Mostly copied from \<open>List_Lexorder\<close>\<close>

instantiation name :: ord
begin

definition less_name where
"xs < ys \<longleftrightarrow> (as_string xs, as_string ys) \<in> lexord {(u, v). (of_char u :: nat) < of_char v}"

definition less_eq_name where
"(xs :: name) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance name :: order
proof
  fix xs :: "name"
  show "xs \<le> xs" by (simp add: less_eq_name_def)
next
  fix xs ys zs :: "name"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: less_eq_name_def less_name_def)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "name"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: less_eq_name_def less_name_def)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "name"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: less_name_def less_eq_name_def)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance name :: linorder
proof
  fix xs ys :: "name"
  have "(as_string xs, as_string ys) \<in> lexord {(u, v). (of_char u::nat) < of_char v} \<or> xs = ys \<or> (as_string ys, as_string xs) \<in> lexord {(u, v). (of_char u::nat) < of_char v}"
    by (metis (no_types, lifting) case_prodI lexord_linear linorder_neqE_nat mem_Collect_eq name.expand of_char_eq_iff)
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: less_eq_name_def less_name_def)
qed

lemma less_name_code[code]:
  "Name xs < Name [] \<longleftrightarrow> False"
  "Name [] < Name (x # xs) \<longleftrightarrow> True"
  "Name (x # xs) < Name (y # ys) \<longleftrightarrow> (of_char x::nat) < of_char y \<or> x = y \<and> Name xs < Name ys"
unfolding less_name_def by auto

lemma le_name_code[code]:
  "Name (x # xs) \<le> Name [] \<longleftrightarrow> False"
  "Name [] \<le> Name (x # xs) \<longleftrightarrow> True"
  "Name (x # xs) \<le> Name (y # ys) \<longleftrightarrow> (of_char x::nat) < of_char y \<or> x = y \<and> Name xs \<le> Name ys"
unfolding less_eq_name_def less_name_def by auto

context begin

qualified definition append :: "name \<Rightarrow> name \<Rightarrow> name" where
"append v1 v2 = Name (as_string v1 @ as_string v2)"

lemma name_append_less:
  assumes "xs \<noteq> Name []"
  shows "append ys xs > ys"
proof -
  have "Name (ys @ xs) > Name ys" if "xs \<noteq> []" for xs ys
    using that
    proof (induction ys)
      case Nil
      thus ?case
        unfolding less_name_def
        by (cases xs) auto
    next
      case (Cons y ys)
      thus ?case
        unfolding less_name_def
        by auto
    qed
  with assms show ?thesis
    unfolding append_def
    by (cases xs, cases ys) auto
qed

end

end


(* Title: Quantales
   Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Quantales\<close>

text \<open>This entry will be merged eventually with other quantale entries and become a standalone one.\<close>

theory Quantales
  imports Main

begin

notation sup (infixl "\<squnion>" 60)
  and inf (infixl "\<sqinter>" 55)
  and top ("\<top>")
  and bot ("\<bottom>")
  and relcomp (infixl ";" 70)
  and times (infixl "\<cdot>" 70)
  and Sup ("\<Squnion>_" [900] 900)
  and Inf ("\<Sqinter>_" [900] 900)

subsection \<open>Properties of Complete Lattices\<close>

lemma (in complete_lattice) Sup_sup_pred: "x \<squnion> \<Squnion>{y. P y} = \<Squnion>{y. y = x \<or> P y}"
  apply (rule antisym)
   apply (simp add: Collect_mono Sup_subset_mono Sup_upper)
  using Sup_least Sup_upper sup.coboundedI2 by force

lemma (in complete_lattice) sup_Sup: "x \<squnion> y = \<Squnion>{x,y}"
  by simp

lemma (in complete_lattice) sup_Sup_var: "x \<squnion> y = \<Squnion>{z. z \<in> {x,y}}"
  by (metis Collect_mem_eq sup_Sup)

lemma (in complete_boolean_algebra) shunt1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> -y \<squnion> z"
proof standard
  assume "x \<sqinter> y \<le> z"
  hence  "-y \<squnion> (x \<sqinter> y) \<le> -y \<squnion> z"
    using sup.mono by blast
  hence "-y \<squnion> x \<le> -y \<squnion> z"
    by (simp add: sup_inf_distrib1)
  thus "x \<le> -y \<squnion> z"
    by simp
next
  assume "x \<le> - y \<squnion> z"
  hence "x \<sqinter> y \<le> (-y \<squnion> z) \<sqinter> y"
    using inf_mono by auto
  thus  "x \<sqinter> y \<le> z"
    using inf.boundedE inf_sup_distrib2 by auto
qed

lemma (in complete_boolean_algebra) meet_shunt: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis bot_least inf_absorb2 inf_compl_bot_left2 shunt1 sup_absorb1)

lemma (in complete_boolean_algebra) join_shunt: "x \<squnion> y = \<top> \<longleftrightarrow> -x \<le> y"
  by (metis compl_sup compl_top_eq double_compl meet_shunt)

subsection \<open> Familes of Proto-Quantales\<close>

text \<open>Proto-Quanales are complete lattices equipped with an operation of composition or multiplication
that need not be associative.\<close>

class proto_near_quantale = complete_lattice + times +
  assumes Sup_distr: "\<Squnion>X \<cdot> y = \<Squnion>{x \<cdot> y |x. x \<in> X}"

begin

lemma mult_botl [simp]: "\<bottom> \<cdot> x = \<bottom>"
  using Sup_distr[where X="{}"] by auto

lemma sup_distr: "(x \<squnion> y) \<cdot> z = (x \<cdot> z) \<squnion> (y \<cdot> z)"
  using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis sup.absorb_iff1 sup_distr)

definition bres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60) where
  "x \<rightarrow> z = \<Squnion>{y. x \<cdot> y \<le> z}"

definition fres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60) where
  "z \<leftarrow> y = \<Squnion>{x. x \<cdot> y \<le> z}"

lemma bres_galois_imp: "x \<cdot> y \<le> z \<longrightarrow> y \<le> x \<rightarrow> z"
  by (simp add: Sup_upper bres_def)

lemma fres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> x \<le> z \<leftarrow> y"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
    by (simp add: Sup_upper fres_def)
next
  assume "x \<le> z \<leftarrow> y"
  hence "x \<cdot> y \<le> \<Squnion>{x. x \<cdot> y \<le> z} \<cdot> y"
    by (simp add: fres_def mult_isor)
  also have "... = \<Squnion>{x \<cdot> y |x. x \<cdot> y \<le> z}"
    by (simp add: Sup_distr)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

class proto_pre_quantale = proto_near_quantale +
  assumes Sup_subdistl: "\<Squnion>{x \<cdot> y | y . y \<in> Y} \<le> x \<cdot> \<Squnion>Y"

begin

lemma sup_subdistl: "(x \<cdot> y) \<squnion> (x \<cdot> z) \<le> x \<cdot> (y \<squnion> z)"
  using Sup_subdistl[where Y="{y, z}"] Sup_le_iff by auto

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis le_iff_sup le_sup_iff sup_subdistl)

end

class weak_proto_quantale = proto_near_quantale +
  assumes weak_Sup_distl: "Y \<noteq> {} \<Longrightarrow> x \<cdot> \<Squnion>Y = \<Squnion>{x \<cdot> y |y. y \<in> Y}"

begin

subclass proto_pre_quantale
proof standard
  have a: "\<And>x Y. Y = {} \<Longrightarrow> \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    by simp
  have b: "\<And>x Y. Y \<noteq> {} \<Longrightarrow> \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    by (simp add: weak_Sup_distl)
  show  "\<And>x Y. \<Squnion>{x \<cdot> y |y. y \<in> Y} \<le> x \<cdot> \<Squnion>Y"
    using a b by blast
qed

lemma  sup_distl: "x \<cdot> (y \<squnion> z) = (x \<cdot> y) \<squnion> (x \<cdot> z)"
  using weak_Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma "y \<le> x \<rightarrow> z \<longrightarrow> x \<cdot> y \<le> z" (* nitpick [expect = genuine] *)
oops

end

class proto_quantale = proto_near_quantale +
  assumes Sup_distl: "x \<cdot> \<Squnion>Y = \<Squnion>{x \<cdot> y |y. y \<in> Y}"

begin

subclass weak_proto_quantale
  by standard (simp add: Sup_distl)

lemma bres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
    by (simp add: Sup_upper bres_def)
next
  assume "y \<le> x \<rightarrow> z"
  hence "x \<cdot> y \<le> x \<cdot> \<Squnion>{y. x \<cdot> y \<le> z}"
    by (simp add: bres_def mult_isol)
  also have "... = \<Squnion>{x \<cdot> y |y. x \<cdot> y \<le> z}"
    by (simp add: Sup_distl)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

subsection \<open>Families of Quantales\<close>

class near_quantale = proto_near_quantale + semigroup_mult

class unital_near_quantale = near_quantale + monoid_mult

begin

definition iter :: "'a \<Rightarrow> 'a" where
  "iter x \<equiv> \<Sqinter>{y. \<exists>i. y = x ^ i}"

lemma iter_ref [simp]: "iter x \<le> 1"
  apply (simp add: iter_def)
  by (metis (mono_tags, lifting) Inf_lower local.power.power_0 mem_Collect_eq)

lemma le_top: "x \<le> \<top> \<cdot> x"
  by (metis mult_isor mult.monoid_axioms top_greatest monoid.left_neutral)

end

class pre_quantale = proto_pre_quantale + semigroup_mult

subclass (in pre_quantale) near_quantale ..

class unital_pre_quantale = pre_quantale + monoid_mult

subclass (in unital_pre_quantale) unital_near_quantale ..

class weak_quantale = weak_proto_quantale + semigroup_mult

subclass (in weak_quantale) pre_quantale ..

text \<open>The following counterexample shows an important consequence of weakness:
the absence of right annihilation.\<close>

lemma (in weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

class unital_weak_quantale = weak_quantale + monoid_mult

lemma (in unital_weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

subclass (in unital_weak_quantale) unital_pre_quantale ..

class quantale = proto_quantale + semigroup_mult

begin

subclass weak_quantale ..

lemma mult_botr [simp]: "x \<cdot> \<bottom> = \<bottom>"
  using Sup_distl[where Y="{}"] by auto

end

class unital_quantale = quantale + monoid_mult

subclass (in unital_quantale) unital_weak_quantale ..

class ab_quantale = quantale + ab_semigroup_mult

begin

lemma bres_fres_eq: "x \<rightarrow> y = y \<leftarrow> x"
  by (simp add: fres_def bres_def mult_commute)

end

class ab_unital_quantale = ab_quantale + unital_quantale

class distrib_quantale = quantale + complete_distrib_lattice

class bool_quantale = quantale + complete_boolean_algebra

class distrib_unital_quantale = unital_quantale + complete_distrib_lattice

class bool_unital_quantale = unital_quantale + complete_boolean_algebra

class distrib_ab_quantale = distrib_quantale + ab_quantale

class bool_ab_quantale = bool_quantale + ab_quantale

class distrib_ab_unital_quantale = distrib_quantale + unital_quantale

class bool_ab_unital_quantale = bool_ab_quantale + unital_quantale

subsection \<open>Quantales of Booleans and Complete Boolean Algebras\<close>

instantiation bool :: bool_ab_unital_quantale
begin

definition "one_bool = True"

definition "times_bool = (\<lambda>x y. x \<and> y)"

instance
  by standard (auto simp: times_bool_def one_bool_def)

end

context complete_distrib_lattice
begin

interpretation cdl_quantale: distrib_quantale _ _ _ _ _ _ _ _ inf
  by standard (simp_all add: inf.assoc Setcompr_eq_image Sup_inf inf_Sup)

end

context complete_boolean_algebra
begin

interpretation cba_quantale: bool_ab_unital_quantale inf _ _ _ _ _ _ _ _ _ _ top
  apply standard
  apply (simp add: inf.assoc)
  apply (simp add: inf.commute)
  apply (simp add: Setcompr_eq_image Sup_inf)
  apply (simp add: Setcompr_eq_image inf_Sup)
  by simp_all

text \<open>In this setting, residuation can be translated like classical implication.\<close>

lemma cba_bres1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_quantale.bres_galois inf.commute by fastforce

lemma cba_bres2: "x \<le> -y \<squnion> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_bres1 shunt1 by auto

lemma cba_bres_prop: "cba_quantale.bres x y = -x \<squnion> y"
  using cba_bres2 eq_iff by blast

end

text \<open>Other models will follow.\<close>

subsection \<open>Products of Quantales\<close>

definition "Inf_prod X = (\<Sqinter>{fst x |x. x \<in> X}, \<Sqinter>{snd x |x.  x \<in> X})"

definition "inf_prod x y = (fst x \<sqinter> fst y, snd x \<sqinter> snd y)"

definition "bot_prod = (bot,bot)"

definition "Sup_prod X = (\<Squnion>{fst x |x. x \<in> X}, \<Squnion>{snd x |x.  x \<in> X})"

definition "sup_prod x y = (fst x \<squnion> fst y, snd x \<squnion> snd y)"

definition "top_prod = (top,top)"

definition "less_eq_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y)"

definition "less_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y) \<and> x \<noteq> y"

definition "times_prod' x y = (fst x \<cdot> fst y, snd x \<cdot> snd y)"

definition "one_prod = (1,1)"

interpretation prod: complete_lattice Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice \<times> 'b::complete_lattice)"
  apply standard
     apply (simp_all add: Inf_prod_def Sup_prod_def inf_prod_def sup_prod_def bot_prod_def top_prod_def less_eq_prod_def less_prod_def Sup_distl Sup_distr)
        apply force+
     apply (rule conjI, (rule Inf_lower, force)+)
    apply (rule conjI, (rule Inf_greatest, force)+)
   apply (rule conjI, (rule Sup_upper, force)+)
  by (rule conjI, (rule Sup_least, force)+)

interpretation prod: proto_near_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_near_quantale \<times> 'b::proto_near_quantale)" times_prod'
  apply (standard, simp add: times_prod'_def Sup_prod_def)
  by (rule conjI, (simp add: Sup_distr, clarify, metis)+)

interpretation prod: proto_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_quantale \<times> 'b::proto_quantale)" times_prod'
  apply (standard, simp add: times_prod'_def Sup_prod_def less_eq_prod_def)
  by (rule conjI, (simp add: Sup_distl, metis)+)

interpretation prod: unital_quantale one_prod times_prod' Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::unital_quantale \<times> 'b::unital_quantale)"
  by standard (simp_all add: one_prod_def times_prod'_def mult.assoc)

subsection \<open>Quantale Modules and Semidirect Products\<close>

text \<open>Quantale modules are extensions of semigroup actions in that a quantale acts on a complete lattice.\<close>

locale unital_quantale_module =
  fixes act :: "'a::unital_quantale \<Rightarrow> 'b::complete_lattice \<Rightarrow> 'b" ("\<alpha>")
  assumes act1: "\<alpha> (x \<cdot> y) p = \<alpha> x (\<alpha> y p)"
    and act2 [simp]: "\<alpha> 1 p = p"
    and act3: "\<alpha> (\<Squnion>X) p = \<Squnion>{\<alpha> x p |x. x \<in> X}"
    and act4: "\<alpha> x (\<Squnion>P) = \<Squnion>{\<alpha> x p |p. p \<in> P}"

context unital_quantale_module
begin

text \<open>Actions are morphisms. The curried notation is particularly convenient for this.\<close>

lemma act_morph1: "\<alpha> (x \<cdot> y) = (\<alpha> x) \<circ> (\<alpha> y)"
  by (simp add: fun_eq_iff act1)

lemma act_morph2: "\<alpha> 1 = id"
  by (simp add: fun_eq_iff)

lemma emp_act: "\<alpha> (\<Squnion>{}) p = \<bottom>"
  by (simp only: act3, force)

lemma emp_act_var: "\<alpha> \<bottom> p = \<bottom>"
  using emp_act by auto

lemma act_emp: "\<alpha> x (\<Squnion>{}) = \<bottom>"
  by (simp only: act4, force)

lemma act_emp_var: "\<alpha> x \<bottom> = \<bottom>"
  using act_emp by auto

lemma act_sup_distl: "\<alpha> x (p \<squnion> q) = (\<alpha> x p) \<squnion> (\<alpha> x q)"
proof-
  have "\<alpha> x (p \<squnion> q) = \<alpha> x (\<Squnion>{p,q})"
    by simp
  also have "... = \<Squnion>{\<alpha> x y |y. y \<in> {p,q}}"
    by (rule act4)
  also have "... = \<Squnion>{v. v = \<alpha> x p \<or> v = \<alpha> x q}"
    by (metis empty_iff insert_iff)
  finally show ?thesis
    by (metis Collect_disj_eq Sup_insert ccpo_Sup_singleton insert_def singleton_conv)
qed

lemma act_sup_distr: "\<alpha> (x \<squnion> y) p = (\<alpha> x p) \<squnion> (\<alpha> y p)"
  proof-
  have "\<alpha> (x \<squnion> y) p  = \<alpha> (\<Squnion>{x,y}) p"
    by simp
  also have "... = \<Squnion>{\<alpha> v p |v. v \<in> {x,y}}"
    by (rule act3)
  also have "... = \<Squnion>{v. v = \<alpha> x p \<or> v = \<alpha> y p}"
    by (metis empty_iff insert_iff)
  finally show ?thesis
    by (metis Collect_disj_eq Sup_insert ccpo_Sup_singleton insert_def singleton_conv)
qed

lemma act_sup_distr_var: "\<alpha> (x \<squnion> y) = (\<alpha> x) \<squnion> (\<alpha> y)"
  by (simp add: fun_eq_iff act_sup_distr)

text \<open>Next we define the semidirect product of a  unital quantale and a complete lattice. \<close>

definition "sd_prod x y = (fst x \<cdot> fst y, snd x \<squnion> \<alpha> (fst x) (snd y))"

lemma sd_distr_aux:
  "\<Squnion>{snd x |x. x \<in> X} \<squnion> \<Squnion>{\<alpha> (fst x) p |x. x \<in> X} = \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
proof (rule antisym, rule sup_least)
  show "\<Squnion>{snd x |x. x \<in> X} \<le> \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
  proof (rule Sup_least)
    fix x :: 'b
    assume "x \<in> {snd x |x. x \<in> X}"
    hence "\<exists>b pa. x \<squnion> b = snd pa \<squnion> \<alpha> (fst pa) p \<and> pa \<in> X"
      by blast
    hence "\<exists>b. x \<squnion> b \<in> {snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by blast
    thus "x \<le> \<Squnion>{snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by (meson Sup_upper sup.bounded_iff)
  qed
next
  show "\<Squnion>{\<alpha> (fst x) p |x. x \<in> X} \<le> \<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X}"
  proof (rule Sup_least)
    fix x :: 'b
    assume "x \<in> {\<alpha> (fst x) p |x. x \<in> X}"
    then have "\<exists>b pa. b \<squnion> x = snd pa \<squnion> \<alpha> (fst pa) p \<and> pa \<in> X"
      by blast
    then have "\<exists>b. b \<squnion> x \<in> {snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by blast
    then show "x \<le> \<Squnion>{snd pa \<squnion> \<alpha> (fst pa) p |pa. pa \<in> X}"
      by (meson Sup_upper le_supE)
  qed
next
  show "\<Squnion>{snd x \<squnion> \<alpha> (fst x) p |x. x \<in> X} \<le> \<Squnion>{snd x |x. x \<in> X} \<squnion> \<Squnion>{\<alpha> (fst x) p |x. x \<in> X}"
    apply (rule Sup_least)
    apply safe
    apply (rule sup_least)
    apply (metis (mono_tags, lifting) Sup_upper mem_Collect_eq sup.coboundedI1)
    by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq sup.coboundedI2)
qed

lemma sd_distr: "sd_prod (Sup_prod X) y = Sup_prod {sd_prod x y |x. x \<in> X}"
proof -
  have "sd_prod (Sup_prod X) y = sd_prod (\<Squnion>{fst x |x. x \<in> X}, \<Squnion>{snd x |x. x \<in> X}) y"
    by (simp add: Sup_prod_def)
  also have
    "... = ((\<Squnion>{fst x |x. x \<in> X}) \<cdot> fst y, (\<Squnion>{snd x |x. x \<in> X}) \<squnion> (\<alpha> (\<Squnion>{fst x | x. x \<in> X})  (snd y)))"
    by (simp add: sd_prod_def)
  also have
    "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, (\<Squnion>{snd x |x. x \<in> X}) \<squnion> (\<alpha> (\<Squnion>{fst x | x. x \<in> X})  (snd y)))"
    by (simp add: Sup_distr)
  also have
    "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, (\<Squnion> {snd x |x. x \<in> X}) \<squnion> (\<Squnion>{\<alpha> (fst x) (snd y) | x. x \<in> X}))"
    by (simp add: act3)
  also have "... = (\<Squnion>{fst x \<cdot> fst y|x. x \<in> X}, \<Squnion>{snd x \<squnion> (\<alpha> (fst x) (snd y)) | x. x \<in> X})"
    by (simp only: sd_distr_aux)
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |x. x \<in> X}"
    by (simp add: Sup_prod_def, metis)
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

lemma sd_distl_aux: "Y \<noteq> {} \<Longrightarrow> p \<squnion> (\<Squnion>{\<alpha> x (snd y) |y. y \<in> Y}) = \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
proof (rule antisym, rule sup_least)
  show "Y \<noteq> {} \<Longrightarrow> p \<le> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
  proof -
    assume "Y \<noteq> {}"
    hence "\<exists>b. b \<in> {p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y} \<and> p \<le> b"
      by fastforce
    thus "p \<le> \<Squnion>{p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y}"
      by (meson Sup_upper2)
  qed
next
  show "Y \<noteq> {} \<Longrightarrow> \<Squnion>{\<alpha> x (snd y) |y. y \<in> Y} \<le> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y}"
    apply (rule Sup_least)
  proof -
    fix xa :: 'b
    assume "xa \<in> {\<alpha> x (snd y) |y. y \<in> Y}"
    then have "\<exists>b. (\<exists>pa. b = p \<squnion> \<alpha> x (snd pa) \<and> pa \<in> Y) \<and> xa \<le> b"
      by fastforce
    then have "\<exists>b. b \<in> {p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y} \<and> xa \<le> b"
      by blast
    then show "xa \<le> \<Squnion>{p \<squnion> \<alpha> x (snd pa) |pa. pa \<in> Y}"
      by (meson Sup_upper2)
  qed
next
  show "Y \<noteq> {} \<Longrightarrow> \<Squnion>{p \<squnion> \<alpha> x (snd y) |y. y \<in> Y} \<le> p \<squnion> \<Squnion>{\<alpha> x (snd y) |y. y \<in> Y}"
    apply (rule Sup_least)
    apply safe
    by (metis (mono_tags, lifting) Sup_le_iff le_sup_iff mem_Collect_eq sup_ge1 sup_ge2)
qed

lemma sd_distl: "Y \<noteq> {} \<Longrightarrow> sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}"
proof -
  assume a: "Y \<noteq> {}"
  have "sd_prod x (Sup_prod Y) = sd_prod x (\<Squnion>{fst y |y. y \<in> Y}, \<Squnion>{snd y |y. y \<in> Y})"
    by (simp add: Sup_prod_def)
  also have "... = ((fst x) \<cdot> (\<Squnion>{fst y |y. y \<in> Y}), (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>{snd y |y. y \<in> Y}))))"
    by (simp add: sd_prod_def)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>{snd y |y. y \<in> Y}))))"
    by (simp add: Sup_distl)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, (snd x \<squnion> (\<Squnion>{\<alpha> (fst x) (snd y) |y. y \<in> Y})))"
    by (simp add: act4, meson)
  also have "... = (\<Squnion>{fst x \<cdot> fst y |y. y \<in> Y}, \<Squnion>{snd x \<squnion> (\<alpha> (fst x) (snd y)) |y. y \<in> Y})"
    using a sd_distl_aux by blast
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |y. y \<in> Y}"
    by (simp add: Sup_prod_def, metis)
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

definition "sd_unit = (1,\<bottom>)"

lemma sd_unitl [simp]: "sd_prod sd_unit x = x"
  by (simp add: sd_prod_def sd_unit_def)

lemma sd_unitr [simp]: "sd_prod x sd_unit = x"
  apply (simp add: sd_prod_def sd_unit_def)
  using act_emp by force

text \<open>The following counterexamples rule out that semidirect products of quantales and complete lattices form quantales.
The reason is that the right annihilation law fails.\<close>

lemma "sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}" (*nitpick[show_all,expect=genuine]*)
  oops

lemma "sd_prod x bot_prod = bot_prod" (*nitpick[show_all,expect=genuine]*)
  oops

text \<open>However we can show that semidirect products of (unital) quantales with complete lattices form weak (unital) quantales. \<close>

interpretation dp_quantale: weak_quantale sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  apply standard
  apply (simp_all add: sd_distl sd_distr)
  apply (simp_all add: sd_prod_def Inf_prod_def Sup_prod_def bot_prod_def sup_prod_def top_prod_def inf_prod_def less_eq_prod_def less_prod_def)
  by (rule conjI, simp add: mult.assoc, simp add: act1 act_sup_distl sup_assoc)

interpretation dpu_quantale: unital_weak_quantale sd_unit sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  by (standard; simp_all)

end

end