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

Axiom to express monotonicity (a variant of the deduction theorem).  Makes the
link between |- and ==>, needed for instance to prove imp_cong.

Axiom left_cong allows the simplifier to use left-side formulas.  Ideally it
should be derived from lower-level axioms.

CANNOT be added to LK0.thy because modal logic is built upon it, and
various modal rules would become inconsistent.
*)

theory LK
imports LK0
begin

axiomatization where
  monotonic:  "($H |- P ==> $H |- Q) ==> $H, P |- Q" and

  left_cong:  "[| P == P';  |- P' ==> ($H |- $F) == ($H' |- $F') |]
               ==> (P, $H |- $F) == (P', $H' |- $F')"

subsection {* Rewrite rules *}

lemma conj_simps:
  "|- P & True <-> P"
  "|- True & P <-> P"
  "|- P & False <-> False"
  "|- False & P <-> False"
  "|- P & P <-> P"
  "|- P & P & Q <-> P & Q"
  "|- P & ~P <-> False"
  "|- ~P & P <-> False"
  "|- (P & Q) & R <-> P & (Q & R)"
  by (fast add!: subst)+

lemma disj_simps:
  "|- P | True <-> True"
  "|- True | P <-> True"
  "|- P | False <-> P"
  "|- False | P <-> P"
  "|- P | P <-> P"
  "|- P | P | Q <-> P | Q"
  "|- (P | Q) | R <-> P | (Q | R)"
  by (fast add!: subst)+

lemma not_simps:
  "|- ~ False <-> True"
  "|- ~ True <-> False"
  by (fast add!: subst)+

lemma imp_simps:
  "|- (P --> False) <-> ~P"
  "|- (P --> True) <-> True"
  "|- (False --> P) <-> True"
  "|- (True --> P) <-> P"
  "|- (P --> P) <-> True"
  "|- (P --> ~P) <-> ~P"
  by (fast add!: subst)+

lemma iff_simps:
  "|- (True <-> P) <-> P"
  "|- (P <-> True) <-> P"
  "|- (P <-> P) <-> True"
  "|- (False <-> P) <-> ~P"
  "|- (P <-> False) <-> ~P"
  by (fast add!: subst)+

lemma quant_simps:
  "!!P. |- (ALL x. P) <-> P"
  "!!P. |- (ALL x. x=t --> P(x)) <-> P(t)"
  "!!P. |- (ALL x. t=x --> P(x)) <-> P(t)"
  "!!P. |- (EX x. P) <-> P"
  "!!P. |- (EX x. x=t & P(x)) <-> P(t)"
  "!!P. |- (EX x. t=x & P(x)) <-> P(t)"
  by (fast add!: subst)+

subsection {* Miniscoping: pushing quantifiers in *}

text {*
  We do NOT distribute of ALL over &, or dually that of EX over |
  Baaz and Leitsch, On Skolemization and Proof Complexity (1994)
  show that this step can increase proof length!
*}

text {*existential miniscoping*}
lemma ex_simps:
  "!!P Q. |- (EX x. P(x) & Q) <-> (EX x. P(x)) & Q"
  "!!P Q. |- (EX x. P & Q(x)) <-> P & (EX x. Q(x))"
  "!!P Q. |- (EX x. P(x) | Q) <-> (EX x. P(x)) | Q"
  "!!P Q. |- (EX x. P | Q(x)) <-> P | (EX x. Q(x))"
  "!!P Q. |- (EX x. P(x) --> Q) <-> (ALL x. P(x)) --> Q"
  "!!P Q. |- (EX x. P --> Q(x)) <-> P --> (EX x. Q(x))"
  by (fast add!: subst)+

text {*universal miniscoping*}
lemma all_simps:
  "!!P Q. |- (ALL x. P(x) & Q) <-> (ALL x. P(x)) & Q"
  "!!P Q. |- (ALL x. P & Q(x)) <-> P & (ALL x. Q(x))"
  "!!P Q. |- (ALL x. P(x) --> Q) <-> (EX x. P(x)) --> Q"
  "!!P Q. |- (ALL x. P --> Q(x)) <-> P --> (ALL x. Q(x))"
  "!!P Q. |- (ALL x. P(x) | Q) <-> (ALL x. P(x)) | Q"
  "!!P Q. |- (ALL x. P | Q(x)) <-> P | (ALL x. Q(x))"
  by (fast add!: subst)+

text {*These are NOT supplied by default!*}
lemma distrib_simps:
  "|- P & (Q | R) <-> P&Q | P&R"
  "|- (Q | R) & P <-> Q&P | R&P"
  "|- (P | Q --> R) <-> (P --> R) & (Q --> R)"
  by (fast add!: subst)+

lemma P_iff_F: "|- ~P ==> |- (P <-> False)"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemmas iff_reflection_F = P_iff_F [THEN iff_reflection]

lemma P_iff_T: "|- P ==> |- (P <-> True)"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemmas iff_reflection_T = P_iff_T [THEN iff_reflection]

lemma LK_extra_simps:
  "|- P | ~P"
  "|- ~P | P"
  "|- ~ ~ P <-> P"
  "|- (~P --> P) <-> P"
  "|- (~P <-> ~Q) <-> (P<->Q)"
  by (fast add!: subst)+

subsection {* Named rewrite rules *}

lemma conj_commute: "|- P&Q <-> Q&P"
  and conj_left_commute: "|- P&(Q&R) <-> Q&(P&R)"
  by (fast add!: subst)+

lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: "|- P|Q <-> Q|P"
  and disj_left_commute: "|- P|(Q|R) <-> Q|(P|R)"
  by (fast add!: subst)+

lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: "|- P&(Q|R) <-> (P&Q | P&R)"
  and conj_disj_distribR: "|- (P|Q)&R <-> (P&R | Q&R)"

  and disj_conj_distribL: "|- P|(Q&R) <-> (P|Q) & (P|R)"
  and disj_conj_distribR: "|- (P&Q)|R <-> (P|R) & (Q|R)"

  and imp_conj_distrib: "|- (P --> (Q&R)) <-> (P-->Q) & (P-->R)"
  and imp_conj: "|- ((P&Q)-->R)   <-> (P --> (Q --> R))"
  and imp_disj: "|- (P|Q --> R)   <-> (P-->R) & (Q-->R)"

  and imp_disj1: "|- (P-->Q) | R <-> (P-->Q | R)"
  and imp_disj2: "|- Q | (P-->R) <-> (P-->Q | R)"

  and de_Morgan_disj: "|- (~(P | Q)) <-> (~P & ~Q)"
  and de_Morgan_conj: "|- (~(P & Q)) <-> (~P | ~Q)"

  and not_iff: "|- ~(P <-> Q) <-> (P <-> ~Q)"
  by (fast add!: subst)+

lemma imp_cong:
  assumes p1: "|- P <-> P'"
    and p2: "|- P' ==> |- Q <-> Q'"
  shows "|- (P-->Q) <-> (P'-->Q')"
  apply (lem p1)
  apply safe
   apply (tactic {*
     REPEAT (rtac @{thm cut} 1 THEN
       DEPTH_SOLVE_1
         (resolve_tac [@{thm thinL}, @{thm thinR}, @{thm p2} COMP @{thm monotonic}] 1) THEN
           Cla.safe_tac @{context} 1) *})
  done

lemma conj_cong:
  assumes p1: "|- P <-> P'"
    and p2: "|- P' ==> |- Q <-> Q'"
  shows "|- (P&Q) <-> (P'&Q')"
  apply (lem p1)
  apply safe
   apply (tactic {*
     REPEAT (rtac @{thm cut} 1 THEN
       DEPTH_SOLVE_1
         (resolve_tac [@{thm thinL}, @{thm thinR}, @{thm p2} COMP @{thm monotonic}] 1) THEN
           Cla.safe_tac @{context} 1) *})
  done

lemma eq_sym_conv: "|- (x=y) <-> (y=x)"
  by (fast add!: subst)

ML_file "simpdata.ML"
setup {* map_theory_simpset (put_simpset LK_ss) *}
setup {* Simplifier.method_setup [] *}

text {* To create substition rules *}

lemma eq_imp_subst: "|- a=b ==> $H, A(a), $G |- $E, A(b), $F"
  by simp

lemma split_if: "|- P(if Q then x else y) <-> ((Q --> P(x)) & (~Q --> P(y)))"
  apply (rule_tac P = Q in cut)
   prefer 2
   apply (simp add: if_P)
  apply (rule_tac P = "~Q" in cut)
   prefer 2
   apply (simp add: if_not_P)
  apply fast
  done

lemma if_cancel: "|- (if P then x else x) = x"
  apply (lem split_if)
  apply fast
  done

lemma if_eq_cancel: "|- (if x=y then y else x) = x"
  apply (lem split_if)
  apply safe
  apply (rule symL)
  apply (rule basic)
  done

end


theory SimAsm_State
  imports Main
begin

section \<open>State\<close>

(* variable: either a register or a global. *)
datatype ('g,'r) var = Reg 'r | Glb 'g

(* state record mapping some key (for example a variable name) to values *)
record ('v,'a) state_rec = st :: "'a \<Rightarrow> 'v"

(* because records can be arbitrarily extended, a record automatically gives rise to a
*_scheme type which defines arbitrary possible extensions to that record.
for example, given ('v,'a) state_rec, we have ('v,'a,'c) state_rec_scheme which represents an
extension with 'c. *)

(* this is shown below where "st s" :: 'a \<Rightarrow> 'v and this assigns the value of the st field back to
itself. *)
fun test :: "('v,'a,'c) state_rec_scheme \<Rightarrow> ('v,'a,'c) state_rec_scheme" where
"test s = s\<lparr>st := st s\<rparr>"

(* state: in its most general form maps a global or register to values, possibly extended. *)
type_synonym ('v,'g,'r,'a) state = "('v,('g,'r) var,'a) state_rec_scheme"
type_synonym ('v,'g,'a) gstate = "('v,'g,'a) state_rec_scheme"

(* a predicate is defined as a set of states satisfying that predicate.
analagously for global predicates. *)
type_synonym ('v,'g,'r,'a) pred = "('v,'g,'r,'a) state set"
type_synonym ('v,'g,'a) gpred = "('v,'g,'a) gstate set"

type_synonym ('v,'g,'r,'a) trel = "('v,'g,'r,'a) state rel"
type_synonym ('v,'g,'a) grel = "('v,'g,'a) gstate rel"

type_synonym ('v,'g,'r,'a) trans = "('v,'g,'r,'a) pred \<Rightarrow> ('v,'g,'r,'a) pred"
type_synonym ('v,'g,'r,'a) rtrans = "('v,'g,'r,'a) trel \<Rightarrow> ('v,'g,'r,'a) trel"

(* the possible extension of the state is used to store this auxiliary information *)
type_synonym ('v,'g,'r,'a) auxfn = "('v,('g,'r) var,'a) state_rec_scheme \<Rightarrow> 'a"

section \<open>Write Operations\<close>

definition st_upd :: "('v,'a,'b) state_rec_scheme \<Rightarrow> 'a \<Rightarrow> 'v \<Rightarrow> ('v,'a,'b) state_rec_scheme"
  where "st_upd m a b = m \<lparr> st := ((st m) (a := b)) \<rparr>"

definition aux_upd :: "('v,'r,'a) state_rec_scheme \<Rightarrow> (('v,'r,'a) state_rec_scheme \<Rightarrow> 'a) \<Rightarrow> ('v,'r,'a) state_rec_scheme"
  where "aux_upd m f \<equiv> m\<lparr>state_rec.more := f m\<rparr>"

nonterminal updbinds and updbind

syntax
  "_updbindm" :: "'a \<Rightarrow> 'a \<Rightarrow> updbind"            ("(2_ :=\<^sub>s/ _)")
  "_updbinda" :: "'a \<Rightarrow> updbind"                  ("(2aux:/ _)")
  ""         :: "updbind \<Rightarrow> updbinds"             ("_")
  "_updbinds":: "updbind \<Rightarrow> updbinds \<Rightarrow> updbinds" ("_,/ _")
  "_Update"  :: "'a \<Rightarrow> updbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)

translations
  "_Update f (_updbinds b bs)" \<rightleftharpoons> "_Update (_Update f b) bs"
  "f(x:=\<^sub>sy)" \<rightleftharpoons> "CONST st_upd f x y"
  "f(aux: y)" \<rightleftharpoons> "CONST aux_upd f y"

lemma aux_nop [simp]:
  "m(aux:more) = m"
  by (auto simp: aux_upd_def)

lemma st_upd_twist: "a \<noteq> c \<Longrightarrow> (m(a :=\<^sub>s b))(c :=\<^sub>s d) = (m(c :=\<^sub>s d))(a :=\<^sub>s b)"
  unfolding st_upd_def by (auto intro!: equality fun_upd_twist)

(* obtains the global state *)
definition glb :: "('v,'g,'r,'a) state \<Rightarrow> ('v,'g,'a) gstate"
  where "glb m \<equiv> \<lparr> st = (\<lambda>v. st m (Glb v)), \<dots> = more m \<rparr>"

(* obtains the register state as a usual function. *)
definition rg :: "('v,'g,'r,'a) state \<Rightarrow> 'r \<Rightarrow> 'v"
  where "rg m \<equiv> \<lambda>v. st m (Reg v)"

lemma [simp]:
  "glb (m(Reg r :=\<^sub>s e)) = glb m"
  by (auto simp: glb_def st_upd_def)

lemma [simp]:
  "P O {(m, m'). m' = m} = P"
  by auto

lemma [simp]:
  "state_rec.more (m(x :=\<^sub>s e)) = state_rec.more m"
  by (auto simp: st_upd_def)

lemma [simp]:
  "state_rec.more (m(aux: f)) = f m"
  by (auto simp: aux_upd_def)

(* what is this? *)
lemma aux_exec [intro!]:
  assumes "(m\<^sub>1,m\<^sub>2) \<in> P"
  shows "(m\<^sub>1,m\<^sub>2(aux: f)) \<in> P O {(m, m'). m' = m(aux: f)}"
  using assms by blast

text \<open>Domain of register variables\<close>
abbreviation locals
  where "locals \<equiv> Reg ` UNIV"

text \<open>Domain of register variables\<close>
abbreviation globals
  where "globals \<equiv> Glb ` UNIV"

end


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

section{*A Small Universe for Lazy Recursive Types*}

theory QUniv imports Univ QPair begin

(*Disjoint sums as a datatype*)
rep_datatype
  elimination   sumE
  induction     TrueI
  case_eqns     case_Inl case_Inr

(*Variant disjoint sums as a datatype*)
rep_datatype
  elimination   qsumE
  induction     TrueI
  case_eqns     qcase_QInl qcase_QInr

definition
  quniv :: "i => i"  where
   "quniv(A) == Pow(univ(eclose(A)))"

subsection{*Properties involving Transset and Sum*}

lemma Transset_includes_summands:
     "[| Transset(C); A+B \<subseteq> C |] ==> A \<subseteq> C & B \<subseteq> C"
apply (simp add: sum_def Un_subset_iff)
apply (blast dest: Transset_includes_range)
done

lemma Transset_sum_Int_subset:
     "Transset(C) ==> (A+B) \<inter> C \<subseteq> (A \<inter> C) + (B \<inter> C)"
apply (simp add: sum_def Int_Un_distrib2)
apply (blast dest: Transset_Pair_D)
done

subsection{*Introduction and Elimination Rules*}

lemma qunivI: "X \<subseteq> univ(eclose(A)) ==> X \<in> quniv(A)"
by (simp add: quniv_def)

lemma qunivD: "X \<in> quniv(A) ==> X \<subseteq> univ(eclose(A))"
by (simp add: quniv_def)

lemma quniv_mono: "A<=B ==> quniv(A) \<subseteq> quniv(B)"
apply (unfold quniv_def)
apply (erule eclose_mono [THEN univ_mono, THEN Pow_mono])
done

subsection{*Closure Properties*}

lemma univ_eclose_subset_quniv: "univ(eclose(A)) \<subseteq> quniv(A)"
apply (simp add: quniv_def Transset_iff_Pow [symmetric])
apply (rule Transset_eclose [THEN Transset_univ])
done

(*Key property for proving A_subset_quniv; requires eclose in def of quniv*)
lemma univ_subset_quniv: "univ(A) \<subseteq> quniv(A)"
apply (rule arg_subset_eclose [THEN univ_mono, THEN subset_trans])
apply (rule univ_eclose_subset_quniv)
done

lemmas univ_into_quniv = univ_subset_quniv [THEN subsetD]

lemma Pow_univ_subset_quniv: "Pow(univ(A)) \<subseteq> quniv(A)"
apply (unfold quniv_def)
apply (rule arg_subset_eclose [THEN univ_mono, THEN Pow_mono])
done

lemmas univ_subset_into_quniv =
    PowI [THEN Pow_univ_subset_quniv [THEN subsetD]]

lemmas zero_in_quniv = zero_in_univ [THEN univ_into_quniv]
lemmas one_in_quniv = one_in_univ [THEN univ_into_quniv]
lemmas two_in_quniv = two_in_univ [THEN univ_into_quniv]

lemmas A_subset_quniv =  subset_trans [OF A_subset_univ univ_subset_quniv]

lemmas A_into_quniv = A_subset_quniv [THEN subsetD]

(*** univ(A) closure for Quine-inspired pairs and injections ***)

(*Quine ordered pairs*)
lemma QPair_subset_univ:
    "[| a \<subseteq> univ(A);  b \<subseteq> univ(A) |] ==> <a;b> \<subseteq> univ(A)"
by (simp add: QPair_def sum_subset_univ)

subsection{*Quine Disjoint Sum*}

lemma QInl_subset_univ: "a \<subseteq> univ(A) ==> QInl(a) \<subseteq> univ(A)"
apply (unfold QInl_def)
apply (erule empty_subsetI [THEN QPair_subset_univ])
done

lemmas naturals_subset_nat =
    Ord_nat [THEN Ord_is_Transset, unfolded Transset_def, THEN bspec]

lemmas naturals_subset_univ =
    subset_trans [OF naturals_subset_nat nat_subset_univ]

lemma QInr_subset_univ: "a \<subseteq> univ(A) ==> QInr(a) \<subseteq> univ(A)"
apply (unfold QInr_def)
apply (erule nat_1I [THEN naturals_subset_univ, THEN QPair_subset_univ])
done

subsection{*Closure for Quine-Inspired Products and Sums*}

(*Quine ordered pairs*)
lemma QPair_in_quniv:
    "[| a: quniv(A);  b: quniv(A) |] ==> <a;b> \<in> quniv(A)"
by (simp add: quniv_def QPair_def sum_subset_univ)

lemma QSigma_quniv: "quniv(A) <*> quniv(A) \<subseteq> quniv(A)"
by (blast intro: QPair_in_quniv)

lemmas QSigma_subset_quniv =  subset_trans [OF QSigma_mono QSigma_quniv]

(*The opposite inclusion*)
lemma quniv_QPair_D:
    "<a;b> \<in> quniv(A) ==> a: quniv(A) & b: quniv(A)"
apply (unfold quniv_def QPair_def)
apply (rule Transset_includes_summands [THEN conjE])
apply (rule Transset_eclose [THEN Transset_univ])
apply (erule PowD, blast)
done

lemmas quniv_QPair_E = quniv_QPair_D [THEN conjE]

lemma quniv_QPair_iff: "<a;b> \<in> quniv(A) \<longleftrightarrow> a: quniv(A) & b: quniv(A)"
by (blast intro: QPair_in_quniv dest: quniv_QPair_D)

subsection{*Quine Disjoint Sum*}

lemma QInl_in_quniv: "a: quniv(A) ==> QInl(a) \<in> quniv(A)"
by (simp add: QInl_def zero_in_quniv QPair_in_quniv)

lemma QInr_in_quniv: "b: quniv(A) ==> QInr(b) \<in> quniv(A)"
by (simp add: QInr_def one_in_quniv QPair_in_quniv)

lemma qsum_quniv: "quniv(C) <+> quniv(C) \<subseteq> quniv(C)"
by (blast intro: QInl_in_quniv QInr_in_quniv)

lemmas qsum_subset_quniv = subset_trans [OF qsum_mono qsum_quniv]

subsection{*The Natural Numbers*}

lemmas nat_subset_quniv =  subset_trans [OF nat_subset_univ univ_subset_quniv]

(* n:nat ==> n:quniv(A) *)
lemmas nat_into_quniv = nat_subset_quniv [THEN subsetD]

lemmas bool_subset_quniv = subset_trans [OF bool_subset_univ univ_subset_quniv]

lemmas bool_into_quniv = bool_subset_quniv [THEN subsetD]

(*Intersecting <a;b> with Vfrom...*)

lemma QPair_Int_Vfrom_succ_subset:
 "Transset(X) ==>
       <a;b> \<inter> Vfrom(X, succ(i))  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
by (simp add: QPair_def sum_def Int_Un_distrib2 Un_mono
              product_Int_Vfrom_subset [THEN subset_trans]
              Sigma_mono [OF Int_lower1 subset_refl])

subsection{*"Take-Lemma" Rules*}

(*for proving a=b by coinduction and c: quniv(A)*)

(*Rule for level i -- preserving the level, not decreasing it*)

lemma QPair_Int_Vfrom_subset:
 "Transset(X) ==>
       <a;b> \<inter> Vfrom(X,i)  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
apply (unfold QPair_def)
apply (erule Transset_Vfrom [THEN Transset_sum_Int_subset])
done

(*@{term"[| a \<inter> Vset(i) \<subseteq> c; b \<inter> Vset(i) \<subseteq> d |] ==> <a;b> \<inter> Vset(i) \<subseteq> <c;d>"}*)
lemmas QPair_Int_Vset_subset_trans =
     subset_trans [OF Transset_0 [THEN QPair_Int_Vfrom_subset] QPair_mono]

lemma QPair_Int_Vset_subset_UN:
     "Ord(i) ==> <a;b> \<inter> Vset(i) \<subseteq> (\<Union>j\<in>i. <a \<inter> Vset(j); b \<inter> Vset(j)>)"
apply (erule Ord_cases)
(*0 case*)
apply (simp add: Vfrom_0)
(*succ(j) case*)
apply (erule ssubst)
apply (rule Transset_0 [THEN QPair_Int_Vfrom_succ_subset, THEN subset_trans])
apply (rule succI1 [THEN UN_upper])
(*Limit(i) case*)
apply (simp del: UN_simps
        add: Limit_Vfrom_eq Int_UN_distrib UN_mono QPair_Int_Vset_subset_trans)
done

end


(* Title:  Stuff.thy
   Author: Lars Noschinski, TU München
*)

theory Stuff
imports
  "~~/src/HOL/Main"
  "~~/src/HOL/Library/Extended_Real"

begin

section {* Additional theorems for base libraries *}

text {*
  This section contains lemmas unrelated to graph theory which might be
  interesting for the Isabelle distribution
*}

lemma ereal_Inf_finite_Min:
  fixes S :: "ereal set"
  assumes "finite S" and "S \<noteq> {}"
  shows "Inf S = Min S"
using assms
by (induct S rule: finite_ne_induct) (auto simp: min_absorb1)

lemma finite_INF_in:
  fixes f :: "'a \<Rightarrow> ereal"
  assumes "finite S"
  assumes "S \<noteq> {}"
  shows "(INF s: S. f s) \<in> f ` S"
proof (unfold INF_def)
  from assms
  have "finite (f ` S)" "f ` S \<noteq> {}" by auto
  then show "Inf (f ` S) \<in> f ` S"
    using ereal_Inf_finite_Min [of "f ` S"]  by simp
qed

lemma not_mem_less_INF:
  fixes f :: "'a \<Rightarrow> 'b :: complete_lattice"
  assumes "f x < (INF s: S. f s)"
  assumes "x \<in> S"
  shows "False"
using assms by (metis INF_lower less_le_not_le)

lemma sym_diff:
  assumes "sym A" "sym B" shows "sym (A - B)"
using assms by (auto simp: sym_def)

subsection {* List *}

lemmas list_exhaust2 = list.exhaust[case_product list.exhaust]

lemma list_exhaust_NSC:
  obtains (Nil) "xs = []" | (Single) x where "xs = [x]" | (Cons_Cons) x y ys where "xs = x # y # ys"
by (metis list.exhaust)

lemma tl_rev:
  "tl (rev p) = rev (butlast p)"
by (induct p) auto

lemma butlast_rev:
  "butlast (rev p) = rev (tl p)"
by (induct p) auto

lemma take_drop_take:
   "take n xs @ drop n (take m xs) = take (max n m) xs"
proof cases
  assume "m < n" then show ?thesis by (auto simp: max_def)
next
  assume "\<not>m < n"
  then have "take n xs = take n (take m xs)" by (auto simp: min_def)
  then show ?thesis by (simp del: take_take add: max_def)
qed

lemma drop_take_drop:
  "drop n (take m xs) @ drop m xs = drop (min n m) xs"
proof cases
  assume A: "\<not>m < n"
  then show ?thesis
    using drop_append[of n "take m xs" "drop m xs"]
  by (cases "length xs < n") (auto simp: not_less min_def)
qed (auto simp: min_def)

lemma not_distinct_decomp_min_prefix:
  assumes "\<not> distinct ws"
  shows "\<exists> xs ys zs y. ws = xs @ y # ys @ y # zs \<and> distinct xs \<and> y \<notin> set xs \<and> y \<notin> set ys "
proof -
  obtain xs y ys where "y \<in> set xs" "distinct xs" "ws = xs @ y # ys"
    using assms by (auto simp: not_distinct_conv_prefix)
  moreover then obtain xs' ys' where "xs = xs' @ y # ys'" by (auto simp: in_set_conv_decomp)
  ultimately show ?thesis by auto
qed

lemma not_distinct_decomp_min_not_distinct:
  assumes "\<not> distinct ws"
  shows "\<exists>xs y ys zs. ws = xs @ y # ys @ y # zs \<and> distinct (ys @ [y])"
using assms
proof (induct ws)
  case (Cons w ws)
  show ?case
  proof (cases "distinct ws")
    case True
    then obtain xs ys where "ws = xs @ w # ys" "w \<notin> set xs"
      using Cons.prems by (fastforce dest: split_list_first)
    then have "distinct (xs @ [w])" "w # ws = [] @ w # xs @ w # ys"
      using `distinct ws` by auto
    then show ?thesis by blast
  next
    case False
    then obtain xs y ys zs where "ws = xs @ y # ys @ y # zs \<and> distinct (ys @ [y])"
      using Cons by auto
    then have "w # ws = (w # xs) @ y # ys @ y # zs \<and> distinct (ys @ [y])"
      by simp
    then show ?thesis by blast
  qed
qed simp

lemma card_Ex_subset:
  "k \<le> card M \<Longrightarrow> \<exists>N. N \<subseteq> M \<and> card N = k"
by (induct rule: inc_induct) (auto simp: card_Suc_eq)

lemma list_set_tl: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
by (cases xs) auto

section {* NOMATCH simproc *}

text {*
 The simplification procedure can be used to avoid simplification of terms of a certain form
*}

definition NOMATCH :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "NOMATCH val pat \<equiv> True"
lemma NOMATCH_cong[cong]: "NOMATCH val pat = NOMATCH val pat" by (rule refl)

simproc_setup NOMATCH ("NOMATCH val pat") = {* fn _ => fn ctxt => fn ct =>
  let
    val thy = Proof_Context.theory_of ctxt
    val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd)
    val m = Pattern.matches thy (dest_binop (Thm.term_of ct))
  in if m then NONE else SOME @{thm NOMATCH_def} end
*}

text {*
  This setup ensures that a rewrite rule of the form @{term "NOMATCH val pat \<Longrightarrow> t"}
  is only applied, if the pattern @{term pat} does not match the value @{term val}.
*}

end


theory BarcanFormulas_S5U imports QML_S5U
begin
  theorem BF:  "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<box>(\<phi>(x))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. \<phi>(x))\<rfloor>"
  by simp

  theorem CBF:  "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<phi>(x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x. \<^bold>\<box>(\<phi>(x)))\<rfloor>"
  by simp
end


theory Defs
  imports "HOL-IMP.Star"
begin

declare [[syntax_ambiguity_warning=false]]

datatype val = Iv int | Pv val val

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

datatype aexp =  N int | V vname | Plus aexp aexp | Pair aexp aexp | Fst aexp | Snd aexp

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)
      | SWAP   vname

datatype ty = Ity | Pty ty ty

type_synonym tyenv = "vname \<Rightarrow> ty"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Pv v1 v2) = Pty (type v1) (type v2)"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
  by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

consts small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool"

consts taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"

consts tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool"

consts atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"

consts btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool"

consts ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool"

consts small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool"

end


theory sort_TSortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Tree = TNode "'a Tree" "'a" "'a Tree" | TNil

fun flatten :: "'a Tree => 'a list => 'a list" where
"flatten (TNode p z q) y = flatten p (Cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

fun add :: "int => int Tree => int Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode (TNil) x (TNil)"

fun toTree :: "int list => int Tree" where
"toTree (Nil2) = TNil"
| "toTree (Cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x =
   dot
     (% (y :: (int list => int list)) => y (Nil2))
     (% (z :: int list) =>
        dot
          (% (x2 :: int Tree) => % (x3 :: int list) => flatten x2 x3)
          (% (x4 :: int list) => toTree x4) z)
     x"

(*hipster flatten dot and2 ordered add toTree tsort *)

theorem x0 :
  "!! (x :: int list) . ordered (tsort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
    File:        OccTools.thy
    Time-stamp:  <2020-06-22T03:53:40Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory OccTools imports ZF_aux InitSeg FinBnd begin

definition list_op :: "[i, i] => i" where
"list_op(A, X) == {z: univ(A). z = [] | (EX a l. z = Cons(a, l) &
                         a: A & l: X)}"

definition list_dom :: "i=>i" where
"list_dom(A) == univ(A)"

definition Occ_fbs_dom :: "i=>i" where
"Occ_fbs_dom(Tag) == list_dom(nat) * Tag"

definition Occ_fbs_op :: "[i, i] => i" where
"Occ_fbs_op(Tag, X) == list_op(nat, domain(X)) * Tag"

definition Occ_shift :: "[i, i] => i" where
"Occ_shift(b, X) == {z. y: X, EX l T. z = <Cons(b, l), T> & y = <l, T>}"

definition Occ_subtree :: "[i, i] => i" where
"Occ_subtree(b, X) == {z. y: X, EX l T. z = <l, T> & y = <Cons(b, l), T>}"

definition Occ_primary :: "i=>i" where
"Occ_primary(X) == {z: X. EX T.  z = <[], T>}"

definition Occ_cons :: "[i, i]=>i" where
"Occ_cons(T, l) == {<[], T>} Un (UN z: length(l). Occ_shift(z, nth(z, l)))"

definition functional :: "i=>o" where
"functional(X) == ALL l A B. <l, A>: X & <l, B>: X --> A = B"

definition CorrectArity :: "[i, i, i]=>o" where
"CorrectArity(X, T, n) == ALL l. <l, T>: X -->
                    (ALL m. m < n -->  (EX N. <l@[m], N>: X)) &
                    (ALL m. n \<le> m --> ~(EX N. <l@[m], N>: X))"

definition DenseTree :: "i=>o" where
"DenseTree(X) == (ALL l A m. <l, A>: X & initseg(nat, m, l) -->
                                 (EX B. <m, B>: X))"

definition Occ_range :: "[i, i=>i]=>i" where
"Occ_range(Tag, Arity) ==
         {X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag)).
             X ~= 0 & functional(X) & DenseTree(X) &
             (ALL T: Tag. CorrectArity(X, T, Arity(T)))}"

definition Occ_cons_cond :: "[i, i=>i, i, i=>i] =>o" where
"Occ_cons_cond(Terms, Occ, Tag, Arity) ==
   (ALL T: Tag. Arity(T): nat) &
   (ALL T: Tag. ALL l: list(Pow(list(nat)*Tag)). Arity(T) = length(l) &
      (ALL z: length(l). EX N: Terms. nth(z, l) = Occ(N))
      --> (EX M: Terms. Occ(M) = Occ_cons(T, l)))"

definition Occ_ind_cond :: "[i, i=>i, i, i=>i, [i, i]=>i] =>o" where
"Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons) ==
   (ALL P.
     (ALL T: Tag. ALL l: list(Terms).
          Term_cons(T, l): Terms &
          Arity(T) = length(l) &
          Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l)) &
          (ALL z: length(l). nth(z, l): P)
         --> Term_cons(T, l): P
      ) --> (ALL M: Terms. M: P))"

lemma Prod_domain_0_eq:
    "domain(0)*A = 0"
apply (rule domain_0 [THEN ssubst])
apply (rule Sigma_empty1)
done

lemma list_op_bnd_mono:
  "bnd_mono(list_dom(A), list_op(A))"
apply (unfold bnd_mono_def list_dom_def list_op_def)
apply (rule list.bnd_mono [unfolded bnd_mono_def])
done

lemma list_op_lfp_eq:
  "list(A) = lfp(list_dom(A), list_op(A))"
apply (unfold list.defs list_dom_def list_op_def lfp_def)
apply (rule refl)
done

lemma list_op_continuous:
  "X~= 0 ==> list_op(A, Union(X)) = (UN x: X. list_op(A, x))"
apply (unfold list_op_def)
apply (erule not_emptyE)
apply (rule equalityI)
apply blast+
done

(** Occ_shift **)
lemma Occ_shiftI:
  "<l, T>: X ==> <Cons(b, l), T>: Occ_shift(b, X)"
apply (unfold Occ_shift_def)
apply blast
done

lemma Occ_shiftE:
  "[| x: Occ_shift(b, X);
      !!l T. [| x = <Cons(b, l), T>; <l, T>: X |] ==> R
   |] ==> R"
apply (unfold Occ_shift_def)
apply blast
done

lemma Occ_shiftE2:
  "[| <l, T>: Occ_shift(b, X);
      !!m. [| l = Cons(b, m); <m, T>: X |] ==> R |] ==> R"
apply (unfold Occ_shift_def)
apply blast
done

lemma Occ_shift_0:
  "Occ_shift(b, 0) = 0"
apply (unfold Occ_shift_def)
apply blast
done

lemma Occ_shift_cons:
  "Occ_shift(b, cons(<l, T>, X)) = cons(<Cons(b, l), T>, Occ_shift(b, X))"
apply (unfold Occ_shift_def)
apply (rule equalityI)
apply blast+
done

lemma Occ_shift_continuous:
  "Occ_shift(b, Union(X)) = (UN x: X. Occ_shift(b, x))"
apply (unfold Occ_shift_def)
apply (rule equalityI)
apply blast+
done

lemma Occ_shift_Un:
  "Occ_shift(b, X Un Y) = Occ_shift(b, X) Un Occ_shift(b, Y)"
apply (unfold Occ_shift_def)
apply (rule equalityI)
apply blast+
done

lemma Occ_shift_iff:
  assumes domX: "X <= A*B"
  and domY: "Y <= C*D"
  and not_emptyX: "X ~= 0"
  shows "Occ_shift(a, X) = Occ_shift(b, Y) <-> a = b & X = Y"
apply (rule iffI)
apply (rule conjI)
apply (drule equalityD1)
apply (rule not_emptyX [THEN not_emptyE])
apply (frule domX [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (drule subsetD)
apply (erule Occ_shiftI)
apply (erule Occ_shiftE2)
apply (erule Cons_iff [THEN iffD1, THEN conjunct1])
apply (rule equalityI)
apply (drule_tac [2] equalityD2)
apply (drule_tac [1] equalityD1)

apply (rule subsetI)
apply (frule domX [THEN subsetD] domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (drule subsetD)
apply (erule Occ_shiftI)
apply (erule Occ_shiftE2)
apply (drule Cons_iff [THEN iffD1, THEN conjunct2])
apply hypsubst
apply assumption

apply (rule subsetI)
apply (frule domX [THEN subsetD] domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (drule subsetD)
apply (erule Occ_shiftI)
apply (erule Occ_shiftE2)
apply (drule Cons_iff [THEN iffD1, THEN conjunct2])
apply hypsubst
apply assumption

apply (erule conjE)
apply hypsubst
apply (rule refl)
done

lemmas Occ_shift_simps =
    Occ_shift_0 Occ_shift_cons Occ_shift_Un Occ_shift_iff

(** Occ_subtree **)

lemma Occ_subtreeI:
  "<Cons(b, l), T>: X ==> <l, T>: Occ_subtree(b, X)"
apply (unfold Occ_subtree_def)
apply (rule ReplaceI)
prefer 2 apply assumption
apply (rule refl conjI exI)+
apply (elim exE conjE)
apply simp
done

lemma Occ_subtreeD:
  "<l, T>: Occ_subtree(b, X) ==> <Cons(b, l), T>: X"
apply (unfold Occ_subtree_def)
apply blast
done

lemma Occ_subtreeE:
  "[| x: Occ_subtree(b, X);
      !!l T. [| x = <l, T>; <Cons(b, l), T>: X |] ==> R |] ==> R"
apply (unfold Occ_subtree_def)
apply blast
done

lemma Occ_subtreeE2:
  "[| <l, T>: Occ_subtree(b, X);
      <Cons(b, l), T>: X ==> R |] ==> R"
apply (unfold Occ_subtree_def)
apply blast
done

lemma Occ_subtree_0:
  "Occ_subtree(b, 0) = 0"
apply (unfold Occ_subtree_def)
apply blast
done

lemma Occ_subtree_cons_Nil:
  "Occ_subtree(a, cons(<[], T>, X)) = Occ_subtree(a, X)"
apply (unfold Occ_subtree_def)
apply (rule equalityI)
apply clarify
apply (erule consE)
apply simp
apply (rule ReplaceI)
apply (intro exI conjI)
prefer 2 apply (rule refl)
apply (rule refl)
apply assumption
apply (elim exE conjE)
apply simp
apply (rule subsetI)
apply clarify
apply (rule ReplaceI)
prefer 2 apply (rule consI2, assumption)
apply blast
apply (elim exE conjE)
apply simp
done

lemma Occ_subtree_cons_Cons:
  "Occ_subtree(a, cons(<Cons(b, l), T>, X)) =
           if(a = b, cons(<l, T>, Occ_subtree(b, X)), Occ_subtree(a, X))"
apply (case_tac "a = b")
apply (rule if_P [THEN sym, THEN [2] trans])
prefer 2 apply assumption
apply (rule_tac [2] if_not_P [THEN sym, THEN [2] trans])
prefer 3 apply assumption
apply (rule_tac [2] equalityI)
apply (rule equalityI)
apply (blast intro!: Occ_subtreeI elim!: Occ_subtreeE
          dest!: Cons_iff [THEN iffD1])+
done

lemma Occ_subtree_continuous:
  "Occ_subtree(b, Union(X)) = (UN x: X. Occ_subtree(b, x))"
apply (rule equalityI)
apply (blast intro!: Occ_subtreeI elim!: Occ_subtreeE
          dest!: Cons_iff [THEN iffD1])+
done

lemma Occ_subtree_UN:
  "Occ_subtree(b, UN z: A. f(z)) = (UN z: A. Occ_subtree(b, f(z)))"
apply (rule equalityI)
apply (blast intro!: Occ_subtreeI elim!: Occ_subtreeE
          dest!: Cons_iff [THEN iffD1])+
done

lemma Occ_subtree_Un:
  "Occ_subtree(b, X Un Y) = Occ_subtree(b, X) Un Occ_subtree(b, Y)"
apply (rule equalityI)
apply (blast intro!: Occ_subtreeI elim!: Occ_subtreeE
          dest!: Cons_iff [THEN iffD1])+
done

lemma Occ_subtree_shift:
  assumes prem: "X <= A*B"
  shows "Occ_subtree(a, Occ_shift(b, X)) = if(a = b, X, 0)"
apply (case_tac "a = b")
apply simp_all
prefer 2
apply (rule subset_empty_iff [THEN iffD1])
apply (rule subsetI)
apply (erule notE)
apply (blast intro!: Occ_subtreeI Occ_shiftI
        elim!: Occ_subtreeE Occ_shiftE dest!: Cons_iff [THEN iffD1])
apply (rule equalityI)
apply (blast intro!: Occ_subtreeI Occ_shiftI
        elim!: Occ_subtreeE Occ_shiftE dest!: Cons_iff [THEN iffD1])
apply (rule subsetI)
apply (frule prem [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (blast intro!: Occ_subtreeI Occ_shiftI
        elim!: Occ_subtreeE Occ_shiftE dest!: Cons_iff [THEN iffD1])
done

lemmas Occ_subtree_simps = Occ_subtree_0 Occ_subtree_cons_Nil
                        Occ_subtree_cons_Cons Occ_subtree_Un
                        Occ_subtree_UN Occ_subtree_shift

(** Occ_primary **)
lemma Occ_primaryI:
  "<[], T>: X ==> <[], T>: Occ_primary(X)"
apply (unfold Occ_primary_def)
apply blast
done

lemma Occ_primaryE:
  "[| x: Occ_primary(X);
      !!T. [| x = <[], T>; <[], T>: X |] ==> R |] ==> R"
apply (unfold Occ_primary_def)
apply blast
done

lemma Occ_primaryE2:
  "[| <l, T>: Occ_primary(X);
      !!T. [| l = []; <[], T>: X |] ==> R |] ==> R"
apply (unfold Occ_primary_def)
apply blast
done

lemma Occ_primary_0:
  "Occ_primary(0) = 0"
apply (unfold Occ_primary_def)
apply blast
done

lemma Occ_primary_cons:
  "Occ_primary(cons(<l, T>, X)) =
           if(l = [], cons(<[], T>, Occ_primary(X)), Occ_primary(X))"
apply (case_tac "l = []")
apply simp_all
apply (rule_tac [2] equalityI)
apply (rule equalityI)
apply (blast intro!: Occ_primaryI elim!: Occ_primaryE)+
done

lemma Occ_primary_continuous:
  "Occ_primary(Union(X)) = (UN x: X. Occ_primary(x))"
apply (rule equalityI)
apply (blast intro!: Occ_primaryI elim!: Occ_primaryE)+
done

lemma Occ_primary_UN:
  "Occ_primary(UN z: X. f(z)) = (UN z: X. Occ_primary(f(z)))"
apply (rule equalityI)
apply (blast intro!: Occ_primaryI elim!: Occ_primaryE)+
done

lemma Occ_primary_Un:
  "Occ_primary(X Un Y) = Occ_primary(X) Un Occ_primary(Y)"
apply (rule equalityI)
apply (blast intro!: Occ_primaryI elim!: Occ_primaryE)+
done

lemma Occ_primary_idempotent:
  "Occ_primary(Occ_primary(X)) = Occ_primary(X)"
apply (rule equalityI)
apply (blast intro!: Occ_primaryI elim!: Occ_primaryE)+
done

lemma Occ_primary_shift:
  "Occ_primary(Occ_shift(b, X)) = 0"
apply (rule subset_empty_iff [THEN iffD1])
apply (rule subsetI)
apply (clarify elim!: Occ_primaryE Occ_shiftE)
apply simp
done

lemma Occ_primary_subtree_shift_eq:
  assumes prem: "X <= list(A) * B"
  shows "X = Occ_primary(X) Un (UN z: A. Occ_shift(z, Occ_subtree(z, X)))"
apply (rule equalityI)
apply (rule subsetI)
apply (frule prem [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (erule list.cases)
apply simp_all
apply (blast intro!: Occ_subtreeI Occ_shiftI Occ_primaryI
        elim!: Occ_subtreeE Occ_shiftE Occ_primaryE
        dest!: Cons_iff [THEN iffD1])+
done

lemmas Occ_primary_simps =
     Occ_primary_0 Occ_primary_cons
     Occ_primary_Un Occ_primary_UN
     Occ_primary_shift Occ_primary_idempotent

(** Occ_cons **)
lemma Occ_consI1:
  "<[], T>: Occ_cons(T, l)"
apply (unfold Occ_cons_def)
apply blast
done

lemma Occ_consI2:
  "[| a: length(l); <m, U>: nth(a, l) |] ==>
           <Cons(a, m), U>: Occ_cons(T, l)"
apply (unfold Occ_cons_def)
apply (rule UnI2)
apply (erule UN_I)
apply (erule Occ_shiftI)
done

lemma Occ_consE:
  assumes major: "x: Occ_cons(T, l)"
  and "x = <[], T> ==> R"
  and "!! a m U. [| x = <Cons(a, m), U>; a: length(l);
              <m, U>: nth(a, l) |] ==> R"
  shows "R"
apply (rule major [unfolded Occ_cons_def, THEN UnE])
apply (erule singletonE)
apply (erule assms)
apply (erule UN_E)
apply (erule Occ_shiftE)
apply (erule assms)
apply assumption+
done

lemma Occ_cons_ConsE:
  assumes major: "<Cons(a, m), U>: Occ_cons(T, l)"
  and prem: "[| a: length(l); <m, U>: nth(a, l) |] ==> R"
  shows "R"
apply (rule major [THEN Occ_consE])
apply simp
apply (rule prem)
apply simp_all
done

lemma Occ_consE2:
  assumes major: "x: Occ_cons(T, l)"
  and l_list: "l: list(A)"
  and "x = <[], T> ==> R"
  and "!! a m U. [| x = <Cons(a, m), U>; a < length(l);
                   <m, U>: nth(a, l) |] ==> R"
  shows "R"
apply (rule major [unfolded Occ_cons_def, THEN UnE])
apply (erule singletonE)
apply (erule assms)
apply (erule UN_E)
apply (erule Occ_shiftE)
apply (erule assms)
apply (erule l_list [THEN length_type, THEN nat_into_Ord, THEN [2] ltI])
apply assumption
done

lemma Occ_cons_type:
  assumes prem1: "T: B"
  and prem2: "l: list(Pow(list(nat)* B))"
  shows "Occ_cons(T, l) <= list(nat) * B"
apply (rule subsetI)
apply (erule Occ_consE)
apply hypsubst
apply (rule SigmaI)
apply (rule list.intros)
apply (rule prem1)
apply hypsubst
apply (frule prem2 [THEN length_type, THEN [2] mem_nat_in_nat])
apply (frule prem2 [THEN [2] nth_type1])
apply (simp add: Pow_Un_0_simps)
apply blast
done

lemma Occ_cons_type2:
  assumes prem1: "T: B"
  and prem2: "length(l): nat"
  and prem3: "ALL z: length(l). nth(z, l)<=list(nat)*B"
  shows "Occ_cons(T, l) <= list(nat) * B"
apply (rule subsetI)
apply (erule Occ_consE)
apply hypsubst
apply (rule SigmaI)
apply (rule list.intros)
apply (rule prem1)
apply hypsubst
apply (frule prem2 [THEN [2] mem_nat_in_nat])
apply (drule prem3 [THEN bspec])
apply blast
done

lemma Occ_cons_Nil:
  "Occ_cons(T, []) = {<[], T>}"
apply (rule equalityI)
apply (rule subsetI)
apply (erule Occ_consE)
apply simp_all
apply (blast intro!: Occ_consI1)
done

lemma Occ_cons_app_last:
  "l: list(A) ==> Occ_cons(T, l@[X]) =
                  Occ_cons(T, l) Un Occ_shift(length(l), X)"
apply (subgoal_tac "l: list(A Un {X})")
apply (simp add: Occ_cons_def Un_commute)
apply (rule list_mono [THEN subsetD])
apply (rule Un_upper1)
apply assumption
done

lemma Occ_subtree_Occ_cons:
  "[| b: nat; l: list(Pow(A * B)) |] ==>
            Occ_subtree(b, Occ_cons(T, l)) = nth(b, l)"
apply (unfold Occ_cons_def)
apply (simp add: Occ_subtree_simps)
apply (rule equalityI)
prefer 2
apply (rule_tac i="b" and j="length(l)" in Ord_linear2)
apply (erule nat_into_Ord)
apply (erule length_type [THEN nat_into_Ord])
apply (safe elim!: Occ_subtreeE Occ_shiftE
            dest!: Cons_iff [THEN iffD1])
prefer 2 apply (frule nth_over_length_lemma)
prefer 2 apply assumption
apply assumption
apply simp
apply (rule UN_I)
apply (erule ltD)
apply (frule nth_type2)
apply assumption
apply (simp add: Occ_subtree_simps)
done

lemma Occ_primary_Occ_cons:
  "Occ_primary(Occ_cons(T, l)) = {<[], T>}"
apply (unfold Occ_cons_def)
apply (simp add: Occ_primary_simps)
done

lemma Occ_cons_iff:
  assumes l_list: "l: list(Pow(A * B))"
  and m_list: "m: list(Pow(A * B))"
  shows "Occ_cons(T, l) = Occ_cons(U, m) <-> T = U &
          (ALL n: length(l) Un length(m). nth(n, l) = nth(n, m))"
apply (safe intro!: nat_UnI length_type)
apply (drule_tac f="Occ_primary" in function_apply_eq)
apply (simp add: Occ_primary_Occ_cons)
apply (drule_tac [2] m_list [THEN length_type, THEN [2] mem_nat_in_nat])
apply (drule l_list [THEN length_type, THEN [2] mem_nat_in_nat])
apply (insert m_list l_list)
apply (drule_tac f="Occ_subtree(n)" in function_apply_eq)
apply (simp add: Occ_subtree_Occ_cons)
apply (drule_tac f="Occ_subtree(n)" in function_apply_eq)
apply (simp add: Occ_subtree_Occ_cons)
apply (unfold Occ_cons_def)
apply (rule equalityI)
apply safe
apply simp_all

apply (case_tac "z < length(m)")
apply (erule bspec [THEN notE])
apply (erule ltD, assumption)
apply (drule not_lt_imp_le)
apply (erule l_list [THEN length_type, THEN [2] mem_nat_in_nat,
                     THEN nat_into_Ord])
apply (rule m_list [THEN length_type, THEN nat_into_Ord])
apply (frule_tac xs="m" in nth_over_length_lemma)
prefer 2 apply assumption
apply (erule length_type [THEN [2] mem_nat_in_nat])
apply assumption
apply (simp add: Occ_shift_0)

apply (case_tac "z < length(l)")
apply (erule bspec [THEN notE])
apply (erule ltD, assumption)
apply (drule not_lt_imp_le)
apply (erule m_list [THEN length_type, THEN [2] mem_nat_in_nat,
                     THEN nat_into_Ord])
apply (rule l_list [THEN length_type, THEN nat_into_Ord])
apply (frule_tac xs="l" in nth_over_length_lemma)
prefer 2 apply assumption
apply (erule length_type [THEN [2] mem_nat_in_nat])
apply assumption
apply (simp add: Occ_shift_0)

done

lemmas Occ_cons_simps = nat_succ_Un  Occ_cons_iff
            Occ_subtree_Occ_cons Occ_primary_Occ_cons

(** functional **)
lemma functionalI:
  "[| !!l A B. [| <l, A>: X; <l, B>: X |] ==> A = B |] ==> functional(X)"
apply (unfold functional_def)
apply blast
done

lemma functionalD:
  "[| functional(X); <l, A>: X; <l, B>: X |] ==> A = B"
apply (unfold functional_def)
apply blast
done

(** DenseTree **)
lemma DenseTreeI:
  "[| !!l A m. [| <l, A>: X; initseg(nat, m, l) |] ==> (EX B. <m, B>: X) |]
      ==> DenseTree(X)"
apply (unfold DenseTree_def)
apply blast
done

lemma DenseTreeE:
  "[| DenseTree(X);
      <l, A>: X; initseg(nat, m, l);
      !!B. [| <m, B>: X |] ==> R |] ==> R"
apply (unfold DenseTree_def)
apply blast
done

lemma CorrectArityI:
  "[| !!l m. [| <l, T>: X; m < n |] ==> (EX N. <l @ [m], N> : X);
      !!l m. [| <l, T>: X; n \<le> m; (EX N. <l @ [m], N> : X) |] ==> False
   |] ==> CorrectArity(X, T, n)"
apply (unfold CorrectArity_def)
apply blast
done

lemma CorrectArityD1:
  "[| CorrectArity(X, T, n);
     <l, T>: X; m < n |] ==>  (EX N. <l @ [m], N>: X)"
apply (unfold CorrectArity_def)
apply blast
done

lemma CorrectArityD2:
  "[| CorrectArity(X, T, n);
     <l, T>: X; n \<le> m |] ==> ~(EX N. <l @ [m], N>: X)"
apply (unfold CorrectArity_def)
apply blast
done

lemma CorrectArityE:
  assumes major: "CorrectArity(X, T, n)"
  and case1: "!!N. [| m < n; <l @ [m], N>: X |] ==> R"
  and case2: "n \<le> m ==> EX N. <l @ [m], N>: X"
  shows "[| <l, T>: X; m: nat; n: nat |] ==> R"
apply (rule Ord_linear2)
apply (frule_tac [4] case2)
apply (rule_tac [4] major [THEN CorrectArityD2, THEN notE])
apply (rule_tac [3] major [THEN CorrectArityD1, THEN exE])
apply (rule_tac [5] case1)
apply (assumption | rule nat_into_Ord)+
done

(** Occ_range **)
lemma Occ_rangeE:
  "[| X: Occ_range(Tag, Arity);
      [| X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag));
         X ~= 0; functional(X); DenseTree(X);
         ALL T: Tag. CorrectArity(X, T, Arity(T)) |] ==> R
   |] ==> R"
apply (unfold Occ_range_def)
apply blast
done

lemma Occ_rangeI:
  "[| X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag));
      X ~= 0; functional(X); DenseTree(X);
      ALL T: Tag. CorrectArity(X, T, Arity(T))
   |] ==> X: Occ_range(Tag, Arity)"
apply (unfold Occ_range_def)
apply blast
done

lemma Occ_range_DenseTreeD:
  "X: Occ_range(Tag, Arity) ==> DenseTree(X)"
apply (erule Occ_rangeE)
apply assumption
done

lemma Occ_range_functionalD:
  "X: Occ_range(Tag, Arity) ==> functional(X)"
apply (erule Occ_rangeE)
apply assumption
done

lemma Occ_range_CorrectArityD:
  "[| X: Occ_range(Tag, Arity); T: Tag |]
        ==> CorrectArity(X, T, Arity(T))"
apply (erule Occ_rangeE)
apply (erule bspec)
apply assumption
done

(** Occ_cons_cond **)
lemma Occ_cons_condD1:
  "[| Occ_cons_cond(Terms, Occ, Tag, Arity); T: Tag |] ==> Arity(T): nat"
apply (unfold Occ_cons_cond_def)
apply blast
done

lemma Occ_cons_condD2:
  "[| Occ_cons_cond(Terms, Occ, Tag, Arity);
      T: Tag; l: list(Pow(list(nat) * Tag));
      Arity(T) = length(l);
      ALL z: length(l). EX N: Terms. nth(z, l) = Occ(N)
   |] ==> EX M: Terms. Occ(M) = Occ_cons(T, l)"
apply (unfold Occ_cons_cond_def)
apply blast
done

lemma Occ_cons_condI:
  "[| !!T. T: Tag ==> Arity(T): nat;
      !!T l. [| T: Tag; l: list(Pow(list(nat) * Tag));
         length(l) = Arity(T);
         ALL z: length(l). EX N: Terms. nth(z, l) = Occ(N) |]
         ==> EX M: Terms. Occ(M) = Occ_cons(T, l)
   |] ==> Occ_cons_cond(Terms, Occ, Tag, Arity)"
apply (unfold Occ_cons_cond_def)
apply (rule conjI)
apply blast
apply (intro ballI impI)
apply simp
done

(** Occ_ind_cond **)
lemma Occ_ind_condD:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  and indstep:
    "!! l T. [| T: Tag; l: list(Terms);
               Term_cons(T, l): Terms;
               Arity(T) = length(l);
               Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l));
               ALL z: length(l). P(nth(z, l)) |]  ==> P(Term_cons(T, l))"
  shows "P(M)"
apply (rule_tac A="Terms" in CollectD2)
apply (rule major [unfolded Occ_ind_cond_def, THEN spec, THEN mp, THEN bspec])
apply (rule_tac [2] prem)
apply (intro allI impI ballI)
apply (elim conjE)
apply (rule CollectI)
apply assumption
apply (erule indstep)
apply assumption+
apply (rule ballI)
apply (drule bspec, assumption)
apply (erule CollectE)
apply assumption
done

lemma Occ_ind_condI:
  assumes ind:
    "!!P M. [| M: Terms;
             ALL T: Tag. ALL l: list(Terms).
              Term_cons(T, l): Terms &
              Arity(T) = length(l) &
              Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l)) &
              (ALL z: length(l). P(nth(z, l))) --> P(Term_cons(T, l))
            |] ==> P(M)"
   shows "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
apply (unfold Occ_ind_cond_def)
apply (intro allI impI ballI)
apply (erule ind)
apply assumption
done

lemma Occ_ind_cond_Occ_domain:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  shows "Occ(M) <= list(nat) * Tag"
apply (rule Occ_ind_condD [OF major prem])
apply (erule_tac P="%x. x <= list(nat) * Tag" in ssubst)
apply (rule Occ_cons_type2)
apply assumption
apply simp_all
done

lemma Occ_ind_cond_Occ_induct:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  and indstep:
     "!! l T. [| T: Tag; l: list(Pow(list(nat) * Tag));
            Occ_cons(T, l) <= list(nat) * Tag;
            length(l) = Arity(T);
            ALL z: length(l). P(nth(z, l)) |]  ==> P(Occ_cons(T, l))"
  shows "P(Occ(M))"
apply (rule Occ_ind_condD [OF major prem])
apply simp
apply (rule indstep)
apply assumption
apply (erule_tac [2] P="%x. x <= list(nat) * Tag" in subst)
apply (erule_tac [2] major [THEN Occ_ind_cond_Occ_domain])
apply (rule map_type)
apply (erule_tac [2] major [THEN Occ_ind_cond_Occ_domain, THEN PowI])
apply assumption
apply (simp_all add: nth_map)
done

lemma Occ_ind_cond_Occ_inj_lemma:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  shows "ALL N: Terms. Occ(M) = Occ(N) --> M = N"
apply (rule Occ_ind_condD [OF major prem])
apply (rule ballI)
apply (erule_tac M="N" in major [THEN Occ_ind_condD])
apply simp
apply (rule impI)
apply (rule Occ_cons_iff [THEN iffD1, elim_format])
prefer 3 apply assumption

apply (rule map_type)
apply assumption
apply (erule major [THEN Occ_ind_cond_Occ_domain, THEN PowI])

apply (rule map_type)
apply assumption
apply (erule major [THEN Occ_ind_cond_Occ_domain, THEN PowI])
apply (erule conjE)
apply hypsubst
apply simp
apply (rename_tac v T')
apply (rule_tac a="v" and b="l" in ssubst)
apply (rule_tac [2] refl)
apply (rule_tac nth_inj)
defer 1
defer 1
apply assumption+
apply (simp_all add: nth_map)
apply (rule ballI)
apply (erule bspec [THEN bspec, THEN mp])
apply (frule length_type [THEN [2] nat_ltI])
apply simp_all
done

lemma Occ_ind_cond_Occ_inj:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  shows "[| M: Terms; N: Terms |] ==> Occ(M) = Occ(N) <-> M = N"
apply (rule iffI)
apply (rule major [THEN Occ_ind_cond_Occ_inj_lemma, THEN bspec, THEN mp])
apply assumption+
apply hypsubst
apply (rule refl)
done

(** Monotonisity **)
lemma Occ_shift_mono:
  "X <= Y ==> Occ_shift(b, X) <= Occ_shift(b, Y)"
apply (blast elim!: Occ_shiftE intro!: Occ_shiftI)
done

lemma Occ_subtree_mono:
  "X <= Y ==> Occ_subtree(b, X) <= Occ_subtree(b, Y)"
apply (blast elim!: Occ_subtreeE intro!: Occ_subtreeI)
done

lemma Occ_primary_mono:
  "X <= Y ==> Occ_primary(X) <= Occ_primary(Y)"
apply (blast elim!: Occ_primaryE intro!: Occ_primaryI)
done

(** Finiteness **)
lemma Occ_shift_FinI:
  "[| X: Fin(list(A)*B); b: A |] ==>  Occ_shift(b, X): Fin(list(A)*B)"
apply (erule Fin_induct)
apply (simp add: Occ_shift_simps)
apply (erule SigmaE)
apply (simp add: Occ_shift_simps)
done

lemma Occ_subtree_FinI:
  "X: Fin(list(A)*B) ==>  Occ_subtree(b, X): Fin(list(A)*B)"
apply (erule Fin_induct)
apply (simp add: Occ_subtree_simps)
apply (erule SigmaE)
apply (erule list.cases)
apply (simp_all add: Occ_subtree_simps)
apply (rule impI)
apply hypsubst
apply (rule Fin.intros)
apply (rule SigmaI)
apply assumption+
done

lemma Occ_primary_FinI:
  "X: Fin(list(A)*B) ==>  Occ_primary(X): Fin(list(A)*B)"
apply (erule Fin_induct)
apply (erule_tac [2] SigmaE)
apply (simp_all add: Occ_primary_simps)
done

lemma Occ_cons_FinI:
  "[| l: list(Fin(list(nat)*Tag)); T: Tag |] ==>
                  Occ_cons(T, l): Fin(list(nat)*Tag)"
apply (erule list_append_induct)
apply (simp_all add: Occ_cons_Nil Occ_cons_app_last)
apply (blast intro: length_type Occ_shift_FinI Fin_UnI)
done

(** Occ_fbs_op **)
lemma Occ_fbs_op_continuous:
  "X ~= 0 ==> Occ_fbs_op(Tag, Union(X)) = (UN x: X. Occ_fbs_op(Tag, x))"
apply (unfold Occ_fbs_op_def)
apply (subgoal_tac "{domain(x). x: X} ~= 0")
apply (simp add: continuous_simps list_op_continuous)
apply (erule not_emptyE)
apply (rule not_emptyI)
apply (rule RepFunI)
apply assumption
done

lemma Occ_fbs_mono_inj_pair:
  assumes major: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem: "X ~= 0"
  shows "mono_inj_pair(list_dom(nat), %x. x * Tag , domain)"
apply (rule prem [THEN not_emptyE])
apply (drule major [unfolded Occ_fbs_dom_def, THEN fin_bnd_set_domain [THEN subsetD], THEN PowD, THEN subsetD])
apply (erule SigmaE)
apply (erule Prod_domain_mono_inj_pair)
done

lemma Occ_fbs_mono_inj_pair2:
  assumes prem1: "X <= A * Tag"
  and prem2: "X ~= 0"
  shows "mono_inj_pair(list_dom(nat), %x. x * Tag , domain)"
apply (rule prem2 [THEN not_emptyE])
apply (drule prem1 [THEN subsetD])
apply (erule SigmaE)
apply (erule Prod_domain_mono_inj_pair)
done

lemma Occ_fbs_op_bnd_cont:
  "bnd_cont(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (rule bnd_contI)
apply (erule Occ_fbs_op_continuous)
apply (unfold Occ_fbs_op_def Occ_fbs_dom_def)
apply (case_tac "Tag = 0")
apply simp
apply (erule not_emptyE)
apply (simp add: domain_of_prod)
apply (insert list_op_bnd_mono [THEN bnd_monoD1])
apply blast
done

lemmas Occ_fbs_op_bnd_mono = Occ_fbs_op_bnd_cont
    [THEN bnd_cont_bnd_mono, rule_format]

lemma Occ_fbs_op_lfp_eq:
  "lfp(Occ_fbs_dom(Tag), Occ_fbs_op(Tag)) = list(nat) * Tag"
apply (case_tac "Tag = 0")
apply (simp add: Occ_fbs_dom_def lfp_def Occ_fbs_op_def)
apply (erule not_emptyE)
apply (drule_tac A1=nat in
  mono_inj_pair_lfp_eq [OF Prod_domain_mono_inj_pair list_op_bnd_mono])
apply (fold Occ_fbs_dom_def Occ_fbs_op_def)
apply (erule list_op_lfp_eq [THEN ssubst])
done

lemma Occ_fbs_op_fin_bnd_set_upper_Fin:
  "Fin(list(nat) * Tag) <= fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (insert Occ_fbs_op_bnd_cont [THEN fin_bnd_set_upper_Fin_lfp])
apply (simp add: Occ_fbs_op_lfp_eq)
done

lemma Occ_fbs_op_lfp_lowerbound:
  "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))
     ==> X <= list(nat) * Tag"
apply (rule Occ_fbs_op_lfp_eq [THEN subst])
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_Pow_lfp_lowerbound,
         THEN subsetD, THEN PowD])
apply assumption
done

(** Preservation Properties of Occ_subtree **)
lemma Occ_subtree_preserves_domain:
  "X <= list(A) * B ==> Occ_subtree(b, X) <= list(A) * B"
apply (blast elim!: Occ_subtreeE ConsE)
done

lemma Occ_subtree_preserves_functionality:
  "functional(X) ==> functional(Occ_subtree(a, X))"
apply (rule functionalI)
apply (drule Occ_subtreeD)+
apply (erule functionalD)
apply assumption+
done

lemma Occ_subtree_preserves_CorrectArity:
  assumes prem: "CorrectArity(X, T, n)"
  shows "CorrectArity(Occ_subtree(a, X), T, n)"
apply (rule CorrectArityI)
apply (erule_tac [2] Occ_subtreeE2)
apply (erule Occ_subtreeE2)
apply (drule_tac [2] prem [THEN CorrectArityD2])
apply (drule prem [THEN CorrectArityD1])
apply assumption
prefer 2 apply assumption
apply (erule_tac [2] notE)
apply (erule exE)
apply (rule exI)
apply (rule Occ_subtreeI)
apply simp
apply (erule exE)
apply (drule Occ_subtreeD)
apply (rule exI)
apply simp
done

lemma Occ_subtree_preserves_DenseTree:
  assumes prem: "DenseTree(X)"
  shows "a: nat ==> DenseTree(Occ_subtree(a, X))"
apply (rule DenseTreeI)
apply (drule Occ_subtreeD)
apply (erule prem [THEN DenseTreeE])
apply (rule initseg_ConsI)
apply assumption+
apply (rule exI)
apply (erule Occ_subtreeI)
done

lemma Occ_subtree_preserves_not_empty:
  assumes major: "<[], T>: X"
  and prem: "CorrectArity(X, T, n)"
  and n_nat: "n: nat"
  shows "ALL z: n. Occ_subtree(z, X) ~= 0"
apply (rule ballI)
apply (frule n_nat [THEN nat_into_Ord, THEN [2] ltI])
apply (drule CorrectArityD1 [OF prem major])
apply (erule exE)
apply (rule not_emptyI)
apply (rule Occ_subtreeI)
apply simp
done

lemma Occ_subtree_Occ_fbs_op_lemma:
  "x <= Occ_fbs_op(Tag, Z) ==> Occ_subtree(b, x) <= domain(Z) * Tag"
apply (unfold Occ_fbs_op_def list_op_def)
apply (clarify elim!: Occ_subtreeE)
apply (drule subsetD)
apply assumption
apply (erule SigmaE)
apply (erule CollectE)
apply safe
apply simp_all
apply (erule domainI)
done

lemma Occ_subtree_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "X ~= 0"
  shows "Occ_subtree(b, X): fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (rule prem1 [THEN Occ_fbs_op_bnd_mono [THEN fin_bnd_set_boundE]])
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_subsetI])
apply (rule Occ_subtree_Occ_fbs_op_lemma)
apply (erule subset_trans)
apply assumption
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_setI2])
apply (erule fin_bnd_setE)
apply (unfold fin_bnd_def Occ_fbs_op_def)
apply (erule mono_inj_pair_fin_bnd_lemma
        [OF Occ_fbs_mono_inj_pair [OF prem1 prem2] list_op_bnd_mono,
          unfolded fin_bnd_def])
done

lemma Occ_subtree_in_Occ_range:
  assumes major: "<Cons(a, l), T>: X"
  and prem: "X: Occ_range(Tag, Arity)"
  and a_nat: "a: nat"
  shows "Occ_subtree(a, X): Occ_range(Tag, Arity)"
apply (rule prem [THEN Occ_rangeE])
apply (rule Occ_rangeI)
apply (rule_tac [5] ballI)
apply (rule_tac [2] not_emptyI)
apply (rule_tac [2] major [THEN Occ_subtreeI])
apply (drule_tac [4] bspec)
apply (assumption | rule a_nat Occ_subtree_in_fin_bnd_set
        Occ_subtree_preserves_functionality
        Occ_subtree_preserves_DenseTree
        Occ_subtree_preserves_CorrectArity)+
done

(** Range of Occurence  **)
lemma Occ_domain_lemma:
  assumes major: "X <= Occ_fbs_dom(Tag)"
  and hinj: "mono_inj_pair(list_dom(nat), %x. x * Tag , domain)"
  and hmono: "bnd_mono(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  shows
    "[|
       Z: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag));
       X <= Occ_fbs_op(Tag, Z)
     |] ==> X <= list(nat)*Tag"
apply (rule list_op_lfp_eq [THEN ssubst])
apply (rule subst [OF mono_inj_pair_lfp_eq
                   [OF hinj list_op_bnd_mono],
                    unfolded Occ_fbs_dom_def])
apply (fold Occ_fbs_dom_def Occ_fbs_op_def)
apply (rule hmono [THEN fin_bnd_set_Pow_lfp_lowerbound,
                   THEN subsetD, THEN PowD])
apply (erule fin_bnd_setE)
apply (rule major [THEN fin_bnd_setI])
apply (rule hmono [THEN fin_bnd_succ])
apply assumption+
done

lemma Occ_DenseTree_not_empty_lemma:
  assumes major: "X ~= 0"
  and domX: "X <= list(nat) * Tag"
  and hierX: "DenseTree(X)"
  shows "EX N: Tag. <[], N>: X"
apply (rule major [THEN not_emptyE])
apply (frule domX [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (erule hierX [THEN DenseTreeE])
apply (erule initseg_NilI)
apply (frule domX [THEN subsetD])
apply (erule SigmaE2)
apply (erule bexI)
apply assumption
done

lemma Occ_primary_functional_lemma:
  assumes major: "<[], T>: X"
  and funcX: "functional(X)"
  shows "Occ_primary(X) = {<[], T>}"
apply (rule equalityI)
apply (rule subsetI)
apply (erule Occ_primaryE)
apply (drule major [THEN funcX [THEN functionalD]])
apply hypsubst
apply (rule singletonI)
apply (rule subsetI)
apply (erule singletonE)
apply hypsubst
apply (rule major [THEN Occ_primaryI])
done

lemma Occ_range_lemma1:
  assumes Arity_nat: "Arity(T): nat"
  and not_empty: "ALL z: Arity(T). Occ_subtree(z, X) ~= 0"
  and prem1: "ALL y. y <= domain(Z)*Tag -->
               y ~=0 & functional(y) & DenseTree(y) &
                (ALL T: Tag. CorrectArity(y, T, Arity(T))) -->
                       (EX M: Terms. y = Occ(M))"
  and prem2: "X <= Occ_fbs_op(Tag, Z)"
  and funcX: "functional(X)"
  and hierX: "DenseTree(X)"
  and corrX: "ALL T:Tag. CorrectArity(X, T, Arity(T))"
  shows "ALL z: Arity(T). EX N: Terms. Occ_subtree(z, X) = Occ(N)"
apply (rule ballI)
apply (rule prem1 [THEN spec, THEN mp,
        OF prem2 [THEN Occ_subtree_Occ_fbs_op_lemma], THEN mp])
apply (frule Arity_nat [THEN [2] mem_nat_in_nat])
apply (assumption | rule conjI ballI funcX hierX
       corrX [THEN bspec] not_empty [THEN bspec]
       Occ_subtree_preserves_functionality
       Occ_subtree_preserves_DenseTree
       Occ_subtree_preserves_CorrectArity)+
done

lemma Occ_range_lemma2:
  assumes Arity_nat: "Arity(T): nat"
  and domX: "X <= list(nat)*Tag"
  and prem:
     "ALL z: Arity(T). EX N: Terms. Occ_subtree(z, X) = Occ(N)"
  shows "EX l: list(Pow(list(nat)*Tag)). Arity(T) = length(l) &
            (ALL z: length(l). nth(z, l) = Occ_subtree(z, X)) &
            (ALL z: length(l). EX N: Terms. nth(z, l) = Occ(N))"
apply (rule nth_existence_lemma [elim_format])
apply (rule_tac [2] Arity_nat)
apply (rule ballI)
apply (rule_tac b1="z" in domX [THEN Occ_subtree_preserves_domain, THEN PowI])
apply (erule bexE)
apply (erule conjE)
apply (rule bexI)
prefer 2 apply assumption
apply (rule conjI)
apply (erule sym)
apply (rule conjI)
apply (erule ssubst)
apply assumption
apply (rule ballI)
apply simp
apply (frule prem [THEN bspec])
apply (erule bexE)
apply (rule bexI)
apply assumption+
done

lemma Occ_cons_lemma:
  assumes major: "<[], T>: X"
  and crrX: "CorrectArity(X, T, length(l))"
  and funcX: "functional(X)"
  and hierX: "DenseTree(X)"
  and domX: "X <= list(nat) * Tag"
  and l_list: "l: list(A)"
  and prem: "ALL z: length(l). nth(z, l) = Occ_subtree(z, X)"
  shows "Occ_cons(T, l) = X"
apply (rule sym)
apply (rule domX [THEN Occ_primary_subtree_shift_eq, THEN trans])
apply (simp add: Occ_primary_functional_lemma [OF major funcX])
apply (rule equalityI)
apply (rule subsetI)
apply (erule UnE)
apply (erule singletonE)
apply hypsubst
apply (rule Occ_consI1)
apply (erule UN_E)
apply (erule Occ_shiftE)
apply hypsubst
apply (rule crrX [THEN CorrectArityE])
apply (rule_tac [3] major)
prefer 3 apply assumption
apply (rule_tac [3] l_list [THEN length_type])
apply (rule Occ_consI2)
apply (erule ltD)
apply (drule ltD)
apply (drule prem [THEN bspec])
apply (erule ssubst)
apply assumption
apply (drule Occ_subtreeD)
apply (rule hierX [THEN DenseTreeE])
apply assumption
apply (erule initseg_ConsI)
apply (rule initseg_NilI)
apply (drule domX [THEN subsetD])
apply (erule SigmaE2)
apply (erule ConsE)
apply assumption
apply (rule exI)
apply simp
apply (rule subsetI)
apply (erule Occ_consE)
apply blast
apply hypsubst
apply (rule UnI2)
apply (rule UN_I)
apply (rule_tac [2] Occ_shiftI)
apply (erule l_list [THEN length_type, THEN [2] mem_nat_in_nat])
apply (drule prem [THEN bspec])
apply (erule subst)
apply assumption
done

lemma Occ_fbs_op_fin_bnd_induct:
  assumes major: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem: "X ~= 0"
  and indstep:
      "!!X. [| X <= list(nat)*Tag; X ~= 0;
              EX Z: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag)).
                X <= Occ_fbs_op(Tag, Z) &
            (ALL Y. Y <= domain(Z)*Tag --> Y ~= 0 -->P(Y)) |] ==> P(X)"
  shows "P(X)"
apply (rule prem [THEN rev_mp])
apply (rule_tac a="X" in mono_inj_pair_fin_bnd_set_induct)
apply (rule Occ_fbs_mono_inj_pair [OF major prem])
apply (rule trivial_mono_inj_pair)
apply (rule Prod_domain_0_eq)
apply (rule list_op_bnd_mono)
apply (fold Occ_fbs_dom_def Occ_fbs_op_def)
apply (rule major)
apply blast
apply (rule impI)
apply (elim bexE conjE)
apply (drule Occ_domain_lemma)
apply (assumption
       | rule Occ_fbs_mono_inj_pair [OF major prem]
              Occ_fbs_op_bnd_mono)+
apply (rule indstep)
apply (assumption | rule bexI conjI)+
done

lemma Occ_range_existence_lemma:
  assumes major: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and prem: "X: Occ_range(Tag, Arity)"
  shows "EX M: Terms. X = Occ(M)"
apply (rule prem [unfolded Occ_range_def, THEN CollectD2, THEN rev_mp])
apply (rule_tac a="X" in mono_inj_pair_fin_bnd_set_induct)
apply (rule Occ_fbs_mono_inj_pair)
apply (rule prem [unfolded Occ_range_def, THEN CollectD1])
apply (rule prem [unfolded Occ_range_def, THEN CollectD2,
                  THEN conjunct1])
apply (rule trivial_mono_inj_pair)
apply (rule Prod_domain_0_eq)
apply (rule list_op_bnd_mono)
apply (fold Occ_fbs_dom_def Occ_fbs_op_def)
apply (rule prem [unfolded Occ_range_def, THEN CollectD1])
apply blast
apply (rule impI)
apply (elim bexE conjE)
apply (drule Occ_domain_lemma)
apply (rule_tac [2] Occ_fbs_op_bnd_mono)
apply (rule Occ_fbs_mono_inj_pair)
apply (rule prem [unfolded Occ_range_def, THEN CollectD1])
apply (assumption
       | rule prem [unfolded Occ_range_def, THEN CollectD2,
                    THEN conjunct1])+
apply (frule Occ_DenseTree_not_empty_lemma)
apply assumption+
apply (erule bexE)
apply (frule bspec)
apply assumption
apply (frule major [THEN Occ_cons_condD1])
apply (frule Occ_subtree_preserves_not_empty)
apply assumption+
apply (frule_tac Arity=Arity in Occ_range_lemma1)
apply assumption+
apply (frule_tac Arity=Arity in Occ_range_lemma2)
apply assumption+
apply (elim bexE conjE)
apply (frule major [THEN Occ_cons_condD2])
apply assumption+
apply (erule bexE)
apply (frule_tac l="l" in Occ_cons_lemma)
apply (erule_tac P="%z. CorrectArity(x, N, z)" in subst)
apply assumption+
apply (rule bexI)
apply (erule sym [THEN trans])
apply (erule sym)
apply assumption
done

lemma Occ_range_depth_induct:
  assumes major: "X: Occ_range(Tag, Arity)"
  and indstep:
     "!!X. [| X <= list(nat) * Tag; X: Occ_range(Tag, Arity);
              EX Z: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag)).
                X <= Occ_fbs_op(Tag, Z) &
            (ALL Y: Occ_range(Tag, Arity). Y <= domain(Z)*Tag --> P(Y))
      |] ==> P(X)"
  shows "P(X)"
apply (rule major [unfolded Occ_range_def, THEN rev_mp])
apply (rule Occ_fbs_op_fin_bnd_induct
       [OF major [unfolded Occ_range_def, THEN CollectD1]
           major [unfolded Occ_range_def, THEN CollectD2, THEN conjunct1]])
apply (rule impI)
apply (rule indstep [unfolded Occ_range_def])
apply assumption+
apply (elim bexE conjE)
apply (rule bexI)
prefer 2 apply assumption
apply (erule conjI)
apply (rule impI [THEN ballI])
apply (erule spec [THEN mp, THEN mp, THEN mp])
apply (erule_tac [2] CollectE conjE)+
apply assumption+
done

(** Occ_in_Occ_range **)
lemma Occ_cons_preserves_functionality:
  "[| ALL z: length(l). functional(nth(z, l)) |]
         ==> functional(Occ_cons(T, l))"
apply (rule functionalI)
apply (erule Occ_consE)
apply (erule Occ_consE)
apply (erule_tac [3] Occ_consE)
apply (drule_tac [4] bspec)
prefer 4 apply assumption
apply simp_all
apply (blast dest: functionalD)
done

lemma Occ_cons_preserves_DenseTree:
  assumes prem: "ALL z: length(l). DenseTree(nth(z, l))"
  and l_list: "l: list(A)"
  shows "DenseTree(Occ_cons(T, l))"
apply (rule DenseTreeI)
apply (erule Occ_consE)
apply (erule Pair_iff [THEN iffD1, THEN conjE])
apply hypsubst
apply (erule initseg_NilE)
apply hypsubst
apply (rule exI)
apply (rule Occ_consI1)
apply (erule Pair_iff [THEN iffD1, THEN conjE])
apply hypsubst
apply (erule initseg_ConsE)
apply hypsubst
apply (rule exI)
apply (rule Occ_consI1)
apply hypsubst
apply (frule prem [THEN bspec])
apply (erule DenseTreeE)
apply (assumption
       | rule Occ_consI2 exI ltI
            l_list [THEN length_type, THEN nat_into_Ord])+
done

lemma Occ_cons_preserves_CorrectArity:
  assumes corr: "ALL z: length(l). CorrectArity(nth(z, l), U, n)"
  and hier: "ALL z: length(l). DenseTree(nth(z, l))"
  and not_empty: "ALL z: length(l). nth(z, l) ~= 0"
  and domnth: "ALL z: length(l). nth(z, l) <= list(nat) * Tag"
  and prem: "T = U ==> n = length(l)"
  shows "CorrectArity(Occ_cons(T, l), U, n)"
apply (rule CorrectArityI)
apply (erule Occ_consE)
apply (erule Pair_iff [THEN iffD1, THEN conjE])
apply (frule sym [THEN prem])
apply hypsubst
apply (frule ltD)
apply (frule not_empty [THEN bspec])
apply (frule domnth [THEN bspec])
apply (frule hier [THEN bspec])
apply (erule not_emptyE)
apply (drule subsetD)
apply assumption
apply (erule SigmaE)
apply hypsubst
apply (erule DenseTreeE)
apply assumption
apply (erule initseg_NilI)
apply (rule exI)
apply simp
apply (erule Occ_consI2)
apply assumption
apply (erule Pair_iff [THEN iffD1, THEN conjE])
apply (frule corr [THEN bspec])
apply (drule CorrectArityD1)
apply hypsubst
apply assumption+
apply (erule exE)
apply (rule exI)
apply simp
apply (erule Occ_consI2)
apply assumption
apply (erule Occ_consE)
apply (elim exE Occ_consE)
apply (erule_tac [3] exE Occ_consE)+
apply simp
prefer 2 apply simp
apply simp
apply clarify
apply (frule sym [THEN prem])
apply hypsubst
apply (erule leE)
apply (drule ltD)
apply (erule mem_asym, assumption)
apply hypsubst
apply (erule mem_irrefl)
apply (frule corr [THEN bspec])
apply simp
apply clarify
apply (drule CorrectArityD2)
apply assumption+
apply (erule notE)
apply (erule exI)
done

lemma Occ_range_domain_lemma:
  "X: Occ_range(Tag, Arity) ==> X <= list(nat) * Tag"
apply (erule Occ_rangeE)
apply (drule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_Pow_lfp_lowerbound, THEN subsetD])
apply (drule PowD)
apply (rule Occ_fbs_op_lfp_eq [THEN subst])
apply assumption
done

lemma Occ_cons_in_fin_bnd_set:
  assumes hmono: "bnd_mono(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and t_tag: "T: Tag"
  and l_list: "l: list(Pow(list(nat)*Tag))"
  and prem:
    "ALL z: length(l). nth(z, l): fin_bnd_set(Occ_fbs_dom(Tag),
                                                Occ_fbs_op(Tag))"
  shows "Occ_cons(T, l): fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (rule prem [THEN rev_mp])
apply (rule l_list [THEN list_append_induct])
apply (simp_all add: Occ_cons_Nil Occ_cons_app_last)
apply (rule hmono [THEN fin_bnd_set_succI])
prefer 2 apply (rule fin_bnd_set_0I)
apply (simp add: Occ_fbs_op_def list_op_def)
apply (rule conjI)
apply (rule nat_subset_univ [THEN [2] list_into_univ])
apply (rule list.intros)
apply (rule t_tag)
apply (rule impI)
apply (rule hmono [THEN fin_bnd_set_UnI])
apply (erule mp)
apply simp
apply (rule hmono [THEN fin_bnd_set_succI])
apply (simp add: Occ_fbs_op_def list_op_def)
apply (rule subsetI)
apply (erule Occ_shiftE)
apply hypsubst
apply (rule SigmaI)
apply (rule CollectI)
apply (rule nat_subset_univ [THEN [2] list_into_univ])
apply (rule list.intros)
apply (erule length_type)
apply (drule subsetD, assumption)
apply (erule SigmaD1)
apply (rule disjI2)
apply (intro exI)
apply (assumption | rule conjI refl length_type domainI)+
apply (drule subsetD, assumption)
apply (erule SigmaD2)
apply (erule conjE)
apply assumption
done

lemma Occ_ind_cond_Occ_in_Occ_range:
  assumes major: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  shows "Occ(M): Occ_range(Tag, Arity)"
apply (rule prem [THEN major [THEN Occ_ind_cond_Occ_induct]])
apply (rule Occ_rangeI)
apply (rule_tac [2] Occ_consI1 [THEN not_emptyI])
apply (rule_tac [4] ballI)

apply (rule Occ_cons_in_fin_bnd_set)
apply (rule Occ_fbs_op_bnd_mono)
apply assumption+
apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply assumption

apply (rule Occ_cons_preserves_functionality)
apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply assumption

apply (rule Occ_cons_preserves_DenseTree)
apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply assumption+

apply (rule Occ_cons_preserves_CorrectArity)
apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply (erule bspec)
apply assumption

apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply assumption

apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_rangeE)
apply assumption

apply (rule ballI)
apply (drule bspec, assumption)
apply (erule Occ_range_domain_lemma)
apply hypsubst
apply (erule sym)
done

lemma Occ_ind_cond_Occ_FinI:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "M: Terms"
  shows "Occ(M): Fin(list(nat) * Tag)"
apply (rule Occ_ind_cond_Occ_induct [OF hind prem])
apply (rule Occ_cons_FinI)
apply (erule nth_convert_list_type)
apply assumption+
done

lemma Occ_ind_cond_Occ_not_empty_lemma:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and major: "M: Terms"
  shows "EX T: Tag. <[], T>: Occ(M)"
apply (rule Occ_ind_cond_Occ_in_Occ_range [OF hind major, THEN Occ_rangeE])
apply (rule Occ_DenseTree_not_empty_lemma)
apply (assumption | rule Occ_ind_cond_Occ_domain [OF hind major])+
done

lemma Occ_range_convert_lemma:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and major: "X: Occ_range(Tag, Arity)"
  and prem: "!!M. M: Terms ==> P(Occ(M))"
  shows "P(X)"
apply (rule Occ_range_existence_lemma [OF hcons major, THEN bexE])
apply (erule ssubst)
apply (erule prem)
done

lemma Occ_range_unique_existence_lemma:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and major: "X: Occ_range(Tag, Arity)"
  shows "EX! M. M: Terms & X = Occ(M)"
apply (rule Occ_range_existence_lemma [OF hcons major, THEN bexE])
apply (rule ex1I)
apply (rule_tac [2] hind [THEN Occ_ind_cond_Occ_inj, THEN iffD1])
apply safe
apply (assumption | rule refl sym)+
done

lemma def_Occinv_type:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "X: Occ_range(Tag, Arity)"
  shows "Occinv(X): Terms"
apply (unfold hinv)
apply (rule conjunct1)
apply (rule Occ_range_unique_existence_lemma
        [OF hcons hind major, THEN theI])
done

lemma def_Occ_Occinv:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "X: Occ_range(Tag, Arity)"
  shows "Occ(Occinv(X)) = X"
apply (unfold hinv)
apply (rule conjunct2 [THEN sym])
apply (rule Occ_range_unique_existence_lemma
        [OF hcons hind major, THEN theI])
done

lemma def_Occinv_Occ:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "M: Terms"
  shows "Occinv(Occ(M)) = M"
apply (unfold hinv)
apply (rule the_equality)
apply (rule_tac [2] hind [THEN Occ_ind_cond_Occ_inj, THEN iffD1])
apply (assumption | erule conjE | rule major refl conjI sym)+
done

lemma def_Occinv_lemma:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "X: Occ_range(Tag, Arity)"
  shows
   "ALL T: Tag. ALL l: list(Terms).
      <[], T>: X &
      Arity(T) = length(l) &
      (ALL z: length(l). nth(z, l) = Occinv(Occ_subtree(z, X)))
    --> Occinv(X) = Term_cons(T, l)"
apply (rule Occ_range_convert_lemma [OF hcons major])
apply (erule hind [THEN Occ_ind_condD])
apply (intro ballI impI)
apply (elim conjE)
apply (rename_tac U m)
apply (subgoal_tac "U = T" "m = l")
apply hypsubst
apply (erule def_Occinv_Occ [OF hcons hind hinv])
prefer 2
apply (frule hind [THEN Occ_ind_cond_Occ_in_Occ_range])
apply (erule Occ_rangeE)
apply (erule functionalD)
apply assumption
apply simp
apply (rule Occ_consI1)
apply (rule nth_inj)
prefer 2
apply simp
prefer 2 apply assumption
prefer 2 apply assumption
apply hypsubst
apply (rule ballI)
apply simp
apply (rule_tac P="%x. Occinv(x) = nth(z, l)" in
         Occ_subtree_Occ_cons [THEN ssubst])
apply (erule mem_nat_in_nat)
apply (erule length_type)
apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])
apply (rule_tac P="%x. Occinv(x) = nth(z, l)" in nth_map [THEN ssubst])
apply assumption
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
apply (rule def_Occinv_Occ [OF hcons hind hinv])
apply (rule nth_type2, assumption)
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
done

lemma def_Occinv:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "<[], T>: X"
  and prem: "X: Occ_range(Tag, Arity)"
  shows
    "[|
        T: Tag; l: list(Terms); Arity(T) = length(l);
        ALL z: length(l). nth(z, l) = Occinv(Occ_subtree(z, X))
     |] ==>  Occinv(X) = Term_cons(T, l)"
apply (rule def_Occinv_lemma [OF hcons hind hinv prem,
         THEN bspec, THEN bspec, THEN mp])
apply (assumption | rule conjI major)+
done

lemma def_Occinv2:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "Occ_cons(T, l): Occ_range(Tag, Arity)"
  shows
    "[| T: Tag; l: list(Pow(list(nat)*Tag)); Arity(T) = length(l)
     |] ==>  Occinv(Occ_cons(T, l)) = Term_cons(T, map(Occinv, l))"
apply (rule def_Occinv [OF hcons hind hinv Occ_consI1 major, THEN trans])
apply (rule_tac [5] refl)
apply (rule_tac [2] nth_convert_list_type)
apply (rule_tac [2] map_type2)
apply (simp_all add: nth_map)
apply (rule ballI)
apply (rule_tac [2] ballI)
prefer 2 apply (simp add: Occ_subtree_Occ_cons)
apply (rule def_Occinv_type [OF hcons hind hinv])
apply (subgoal_tac "z: nat")
prefer 2 apply (erule mem_nat_in_nat)
apply (erule length_type)
apply (rule Occ_subtree_Occ_cons [THEN subst])
apply assumption+
apply (rule major [THEN Occ_rangeE])
apply (drule bspec, assumption)
apply (erule CorrectArityD1 [THEN exE])
apply (rule Occ_consI1)
apply simp
apply (erule nat_into_Ord [THEN [2] ltI])
apply (erule length_type)
apply simp
apply (erule Occ_cons_ConsE)
apply (rule Occ_subtree_in_Occ_range)
apply (erule Occ_consI2)
apply (assumption | rule major)+
done

lemma def_Occinv_convert_lemma:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "M: Terms"
  and prem: "!!X. X: Occ_range(Tag, Arity) ==> P(Occinv(X))"
  shows "P(M)"
apply (insert major [THEN hind [THEN Occ_ind_cond_Occ_in_Occ_range, THEN prem]])
apply (simp add: def_Occinv_Occ [OF hcons hind hinv major])
done

lemma def_Terms_depth_induct:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and major: "M: Terms"
  and indstep:
       "!!M Z. [| Occ(M) <= list(nat) * Tag; M: Terms;
            Z: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag));
            Occ(M) <= Occ_fbs_op(Tag, Z);
            ALL N: Terms. Occ(N) <= domain(Z)*Tag --> P(N)
        |] ==> P(M)"
  shows "P(M)"
apply (rule def_Occinv_convert_lemma [OF hcons hind hinv major])
apply (erule Occ_range_depth_induct)
apply safe
apply (rule indstep)
apply (erule_tac [2] def_Occinv_type [OF hcons hind hinv])
apply (simp_all add: def_Occ_Occinv [OF hcons hind hinv])
apply (intro ballI impI)
apply (drule bspec [THEN mp])
apply (erule hind [THEN Occ_ind_cond_Occ_in_Occ_range])
apply assumption
apply (simp add: def_Occinv_Occ [OF hcons hind hinv])
done

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2011 Victor Porton

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open>Generalizations\<close>

theory Generalization_ZF imports func1

begin

text\<open>
  This theory formalizes the intuitive notion of \emph{generalization}.

  See http://www.mathematics21.org/generalization.html for more details.

  Contributed by Victor Porton.
\<close>

subsection\<open>Generalization situation\<close>

text\<open>In mathematics it is often encountered that a small set $S$
  naturally bijectively corresponds to a
  subset $R$ of a larger set $B$. (In other words, there is specified an injection
  $E$ from $S$ to $B$.) It is a widespread practice to equate $S$ with $R$.
  But strictly speaking this equating may contradict to the axioms of ZF/ZFC
  because we are not insured against $S\cap B\neq \emptyset$ incidents.
  To work around of this (and formulate things exactly what could benefit
  computer proof assistants) we will replace the set B with a new set B
  having a bijection $M : B \rightarrow B$ such that $M \circ E = id_S$.
  (I call this bijection $M$ from the first letter of the word "move"
  which signifies the move from the old set $B$ to a new set $B$.
  This section contains some basic lemmas holding in this setup.
\<close>

text\<open>The next locale defines our assumptions.\<close>

locale generalization =
  fixes small and big
  fixes embed
  assumes embed_inj: "embed \<in> inj(small, big)"

text\<open>We define the \<open>small2\<close> set as the range of \<open>embed\<close>.\<close>

definition (in generalization) "small2 \<equiv> range(embed)"

text\<open>We define \<open>spec\<close> as the converse of \<open>embed\<close>.\<close>

definition (in generalization) "spec \<equiv> converse(embed)"

text\<open>Spec is an injection from range of \<open>embed\<close> to \<open>small\<close>.\<close>

lemma (in generalization) spec_inj: shows "spec \<in> inj(small2, small)"
  using embed_inj inj_converse_inj small2_def spec_def by simp

text\<open>Spec maps range of \<open>embed\<close> to \<open>small\<close>.\<close>

lemma (in generalization) spec_fun: shows "spec: small2\<rightarrow>small"
  using embed_inj inj_converse_fun small2_def spec_def by simp

text\<open>Embed maps \<open>small\<close>small to \<open>big\<close>.\<close>

lemma (in generalization) embed_fun: shows "embed: small\<rightarrow>big"
  using  embed_inj inj_is_fun by simp

text\<open>Embed is a surjection from \<open>small\<close> to \<open>small2\<close>.\<close>

lemma (in generalization) embed_surj: shows "embed \<in> surj(small, small2)"
  using fun_is_surj embed_fun small2_def by simp

text\<open>Embed is a bijection between \<open>small\<close> and \<open>small2\<close>.\<close>

theorem (in generalization) embed_bij: shows "embed \<in> bij(small, small2)"
  using embed_inj inj_bij_range small2_def by simp

text\<open>\<open>small2\<close> (i.e. range of \<open>embed\<close>) is a
  subset of \<open>big\<close>.\<close>

theorem (in generalization) small2_sub_big: shows "small2 \<subseteq> big"
  using embed_fun func1_1_L5B small2_def by simp

text\<open>\<open>spec\<close> is a bijection beween \<open>small2\<close> and \<open>small\<close>.\<close>

theorem (in generalization) spec_bij: shows "spec \<in> bij(small2, small)"
  using bij_converse_bij embed_bij spec_def by simp

subsection\<open>Arbitrary generalizations\<close>

text\<open>This section considers a more general situation.\<close>

text\<open>The next locale extends \<open>generalization\<close>
  adding another big set and the \<open>move\<close> operation.\<close>

locale generalization1 = generalization +
  fixes newbig
  fixes move
  assumes move_bij: "move \<in> bij(big, newbig)"
  assumes move_embed: "move O embed = id(small)"

text\<open>in \<open>generalization1\<close> context we define \<open>ret\<close>
  as the converse of \<open>move\<close>.\<close>

definition (in generalization1) "ret \<equiv> converse(move)"

text\<open>\<open>move\<close> is a map from \<open>big\<close> to \<open>newbig\<close>.\<close>

lemma (in generalization1) move_fun: shows "move: big\<rightarrow>newbig"
  using move_bij bij_is_fun by simp

text\<open>\<open>move\<close> is an injection from \<open>big\<close> to \<open>newbig\<close>.\<close>

lemma (in generalization1) move_inj: shows "move\<in>inj(big, newbig)"
  using move_bij bij_is_inj by simp

text\<open>Move is a surjection \<open>big\<close> to \<open>newbig\<close>.\<close>

lemma (in generalization1) move_surj: shows "move\<in>surj(big, newbig)"
  using move_bij bij_is_surj by simp

text\<open>\<open>big\<close> is the domain of \<open>move\<close>.\<close>

lemma (in generalization1) move_domain: shows "domain(move) = big"
  using domain_of_fun move_fun by simp

text\<open>Composing \<open>move\<close> with \<open>embed\<close> takes elements of
  \<open>small\<close> to themselves.\<close>

theorem (in generalization1) move_embed_plain: assumes "x\<in>small"
  shows "move`(embed`(x)) = x"
proof -
  from assms have "move`(embed`(x)) = (move O embed)`(x)"
    using embed_fun comp_fun_apply by simp
  with assms show ?thesis using move_embed by simp
qed

text\<open>\<open>ret\<close> is a bijection from \<open>newbig\<close>newbig to \<open>big\<close>.\<close>

lemma (in generalization1) ret_bij: shows "ret\<in>bij(newbig, big)"
  using move_bij ret_def by simp

text\<open>\<open>ret\<close> is a injection from \<open>newbig\<close> onto \<open>big\<close>.\<close>

lemma (in generalization1) ret_inj: shows "ret \<in> inj(newbig,big)"
  using ret_bij bij_is_inj by simp

text\<open>\<open>ret\<close> is a surjection from \<open>newbig\<close> onto \<open>big\<close>.\<close>

lemma (in generalization1) ret_surj: shows "ret \<in> surj(newbig,big)"
  using ret_bij bij_is_surj by simp

text\<open>\<open>embed\<close> is a restriciton of \<open>ret\<close> to \<open>small\<close>.\<close>

lemma (in generalization1) ret_restrict: shows "embed = restrict(ret, small)"
proof -
  have "embed\<subseteq>small\<times>big"
    using fun_is_rel embed_fun by auto
  moreover
  have "(converse(move) O move) O embed = converse(move) O id(small)"
    using  move_embed comp_assoc by auto
  then have a: "id(big) O embed = converse(move) O id(small)"
    using left_comp_inverse move_inj by simp
  ultimately show ?thesis using left_comp_id right_comp_id_any ret_def
    by auto
qed

subsection\<open>ZF generalization\<close>

text\<open>We continue material from the previous section.\<close>

text\<open>We will need this lemma to assert that ZF generalization
  is an arbitrary generalization:\<close>

lemma mem_not_refl_2: shows "{t} \<notin> t"
  using foundation by auto

text\<open>Definition of token.\<close>

definition (in generalization) "token \<equiv> Pow(\<Union>(\<Union>(small)))"

text\<open>Definition of function moving the \<open>small\<close> set into \<open>big\<close>.\<close>

definition (in generalization)
  "zf_move_fun(x) \<equiv> if x\<in>small2 then spec`(x) else \<langle>token,x\<rangle>"

text\<open>Definition of \<open>zf_move\<close> - the ZF version of \<open>zf_move_fun\<close>.\<close>

definition (in generalization)
  "zf_move \<equiv> {\<langle>x,zf_move_fun(x)\<rangle>. x\<in>big}"

text\<open>Definition of \<open>zf_newbig\<close> as the range of \<open>zf_move\<close>.\<close>

definition (in generalization) "zf_newbig \<equiv> range(zf_move)"

text\<open>\<open>zf_move\<close> is a function that maps \<open>big\<close> to \<open>newbig\<close>.\<close>

lemma (in generalization) zf_move_fun: shows "zf_move: big\<rightarrow>zf_newbig"
  using lam_is_fun_range zf_move_def zf_newbig_def by simp

text\<open>\<open>token\<close> is not in \<open>small\<close>.\<close>

lemma (in generalization) token_not_small: shows "\<langle>token,x\<rangle>\<notin>small"
proof
  assume "\<langle>token,x\<rangle>\<in>small"
  then have "{token}\<in>token" using token_def Pair_def by auto
  then show False using mem_not_refl_2 by blast
qed

text\<open>Domain of \<open>zf_move\<close> is \<open>big\<close>.\<close>

lemma (in generalization) zf_move_domain: shows "domain(zf_move) = big"
  using  zf_move_fun func1_1_L1 by simp

text\<open>\<open>small\<close> is a subset of \<open>big\<close>.\<close>

theorem (in generalization) small_less_zf_newbig:
  shows "small \<subseteq> zf_newbig"
proof
  fix x
  assume s: "x \<in> small"
  then have s1: "embed`(x) \<in> small2"
    using embed_fun apply_rangeI small2_def
    by simp
  then have s2: "embed`(x)\<in>big" using small2_sub_big by auto
  with s1 s have x_val: "zf_move`(embed`(x)) = x"
    using ZF_fun_from_tot_val zf_move_fun embed_inj
      left_inverse spec_def zf_move_def zf_move_fun_def
    by simp
  from s2 have "zf_move`(embed`(x))\<in>range(zf_move)"
    using zf_move_fun apply_rangeI by simp
  with x_val show "x \<in> zf_newbig" using zf_newbig_def by auto
qed

text\<open>\<open>zf_move\<close> is an injection from \<open>big\<close>
  to \<open>zf_newbig\<close>.\<close>

theorem (in generalization) zf_move_inj: shows "zf_move\<in>inj(big, zf_newbig)"
proof -
  have "\<forall>a\<in>big. \<forall>b\<in>big.
    zf_move`(a) = zf_move`(b) \<longrightarrow> a=b"
  proof -
    {
      fix a b
      assume "a\<in>big" and "b\<in>big"
      then have spec1_a: "a\<in>small2  \<longrightarrow>  zf_move`(a) = spec`(a)" and
        spec2_a: "a\<notin>small2 \<longrightarrow> zf_move`a = \<langle>token,a\<rangle>" and
        spec1_b: "b\<in>small2  \<longrightarrow> zf_move`(b) = spec`(b)" and
        spec2_b: "b\<notin>small2 \<longrightarrow> zf_move`(b) = \<langle>token,b\<rangle>"
        using ZF_fun_from_tot_val1 zf_move_fun_def zf_move_def
        by auto
      assume move_eq: "zf_move`(a) = zf_move`(b)"
      have "a=b"
      proof -
        { assume "a\<in>small2" and "b\<in>small2"
          with \<open>a\<in>small2\<close> spec1_a \<open>b\<in>small2\<close> spec1_b move_eq
          have I: "spec`(a) = spec`(b)" by simp
          have "spec \<in> inj(small2,small)"
            using spec_inj by simp
          then have "spec \<in>
            {f:small2 \<rightarrow> small. \<forall>w\<in>small2. \<forall>x\<in>small2. f`(w)=f`(x) \<longrightarrow> w=x}"
            unfolding inj_def by auto
          hence "\<forall>w\<in>small2. \<forall>x\<in>small2. spec`(w)=spec`(x) \<longrightarrow> w=x" by auto
          with \<open>a\<in>small2\<close> \<open>b\<in>small2\<close> I have "a=b" by auto
        }
        moreover
        { assume "a\<in>small2" "b\<notin>small2"
          with spec1_a spec_fun have ma_s: "zf_move`a\<in>small"
            using apply_funtype by auto
          from \<open>b\<notin>small2\<close> spec2_b have "zf_move`b\<notin>small"
            using token_not_small by auto
           with move_eq ma_s have False by auto
        }
        moreover
        { assume "a\<notin>small2" and "b\<in>small2"
          with spec1_b spec_fun have mb_s: "zf_move`(b)\<in>small"
            using apply_funtype by auto
          from \<open>a\<notin>small2\<close> spec2_a  have "zf_move`(a)\<notin>small"
            using token_not_small by auto
          with move_eq mb_s have False by auto
        }
        moreover
        { assume "a\<notin>small2" and "b\<notin>small2"
          with spec2_a spec2_b have
            "zf_move`(a) = \<langle>token,a\<rangle>" and
            "zf_move`(b) = \<langle>token,b\<rangle>"
            by auto
          with move_eq have "a=b" by auto
        }
        ultimately show "a=b" by auto
      qed
    }
    thus ?thesis by auto
  qed
  with zf_move_fun show ?thesis using inj_def by simp
qed

text\<open>\<open>zf_move\<close> is a surjection of \<open>big\<close> onto  \<open>zf_newbig\<close>.\<close>

theorem (in generalization) zf_move_surj:
  shows "zf_move \<in> surj(big,zf_newbig)"
  using zf_move_fun fun_is_surj zf_newbig_def by simp

text\<open>\<open>zf_move\<close> is a bijection from \<open>big\<close> to  \<open>zf_newbig\<close>.\<close>

theorem (in generalization) zf_move_bij: shows "zf_move \<in> bij(big, zf_newbig)"
  using zf_move_inj inj_bij_range zf_newbig_def by simp

text\<open>The essential condition to prove that composition of \<open>zf_move\<close>
  and \<open>embed\<close> is identity.\<close>

theorem (in generalization) zf_move_embed:
  assumes "x \<in> small" shows "zf_move`(embed`(x)) = x"
  using assms embed_fun apply_rangeI small2_sub_big ZF_fun_from_tot_val1
    embed_inj small2_def spec_def zf_move_def zf_move_fun_def by auto

text\<open>Composition of \<open>zf_move\<close>  and \<open>embed\<close> is identity.\<close>

theorem (in generalization) zf_embed_move: shows "zf_move O embed = id(small)"
proof -
  have "\<forall>y\<in>small. zf_move`(embed`y) = y" and
     "embed: small\<rightarrow>big" and "zf_move: big\<rightarrow>zf_newbig"
    using zf_move_embed embed_fun zf_move_fun by auto
  then show ?thesis using comp_eq_id_iff1 by blast
qed

end