theory nat_acc_plus_same
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun accplus :: "Nat => Nat => Nat" where
"accplus (Z) y = y"
| "accplus (S z) y = accplus z (S y)"

(*hipster plus accplus *)

theorem x0 :
  "!! (x :: Nat) . !! (y :: Nat) . (plus x y) = (accplus x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory SINVAR_Dependability_norefl
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant @{text "Dependability_norefl"}*}

text{*A version of the Dependability model but if a node reaches itself, it is ignored*}

type_synonym dependability_level = nat

definition default_node_properties :: "dependability_level"
  where  "default_node_properties \<equiv> 0"

text {* Less-equal other nodes depend on the output of a node than its dependability level. *}
fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (num_reachable_norefl G e1) \<le> (nP e1))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
apply (simp add: succ_tran_def)
by (metis (lifting, no_types) Collect_cong Range.intros Range_empty Range_insert mem_Collect_eq singleton_conv singleton_iff trancl.r_into_trancl trancl_range)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

interpretation Dependability: SecurityInvariant_ACS
where default_node_properties = SINVAR_Dependability_norefl.default_node_properties
and sinvar = SINVAR_Dependability_norefl.sinvar
and verify_globals = verify_globals
  unfolding SINVAR_Dependability_norefl.default_node_properties_def
  apply unfold_locales
   apply simp
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp split: split_split_asm split_split)
   apply (simp add:graph_ops)
   apply(clarify)
   apply (metis gr0I le0)
  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 0, vertex_2 := 0)" in exI, simp)
  apply(rule conjI)
   apply(simp add: unique_default_example num_reachable_norefl_def)
  apply(rule_tac x="vertex_1" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(simp add: unique_default_example num_reachable_norefl_def)
  apply(simp add: succ_tran_def unique_default_example_simp1 unique_default_example_simp2)
  done

  lemma TopoS_Dependability_norefl: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


theory SINVAR_SecGwExt_simplified
imports "../TopoS_Helper"
begin

(*

Rather than maintaining this file, just delete it!

*)

subsection {* SecurityInvariant SecurityGatewayExtended simplified*}
text {* A simplified version for demonstration purposes. Do not use in real world *}

datatype secgw_member = SecurityGateway | SecurityGatewayIN | DomainMember | Unassigned

definition default_node_properties :: "secgw_member"
  where  "default_node_properties \<equiv> Unassigned"

fun allowed_secgw_flow :: "secgw_member \<Rightarrow> secgw_member \<Rightarrow> bool" where
  "allowed_secgw_flow SecurityGateway _ = True" |
  "allowed_secgw_flow SecurityGatewayIN _ = True" |
  "allowed_secgw_flow DomainMember SecurityGateway = True" |
  "allowed_secgw_flow DomainMember SecurityGatewayIN = True" |
  "allowed_secgw_flow DomainMember DomainMember = False" |
  "allowed_secgw_flow DomainMember Unassigned = True" |
  "allowed_secgw_flow Unassigned SecurityGatewayIN = True" |
  "allowed_secgw_flow Unassigned SecurityGateway = False" |
  "allowed_secgw_flow Unassigned Unassigned = True" |
  "allowed_secgw_flow Unassigned DomainMember = False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. e1 \<noteq> e2 \<longrightarrow> allowed_secgw_flow (nP e1) (nP e2))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

subsection{*ENF*}
  lemma SecurityGateway_ENFnr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl sinvar allowed_secgw_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_def)
  lemma Unassigned_weakrefl: "allowed_secgw_flow Unassigned Unassigned"
    by(simp)
  lemma Unassigned_botdefault: "\<forall> e1 e2. e2 \<noteq> Unassigned \<longrightarrow> \<not> allowed_secgw_flow e1 e2 \<longrightarrow> \<not> allowed_secgw_flow Unassigned e2"
    apply(rule allI)+
    apply(case_tac e2)
    apply(simp_all)
    apply(case_tac e1)
    apply(simp_all)
    done
  lemma Unassigned_not_to_Member: "\<not> allowed_secgw_flow Unassigned DomainMember"
    by(simp)
  lemma All_to_Unassigned: "\<forall> e1. allowed_secgw_flow e1 Unassigned"
    by (rule allI, case_tac e1, simp_all)

  definition SecurityGatewayExtended_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> ('v \<times> 'v) set set" where
  "SecurityGatewayExtended_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_secgw_flow (nP e1) (nP e2)} })"
  lemma SecurityGatewayExtended_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = SecurityGatewayExtended_offending_set"
    apply(simp only: fun_eq_iff ENFnr_offending_set[OF SecurityGateway_ENFnr] SecurityGatewayExtended_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

(*such deprecated proof, very ugly.*)
interpretation SecurityGatewayExtended_simplified: SecurityInvariant
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
and receiver_violation = receiver_violation
where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = SecurityGatewayExtended_offending_set"
  unfolding receiver_violation_def
  unfolding default_node_properties_def
  apply unfold_locales

  (*apply(frule SecurityInvariant_withOffendingFlows.ENFnr_offending_case1[OF SecurityGateway_ENFnr])*)

  (* only remove receiver_violation: *)
  apply(rule conjI) prefer 2 apply(simp) apply(simp only:HOL.not_False_eq_True HOL.simp_thms(15)) apply(rule impI)

  apply (rule SecurityInvariant_withOffendingFlows.ENFnr_fsts_weakrefl_instance[OF SecurityGateway_ENFnr Unassigned_botdefault All_to_Unassigned])[1]
  apply(simp_all)[3]

 apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split add:prod_case_beta)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(case_tac otherbot, simp_all)
  apply(rename_tac secgwcase)
  apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(rename_tac secgwINcase)
  apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
  apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(rename_tac membercase)
  apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := SecurityGateway)" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(fact SecurityGatewayExtended_offending_set)
  done

hide_const (open) sinvar verify_globals receiver_violation

end


chapter \<open>Abstract Formulations of Gödel-Rosser's First Incompleteness Theorem\<close>

(*<*)
theory Abstract_First_Goedel_Rosser
  imports Rosser_Formula Standard_Model_More
begin
(*>*)

text \<open>The development here is very similar to that of Gödel First Incompleteness Theorem.
It lacks classical logical variants, since for them Rosser's trick does bring
any extra value.\<close>

section \<open>Proof-Theoretic Versions\<close>

context Rosser_Form_Proofs
begin

lemma NN_neg_unique_xx':
  assumes [simp]:"\<phi> \<in> fmla" "Fvars \<phi> = {}"
  shows
    "bprv (imp (NN \<langle>\<phi>\<rangle> (Var xx'))
          (eql \<langle>neg \<phi>\<rangle> (Var xx')))"
  using B.prv_subst[of yy _ "Var xx'", OF _ _ _ NN_neg_unique[OF assms]] by fastforce

lemma NN_imp_xx':
  assumes [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" "\<chi> \<in> fmla"
  shows "bprv (imp (subst \<chi> \<langle>neg \<phi>\<rangle> xx')
                   (all xx' (imp (NN \<langle>\<phi>\<rangle> (Var xx')) \<chi>)))"
proof-
  have 2: "bprv (imp (eql \<langle>neg \<phi>\<rangle> (Var xx')) (imp (subst \<chi> \<langle>neg \<phi>\<rangle> xx') \<chi>))"
    using B.prv_eql_subst_trm[of xx' \<chi> "\<langle>neg \<phi>\<rangle>" "Var xx'", simplified] .
  have 1: "bprv (imp (subst \<chi> \<langle>neg \<phi>\<rangle> xx') (imp (eql \<langle>neg \<phi>\<rangle> (Var xx')) \<chi>))"
    by (simp add: "2" B.prv_imp_com)
  have 0: "bprv (imp (subst \<chi> \<langle>neg \<phi>\<rangle> xx') (imp (NN \<langle>\<phi>\<rangle> (Var xx')) \<chi>))"
    using 1
    by (elim B.prv_prv_imp_trans[rotated 3])
      (auto simp add: B.prv_imp_com B.prv_imp_monoR NN_neg_unique_xx')
  show ?thesis by (rule B.prv_all_imp_gen) (auto simp: 0)
qed

lemma goedel_rosser_first_theEasyHalf:
  assumes c: "consistent"
  shows "\<not> prv \<phi>R"
proof
  assume 0: "prv \<phi>R"
  then obtain "prf" where [simp]: "prf \<in> proof" and "prfOf prf \<phi>R" using prv_prfOf by auto
  hence 00: "bprv (PPf (encPf prf) \<langle>\<phi>R\<rangle>)" using prfOf_PPf by auto
  from dwf_dwfd.d_dwf.bprv_prv'[OF _ 00, simplified] have b00: "prv (PPf (encPf prf) \<langle>\<phi>R\<rangle>)" .
  have "\<not> prv (neg \<phi>R)" using 0 c unfolding consistent_def3 by auto
  hence "\<forall> prf \<in> proof.  \<not> prfOf prf (neg \<phi>R)" using 00 prv_prfOf by auto
  hence "bprv (neg (PPf p \<langle>neg \<phi>R\<rangle>))" if "p \<in> num" for p using not_prfOf_PPf Clean_PPf_encPf that
    by (cases "p \<in> encPf ` proof") auto
  hence 1: "prv (all zz (imp (LLq (Var zz) (encPf prf)) (neg (PPf (Var zz) \<langle>neg \<phi>R\<rangle>))))"
    (* here use locale assumption about the order-like relation: *)
    by (intro LLq_num) auto
  have 11: "prv (RR (encPf prf) \<langle>\<phi>R\<rangle>)"
    using NN_imp_xx'[of \<phi>R "neg (PPf (Var zz) (Var xx'))", simplified]
    by (auto simp add: RR_def2 R_def
      intro!: prv_all_congW[OF _ _ _ _ 1] prv_imp_monoL[OF _ _ _ dwf_dwfd.d_dwf.bprv_prv'])
  have 3: "prv (cnj (PPf (encPf prf) \<langle>\<phi>R\<rangle>) (RR (encPf prf) \<langle>\<phi>R\<rangle>))"
    by (rule prv_cnjI[OF _ _ b00 11]) auto
  have "prv ((PP' \<langle>\<phi>R\<rangle>))" unfolding PP'_def P'_def
     using 3 by (auto intro: prv_exiI[of _ _ "encPf prf"])
  moreover have "prv (neg (PP' \<langle>\<phi>R\<rangle>))"
    using prv_eqv_prv[OF _ _ 0 prv_\<phi>R_eqv] by auto
  ultimately show False using c unfolding consistent_def3 by auto
qed

lemma goedel_rosser_first_theHardHalf:
  assumes c: "consistent"
  shows "\<not> prv (neg \<phi>R)"
proof
  assume 0: "prv (neg \<phi>R)"
  then obtain "prf" where [simp,intro!]: "prf \<in> proof" and pr: "prfOf prf (neg \<phi>R)" using prv_prfOf by auto
  define p where p: "p = encPf prf"
  have [simp,intro!]: "p \<in> num" unfolding p by auto
  have 11: "bprv (PPf p \<langle>neg \<phi>R\<rangle>)" using pr prfOf_PPf unfolding p by auto
  have 1: "bprv (NN \<langle>\<phi>R\<rangle> \<langle>neg \<phi>R\<rangle>)" using NN_neg by simp

  have "\<not> prv \<phi>R" using 0 c unfolding consistent_def3 by auto
  from not_prv_prv_neg_PPf[OF _ _ this]
  have b2: "\<forall> r \<in> num. bprv (neg (PPf r \<langle>\<phi>R\<rangle>))" by auto
  hence 2: "\<forall> r \<in> num. prv (neg (PPf r \<langle>\<phi>R\<rangle>))"
    by (auto intro: dwf_dwfd.d_dwf.bprv_prv')

  obtain P where P[simp,intro!]: "P \<subseteq>num" "finite P"
    and 3: "prv (dsj (sdsj {eql (Var yy) r |r. r \<in> P}) (LLq p (Var yy)))"
    (* here use the other locale assumption about the order-like relation: *)
    using LLq_num2 by auto

  have "prv (imp (cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>)) fls)"
  proof(rule prv_dsj_cases[OF _ _ _ 3])
    {fix r assume r: "r \<in> P" hence rn[simp]: "r \<in> num" using P(1) by blast
      have "prv (imp (cnj (PPf r \<langle>\<phi>R\<rangle>) (RR r \<langle>\<phi>R\<rangle>)) fls)"
        using 2 unfolding neg_def
        by (metis FvarsT_num PPf RR rn \<phi>R all_not_in_conv cnj enc fls imp in_num prv_imp_cnj3L prv_imp_mp)
      hence "prv (imp (eql (Var yy) r)
                (imp (cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>)) fls))"
        using prv_eql_subst_trm_id[of yy "cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>)" r,simplified]
        unfolding neg_def[symmetric]
        by (intro prv_neg_imp_imp_trans) auto
    }
    thus "prv (imp (sdsj {eql (Var yy) r |r. r \<in> P})
              (imp (cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>)) fls))"
       using Var P(1) eql by (intro prv_sdsj_imp) (auto 0 0 simp: set_rev_mp)
  next
    let ?\<phi> = "all xx' (imp (NN \<langle>\<phi>R\<rangle> (Var xx')) (neg (PPf p (Var xx'))))"
    have "bprv (neg ?\<phi>)"
      using 1 11 by (intro B.prv_imp_neg_allWI[where t = "\<langle>neg \<phi>R\<rangle>"]) (auto intro: B.prv_prv_neg_imp_neg)
    hence "prv (neg ?\<phi>)" by (auto intro: dwf_dwfd.d_dwf.bprv_prv')
    hence 00: "prv (imp (LLq p (Var yy))
                       (imp (imp (LLq p (Var yy)) ?\<phi>) fls))"
      unfolding neg_def[symmetric] by (intro prv_imp_neg_imp_neg_imp) auto
    have "prv (imp (LLq p (Var yy))
              (imp (RR (Var yy) \<langle>\<phi>R\<rangle>) fls))"
      unfolding neg_def[symmetric] using 00[folded neg_def]
      by (auto simp add: RR_def2 R_def intro!: prv_imp_neg_allI[where t = p])
    thus "prv (imp (LLq p (Var yy))
              (imp (cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>)) fls))"
      unfolding neg_def[symmetric] by (intro prv_imp_neg_imp_cnjR) auto
  qed(auto, insert Var P(1) eql, simp_all add: set_rev_mp)
  hence "prv (neg (exi yy (cnj (PPf (Var yy) \<langle>\<phi>R\<rangle>) (RR (Var yy) \<langle>\<phi>R\<rangle>))))"
    unfolding neg_def[symmetric] by (intro prv_neg_neg_exi) auto
  hence "prv (neg (PP' \<langle>\<phi>R\<rangle>))" unfolding PP'_def P'_def by simp
  hence "prv \<phi>R" using prv_\<phi>R_eqv by (meson PP' \<phi>R enc in_num neg prv_eqv_prv_rev)
  with \<open>\<not> prv \<phi>R\<close> show False using c unfolding consistent_def3 by auto
qed

theorem goedel_rosser_first_ex:
  assumes "consistent"
  shows "\<exists> \<phi>. \<phi> \<in> fmla \<and> \<not> prv \<phi> \<and> \<not> prv (neg \<phi>)"
  using assms goedel_rosser_first by (intro exI[of _ \<phi>R]) blast

end \<comment> \<open>context @{locale Rosser_Form}\<close>

section \<open>Model-Theoretic Versions\<close>

subsection \<open>First model-theoretic version\<close>

locale Rosser_Form_Proofs_Minimal_Truth =
Rosser_Form_Proofs
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  fls
  prv bprv
  Lq
  dsj
  "proof" prfOf
  enc
  N S
  encPf
  Pf
+
Minimal_Truth_Soundness
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  bprv
  isTrue
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and Lq
and prv bprv
and enc ("\<langle>_\<rangle>")
and N S P
and "proof" :: "'proof set" and prfOf encPf
and Pf
and isTrue
begin

lemma Fvars_PP'[simp]: "Fvars (PP' \<langle>\<phi>R\<rangle>) = {}" unfolding PP'_def
  by (subst Fvars_subst) auto

lemma Fvars_RR'[simp]: "Fvars (RR (Var yy) \<langle>\<phi>R\<rangle>) = {yy}"
  unfolding RR_def
  by (subst Fvars_psubst) (fastforce intro!: exI[of _ "{yy}"])+

lemma isTrue_PPf_implies_\<phi>R:
assumes "isTrue (all yy (neg (PPf (Var yy) \<langle>\<phi>R\<rangle>)))"
(is "isTrue ?H")
shows "isTrue \<phi>R"
proof-
  define F where "F \<equiv> RR (Var yy) \<langle>\<phi>R\<rangle>"
  have [simp]: "F \<in> fmla" "Fvars F = {yy}"
    unfolding F_def by auto
  have [simp]: "exi yy (PPf (Var yy) \<langle>\<phi>R\<rangle>) \<in> fmla"
    unfolding PPf_def by auto

  have 1: "bprv
     (imp (all yy (neg (PPf (Var yy) \<langle>\<phi>R\<rangle>)))
       (neg (exi yy (PPf (Var yy) \<langle>\<phi>R\<rangle>))))"
  (is "bprv (imp (all yy (neg ?G)) (neg (exi yy ?G)))")
    using B.prv_all_neg_imp_neg_exi[of yy ?G] by auto
  have 2: "bprv (imp (neg (exi yy ?G)) (neg (exi yy (cnj ?G F))))"
    by (auto intro!: B.prv_imp_neg_rev B.prv_exi_cong B.prv_imp_cnjL)
  have "bprv (imp (all yy (neg ?G)) (neg (exi yy (cnj ?G F))))"
    using B.prv_prv_imp_trans[OF _ _ _  1 2] by simp
  hence "bprv (imp ?H (neg (PP' \<langle>\<phi>R\<rangle>)))"
    unfolding PP'_def P'_def
    by (simp add: F_def)
  from B.prv_prv_imp_trans[OF _ _ _  this bprv_imp_\<phi>R]
  have "bprv (imp ?H \<phi>R)" by auto
  from prv_imp_implies_isTrue[OF _ _ _ _ this assms, simplified]
  show ?thesis .
qed

theorem isTrue_\<phi>R:
  assumes "consistent"
  shows "isTrue \<phi>R"
proof-
  have "\<forall> n \<in> num. bprv (neg (PPf n \<langle>\<phi>R\<rangle>))"
    using not_prv_prv_neg_PPf[OF _ _ goedel_rosser_first_theEasyHalf[OF assms]]
    by auto
  hence "\<forall> n \<in> num. isTrue (neg (PPf n \<langle>\<phi>R\<rangle>))" by (auto intro: sound_isTrue)
  hence "isTrue (all yy (neg (PPf (Var yy) \<langle>\<phi>R\<rangle>)))" by (auto intro: isTrue_all)
  thus ?thesis using isTrue_PPf_implies_\<phi>R by auto
qed

theorem goedel_rosser_first_strong: "consistent \<Longrightarrow> \<not> prv \<phi>R \<and> \<not> prv (neg \<phi>R) \<and> isTrue \<phi>R"
  using isTrue_\<phi>R goedel_rosser_first by blast

theorem goedel_rosser_first_strong_ex:
"consistent \<Longrightarrow> \<exists> \<phi>. \<phi> \<in> fmla \<and> \<not> prv \<phi> \<and> \<not> prv (neg \<phi>) \<and> isTrue \<phi>"
  using goedel_rosser_first_strong by (intro exI[of _ \<phi>R]) blast

end \<comment> \<open>context @{locale Rosser_Form_Proofs_Minimal_Truth}\<close>

subsection \<open>Second model-theoretic version\<close>

context Rosser_Form
begin
print_context
end

locale Rosser_Form_Minimal_Truth_Soundness_HBL1iff_Compl_Pf =
Rosser_Form
  var trm fmla Var
  FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  fls
  prv bprv
  Lq
  dsj
  enc
  N
  S
  P
+
Minimal_Truth_Soundness_HBL1iff_Compl_Pf
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  enc
  prv bprv
  P
  isTrue
  Pf
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv bprv
and Lq
and enc ("\<langle>_\<rangle>")
and N S
and isTrue
and P Pf

locale Rosser_Form_Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf =
Rosser_Form_Minimal_Truth_Soundness_HBL1iff_Compl_Pf
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv bprv
  Lq
  enc
  N S
  isTrue
  P
  Pf
+
M : Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  enc
  prv bprv
  N
  isTrue
  Pf
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv bprv
and Lq
and enc ("\<langle>_\<rangle>")
and N S P
and isTrue
and Pf

sublocale
  Rosser_Form_Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf <
  recover_proofs: Rosser_Form_Proofs_Minimal_Truth
  where prfOf = prfOf and "proof" = "proof" and encPf = encPf
  and prv = prv and bprv = bprv
  by standard

context Rosser_Form_Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf
begin
thm recover_proofs.goedel_rosser_first_strong
end

(*<*)
end
(*>*)


section\<open>The existence of generic extensions\<close>

theory Forcing_Main
  imports
    Ordinals_In_MG
    Choice_Axiom
    Succession_Poset

begin

subsection\<open>The generic extension is countable\<close>

lemma (in forcing_data1) surj_nat_MG : "\<exists>f. f \<in> surj(\<omega>,M[G])"
proof -
  let ?f="\<lambda>n\<in>\<omega>. val(G,enum`n)"
  have "x \<in> \<omega> \<Longrightarrow> val(G, enum ` x)\<in> M[G]" for x
    using GenExtI bij_is_fun[OF M_countable]
    by simp
  then
  have "?f: \<omega> \<rightarrow> M[G]"
    using lam_type[of \<omega> "\<lambda>n. val(G,enum`n)" "\<lambda>_.M[G]"] by simp
  moreover
  have "\<exists>n\<in>\<omega>. ?f`n = x" if "x\<in>M[G]" for x
    using that GenExt_iff[of _ G] bij_is_surj[OF M_countable]
    unfolding surj_def by auto
  ultimately
  show ?thesis
    unfolding surj_def by blast
qed

lemma (in G_generic1) MG_eqpoll_nat: "M[G] \<approx> \<omega>"
proof -
  obtain f where "f \<in> surj(\<omega>,M[G])"
    using surj_nat_MG by blast
  then
  have "M[G] \<lesssim> \<omega>"
    using well_ord_surj_imp_lepoll well_ord_Memrel[of \<omega>] by simp
  moreover
  have "\<omega> \<lesssim> M[G]"
    using ext.nat_into_M subset_imp_lepoll by (auto del:lepollI)
  ultimately
  show ?thesis
    using eqpollI by simp
qed

subsection\<open>Extensions of ctms of fragments of $\ZFC$\<close>

context G_generic1
begin

lemma sats_ground_repl_fm_imp_sats_ZF_replacement_fm:
  assumes
    "\<phi>\<in>formula" "M, [] \<Turnstile> \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot>"
  shows
    "M[G], [] \<Turnstile> \<cdot>Replacement(\<phi>)\<cdot>"
  using assms sats_ZF_replacement_fm_iff
  by (auto simp:replacement_assm_def ground_replacement_assm_def
      intro:strong_replacement_in_MG[simplified])

lemma satT_ground_repl_fm_imp_satT_ZF_replacement_fm:
  assumes
    "\<Phi> \<subseteq> formula" "M \<Turnstile> { \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>}"
  shows
    "M[G] \<Turnstile> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>}"
  using assms sats_ground_repl_fm_imp_sats_ZF_replacement_fm
  by auto

end \<comment> \<open>\<^locale>\<open>G_generic1\<close>\<close>

theorem extensions_of_ctms:
  assumes
    "M \<approx> \<omega>" "Transset(M)"
    "M \<Turnstile> \<cdot>Z\<cdot> \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead}"
    "\<Phi> \<subseteq> formula" "M \<Turnstile> { \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>}"
  shows
    "\<exists>N.
      M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> M\<noteq>N \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)) \<and>
      ((M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N, [] \<Turnstile> \<cdot>AC\<cdot>) \<and> N \<Turnstile> \<cdot>Z\<cdot> \<union> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>}"
proof -
  from \<open>M \<Turnstile> \<cdot>Z\<cdot> \<union> _\<close> \<open>Transset(M)\<close>
  interpret M_ZF_ground_trans M
    using M_satT_imp_M_ZF_ground_trans
    by simp
  from \<open>M \<approx> \<omega>\<close>
  obtain enum where "enum \<in> bij(\<omega>,M)"
    using eqpoll_sym unfolding eqpoll_def by blast
  then
  interpret M_ctm1 M enum by unfold_locales
  interpret forcing_data1 "2\<^bsup><\<omega>\<^esup>" seqle 0 M enum
    using nat_into_M seqspace_closed seqle_in_M
    by unfold_locales simp
  obtain G where "M_generic(G)" "M \<noteq> M[G]"
    using cohen_extension_is_proper
    by blast
  text\<open>Recall that \<^term>\<open>M[G]\<close> denotes the generic extension
  of \<^term>\<open>M\<close> using the poset of sequences \<^term>\<open>2\<^bsup><\<omega>\<^esup>\<close>.\<close>
  then
  interpret G_generic1 "2\<^bsup><\<omega>\<^esup>" seqle 0 _ enum G by unfold_locales
  interpret MG: M_Z_basic "M[G]"
    using generic pairing_in_MG
      Union_MG  extensionality_in_MG power_in_MG
      foundation_in_MG replacement_assm_MG
      separation_in_MG infinity_in_MG replacement_ax1
    by unfold_locales simp
  have "M, []\<Turnstile> \<cdot>AC\<cdot> \<Longrightarrow> M[G], [] \<Turnstile> \<cdot>AC\<cdot>"
  proof -
    assume "M, [] \<Turnstile> \<cdot>AC\<cdot>"
    then
    have "choice_ax(##M)"
      unfolding ZF_choice_fm_def using ZF_choice_auto by simp
    then
    have "choice_ax(##M[G])" using choice_in_MG by simp
    then
    show "M[G], [] \<Turnstile> \<cdot>AC\<cdot>"
      using ZF_choice_auto sats_ZFC_iff_sats_ZF_AC
      unfolding ZF_choice_fm_def by simp
  qed
  moreover
  note \<open>M \<noteq> M[G]\<close> \<open>M \<Turnstile> { \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>}\<close> \<open>\<Phi> \<subseteq> formula\<close>
  moreover
  have "Transset(M[G])" using Transset_MG .
  moreover
  have "M \<subseteq> M[G]" using M_subset_MG[OF one_in_G] generic by simp
  ultimately
  show ?thesis
    using Ord_MG_iff MG_eqpoll_nat ext.M_satT_Zermelo_fms
      satT_ground_repl_fm_imp_satT_ZF_replacement_fm[of \<Phi>]
    by (rule_tac x="M[G]" in exI, auto)
qed

lemma ZF_replacement_overhead_sub_ZF: "{\<cdot>Replacement(p)\<cdot> . p \<in> overhead} \<subseteq> ZF"
  using instances1_fms_type instances_ground_fms_type
  unfolding overhead_def ZF_def ZF_schemes_def by auto

theorem extensions_of_ctms_ZF:
  assumes
    "M \<approx> \<omega>" "Transset(M)" "M \<Turnstile> ZF"
  shows
    "\<exists>N.
      M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> N \<Turnstile> ZF \<and> M\<noteq>N \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)) \<and>
      ((M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N \<Turnstile> ZFC)"
proof -
  from assms
  have "\<exists>N.
      M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> M\<noteq>N \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)) \<and>
      ((M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N, [] \<Turnstile> \<cdot>AC\<cdot>) \<and> N \<Turnstile> \<cdot>Z\<cdot> \<union> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> formula}"
    using extensions_of_ctms[of M formula] satT_ZF_imp_satT_Z[of M]
      satT_mono[OF _ ground_repl_fm_sub_ZF, of M]
      satT_mono[OF _ ZF_replacement_overhead_sub_ZF, of M]
    by (auto simp: satT_Un_iff)
  then
  obtain N where "N \<Turnstile> \<cdot>Z\<cdot> \<union> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> formula}" "M \<subseteq> N" "N \<approx> \<omega>" "Transset(N)"
    "M \<noteq> N" "(\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)"
    "(M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N, [] \<Turnstile> \<cdot>AC\<cdot>"
    by blast
  moreover from \<open>N \<Turnstile> \<cdot>Z\<cdot> \<union> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> formula}\<close>
  have "N \<Turnstile> ZF"
    using satT_Z_ZF_replacement_imp_satT_ZF by auto
  moreover from this and \<open>(M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N, [] \<Turnstile> \<cdot>AC\<cdot>\<close>
  have "(M, []\<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N \<Turnstile> ZFC"
    using sats_ZFC_iff_sats_ZF_AC by simp
  ultimately
  show ?thesis
    by auto
qed

end


(*  Title:      HOL/HOLCF/Cprod.thy
    Author:     Franz Regensburger
*)

section {* The cpo of cartesian products *}

theory Cprod
imports Cfun
begin

default_sort cpo

subsection {* Continuous case function for unit type *}

definition
  unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
  "unit_when = (\<Lambda> a _. a)"

translations
  "\<Lambda>(). t" == "CONST unit_when\<cdot>t"

lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
by (simp add: unit_when_def)

subsection {* Continuous version of split function *}

definition
  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
  "csplit = (\<Lambda> f p. f\<cdot>(fst p)\<cdot>(snd p))"

translations
  "\<Lambda>(CONST Pair x y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"

abbreviation
  cfst :: "'a \<times> 'b \<rightarrow> 'a" where
  "cfst \<equiv> Abs_cfun fst"

abbreviation
  csnd :: "'a \<times> 'b \<rightarrow> 'b" where
  "csnd \<equiv> Abs_cfun snd"

subsection {* Convert all lemmas to the continuous versions *}

lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
by (simp add: csplit_def)

lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
by (simp add: csplit_def)

end


theory "Bound_Effect"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Ids"
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Frechet_Correctness"
  "Static_Semantics"
  "Coincidence"
begin
section \<open>Bound Effect Theorem\<close>
text \<open>The bound effect lemma says that a program can only modify its bound variables and nothing else.
  This is one of the major lemmas for showing correctness of uniform substitution. \<close>

lemma bound_effect:
  fixes I::"interp"
  assumes good_interp:"is_interp I"
  shows "\<And>\<nu> :: state. \<And>\<omega> :: state. hpsafe \<alpha> \<Longrightarrow> (\<nu>, \<omega>) \<in> prog_sem I \<alpha> \<Longrightarrow> Vagree \<nu> \<omega> (- (BVP \<alpha>))"
proof (induct rule: hp_induct)
  case Var then show "?case"
    using agree_nil Compl_UNIV_eq BVP.simps(1) by fastforce
next
  case Test then show "?case"
    by auto(simp add: agree_refl Compl_UNIV_eq Vagree_def)
next
  case (Choice a b \<nu> \<omega>)
  assume IH1:"\<And>\<nu>'. \<And>\<omega>'. hpsafe a \<Longrightarrow>((\<nu>', \<omega>') \<in> prog_sem I a \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP a))"
  assume IH2:"\<And>\<nu>'. \<And>\<omega>'. hpsafe b \<Longrightarrow>((\<nu>', \<omega>') \<in> prog_sem I b \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP b))"
  assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (a \<union>\<union> b)"
  assume safe:"hpsafe (Choice a b)"
  from safe have safes:"hpsafe a" "hpsafe b" by (auto dest: hpsafe.cases)
  have sems:"(\<nu>, \<omega>) \<in> prog_sem I (a) \<or> (\<nu>, \<omega>) \<in> prog_sem I (b)" using sem by auto
  have agrees:"Vagree \<nu> \<omega> (- BVP a) \<or> Vagree \<nu> \<omega> (- BVP b)" using IH1 IH2 sems safes by blast
  have sub1:"-(BVP a) \<supseteq> (- BVP a \<inter> - BVP b)" by auto
  have sub2:"-(BVP a) \<supseteq> (- BVP a \<inter> - BVP b)" by auto
  have res:"Vagree \<nu> \<omega> (- BVP a \<inter> - BVP b)" using agrees sub1 sub2 agree_supset by blast
  then show "?case" by auto
next
  case (Compose a b \<nu> \<omega>)
  assume IH1:"\<And>\<nu>'. \<And>\<omega>'. hpsafe a \<Longrightarrow> (\<nu>', \<omega>') \<in> prog_sem I a \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP a)"
  assume IH2:"\<And>\<nu>'. \<And>\<omega>'. hpsafe b \<Longrightarrow> (\<nu>', \<omega>') \<in> prog_sem I b \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP b)"
  assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (a ;; b)"
  assume safe:"hpsafe (a ;; b)"
  from safe have safes:"hpsafe a" "hpsafe b" by (auto dest: hpsafe.cases)
  then show "?case"
    using agree_trans IH1 IH2 sem safes by fastforce
next
  fix ODE::"ODE" and P::"formula" and \<nu> \<omega>
  assume safe:"hpsafe (EvolveODE ODE P)"
  from safe have osafe:"osafe ODE" and fsafe:"fsafe P" by (auto dest: hpsafe.cases)
  show "(\<nu>, \<omega>) \<in> prog_sem I (EvolveODE ODE P) \<Longrightarrow> Vagree \<nu> \<omega> (- BVP (EvolveODE ODE P))"
  proof -
    assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (EvolveODE ODE P)"
    from sem have agree:"Vagree \<nu> \<omega> (- BVO ODE)"
      apply(simp only: prog_sem.simps mem_Collect_eq osafe fsafe)
      apply(erule exE)+
    proof -
      fix \<nu>' sol t
      assume assm:
        "(\<nu>, \<omega>) = (\<nu>', mk_v I ODE \<nu>' (sol t)) \<and>
         0 \<le> t \<and>
         (sol solves_ode (\<lambda>_. ODE_sem I ODE)) {0..t} {x. mk_v I ODE \<nu>' x \<in> fml_sem I P} \<and>  (sol 0) = (fst \<nu>')"
      have semBV:"-BVO ODE \<subseteq> -semBV I ODE"
      proof(induction ODE)
        case (OVar x1 x2)
        then show ?case using good_interp by(cases x2, auto simp add: is_interp_def)
      next
        case (OSing x1 x2)
        then show ?case by auto
      next
        case (OProd ODE1 ODE2)
        then show ?case by auto
      qed
      from assm have "Vagree \<omega> \<nu> (- BVO ODE)" using mk_v_agree[of I ODE \<nu> "(sol t)"]
        using agree_sub[OF semBV] by auto
      thus  "Vagree \<nu> \<omega> (- BVO ODE)" by (rule agree_comm)
    qed
    thus "Vagree \<nu> \<omega> (- BVP (EvolveODE ODE P))" by auto
  qed
next
  case (Star a \<nu> \<omega>) then
  have IH:"(\<And>\<nu> \<omega>. hpsafe a \<Longrightarrow> (\<nu>, \<omega>) \<in> prog_sem I a \<Longrightarrow> Vagree \<nu> \<omega> (- BVP a))"
    and safe:"hpsafe a**"
    and sem:"(\<nu>, \<omega>) \<in> prog_sem I a**"
    by auto
  from safe have asafe:"hpsafe a" by (auto dest: hpsafe.cases)
  show "Vagree \<nu> \<omega> (- BVP a**)"
    using sem apply (simp only: prog_sem.simps)
    apply (erule converse_rtrancl_induct)
     subgoal by(rule agree_refl)
    subgoal for y z using IH[of y z, OF asafe] sem by (auto simp add: Vagree_def)
    done
qed (auto simp add: Vagree_def)
end


section \<open>The ZF Axioms, Ordinals and Transfinite Recursion\<close>

theory ZFC_in_HOL
  imports ZFC_Library

begin

subsection\<open>Syntax and axioms\<close>

hide_const (open) list.set Sum subset

notation
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65) and
  Inf ("\<Sqinter>") and
  Sup ("\<Squnion>")

typedecl V

text\<open>Presentation refined by Dmitriy Traytel\<close>
axiomatization elts :: "V \<Rightarrow> V set"
 where ext [intro?]:    "elts x = elts y \<Longrightarrow> x=y"
   and down_raw:        "Y \<subseteq> elts x \<Longrightarrow> Y \<in> range elts"
   and Union_raw:       "X \<in> range elts \<Longrightarrow> Union (elts ` X) \<in> range elts"
   and Pow_raw:         "X \<in> range elts \<Longrightarrow> inv elts ` Pow X \<in> range elts"
   and replacement_raw: "X \<in> range elts \<Longrightarrow> f ` X \<in> range elts"
   and inf_raw:         "range (g :: nat \<Rightarrow> V) \<in> range elts"
   and foundation:      "wf {(x,y). x \<in> elts y}"

lemma mem_not_refl [simp]: "i \<notin> elts i"
  using wf_not_refl [OF foundation] by force

lemma mem_not_sym: "\<not> (x \<in> elts y \<and> y \<in> elts x)"
  using wf_not_sym [OF foundation] by force

text \<open>A set is small if it can be injected into the extension of a V-set.\<close>
definition small :: "'a set \<Rightarrow> bool"
  where "small X \<equiv> \<exists>V_of :: 'a \<Rightarrow> V. inj_on V_of X \<and> V_of ` X \<in> range elts"

lemma small_empty [iff]: "small {}"
  by (simp add: small_def down_raw)

lemma small_iff_range: "small X \<longleftrightarrow> X \<in> range elts"
  apply (simp add: small_def)
  by (metis inj_on_id2 replacement_raw the_inv_into_onto)

text\<open>Small classes can be mapped to sets.\<close>
definition   "set X \<equiv> (if small X then inv elts X else inv elts {})"

lemma set_of_elts [simp]: "set (elts x) = x"
  by (force simp add: ext set_def f_inv_into_f small_def)

lemma elts_of_set [simp]: "elts (set X) = (if small X then X else {})"
  by (simp add: ZFC_in_HOL.set_def down_raw f_inv_into_f small_iff_range)

lemma down: "Y \<subseteq> elts x \<Longrightarrow> small Y"
  by (simp add: down_raw small_iff_range)

lemma Union [intro]: "small X \<Longrightarrow> small (Union (elts ` X))"
  by (simp add: Union_raw small_iff_range)

lemma Pow: "small X \<Longrightarrow> small (set ` Pow X)"
  unfolding small_iff_range using Pow_raw set_def down by force

declare replacement_raw [intro,simp]

lemma replacement [intro,simp]:
  assumes "small X"
  shows "small (f ` X)"
proof -
  let ?A = "inv_into X f ` (f ` X)"
  have AX: "?A \<subseteq> X"
    by (simp add: image_subsetI inv_into_into)
  have inj: "inj_on f ?A"
    by (simp add: f_inv_into_f inj_on_def)
  have injo: "inj_on (inv_into X f) (f ` X)"
    using inj_on_inv_into by blast
  have "\<exists>V_of. inj_on V_of (f ` X) \<and> V_of ` f ` X \<in> range elts"
    if "inj_on V_of X" and "V_of ` X = elts x"
    for V_of :: "'a \<Rightarrow> V" and x
  proof (intro exI conjI)
    show "inj_on (V_of \<circ> inv_into X f) (f ` X)"
      by (meson \<open>inv_into X f ` f ` X \<subseteq> X\<close> comp_inj_on inj_on_subset injo that)
    have "(\<lambda>x. V_of (inv_into X f (f x))) ` X = elts (set (V_of ` ?A))"
      by (metis AX down elts_of_set image_image image_mono that(2))
    then show "(V_of \<circ> inv_into X f) ` f ` X \<in> range elts"
      by (metis image_comp image_image rangeI)
  qed
  then show ?thesis
    using assms by (auto simp: small_def)
qed

lemma small_image_iff [simp]: "inj_on f A \<Longrightarrow> small (f ` A) \<longleftrightarrow> small A"
  by (metis replacement the_inv_into_onto)

text \<open>A little bootstrapping is needed to characterise @{term small} for sets of arbitrary type.\<close>

lemma inf: "small (range (g :: nat \<Rightarrow> V))"
  by (simp add: inf_raw small_iff_range)

lemma small_image_nat_V [simp]: "small (g ` N)" for g :: "nat \<Rightarrow> V"
  by (metis (mono_tags, hide_lams) down elts_of_set image_iff inf rangeI subsetI)

lemma Finite_V:
  fixes X :: "V set"
  assumes "finite X" shows "small X"
  using ex_bij_betw_nat_finite [OF assms] unfolding bij_betw_def by (metis small_image_nat_V)

lemma small_insert_V:
  fixes X :: "V set"
  assumes "small X"
  shows "small (insert a X)"
proof (cases "finite X")
  case True
  then show ?thesis
    by (simp add: Finite_V)
next
  case False
  show ?thesis
    using infinite_imp_bij_betw2 [OF False]
    by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
qed

lemma small_UN_V [simp,intro]:
  fixes B :: "'a \<Rightarrow> V set"
  assumes X: "small X" and B: "\<And>x. x \<in> X \<Longrightarrow> small (B x)"
  shows "small (\<Union>x\<in>X. B x)"
proof -
  have "(\<Union> (elts ` (\<lambda>x. ZFC_in_HOL.set (B x)) ` X)) = (\<Union> (B ` X))"
    using B by force
  then show ?thesis
    using Union [OF replacement [OF X, of "\<lambda>x. ZFC_in_HOL.set (B x)"]] by simp
qed

definition vinsert where "vinsert x y \<equiv> set (insert x (elts y))"

lemma elts_vinsert [simp]: "elts (vinsert x y) = insert x (elts y)"
  using down small_insert_V vinsert_def by auto

definition succ where "succ x \<equiv> vinsert x x"

lemma elts_succ [simp]: "elts (succ x) = insert x (elts x)"
  by (simp add: succ_def)

lemma finite_imp_small:
  assumes "finite X" shows "small X"
  using assms
proof induction
  case empty
  then show ?case
    by simp
next
  case (insert a X)
  then obtain V_of u where u: "inj_on V_of X" "V_of ` X = elts u"
    by (meson small_def image_iff)
  show ?case
    unfolding small_def
  proof (intro exI conjI)
    show "inj_on (V_of(a:=u)) (insert a X)"
      using u
      apply (clarsimp simp add: inj_on_def)
      by (metis image_eqI mem_not_refl)
    have "(V_of(a:=u)) ` insert a X = elts (vinsert u u)"
      using insert.hyps(2) u(2) by auto
    then show "(V_of(a:=u)) ` insert a X \<in> range elts"
      by (blast intro:  elim: )
  qed
qed

lemma small_insert:
  assumes "small X"
  shows "small (insert a X)"
proof (cases "finite X")
  case True
  then show ?thesis
    by (simp add: finite_imp_small)
next
  case False
  show ?thesis
    using infinite_imp_bij_betw2 [OF False]
    by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
qed

lemma small_insert_iff [iff]: "small (insert a X) \<longleftrightarrow> small X"
  by (meson small_insert smaller_than_small subset_insertI)

lemma small_iff: "small X \<longleftrightarrow> (\<exists>x. X = elts x)"
  by (metis down elts_of_set subset_refl)

lemma small_elts [iff]: "small (elts x)"
  by (auto simp: small_iff)

lemma small_diff [iff]: "small (elts a - X)"
  by (meson Diff_subset down)

lemma small_set [simp]: "small (list.set xs)"
  by (simp add: ZFC_in_HOL.finite_imp_small)

lemma small_upair: "small {x,y}"
  by simp

lemma small_Un_elts: "small (elts x \<union> elts y)"
  using Union [OF small_upair] by auto

lemma small_eqcong: "\<lbrakk>small X; X \<approx> Y\<rbrakk> \<Longrightarrow> small Y"
  by (metis bij_betw_imp_surj_on eqpoll_def replacement)

lemma big_UNIV [simp]: "\<not> small (UNIV::V set)" (is  "\<not> small ?U")
  proof
    assume "small ?U"
    then have "small A" for A :: "V set"
      by (metis (full_types) UNIV_I down small_iff subsetI)
    then have "range elts = UNIV"
      by (meson small_iff surj_def)
  then show False
    by (metis Cantors_paradox Pow_UNIV)
qed

lemma inj_on_set: "inj_on set (Collect small)"
  by (metis elts_of_set inj_onI mem_Collect_eq)

lemma set_injective [simp]: "\<lbrakk>small X; small Y\<rbrakk> \<Longrightarrow> set X = set Y \<longleftrightarrow> X=Y"
  by (metis elts_of_set)

subsection\<open>Type classes and other basic setup\<close>

instantiation V :: zero
begin
definition zero_V where "0 \<equiv> set {}"
instance ..
end

lemma elts_0 [simp]: "elts 0 = {}"
  by (simp add: zero_V_def)

lemma set_empty [simp]: "set {} = 0"
  by (simp add: zero_V_def)

instantiation V :: one
begin
definition one_V where "1 \<equiv> succ 0"
instance ..
end

lemma elts_1 [simp]: "elts 1 = {0}"
  by (simp add: one_V_def)

lemma insert_neq_0 [simp]: "set (insert a X) = 0 \<longleftrightarrow> \<not> small X"
  unfolding zero_V_def
  by (metis elts_of_set empty_not_insert set_of_elts small_insert_iff)

lemma elts_eq_empty_iff [simp]: "elts x = {} \<longleftrightarrow> x=0"
  by (auto simp: ZFC_in_HOL.ext)

instantiation V :: distrib_lattice
begin

definition inf_V where "inf_V x y \<equiv> set (elts x \<inter> elts y)"

definition sup_V where "sup_V x y \<equiv> set (elts x \<union> elts y)"

definition less_eq_V where "less_eq_V x y \<equiv> elts x \<subseteq> elts y"

definition less_V where "less_V x y \<equiv> less_eq x y \<and> x \<noteq> (y::V)"

instance
proof
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" for x :: V and y :: V
    using ext less_V_def less_eq_V_def by auto
  show "x \<le> x" for x :: V
    by (simp add: less_eq_V_def)
  show "x \<le> z" if "x \<le> y" "y \<le> z" for x y z :: V
    using that by (auto simp: less_eq_V_def)
  show "x = y" if "x \<le> y" "y \<le> x" for x y :: V
    using that by (simp add: ext less_eq_V_def)
  show "inf x y \<le> x" for x y :: V
    by (metis down elts_of_set inf_V_def inf_sup_ord(1) less_eq_V_def)
  show "inf x y \<le> y" for x y :: V
    by (metis Int_lower2 down elts_of_set inf_V_def less_eq_V_def)
  show "x \<le> inf y z" if "x \<le> y" "x \<le> z" for x y z :: V
  proof -
    have "small (elts y \<inter> elts z)"
      by (meson down inf.cobounded1)
    then show ?thesis
      using elts_of_set inf_V_def less_eq_V_def that by auto
  qed
  show "x \<le> x \<squnion> y" "y \<le> x \<squnion> y" for x y :: V
    by (simp_all add: less_eq_V_def small_Un_elts sup_V_def)
  show "sup y z \<le> x" if "y \<le> x" "z \<le> x" for x y z :: V
    using less_eq_V_def sup_V_def that by auto
  show "sup x (inf y z) = inf (x \<squnion> y) (sup x z)" for x y z :: V
  proof -
    have "small (elts y \<inter> elts z)"
      by (meson down inf.cobounded2)
    then show ?thesis
      by (simp add: Un_Int_distrib inf_V_def small_Un_elts sup_V_def)
  qed
qed
end

lemma V_equalityI [intro]: "(\<And>x. x \<in> elts a \<longleftrightarrow> x \<in> elts b) \<Longrightarrow> a = b"
  by (meson dual_order.antisym less_eq_V_def subsetI)

lemma vsubsetI [intro!]: "(\<And>x. x \<in> elts a \<Longrightarrow> x \<in> elts b) \<Longrightarrow> a \<le> b"
  by (simp add: less_eq_V_def subsetI)

lemma vsubsetD [elim, intro?]: "a \<le> b \<Longrightarrow> c \<in> elts a \<Longrightarrow> c \<in> elts b"
  using less_eq_V_def by auto

lemma rev_vsubsetD: "c \<in> elts a \<Longrightarrow> a \<le> b \<Longrightarrow> c \<in> elts b"
  \<comment> \<open>The same, with reversed premises for use with @{method erule} -- cf. @{thm rev_mp}.\<close>
  by (rule vsubsetD)

lemma vsubsetCE [elim,no_atp]: "a \<le> b \<Longrightarrow> (c \<notin> elts a \<Longrightarrow> P) \<Longrightarrow> (c \<in> elts b \<Longrightarrow> P) \<Longrightarrow> P"
  \<comment> \<open>Classical elimination rule.\<close>
  using vsubsetD by blast

lemma set_image_le_iff: "small A \<Longrightarrow> set (f ` A) \<le> B \<longleftrightarrow> (\<forall>x\<in>A. f x \<in> elts B)"
  by auto

lemma eq0_iff: "x = 0 \<longleftrightarrow> (\<forall>y. y \<notin> elts x)"
  by auto

lemma less_eq_V_0_iff [simp]: "x \<le> 0 \<longleftrightarrow> x = 0" for x::V
  by auto

lemma subset_iff_less_eq_V:
  assumes "small B" shows "A \<subseteq> B \<longleftrightarrow> set A \<le> set B \<and> small A"
  using assms down small_iff by auto

lemma small_Collect [simp]: "small A \<Longrightarrow> small {x \<in> A. P x}"
  by (simp add: smaller_than_small)

lemma small_Union_iff: "small (\<Union>(elts ` X)) \<longleftrightarrow> small X"
  proof
  show "small X"
    if "small (\<Union> (elts ` X))"
  proof -
    have "X \<subseteq> set ` Pow (\<Union> (elts ` X))"
      by fastforce
    then show ?thesis
      using Pow subset_iff_less_eq_V that by auto
  qed
qed auto

lemma not_less_0 [iff]:
  fixes x::V shows "\<not> x < 0"
  by (simp add: less_eq_V_def less_le_not_le)

lemma le_0 [iff]:
  fixes x::V shows "0 \<le> x"
  by auto

lemma min_0L [simp]: "min 0 n = 0" for n :: V
  by (simp add: min_absorb1)

lemma min_0R [simp]: "min n 0 = 0" for n :: V
  by (simp add: min_absorb2)

definition VPow :: "V \<Rightarrow> V"
  where "VPow x \<equiv> set (set ` Pow (elts x))"

lemma VPow_iff [iff]: "y \<in> elts (VPow x) \<longleftrightarrow> y \<le> x"
  using down Pow
  apply (auto simp: VPow_def less_eq_V_def)
  using less_eq_V_def apply fastforce
  done

lemma VPow_le_VPow_iff [simp]: "VPow a \<le> VPow b \<longleftrightarrow> a \<le> b"
  by auto

lemma elts_VPow: "elts (VPow x) = set ` Pow (elts x)"
  by (auto simp: VPow_def Pow)

lemma small_sup_iff [simp]: "small (X \<union> Y) \<longleftrightarrow> small X \<and> small Y" for X::"V set"
  by (metis down elts_of_set small_Un_elts sup_ge1 sup_ge2)

lemma elts_sup_iff [simp]: "elts (x \<squnion> y) = elts x \<union> elts y"
  by (simp add: sup_V_def)

lemma trad_foundation:
  assumes z: "z \<noteq> 0" shows "\<exists>w. w \<in> elts z \<and> w \<sqinter> z = 0"
  using foundation assms
  by (simp add: wf_eq_minimal) (metis Int_emptyI equals0I inf_V_def set_of_elts zero_V_def)

instantiation "V" :: Sup
begin
definition Sup_V where "Sup_V X \<equiv> if small X then set (Union (elts ` X)) else 0"
instance ..
end

instantiation "V" :: Inf
begin
definition Inf_V where "Inf_V X \<equiv> if X = {} then 0 else set (Inter (elts ` X))"
instance ..
end

lemma V_disjoint_iff: "x \<sqinter> y = 0 \<longleftrightarrow> elts x \<inter> elts y = {}"
  by (metis down elts_of_set inf_V_def inf_le1 zero_V_def)

text\<open>I've no idea why @{term bdd_above} is treated differently from @{term bdd_below}, but anyway\<close>
lemma bdd_above_iff_small [simp]: "bdd_above X = small X" for X::"V set"
proof
  show "small X" if "bdd_above X"
  proof -
    obtain a where "\<forall>x\<in>X. x \<le> a"
      using that \<open>bdd_above X\<close> bdd_above_def by blast
    then show "small X"
      by (meson VPow_iff \<open>\<forall>x\<in>X. x \<le> a\<close> down subsetI)
  qed
  show "bdd_above X"
    if "small X"
  proof -
    have "\<forall>x\<in>X. x \<le> \<Squnion> X"
      by (simp add: SUP_upper Sup_V_def Union less_eq_V_def that)
    then show ?thesis
      by (meson bdd_above_def)
  qed
qed

instantiation "V" :: conditionally_complete_lattice
begin

definition bdd_below_V where "bdd_below_V X \<equiv> X \<noteq> {}"

instance
  proof
  show "\<Sqinter> X \<le> x" if "x \<in> X" "bdd_below X"
    for x :: V and X :: "V set"
    using that by (auto simp: bdd_below_V_def Inf_V_def split: if_split_asm)
  show "z \<le> \<Sqinter> X"
    if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
    for X :: "V set" and z :: V
    using that
    apply (clarsimp simp add: bdd_below_V_def Inf_V_def less_eq_V_def split: if_split_asm)
    by (meson INT_subset_iff down eq_refl equals0I)
  show "x \<le> \<Squnion> X" if "x \<in> X" and "bdd_above X" for x :: V and X :: "V set"
    using that Sup_V_def by auto
  show "\<Squnion> X \<le> (z::V)" if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> x \<le> z" for X :: "V set" and z :: V
    using that  by (simp add: SUP_least Sup_V_def less_eq_V_def)
qed
end

lemma Sup_upper: "\<lbrakk>x \<in> A; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>A" for A::"V set"
  by (auto simp: Sup_V_def SUP_upper Union less_eq_V_def)

lemma Sup_empty [simp]: "\<Squnion>{} = (0::V)"
  using Sup_V_def by auto

lemma elts_Sup [simp]: "small X \<Longrightarrow> elts (\<Squnion> X) = \<Union>(elts ` X)"
  by (auto simp: Sup_V_def)

lemma Sup_V_insert:
  fixes x::V assumes "small A" shows "\<Squnion>(insert x A) = x \<squnion> \<Squnion>A"
  by (simp add: assms cSup_insert_If)

lemma Sup_Un_distrib: "\<lbrakk>small A; small B\<rbrakk> \<Longrightarrow> \<Squnion>(A \<union> B) = \<Squnion>A \<squnion> \<Squnion>B" for A::"V set"
  by auto

lemma SUP_sup_distrib:
  fixes f :: "V \<Rightarrow> V"
  shows "small A \<Longrightarrow> (SUP x\<in>A. f x \<squnion> g x) = \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A)"
  by (force simp:)

lemma SUP_const [simp]: "(SUP y \<in> A. a) = (if A = {} then (0::V) else a)"
  by simp

lemma cSUP_subset_mono:
  fixes f :: "'a \<Rightarrow> V set" and g :: "'a \<Rightarrow> V set"
  shows "\<lbrakk>A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
  by (simp add: SUP_subset_mono)

lemma mem_Sup_iff [iff]: "x \<in> elts (\<Squnion>X) \<longleftrightarrow> x \<in> \<Union> (elts ` X) \<and> small X"
  using Sup_V_def by auto

lemma cSUP_UNION:
  fixes B :: "V \<Rightarrow> V set" and f :: "V \<Rightarrow> V"
  assumes ne: "small A" and bdd_UN: "small (\<Union>x\<in>A. f ` B x)"
  shows "\<Squnion>(f ` (\<Union>x\<in>A. B x)) = \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
proof -
  have bdd: "\<And>x. x \<in> A \<Longrightarrow> small (f ` B x)"
    using bdd_UN subset_iff_less_eq_V
    by (meson SUP_upper smaller_than_small)
  then have bdd2: "small ((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
    using ne(1) by blast
  have "\<Squnion>(f ` (\<Union>x\<in>A. B x)) \<le> \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
  moreover have "\<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A) \<le> \<Squnion>(f ` (\<Union>x\<in>A. B x))"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
  ultimately show ?thesis
    by (rule order_antisym)
qed

lemma Sup_subset_mono: "small B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B" for A::"V set"
  by auto

lemma Sup_le_iff: "small A \<Longrightarrow> Sup A \<le> a \<longleftrightarrow> (\<forall>x\<in>A. x \<le> a)" for A::"V set"
  by auto

lemma SUP_le_iff: "small (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)" for f :: "V \<Rightarrow> V"
  by blast

lemma Sup_eq_0_iff [simp]: "\<Squnion>A = 0 \<longleftrightarrow> A \<subseteq> {0} \<or> \<not> small A" for A :: "V set"
  using Sup_upper by fastforce

lemma Sup_Union_commute:
  fixes f :: "V \<Rightarrow> V set"
  assumes "small A" "\<And>x. x\<in>A \<Longrightarrow> small (f x)"
  shows "\<Squnion> (\<Union>x\<in>A. f x) = (SUP x\<in>A. \<Squnion> (f x))"
  using assms
  by (force simp: subset_iff_less_eq_V intro!: antisym)

lemma Sup_eq_Sup:
  fixes B :: "V set"
  assumes "B \<subseteq> A" "small A" and *: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y \<in> B. x \<le> y"
  shows "Sup A = Sup B"
proof -
  have "small B"
    using assms subset_iff_less_eq_V by auto
  moreover have "\<exists>y\<in>B. u \<in> elts y"
    if "x \<in> A" "u \<in> elts x" for u x
    using that "*" by blast
  moreover have "\<exists>x\<in>A. v \<in> elts x"
    if "y \<in> B" "v \<in> elts y" for v y
    using that \<open>B \<subseteq> A\<close> by blast
  ultimately show ?thesis
    using assms by auto
qed

subsection\<open>Successor function\<close>

lemma vinsert_not_empty [simp]: "vinsert a A \<noteq> 0"
  and empty_not_vinsert [simp]: "0 \<noteq> vinsert a A"
  by (auto simp: vinsert_def)

lemma succ_not_0 [simp]: "succ n \<noteq> 0" and zero_not_succ [simp]: "0 \<noteq> succ n"
  by (auto simp: succ_def)

instantiation V :: zero_neq_one
begin
instance
  by intro_classes (metis elts_0 elts_succ empty_iff insert_iff one_V_def set_of_elts)
end

instantiation V :: zero_less_one
begin
instance
  by intro_classes (simp add: less_V_def)
end

lemma succ_ne_self [simp]: "i \<noteq> succ i"
  by (metis elts_succ insertI1 mem_not_refl)

lemma succ_notin_self: "succ i \<notin> elts i"
  using elts_succ mem_not_refl by blast

lemma le_succE: "succ i \<le> succ j \<Longrightarrow> i \<le> j"
  using less_eq_V_def mem_not_sym by auto

lemma succ_inject_iff [iff]: "succ i = succ j \<longleftrightarrow> i = j"
  by (simp add: dual_order.antisym le_succE)

lemma inj_succ: "inj succ"
  by (simp add: inj_def)

lemma succ_neq_zero: "succ x \<noteq> 0"
  by (metis elts_0 elts_succ insert_not_empty)

definition pred where "pred i \<equiv> THE j. i = succ j"

lemma pred_succ [simp]: "pred (succ i) = i"
  by (simp add: pred_def)

subsection \<open>Ordinals\<close>

definition Transset where "Transset x \<equiv> \<forall>y \<in> elts x. y \<le> x"

definition Ord where "Ord x \<equiv> Transset x \<and> (\<forall>y \<in> elts x. Transset y)"

abbreviation ON where "ON \<equiv> Collect Ord"

subsubsection \<open>Transitive sets\<close>

lemma Transset_0 [iff]: "Transset 0"
  by (auto simp: Transset_def)

lemma Transset_succ [intro]:
  assumes "Transset x" shows "Transset (succ x)"
  using assms
  by (auto simp: Transset_def succ_def less_eq_V_def)

lemma Transset_Sup:
  assumes "\<And>x. x \<in> X \<Longrightarrow> Transset x" shows "Transset (\<Squnion>X)"
proof (cases "small X")
  case True
  with assms show ?thesis
    by (simp add: Transset_def) (meson Sup_upper assms dual_order.trans)
qed (simp add: Sup_V_def)

lemma Transset_sup:
  assumes "Transset x" "Transset y" shows "Transset (x \<squnion> y)"
  using Transset_def assms by fastforce

lemma Transset_inf: "\<lbrakk>Transset i; Transset j\<rbrakk> \<Longrightarrow> Transset (i \<sqinter> j)"
  by (simp add: Transset_def rev_vsubsetD)

lemma Transset_VPow: "Transset(i) \<Longrightarrow> Transset(VPow(i))"
  by (auto simp: Transset_def)

lemma Transset_Inf: "(\<And>i. i \<in> A \<Longrightarrow> Transset i) \<Longrightarrow> Transset (\<Sqinter> A)"
  by (force simp: Transset_def Inf_V_def)

lemma Transset_SUP: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Squnion> (B ` A))"
  by (metis Transset_Sup imageE)

lemma Transset_INT: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Sqinter> (B ` A))"
  by (metis Transset_Inf imageE)

subsubsection \<open>Zero, successor, sups\<close>

lemma Ord_0 [iff]: "Ord 0"
  by (auto simp: Ord_def)

lemma Ord_succ [intro]:
  assumes "Ord x" shows "Ord (succ x)"
  using assms by (auto simp: Ord_def)

lemma Ord_Sup:
  assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" shows "Ord (\<Squnion>X)"
proof (cases "small X")
  case True
  with assms show ?thesis
    by (auto simp: Ord_def Transset_Sup)
qed (simp add: Sup_V_def)

lemma Ord_Union:
  assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" "small X" shows "Ord (set (\<Union> (elts ` X)))"
  by (metis Ord_Sup Sup_V_def assms)

lemma Ord_sup:
  assumes "Ord x" "Ord y" shows "Ord (x \<squnion> y)"
  using assms
  proof (clarsimp simp: Ord_def)
  show "Transset (x \<squnion> y) \<and> (\<forall>y\<in>elts x \<union> elts y. Transset y)"
    if "Transset x" "Transset y" "\<forall>y\<in>elts x. Transset y" "\<forall>y\<in>elts y. Transset y"
    using Ord_def Transset_sup assms by auto
qed

lemma big_ON [simp]: "\<not> small ON"
proof
  assume "small ON"
  then have "set ON \<in> ON"
    by (metis Ord_Union Ord_succ Sup_upper elts_Sup elts_succ insertI1 mem_Collect_eq mem_not_refl set_of_elts vsubsetD)
  then show False
    by (metis \<open>small ON\<close> elts_of_set mem_not_refl)
qed

lemma Ord_1 [iff]: "Ord 1"
  using Ord_succ one_V_def succ_def vinsert_def by fastforce

lemma OrdmemD: "Ord k \<Longrightarrow> j \<in> elts k \<Longrightarrow> j < k"
  using Ord_def Transset_def less_V_def by auto

lemma Ord_trans: "\<lbrakk> i \<in> elts j;  j \<in> elts k;  Ord k \<rbrakk>  \<Longrightarrow> i \<in> elts k"
  using Ord_def Transset_def by blast

lemma mem_0_Ord:
  assumes k: "Ord k" and knz: "k \<noteq> 0" shows "0 \<in> elts k"
  by (metis Ord_def Transset_def inf.orderE k knz trad_foundation)

lemma Ord_in_Ord: "\<lbrakk> Ord k;  m \<in> elts k \<rbrakk>  \<Longrightarrow> Ord m"
  using Ord_def Ord_trans by blast

lemma OrdI: "\<lbrakk>Transset i; \<And>x. x \<in> elts i \<Longrightarrow> Transset x\<rbrakk> \<Longrightarrow> Ord i"
  by (simp add: Ord_def)

lemma Ord_is_Transset: "Ord i \<Longrightarrow> Transset i"
  by (simp add: Ord_def)

lemma Ord_contains_Transset: "\<lbrakk>Ord i; j \<in> elts i\<rbrakk> \<Longrightarrow> Transset j"
  using Ord_def by blast

lemma ON_imp_Ord:
  assumes "H \<subseteq> ON" "x \<in> H"
  shows "Ord x"
  using assms by blast

lemma elts_subset_ON: "Ord \<alpha> \<Longrightarrow> elts \<alpha> \<subseteq> ON"
  using Ord_in_Ord by blast

lemma Transset_pred [simp]: "Transset x \<Longrightarrow> \<Squnion>(elts (succ x)) = x"
  by (fastforce simp: Transset_def)

lemma Ord_pred [simp]: "Ord \<beta> \<Longrightarrow> \<Squnion> (insert \<beta> (elts \<beta>)) = \<beta>"
  using Ord_def Transset_pred by auto

subsubsection \<open>Induction, Linearity, etc.\<close>

lemma Ord_induct [consumes 1, case_names step]:
  assumes k: "Ord k"
      and step: "\<And>x.\<lbrakk> Ord x; \<And>y. y \<in> elts x \<Longrightarrow> P y \<rbrakk>  \<Longrightarrow> P x"
    shows "P k"
  using foundation k
proof (induction k rule: wf_induct_rule)
  case (less x)
  then show ?case
    using Ord_in_Ord local.step by auto
qed

text \<open>Comparability of ordinals\<close>
lemma Ord_linear: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<or> k=l \<or> l \<in> elts k"
proof (induct k arbitrary: l rule: Ord_induct)
  case (step k)
  note step_k = step
  show ?case using \<open>Ord l\<close>
    proof (induct l rule: Ord_induct)
      case (step l)
      thus ?case using step_k
        by (metis Ord_trans V_equalityI)
    qed
qed

text \<open>The trichotomy law for ordinals\<close>
lemma Ord_linear_lt:
  assumes "Ord k" "Ord l"
  obtains (lt) "k < l" | (eq) "k=l" | (gt) "l < k"
  using Ord_linear OrdmemD assms by blast

lemma Ord_linear2:
  assumes "Ord k" "Ord l"
  obtains (lt) "k < l" | (ge) "l \<le> k"
  by (metis Ord_linear_lt eq_refl assms order.strict_implies_order)

lemma Ord_linear_le:
  assumes "Ord k" "Ord l"
  obtains (le) "k \<le> l" | (ge) "l \<le> k"
  by (meson Ord_linear2 le_less assms)

lemma union_less_iff [simp]: "\<lbrakk>Ord i; Ord j\<rbrakk> \<Longrightarrow> i \<squnion> j < k \<longleftrightarrow> i<k \<and> j<k"
  by (metis Ord_linear_le le_iff_sup sup.order_iff sup.strict_boundedE)

lemma Ord_mem_iff_lt: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<longleftrightarrow> k < l"
  by (metis Ord_linear OrdmemD less_le_not_le)

lemma Ord_Collect_lt: "Ord \<alpha> \<Longrightarrow> {\<xi>. Ord \<xi> \<and> \<xi> < \<alpha>} = elts \<alpha>"
  by (auto simp flip: Ord_mem_iff_lt elim: Ord_in_Ord OrdmemD)

lemma Ord_not_less: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x < y \<longleftrightarrow> y \<le> x"
  by (metis (no_types) Ord_linear2 leD)

lemma Ord_not_le: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x \<le> y \<longleftrightarrow> y < x"
  by (metis (no_types) Ord_linear2 leD)

lemma le_succ_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> succ j \<longleftrightarrow> i \<le> j"
  by (metis Ord_linear_le Ord_succ le_succE order_antisym)

lemma succ_le_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> j \<longleftrightarrow> i < j"
  using Ord_mem_iff_lt dual_order.strict_implies_order less_eq_V_def by fastforce

lemma succ_in_Sup_Ord:
  assumes eq: "succ \<beta> = \<Squnion>A" and "small A" "A \<subseteq> ON" "Ord \<beta>"
  shows "succ \<beta> \<in> A"
proof -
  have "\<not> \<Squnion>A \<le> \<beta>"
    using eq \<open>Ord \<beta>\<close> succ_le_iff by fastforce
  then show ?thesis
    using assms by (metis Ord_linear2 Sup_least Sup_upper eq_iff mem_Collect_eq subsetD succ_le_iff)
qed

lemma zero_in_succ [simp,intro]: "Ord i \<Longrightarrow> 0 \<in> elts (succ i)"
  using mem_0_Ord by auto

lemma Ord_finite_Sup: "\<lbrakk>finite A; A \<subseteq> ON; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<Squnion>A \<in> A"
proof (induction A rule: finite_induct)
  case (insert x A)
  then have *: "small A" "A \<subseteq> ON" "Ord x"
    by (auto simp add: ZFC_in_HOL.finite_imp_small insert.hyps)
  show ?case
  proof (cases "A = {}")
    case False
    then have "\<Squnion>A \<in> A"
      using insert by blast
    then have "\<Squnion>A \<le> x" if "x \<squnion> \<Squnion>A \<notin> A"
      using * by (metis ON_imp_Ord Ord_linear_le sup.absorb2 that)
    then show ?thesis
      by (fastforce simp: \<open>small A\<close> Sup_V_insert)
  qed auto
qed auto

subsubsection \<open>The natural numbers\<close>

primrec ord_of_nat :: "nat \<Rightarrow> V" where
  "ord_of_nat 0 = 0"
| "ord_of_nat (Suc n) = succ (ord_of_nat n)"

lemma ord_of_nat_eq_initial: "ord_of_nat n = set (ord_of_nat ` {..<n})"
  by (induction n) (auto simp: lessThan_Suc succ_def)

lemma mem_ord_of_nat_iff [simp]: "x \<in> elts (ord_of_nat n) \<longleftrightarrow> (\<exists>m<n. x = ord_of_nat m)"
  by (subst ord_of_nat_eq_initial) auto

lemma elts_ord_of_nat: "elts (ord_of_nat k) = ord_of_nat ` {..<k}"
  by auto

lemma Ord_equality: "Ord i \<Longrightarrow> i = \<Squnion> (succ ` elts i)"
  by (force intro: Ord_trans)

lemma Ord_ord_of_nat [simp]: "Ord (ord_of_nat k)"
  by (induct k, auto)

lemma ord_of_nat_equality: "ord_of_nat n = \<Squnion> ((succ \<circ> ord_of_nat) ` {..<n})"
  by (metis Ord_equality Ord_ord_of_nat elts_of_set image_comp small_image_nat_V ord_of_nat_eq_initial)

definition \<omega> :: V where "\<omega> \<equiv> set (range ord_of_nat)"

lemma elts_\<omega>: "elts \<omega> = {\<alpha>. \<exists>n. \<alpha> = ord_of_nat n}"
  by (auto simp: \<omega>_def image_iff)

lemma nat_into_Ord [simp]: "n \<in> elts \<omega> \<Longrightarrow> Ord n"
  by (metis Ord_ord_of_nat \<omega>_def elts_of_set image_iff inf)

lemma Sup_\<omega>: "\<Squnion>(elts \<omega>) = \<omega>"
  unfolding \<omega>_def by force

lemma Ord_\<omega> [iff]: "Ord \<omega>"
  by (metis Ord_Sup Sup_\<omega> nat_into_Ord)

lemma zero_in_omega [iff]: "0 \<in> elts \<omega>"
  by (metis \<omega>_def elts_of_set inf ord_of_nat.simps(1) rangeI)

lemma succ_in_omega [simp]: "n \<in> elts \<omega> \<Longrightarrow> succ n \<in> elts \<omega>"
  by (metis \<omega>_def elts_of_set image_iff small_image_nat_V ord_of_nat.simps(2) rangeI)

lemma ord_of_eq_0: "ord_of_nat j = 0 \<Longrightarrow> j = 0"
  by (induct j) (auto simp: succ_neq_zero)

lemma ord_of_nat_le_omega: "ord_of_nat n \<le> \<omega>"
  by (metis Sup_\<omega> ZFC_in_HOL.Sup_upper \<omega>_def elts_of_set inf rangeI)

lemma ord_of_eq_0_iff [simp]: "ord_of_nat n = 0 \<longleftrightarrow> n=0"
  by (auto simp: ord_of_eq_0)

lemma ord_of_nat_inject [iff]: "ord_of_nat i = ord_of_nat j \<longleftrightarrow> i=j"
proof (induct i arbitrary: j)
  case 0 show ?case
    using ord_of_eq_0 by auto
next
  case (Suc i) then show ?case
    by auto (metis elts_0 elts_succ insert_not_empty not0_implies_Suc ord_of_nat.simps succ_inject_iff)
qed

corollary inj_ord_of_nat: "inj ord_of_nat"
  by (simp add: linorder_injI)

corollary countable:
  assumes "countable X" shows "small X"
proof -
  have "X \<subseteq> range (from_nat_into X)"
    by (simp add: assms subset_range_from_nat_into)
  then show ?thesis
    by (meson inf_raw inj_ord_of_nat replacement small_def smaller_than_small)
qed

corollary infinite_\<omega>: "infinite (elts \<omega>)"
  using range_inj_infinite [of ord_of_nat]
  by (simp add: \<omega>_def inj_ord_of_nat)

corollary ord_of_nat_mono_iff [iff]: "ord_of_nat i \<le> ord_of_nat j \<longleftrightarrow> i \<le> j"
  by (metis Ord_def Ord_ord_of_nat Transset_def eq_iff mem_ord_of_nat_iff not_less ord_of_nat_inject)

corollary ord_of_nat_strict_mono_iff [iff]: "ord_of_nat i < ord_of_nat j \<longleftrightarrow> i < j"
  by (simp add: less_le_not_le)

lemma small_image_nat [simp]:
  fixes N :: "nat set" shows "small (g ` N)"
  by (simp add: countable)

lemma finite_Ord_omega: "\<alpha> \<in> elts \<omega> \<Longrightarrow> finite (elts \<alpha>)"
  proof (clarsimp simp add: \<omega>_def)
  show "finite (elts (ord_of_nat n))" if "\<alpha> = ord_of_nat n" for n
    using that by (simp add: ord_of_nat_eq_initial [of n])
qed

lemma infinite_Ord_omega: "Ord \<alpha> \<Longrightarrow> infinite (elts \<alpha>) \<Longrightarrow> \<omega> \<le> \<alpha>"
  by (meson Ord_\<omega> Ord_linear2 Ord_mem_iff_lt finite_Ord_omega)

lemma ord_of_minus_1: "n > 0 \<Longrightarrow> ord_of_nat n = succ (ord_of_nat (n - 1))"
  by (metis Suc_diff_1 ord_of_nat.simps(2))

lemma card_ord_of_nat [simp]: "card (elts (ord_of_nat m)) = m"
  by (induction m) (auto simp: \<omega>_def finite_Ord_omega)

lemma ord_of_nat_\<omega> [iff]:"ord_of_nat n \<in> elts \<omega>"
  by (simp add: \<omega>_def)

lemma succ_\<omega>_iff [iff]: "succ n \<in> elts \<omega> \<longleftrightarrow> n \<in> elts \<omega>"
  by (metis Ord_\<omega> OrdmemD elts_vinsert insert_iff less_V_def succ_def succ_in_omega vsubsetD)

lemma \<omega>_gt0: "\<omega> > 0"
  by (simp add: OrdmemD)

lemma \<omega>_gt1: "\<omega> > 1"
  by (simp add: OrdmemD one_V_def)

subsubsection\<open>Limit ordinals\<close>

definition Limit :: "V\<Rightarrow>bool"
  where "Limit i \<equiv> Ord i \<and> 0 \<in> elts i \<and> (\<forall>y. y \<in> elts i \<longrightarrow> succ y \<in> elts i)"

lemma zero_not_Limit [iff]: "\<not> Limit 0"
  by (simp add: Limit_def)

lemma not_succ_Limit [simp]: "\<not> Limit(succ i)"
  by (metis Limit_def Ord_mem_iff_lt elts_succ insertI1 less_irrefl)

lemma Limit_is_Ord: "Limit \<xi> \<Longrightarrow> Ord \<xi>"
  by (simp add: Limit_def)

lemma succ_in_Limit_iff: "Limit \<xi> \<Longrightarrow> succ \<alpha> \<in> elts \<xi> \<longleftrightarrow> \<alpha> \<in> elts \<xi>"
  by (metis Limit_def OrdmemD elts_succ insertI1 less_V_def vsubsetD)

lemma Limit_eq_Sup_self [simp]: "Limit i \<Longrightarrow> Sup (elts i) = i"
  apply (rule order_antisym)
  apply (simp add: Limit_def Ord_def Transset_def Sup_least)
  by (metis Limit_def Ord_equality Sup_V_def SUP_le_iff Sup_upper small_elts)

lemma zero_less_Limit: "Limit \<beta> \<Longrightarrow> 0 < \<beta>"
  by (simp add: Limit_def OrdmemD)

lemma non_Limit_ord_of_nat [iff]: "\<not> Limit (ord_of_nat m)"
  by (metis Limit_def mem_ord_of_nat_iff not_succ_Limit ord_of_eq_0_iff ord_of_minus_1)

lemma Limit_omega [iff]: "Limit \<omega>"
  by (simp add: Limit_def)

lemma omega_nonzero [simp]: "\<omega> \<noteq> 0"
  using Limit_omega by fastforce

lemma Ord_cases_lemma:
  assumes "Ord k" shows "k = 0 \<or> (\<exists>j. k = succ j) \<or> Limit k"
proof (cases "Limit k")
  case False
  have "succ j \<in> elts k" if  "\<forall>j. k \<noteq> succ j" "j \<in> elts k" for j
    by (metis Ord_in_Ord Ord_linear Ord_succ assms elts_succ insertE mem_not_sym that)
  with assms show ?thesis
    by (auto simp: Limit_def mem_0_Ord)
qed auto

lemma Ord_cases [cases type: V, case_names 0 succ limit]:
  assumes "Ord k"
  obtains "k = 0" | l where "Ord l" "succ l = k" | "Limit k"
  by (metis assms Ord_cases_lemma Ord_in_Ord elts_succ insertI1)

lemma non_succ_LimitI:
  assumes "i\<noteq>0" "Ord(i)" "\<And>y. succ(y) \<noteq> i"
  shows "Limit(i)"
  using Ord_cases_lemma assms by blast

lemma Ord_induct3 [consumes 1, case_names 0 succ Limit, induct type: V]:
  assumes \<alpha>: "Ord \<alpha>"
    and P: "P 0" "\<And>\<alpha>. \<lbrakk>Ord \<alpha>; P \<alpha>\<rbrakk> \<Longrightarrow> P (succ \<alpha>)"
           "\<And>\<alpha>. \<lbrakk>Limit \<alpha>; \<And>\<xi>. \<xi> \<in> elts \<alpha> \<Longrightarrow> P \<xi>\<rbrakk> \<Longrightarrow> P (SUP \<xi> \<in> elts \<alpha>. \<xi>)"
  shows "P \<alpha>"
  using \<alpha>
proof (induction \<alpha> rule: Ord_induct)
  case (step \<alpha>)
  then show ?case
    by (metis Limit_eq_Sup_self Ord_cases P elts_succ image_ident insertI1)
qed

subsubsection\<open>Properties of LEAST for ordinals\<close>

lemma
  assumes "Ord k" "P k"
  shows Ord_LeastI: "P (LEAST i. Ord i \<and> P i)" and Ord_Least_le: "(LEAST i. Ord i \<and> P i) \<le> k"
proof -
  have "P (LEAST i. Ord i \<and> P i) \<and> (LEAST i. Ord i \<and> P i) \<le> k"
    using assms
  proof (induct k rule: Ord_induct)
    case (step x) then have "P x" by simp
    show ?case proof (rule classical)
      assume assm: "\<not> (P (LEAST a. Ord a \<and> P a) \<and> (LEAST a. Ord a \<and> P a) \<le> x)"
      have "\<And>y. Ord y \<and> P y \<Longrightarrow> x \<le> y"
      proof (rule classical)
        fix y
        assume y: "Ord y \<and> P y" "\<not> x \<le> y"
        with step obtain "P (LEAST a. Ord a \<and> P a)" and le: "(LEAST a. Ord a \<and> P a) \<le> y"
          by (meson Ord_linear2 Ord_mem_iff_lt)
        with assm have "x < (LEAST a. Ord a \<and> P a)"
          by (meson Ord_linear_le y order.trans \<open>Ord x\<close>)
        then show "x \<le> y"
          using le by auto
      qed
      then have Least: "(LEAST a. Ord a \<and> P a) = x"
        by (simp add: Least_equality \<open>Ord x\<close> step.prems)
      with \<open>P x\<close> show ?thesis by simp
    qed
  qed
  then show "P (LEAST i. Ord i \<and> P i)" and "(LEAST i. Ord i \<and> P i) \<le> k" by auto
qed

lemma Ord_Least:
  assumes "Ord k" "P k"
  shows "Ord (LEAST i. Ord i \<and> P i)"
proof -
  have "Ord (LEAST i. Ord i \<and> (Ord i \<and> P i))"
    using Ord_LeastI [where P = "\<lambda>i. Ord i \<and> P i"] assms by blast
  then show ?thesis
    by simp
qed

\<comment> \<open>The following 3 lemmas are due to Brian Huffman\<close>
lemma Ord_LeastI_ex: "\<exists>i. Ord i \<and> P i \<Longrightarrow> P (LEAST i. Ord i \<and> P i)"
  using Ord_LeastI by blast

lemma Ord_LeastI2:
  "\<lbrakk>Ord a; P a; \<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
  by (blast intro: Ord_LeastI Ord_Least)

lemma Ord_LeastI2_ex:
  "\<exists>a. Ord a \<and> P a \<Longrightarrow> (\<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x) \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
  by (blast intro: Ord_LeastI_ex Ord_Least)

lemma Ord_LeastI2_wellorder:
  assumes "Ord a" "P a"
  and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
  shows "Q (LEAST i. Ord i \<and> P i)"
proof (rule LeastI2_order)
  show "Ord (LEAST i. Ord i \<and> P i) \<and> P (LEAST i. Ord i \<and> P i)"
    using Ord_Least Ord_LeastI assms by auto
next
  fix y assume "Ord y \<and> P y" thus "(LEAST i. Ord i \<and> P i) \<le> y"
    by (simp add: Ord_Least_le)
next
  fix x assume "Ord x \<and> P x" "\<forall>y. Ord y \<and> P y \<longrightarrow> x \<le> y" thus "Q x"
    by (simp add: assms(3))
qed

lemma Ord_LeastI2_wellorder_ex:
  assumes "\<exists>x. Ord x \<and> P x"
  and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
  shows "Q (LEAST i. Ord i \<and> P i)"
using assms by clarify (blast intro!: Ord_LeastI2_wellorder)

lemma not_less_Ord_Least: "\<lbrakk>k < (LEAST x. Ord x \<and> P x); Ord k\<rbrakk> \<Longrightarrow> \<not> P k"
  using Ord_Least_le less_le_not_le by auto

lemma exists_Ord_Least_iff: "(\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha>) \<longleftrightarrow> (\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha> \<and> (\<forall>\<beta> < \<alpha>. Ord \<beta> \<longrightarrow> \<not> P \<beta>))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs thus ?lhs by blast
next
  assume H: ?lhs then obtain \<alpha> where \<alpha>: "Ord \<alpha>" "P \<alpha>" by blast
  let ?x = "LEAST \<alpha>. Ord \<alpha> \<and> P \<alpha>"
  have "Ord ?x"
    by (metis Ord_Least \<alpha>)
  moreover
  { fix \<beta> assume m: "\<beta> < ?x" "Ord \<beta>"
    from not_less_Ord_Least[OF m] have "\<not> P \<beta>" . }
  ultimately show ?rhs
    using Ord_LeastI_ex[OF H] by blast
qed

lemma Ord_mono_imp_increasing:
  assumes fun_hD: "h \<in> D \<rightarrow> D"
    and mono_h: "strict_mono_on h D"
    and "D \<subseteq> ON" and \<nu>: "\<nu> \<in> D"
  shows "\<nu> \<le> h \<nu>"
proof (rule ccontr)
  assume non: "\<not> \<nu> \<le> h \<nu>"
  define \<mu> where "\<mu> \<equiv> LEAST \<mu>. Ord \<mu> \<and> \<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
  have "Ord \<nu>"
    using \<nu> \<open>D \<subseteq> ON\<close> by blast
  then have \<mu>: "\<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
    unfolding \<mu>_def by (rule Ord_LeastI) (simp add: \<nu> non)
  have "Ord (h \<nu>)"
    using assms by auto
  then have "Ord (h (h \<nu>))"
    by (meson ON_imp_Ord \<nu> assms funcset_mem)
  have "Ord \<mu>"
    using \<mu> \<open>D \<subseteq> ON\<close> by blast
  then have "h \<mu> < \<mu>"
    by (metis ON_imp_Ord Ord_linear2 PiE \<mu> \<open>D \<subseteq> ON\<close> fun_hD)
  then have "\<not> h \<mu> \<le> h (h \<mu>)"
    using \<mu> fun_hD mono_h by (force simp: strict_mono_on_def)
  moreover have *: "h \<mu> \<in> D"
    using \<mu> fun_hD by auto
  moreover have "Ord (h \<mu>)"
    using \<open>D \<subseteq> ON\<close> * by blast
  ultimately have "\<mu> \<le> h \<mu>"
    by (simp add: \<mu>_def Ord_Least_le)
  then show False
    using \<mu> by blast
qed

lemma le_Sup_iff:
  assumes "A \<subseteq> ON" "Ord x" "small A" shows "x \<le> \<Squnion>A \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>a\<in>A. y < a))"
proof (intro iffI ballI impI)
  show "\<exists>a\<in>A. y < a"
    if "x \<le> \<Squnion> A" "y \<in> ON" "y < x"
    for y
  proof -
    have "\<not> \<Squnion> A \<le> y" "Ord y"
      using that by auto
    then show ?thesis
      by (metis Ord_linear2 Sup_least \<open>A \<subseteq> ON\<close> mem_Collect_eq subset_eq)
  qed
  show "x \<le> \<Squnion> A"
    if "\<forall>y\<in>ON. y < x \<longrightarrow> (\<exists>a\<in>A. y < a)"
    using that assms
    by (metis Ord_Sup Ord_linear_le Sup_upper less_le_not_le mem_Collect_eq subsetD)
qed

lemma le_SUP_iff: "\<lbrakk>f ` A \<subseteq> ON; Ord x; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>(f ` A) \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>i\<in>A. y < f i))"
  by (simp add: le_Sup_iff)

subsection\<open>Transfinite Recursion and the V-levels\<close>

definition transrec :: "[[V\<Rightarrow>V,V]\<Rightarrow>V, V] \<Rightarrow> V"
  where "transrec H a \<equiv> wfrec {(x,y). x \<in> elts y} H a"

lemma transrec: "transrec H a = H (\<lambda>x \<in> elts a. transrec H x) a"
proof -
  have "(cut (wfrec {(x, y). x \<in> elts y} H) {(x, y). x \<in> elts y} a)
      = (\<lambda>x\<in>elts a. wfrec {(x, y). x \<in> elts y} H x)"
    by (force simp: cut_def)
  then show ?thesis
    unfolding transrec_def
    by (simp add: foundation wfrec)
qed

text\<open>Avoids explosions in proofs; resolve it with a meta-level definition\<close>
lemma def_transrec:
    "\<lbrakk>\<And>x. f x \<equiv> transrec H x\<rbrakk> \<Longrightarrow> f a = H(\<lambda>x \<in> elts a. f x) a"
  by (metis restrict_ext transrec)

lemma eps_induct [case_names step]:
  assumes "\<And>x. (\<And>y. y \<in> elts x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P a"
  using wf_induct [OF foundation] assms by auto

definition Vfrom :: "[V,V] \<Rightarrow> V"
  where "Vfrom a \<equiv> transrec (\<lambda>f x. a \<squnion> \<Squnion>((\<lambda>y. VPow(f y)) ` elts x))"

abbreviation Vset :: "V \<Rightarrow> V" where "Vset \<equiv> Vfrom 0"

lemma Vfrom: "Vfrom a i = a \<squnion> \<Squnion>((\<lambda>j. VPow(Vfrom a j)) ` elts i)"
  apply (subst Vfrom_def)
  apply (subst transrec)
  using Vfrom_def by auto

lemma Vfrom_0 [simp]: "Vfrom a 0 = a"
  by (subst Vfrom) auto

lemma Vset: "Vset i = \<Squnion>((\<lambda>j. VPow(Vset j)) ` elts i)"
  by (subst Vfrom) auto

lemma Vfrom_mono1:
  assumes "a \<le> b" shows "Vfrom a i \<le> Vfrom b i"
proof (induction i rule: eps_induct)
  case (step i)
  then have "a \<squnion> (SUP j\<in>elts i. VPow (Vfrom a j)) \<le> b \<squnion> (SUP j\<in>elts i. VPow (Vfrom b j))"
    by (intro sup_mono cSUP_subset_mono \<open>a \<le> b\<close>) auto
  then show ?case
    by (metis Vfrom)
qed

lemma Vfrom_mono2: "Vfrom a i \<le> Vfrom a (i \<squnion> j)"
proof (induction arbitrary: j rule: eps_induct)
  case (step i)
  then have "a \<squnion> (SUP j\<in>elts i. VPow (Vfrom a j))
           \<le> a \<squnion> (SUP j\<in>elts (i \<squnion> j). VPow (Vfrom a j))"
    by (intro sup_mono cSUP_subset_mono order_refl) auto
  then show ?case
    by (metis Vfrom)
qed

lemma Vfrom_mono: "\<lbrakk>Ord i; a\<le>b; i\<le>j\<rbrakk> \<Longrightarrow> Vfrom a i \<le> Vfrom b j"
  by (metis (no_types) Vfrom_mono1 Vfrom_mono2 dual_order.trans sup.absorb_iff2)

lemma Transset_Vfrom: "Transset(A) \<Longrightarrow> Transset(Vfrom A i)"
proof (induction i rule: eps_induct)
  case (step i)
  then show ?case
    by (metis Transset_SUP Transset_VPow Transset_sup Vfrom)
qed

lemma Transset_Vset [simp]: "Transset(Vset i)"
  by (simp add: Transset_Vfrom)

lemma Vfrom_sup: "Vfrom a (i \<squnion> j) = Vfrom a i \<squnion> Vfrom a j"
proof (rule order_antisym)
  show "Vfrom a (i \<squnion> j) \<le> Vfrom a i \<squnion> Vfrom a j"
    by (simp add: Vfrom [of a "i \<squnion> j"] Vfrom [of a i] Vfrom [of a j] Sup_Un_distrib image_Un sup.assoc sup.left_commute)
  show "Vfrom a i \<squnion> Vfrom a j \<le> Vfrom a (i \<squnion> j)"
    by (metis Vfrom_mono2 le_supI sup_commute)
qed

lemma Vfrom_succ_Ord:
  assumes "Ord i" shows "Vfrom a (succ i) = a \<squnion> VPow(Vfrom a i)"
proof (cases "i = 0")
  case True
  then show ?thesis
    by (simp add: Vfrom [of _ "succ 0"])
next
  case False
  have *: "(SUP x\<in>elts i. VPow (Vfrom a x)) \<le> VPow (Vfrom a i)"
  proof (rule cSup_least)
    show "(\<lambda>x. VPow (Vfrom a x)) ` elts i \<noteq> {}"
      using False by auto
    show "x \<le> VPow (Vfrom a i)" if "x \<in> (\<lambda>x. VPow (Vfrom a x)) ` elts i" for x
      using that
      by clarsimp (meson Ord_in_Ord Ord_linear_le Vfrom_mono assms mem_not_refl order_refl vsubsetD)
  qed
  show ?thesis
  proof (rule Vfrom [THEN trans])
    show "a \<squnion> (SUP j\<in>elts (succ i). VPow (Vfrom a j)) = a \<squnion> VPow (Vfrom a i)"
      using assms
      by (intro sup_mono order_antisym) (auto simp: Sup_V_insert *)
  qed
qed

lemma Vfrom_Sup:
  assumes "X \<noteq> {}" "small X"
  shows "Vfrom a (Sup X) = (SUP y\<in>X. Vfrom a y)"
proof (rule order_antisym)
  have "Vfrom a (\<Squnion> X) = a \<squnion> (SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
    by (metis Vfrom)
  also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
  proof -
    have "a \<le> \<Squnion> (Vfrom a ` X)"
      by (metis Vfrom all_not_in_conv assms bdd_above_iff_small cSUP_upper2 replacement sup_ge1)
    moreover have "(SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j)) \<le> \<Squnion> (Vfrom a ` X)"
    proof -
      have "VPow (Vfrom a x) \<le> \<Squnion> (Vfrom a ` X)"
        if "y \<in> X" "x \<in> elts y" for x y
      proof -
        have "VPow (Vfrom a x) \<le> Vfrom a y"
          by (metis Vfrom bdd_above_iff_small cSUP_upper2 le_supI2 order_refl replacement small_elts that(2))
        also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
          using assms that by (force intro: cSUP_upper)
        finally show ?thesis .
      qed
      then show ?thesis
        by (simp add: SUP_le_iff \<open>small X\<close>)
    qed
    ultimately show ?thesis
      by auto
  qed
  finally show "Vfrom a (\<Squnion> X) \<le> \<Squnion> (Vfrom a ` X)" .
  have "\<And>x. x \<in> X \<Longrightarrow>
         a \<squnion> (SUP j\<in>elts x. VPow (Vfrom a j))
         \<le> a \<squnion> (SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
    using cSUP_subset_mono \<open>small X\<close> by auto
  then show "\<Squnion> (Vfrom a ` X) \<le> Vfrom a (\<Squnion> X)"
    by (metis Vfrom assms(1) cSUP_least)
qed

lemma Limit_Vfrom_eq:
    "Limit(i) \<Longrightarrow> Vfrom a i = (SUP y \<in> elts i. Vfrom a y)"
  by (metis Limit_def Limit_eq_Sup_self Vfrom_Sup ex_in_conv small_elts)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Words of Length 64"

theory Word_64
  imports
    Word_Lemmas
    Word_Names
    Word_Syntax
    Rsplit
    More_Word_Operations
begin

lemma len64: "len_of (x :: 64 itself) = 64" by simp

type_synonym machine_word_len = 64
type_synonym machine_word = "machine_word_len word"

definition word_bits :: nat
where
  "word_bits = LENGTH(machine_word_len)"

text \<open>The following two are numerals so they can be used as nats and words.\<close>
definition word_size_bits :: "'a :: numeral"
where
  "word_size_bits = 3"

definition word_size :: "'a :: numeral"
where
  "word_size = 8"

lemma word_bits_conv[code]:
  "word_bits = 64"
  unfolding word_bits_def by simp

lemma word_size_word_size_bits:
  "(word_size::nat) = 2 ^ word_size_bits"
  unfolding word_size_def word_size_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

lemma ucast_8_64_inj:
  "inj (ucast ::  8 word \<Rightarrow> 64 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 64 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_64 = upper_bits_unset_is_l2p [where 'a=64, folded word_bits_def]
lemmas le_2p_upper_bits_64 = le_2p_upper_bits [where 'a=64, folded word_bits_def]
lemmas le2p_bits_unset_64 = le2p_bits_unset[where 'a=64, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (64) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower64' = unat_power_lower[where 'a=64]
lemmas unat_power_lower64 [simp] = unat_power_lower64'[unfolded word_bits_len_of]

lemmas word64_less_sub_le' = word_less_sub_le[where 'a = 64]
lemmas word64_less_sub_le[simp] = word64_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word64) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word64_power_less_1' = word_power_less_1[where 'a = 64]
lemmas word64_power_less_1[simp] = word64_power_less_1'[folded word_bits_def]

lemma of_nat64_0:
  "\<lbrakk>of_nat n = (0::word64); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word64) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_eq)
  done

lemmas unat_of_nat64' = unat_of_nat_eq[where 'a=64]
lemmas unat_of_nat64 = unat_of_nat64'[unfolded word_bits_len_of]

lemmas word_power_nonzero_64 = word_power_nonzero [where 'a=64, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 64, unfolded word_bits_len_of]]

lemmas div_power_helper_64 = div_power_helper [where 'a=64, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 64)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_64 = of_nat_power [where 'a=64, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word64
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word64' = unat_mask[where 'a=64]
lemmas unat_mask_word64 = unat_mask_word64'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 64 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word64)) = 2 ^ (min sz word_bits - 3)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "3 \<le> sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_eq)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=64 and sz=sz and us=3, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word64 min_def word_bits_def)
   apply (case_tac nata, simp add: unat_word_ariths unat_mask_word64 word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word64 min_def word_bits_def word_size_def)
  done

lemmas word64_minus_one_le' = word_minus_one_le[where 'a=64]
lemmas word64_minus_one_le = word64_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::"8 word"
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word64)"
proof
  assume "ucast a = (0xFF::word64)"
  also
  have "(0xFF::word64) = ucast (0xFF::8 word)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word64) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word64)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word64)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_64:
  "(ucast x \<le> (ucast y :: word64)) = (x \<le> (y :: 8 word))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word64)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word64. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_64_0:
  "(2 ^ 64 :: word64) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word64 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_64_max_word  = max_word_mask [symmetric, where 'a=64, simplified]

lemma of_nat64_n_less_equal_power_2:
 "n < 64 \<Longrightarrow> ((of_nat n)::64 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word64) = [0, 0, 0, 0, 0, 0, 0, 0 :: 8 word]"
  by (simp add: word_rsplit_def bin_rsplit_def)

lemma unat_ucast_10_64 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word64) = unat x"
  by transfer simp

lemma bool_mask [simp]:
  fixes x :: word64
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word64_bounds:
  "- (2 ^ (size (x :: word64) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (x :: word64) - 1)) - 1) = (9223372036854775807 :: int)"
  "- (2 ^ (size (y :: 64 signed word) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (y :: 64 signed word) - 1)) - 1) = (9223372036854775807 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::64 word) \<ge> -9223372036854775808"
  by (metis sint_ge word64_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word64'
    = signed_arith_ineq_checks_to_eq[where 'a=64]
      signed_arith_ineq_checks_to_eq[where 'a="64 signed"]

lemmas signed_arith_ineq_checks_to_eq_word64
    = signed_arith_ineq_checks_to_eq_word64' [unfolded word64_bounds]

lemmas signed_mult_eq_checks64_to_64'
    = signed_mult_eq_checks_double_size[where 'a=64 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="64 signed" and 'b=64]

lemmas signed_mult_eq_checks64_to_64 = signed_mult_eq_checks64_to_64'[simplified]

lemmas sdiv_word64_max' = sdiv_word_max [where 'a=64] sdiv_word_max [where 'a="64 signed"]
lemmas sdiv_word64_max = sdiv_word64_max'[simplified word_size, simplified]

lemmas sdiv_word64_min' = sdiv_word_min [where 'a=64] sdiv_word_min [where 'a="64 signed"]
lemmas sdiv_word64_min = sdiv_word64_min' [simplified word_size, simplified]

lemmas sint64_of_int_eq' = sint_of_int_eq [where 'a=64]
lemmas sint64_of_int_eq = sint64_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word64) :: sword64) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: 16 sword) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: 8 sword) = (of_nat x)"
  by (simp_all add: of_nat_take_bit take_bit_word_eq_self)

lemmas signed_shift_guard_simpler_64'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_64 = signed_shift_guard_simpler_64'[simplified]

lemma word64_31_less:
  "31 < len_of TYPE (64 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (64)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_64
    = signed_shift_guard_to_word[OF word64_31_less(1-2)]
    signed_shift_guard_to_word[OF word64_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "64 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 64 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word64) >> 1 = 0 \<Longrightarrow> x < 2"
  by transfer (simp add: take_bit_drop_bit drop_bit_Suc)

lemma mask_step_down_64:
  \<open>\<exists>x. mask x = b\<close> if \<open>b && 1 = 1\<close>
    and \<open>\<exists>x. x < 64 \<and> mask x = b >> 1\<close> for b :: \<open>64word\<close>
proof -
  from \<open>b && 1 = 1\<close> have \<open>odd b\<close>
    by (auto simp add: mod_2_eq_odd and_one_eq)
  then have \<open>b mod 2 = 1\<close>
    using odd_iff_mod_2_eq_one by blast
  from \<open>\<exists>x. x < 64 \<and> mask x = b >> 1\<close> obtain x where \<open>x < 64\<close> \<open>mask x = b >> 1\<close> by blast
  then have \<open>mask x = b div 2\<close>
    using shiftr1_is_div_2 [of b] by simp
  with \<open>b mod 2 = 1\<close> have \<open>2 * mask x + 1 = 2 * (b div 2) + b mod 2\<close>
    by (simp only:)
  also have \<open>\<dots> = b\<close>
    by (simp add: mult_div_mod_eq)
  finally have \<open>2 * mask x + 1 = b\<close> .
  moreover have \<open>mask (Suc x) = 2 * mask x + (1 :: 'a::len word)\<close>
    by (simp add: mask_Suc_rec)
  ultimately show ?thesis
    by auto
qed

lemma unat_of_int_64:
  "\<lbrakk>i \<ge> 0; i \<le> 2 ^ 63\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword64)) = nat i"
  unfolding unat_eq_nat_uint
  apply (subst eq_nat_nat_iff)
  apply (simp_all add: take_bit_int_eq_self)
  done

lemmas word_ctz_not_minus_1_64 = word_ctz_not_minus_1[where 'a=64, simplified]

lemma word64_and_max_simp:
  \<open>x AND 0xFFFFFFFFFFFFFFFF = x\<close> for x :: \<open>64 word\<close>
  using word_and_full_mask_simp [of x]
  by (simp add: numeral_eq_Suc mask_Suc_exp)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Bisim_SC
  imports Weak_Early_Cong Strong_Early_Bisim_SC
begin

(******** Structural Congruence **********)

lemma matchId:
  fixes a :: name
  and   P :: pi

  shows "[a\<frown>a]P \<simeq> P"
proof -
  have "[a\<frown>a]P \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.matchId)
  thus ?thesis by(rule strongBisimWeakCong)
qed

(******** The \<nu>-operator *****************)

lemma resComm:
  fixes P :: pi

  shows "<\<nu>a><\<nu>b>P \<simeq> <\<nu>b><\<nu>a>P"
proof -
  have "<\<nu>a><\<nu>b>P \<sim>\<^sub>e <\<nu>b><\<nu>a>P" by(rule Strong_Early_Bisim_SC.resComm)
  thus ?thesis by(rule strongBisimWeakCong)
qed

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<simeq> Q \<oplus> P"
proof -
  have "P \<oplus> Q \<sim>\<^sub>e Q \<oplus> P" by(rule Strong_Early_Bisim_SC.sumSym)
  thus ?thesis by(rule strongBisimWeakCong)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<simeq> P"
proof -
  have "P \<parallel> \<zero> \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.parZero)
  thus ?thesis by(rule strongBisimWeakCong)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<simeq> Q \<parallel> P"
proof -
  have "P \<parallel> Q \<sim>\<^sub>e Q \<parallel> P" by(rule Strong_Early_Bisim_SC.parSym)
  thus ?thesis by(rule strongBisimWeakCong)
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<simeq> P \<parallel> <\<nu>x>Q"
proof -
  from `x \<sharp> P` have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sub>e P \<parallel> <\<nu>x>Q" by(rule Strong_Early_Bisim_SC.scopeExtPar)
  thus ?thesis by(rule strongBisimWeakCong)
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<simeq> (<\<nu>x>P) \<parallel> Q"
proof -
  from `x \<sharp> Q` have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sub>e (<\<nu>x>P) \<parallel> Q" by(rule Strong_Early_Bisim_SC.scopeExtPar')
  thus ?thesis by(rule strongBisimWeakCong)
qed

  shows "(P \<parallel> Q) \<parallel> R \<simeq> P \<parallel> (Q \<parallel> R)"
proof -
  have "(P \<parallel> Q) \<parallel> R \<sim>\<^sub>e P \<parallel> (Q \<parallel> R)" by(rule Strong_Early_Bisim_SC.parAssoc)
  thus ?thesis by(rule strongBisimWeakCong)
qed

lemma freshRes:
  fixes P :: pi
  and   a :: name

  assumes "a \<sharp> P"

  shows "<\<nu>a>P \<simeq> P"
proof -
  from `a \<sharp> P` have "<\<nu>a>P \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.freshRes)
  thus ?thesis by(rule strongBisimWeakCong)
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<simeq> P \<oplus> <\<nu>x>Q"
proof -
  from `x \<sharp> P` have "<\<nu>x>(P \<oplus> Q) \<sim>\<^sub>e P \<oplus> <\<nu>x>Q" by(rule Strong_Early_Bisim_SC.scopeExtSum)
  thus ?thesis by(rule strongBisimWeakCong)
qed

lemma bangSC:
  fixes P

  shows "!P \<simeq> P \<parallel> !P"
proof -
  have "!P \<sim>\<^sub>e P \<parallel> !P" by(rule Strong_Early_Bisim_SC.bangSC)
  thus ?thesis by(rule strongBisimWeakCong)
qed

end


section \<open> Refinement Calculus \<close>

theory utp_des_refcalc
  imports utp_des_prog
begin

definition des_spec :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> ('\<alpha> \<Rightarrow> '\<alpha> upred) \<Rightarrow> '\<alpha> hrel_des" where
[upred_defs, ndes_simp]: "des_spec x p q = (\<Squnion> v \<bullet> ((p \<and> &\<^bold>v =\<^sub>u \<guillemotleft>v\<guillemotright>) \<turnstile>\<^sub>n x:[\<lceil>q(v)\<rceil>\<^sub>>]))"

syntax
  "_init_var"      :: "logic"
  "_des_spec"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_:[_,/ _]\<^sub>D" [99,0,0] 100)
  "_des_log_const" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("con\<^sub>D _ \<bullet> _" [0, 10] 10)

translations
  "_des_spec x p q" => "CONST des_spec x p (\<lambda> _init_var. q)"
  "_des_spec (_salphaset (_salphamk x)) p q" <= "CONST des_spec x p (\<lambda> iv. q)"
  "_des_log_const x P" => "\<Squnion> x \<bullet> P"

parse_translation \<open>
let
  fun init_var_tr [] = Syntax.free "iv"
    | init_var_tr _  = raise Match;
in
[(@{syntax_const "_init_var"}, K init_var_tr)]
end
\<close>

abbreviation "choose\<^sub>D x \<equiv> {&x}:[true,true]\<^sub>D"

lemma des_spec_simple_def:
  "x:[pre,post]\<^sub>D = (pre \<turnstile>\<^sub>n x:[\<lceil>post\<rceil>\<^sub>>])"
  by (rel_auto)

lemma des_spec_abort:
  "x:[false,post]\<^sub>D = \<bottom>\<^sub>D"
  by (rel_auto)

lemma des_spec_skip: "\<emptyset>:[true,true]\<^sub>D = II\<^sub>D"
  by (rel_auto)

lemma des_spec_strengthen_post:
  assumes "`post' \<Rightarrow> post`"
  shows "w:[pre, post]\<^sub>D \<sqsubseteq> w:[pre, post']\<^sub>D"
  using assms by (rel_auto)

lemma des_spec_weaken_pre:
  assumes "`pre \<Rightarrow> pre'`"
  shows "w:[pre, post]\<^sub>D \<sqsubseteq> w:[pre', post]\<^sub>D"
  using assms by (rel_auto)

lemma des_spec_refine_skip:
  assumes "vwb_lens w" "`pre \<Rightarrow> post`"
  shows "w:[pre, post]\<^sub>D \<sqsubseteq> II\<^sub>D"
  using assms by (rel_auto)

lemma rc_iter:
  fixes V :: "(nat, 'a) uexpr"
  assumes "vwb_lens w"
  shows "w:[ivr, ivr \<and> \<not> (\<Or> i\<in>A \<bullet> g(i))]\<^sub>D
        \<sqsubseteq> (do i\<in>A \<bullet> g(i) \<rightarrow> \<Squnion> iv \<bullet> w:[ivr \<and> g(i) \<and> \<guillemotleft>iv\<guillemotright> =\<^sub>u &\<^bold>v, ivr \<and> (V <\<^sub>u V\<lbrakk>\<guillemotleft>iv\<guillemotright>/\<^bold>v\<rbrakk>)]\<^sub>D od)" (is "?lhs \<sqsubseteq> ?rhs")
  apply (rule order_trans)
   defer
   apply (simp add: des_spec_simple_def)
   apply (rule IterateD_refine_intro[of _ _ _ _ V])
   apply (simp add: assms)
  apply (rule IterateD_mono_refine)
    apply (simp_all add: ndes_simp closure)
   apply (rel_auto)
  done

end