section \<open>The Ford-Fulkerson Method\<close>
theory FordFulkerson_Algo
imports
  Flow_Networks.Ford_Fulkerson EdmondsKarp_Maxflow.EdmondsKarp_Termination_Abstract
 (*  Maxflow_Lib.Refine_Add_Fofu *)
  "../../Refine_Imperative_HOL/Sepref"
  "NREST.RefineMonadicVCG"
begin

text \<open>In this theory, we formalize the abstract Ford-Fulkerson
  method, which is independent of how an augmenting path is chosen\<close>

text \<open>We specify augmentation of a flow along a path\<close>
definition (in NFlow) "augment_with_path p \<equiv> augment (augmentingFlow p)"

locale FoFu = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes  R :: "(nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> nat"
     and find_augmenting_time :: "nat "
     and augment_with_path_time :: "nat"
     and init_graph :: "nat"
     and special_info :: "(nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> (nat \<times> nat) list \<Rightarrow> bool"
   assumes ff: "NFlow c s t a \<Longrightarrow>
 \<forall>x. \<not> special_info a x
   \<Longrightarrow> NPreflow.isAugmentingPath c s t a x \<Longrightarrow> False"

  and R_decreases: "NFlow c s t a \<Longrightarrow> special_info a x \<Longrightarrow> R (NFlow.augment_with_path c a x) < R a"

  and fat_g_0[simp]: "\<And>x. enat find_augmenting_time \<noteq> 0"

  and augments: "\<And>p f.  NFlow c s t f \<Longrightarrow> special_info f p \<Longrightarrow> NPreflow.isAugmentingPath c s t f p"

context Network
begin

subsection \<open>Algorithm\<close>
text \<open>
  We abstractly specify the procedure for finding an augmenting path:
  Assuming a valid flow, the procedure must return an augmenting path
  iff there exists one.
  \<close>
definition (in FoFu) "find_augmenting_spec f \<equiv> do {
    ASSERT (NFlow c s t f);
    SELECT (%p. \<comment>\<open> NPreflow.isAugmentingPath c s t f p \<and> \<close> special_info f p) (find_augmenting_time)
  }"

text \<open>
  We also specify the loop invariant, and annotate it to the loop.
\<close>
abbreviation "fofu_invar \<equiv> \<lambda>(f,brk).
        NFlow c s t f
      \<and> (brk \<longrightarrow> (\<forall>p. \<not>NPreflow.isAugmentingPath c s t f p))
    "

fun (in FoFu) Te where "Te (f,brk) = (if brk then 0 else (find_augmenting_time + augment_with_path_time)  * (1+ R f))"

text \<open>Finally, we obtain the Ford-Fulkerson algorithm.
  Note that we annotate some assertions to ease later refinement\<close>
definition (in FoFu) "fofu \<equiv> do {
  f\<^sub>0 \<leftarrow> SPECT [(\<lambda>_. 0) \<mapsto> init_graph];

  (f,_) \<leftarrow> whileIET fofu_invar Te
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_augmenting_spec f;
      case p of
        None \<Rightarrow> RETURNT (f,True)
      | Some p \<Rightarrow> do {
          ASSERT (p\<noteq>[]);
          ASSERT (NPreflow.isAugmentingPath c s t f p);
          f \<leftarrow> SPECT [NFlow.augment_with_path c f p \<mapsto> augment_with_path_time];
          ASSERT (NFlow c s t f);
          RETURNT (f, False)
        }
    })
    (f\<^sub>0,False);
  ASSERT (NFlow c s t f);
  RETURNT f
}"

subsection \<open>Partial Correctness\<close>
text \<open>Correctness of the algorithm is a consequence from the
  Ford-Fulkerson theorem. We need a few straightforward
  auxiliary lemmas, though:
\<close>

text \<open>The zero flow is a valid flow\<close>
lemma zero_flow: "NFlow c s t (\<lambda>_. 0)"
  apply unfold_locales
  by (auto simp: s_node t_node cap_non_negative)

text \<open>Augmentation preserves the flow property\<close>
lemma (in NFlow) augment_pres_nflow:
  assumes AUG: "isAugmentingPath p"
  shows "NFlow c s t (augment (augmentingFlow p))"
proof -
  from augment_flow_presv[OF augFlow_resFlow[OF AUG]]
  interpret f': Flow c s t "augment (augmentingFlow p)" .
  show ?thesis by intro_locales
qed

text \<open>Augmenting paths cannot be empty\<close>
lemma (in NFlow) augmenting_path_not_empty:
  "\<not>isAugmentingPath []"
  unfolding isAugmentingPath_def using s_not_t by auto

text \<open>Finally, we can use the verification condition generator to
  show correctness\<close>

definition (in FoFu) "maxFlow_time = enat ( init_graph + (find_augmenting_time + augment_with_path_time) * (R (\<lambda>_. 0) + 1)) "

theorem (in FoFu)  fofu_partial_correct: "fofu \<le> SPECT (emb (\<lambda>f. isMaxFlow f) (maxFlow_time))"
  unfolding fofu_def find_augmenting_spec_def
  apply(rule T_specifies_I)
  apply(vcg'\<open>-\<close>)  apply (simp_all)
  subgoal by (auto simp: zero_flow)
  subgoal  using ff by blast
  subgoal
      apply (auto simp add: Some_le_mm3_Some_conv R_decreases  less_imp_le_nat)
      by (metis R_decreases diff_mult_distrib2 prod_ineqs2 zero_less_diff)
  subgoal  unfolding NFlow.augment_with_path_def
      using  NFlow.augment_pres_nflow augments by metis
  subgoal using augments by simp
  subgoal  using NFlow.augmenting_path_not_empty augments by blast
  subgoal unfolding maxFlow_time_def apply (auto simp: Some_le_emb'_conv)
    using NFlow.noAugPath_iff_maxFlow[symmetric] by blast
  done

theorem (in FoFu)  fofu_partial_correct': "fofu \<le> SPECT (emb (\<lambda>f. isMaxFlow f) (maxFlow_time))"
  unfolding fofu_def find_augmenting_spec_def
  apply(labeled_VCG) using [[goals_limit = 16]]
  apply (casify) oops

(*
subsection \<open>Algorithm without Assertions\<close>
text \<open>For presentation purposes, we extract a version of the algorithm
  without assertions, and using a bit more concise notation\<close>

context begin

private abbreviation (input) "augment
  \<equiv> NFlow.augment_with_path"
private abbreviation (input) "is_augmenting_path f p
  \<equiv> NPreflow.isAugmentingPath c s t f p"

text \<open> {} \<close>
text_raw \<open>\DefineSnippet{ford_fulkerson_algo}{\<close>
definition "ford_fulkerson_method \<equiv> do {
  let f\<^sub>0 = (\<lambda>(u,v). 0);

  (f,brk) \<leftarrow> while (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,brk). do {
      p \<leftarrow> select p. is_augmenting_path f p;
      case p of
        None \<Rightarrow> return (f,True)
      | Some p \<Rightarrow> return (augment c f p, False)
    })
    (f\<^sub>0,False);
  return f
}"
text_raw \<open>}%EndSnippet\<close>

text \<open> {} \<close>

end \<comment> \<open>Anonymous context\<close> *)
end \<comment> \<open>Network\<close>
(*
text \<open> {} \<close>
text_raw \<open>\DefineSnippet{ford_fulkerson_correct}{\<close>
theorem (in Network) "ford_fulkerson_method \<le> (spec f. isMaxFlow f)"
text_raw \<open>}%EndSnippet\<close>
text \<open> {} \<close>
proof -
  have [simp]: "(\<lambda>(u,v). 0) = (\<lambda>_. 0)" by auto
  have "ford_fulkerson_method \<le> fofu"
    unfolding ford_fulkerson_method_def fofu_def Let_def find_augmenting_spec_def
    apply (rule refine_IdD)
    apply (refine_vcg)
    apply (refine_dref_type)
    apply (vc_solve simp: NFlow.augment_with_path_def solve: exI)
    done
  also note fofu_partial_correct
  finally show ?thesis .
qed
*)
end \<comment> \<open>Theory\<close>


(*  Title:      HOL/Hoare/Hoare_Logic.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   1998 TUM
    Author:     Walter Guttmann (extension to total-correctness proofs)
*)

section \<open>Hoare logic\<close>

theory Hoare_Logic
  imports Hoare_Syntax Hoare_Tac
begin

subsection \<open>Sugared semantic embedding of Hoare logic\<close>

text \<open>
  Strictly speaking a shallow embedding (as implemented by Norbert Galm
  following Mike Gordon) would suffice. Maybe the datatype com comes in useful
  later.
\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Seq "'a com" "'a com"
| Cond "'a bexp" "'a com" "'a com"
| While "'a bexp" "'a com"

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a => 'a => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s (f s)"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (Seq c1 c2) s s'"
| "s \<in> b \<Longrightarrow> Sem c1 s s' \<Longrightarrow> Sem (Cond b c1 c2) s s'"
| "s \<notin> b \<Longrightarrow> Sem c2 s s' \<Longrightarrow> Sem (Cond b c1 c2) s s'"
| "s \<notin> b \<Longrightarrow> Sem (While b c) s s"
| "s \<in> b \<Longrightarrow> Sem c s s'' \<Longrightarrow> Sem (While b c) s'' s' \<Longrightarrow>
   Sem (While b c) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a anno \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c a q \<equiv> \<forall>s s'. Sem c s s' \<longrightarrow> s \<in> p \<longrightarrow> s' \<in> q"

definition ValidTC :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a anno \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "ValidTC p c a q \<equiv> \<forall>s. s \<in> p \<longrightarrow> (\<exists>t. Sem c s t \<and> t \<in> q)"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (Seq c1 c2) s s'"
  "Sem (Cond b c1 c2) s s'"

lemma Sem_deterministic:
  assumes "Sem c s s1"
      and "Sem c s s2"
    shows "s1 = s2"
proof -
  have "Sem c s s1 \<Longrightarrow> (\<forall>s2. Sem c s s2 \<longrightarrow> s1 = s2)"
    by (induct rule: Sem.induct) (subst Sem.simps, blast)+
  thus ?thesis
    using assms by simp
qed

lemma tc_implies_pc:
  "ValidTC p c a q \<Longrightarrow> Valid p c a q"
  by (metis Sem_deterministic Valid_def ValidTC_def)

lemma tc_extract_function:
  "ValidTC p c a q \<Longrightarrow> \<exists>f . \<forall>s . s \<in> p \<longrightarrow> f s \<in> q"
  by (metis ValidTC_def)

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) a q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) a q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 a1 Q \<Longrightarrow> Valid Q c2 a2 R \<Longrightarrow> Valid P (Seq c1 c2) (Aseq a1 a2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 a1 q \<Longrightarrow> Valid w' c2 a2 q \<Longrightarrow> Valid p (Cond b c1 c2) (Acond a1 a2) q"
by (auto simp:Valid_def)

lemma While_aux:
  assumes "Sem (While b c) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
    s \<in> I \<Longrightarrow> s' \<in> I \<and> s' \<notin> b"
  using assms
  by (induct "While b c" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c (A 0) i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b c) (Awhile i v A) q"
apply (clarsimp simp:Valid_def)
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma SkipRuleTC:
  assumes "p \<subseteq> q"
    shows "ValidTC p (Basic id) a q"
  by (metis assms Sem.intros(1) ValidTC_def id_apply subsetD)

lemma BasicRuleTC:
  assumes "p \<subseteq> {s. f s \<in> q}"
    shows "ValidTC p (Basic f) a q"
  by (metis assms Ball_Collect Sem.intros(1) ValidTC_def)

lemma SeqRuleTC:
  assumes "ValidTC p c1 a1 q"
      and "ValidTC q c2 a2 r"
    shows "ValidTC p (Seq c1 c2) (Aseq a1 a2) r"
  by (meson assms Sem.intros(2) ValidTC_def)

lemma CondRuleTC:
 assumes "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}"
     and "ValidTC w c1 a1 q"
     and "ValidTC w' c2 a2 q"
   shows "ValidTC p (Cond b c1 c2) (Acond a1 a2) q"
proof (unfold ValidTC_def, rule allI)
  fix s
  show "s \<in> p \<longrightarrow> (\<exists>t . Sem (Cond b c1 c2) s t \<and> t \<in> q)"
    apply (cases "s \<in> b")
    apply (metis (mono_tags, lifting) assms(1,2) Ball_Collect Sem.intros(3) ValidTC_def)
    by (metis (mono_tags, lifting) assms(1,3) Ball_Collect Sem.intros(4) ValidTC_def)
qed

lemma WhileRuleTC:
  assumes "p \<subseteq> i"
      and "\<And>n::nat . ValidTC (i \<inter> b \<inter> {s . v s = n}) c (A n) (i \<inter> {s . v s < n})"
      and "i \<inter> uminus b \<subseteq> q"
    shows "ValidTC p (While b c) (Awhile i v (\<lambda>n. A n)) q"
proof -
  {
    fix s n
    have "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b c) s t \<and> t \<in> q)"
    proof (induction "n" arbitrary: s rule: less_induct)
      fix n :: nat
      fix s :: 'a
      assume 1: "\<And>(m::nat) s::'a . m < n \<Longrightarrow> s \<in> i \<and> v s = m \<longrightarrow> (\<exists>t . Sem (While b c) s t \<and> t \<in> q)"
      show "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b c) s t \<and> t \<in> q)"
      proof (rule impI, cases "s \<in> b")
        assume 2: "s \<in> b" and "s \<in> i \<and> v s = n"
        hence "s \<in> i \<inter> b \<inter> {s . v s = n}"
          using assms(1) by auto
        hence "\<exists>t . Sem c s t \<and> t \<in> i \<inter> {s . v s < n}"
          by (metis assms(2) ValidTC_def)
        from this obtain t where 3: "Sem c s t \<and> t \<in> i \<inter> {s . v s < n}"
          by auto
        hence "\<exists>u . Sem (While b c) t u \<and> u \<in> q"
          using 1 by auto
        thus "\<exists>t . Sem (While b c) s t \<and> t \<in> q"
          using 2 3 Sem.intros(6) by force
      next
        assume "s \<notin> b" and "s \<in> i \<and> v s = n"
        thus "\<exists>t . Sem (While b c) s t \<and> t \<in> q"
          using Sem.intros(5) assms(3) by fastforce
      qed
    qed
  }
  thus ?thesis
    using assms(1) ValidTC_def by force
qed

subsubsection \<open>Concrete syntax\<close>

setup \<open>
  Hoare_Syntax.setup
   {Basic = \<^const_syntax>\<open>Basic\<close>,
    Skip = \<^const_syntax>\<open>annskip\<close>,
    Seq = \<^const_syntax>\<open>Seq\<close>,
    Cond = \<^const_syntax>\<open>Cond\<close>,
    While = \<^const_syntax>\<open>While\<close>,
    Valid = \<^const_syntax>\<open>Valid\<close>,
    ValidTC = \<^const_syntax>\<open>ValidTC\<close>}
\<close>

subsubsection \<open>Proof methods: VCG\<close>

declare BasicRule [Hoare_Tac.BasicRule]
  and SkipRule [Hoare_Tac.SkipRule]
  and SeqRule [Hoare_Tac.SeqRule]
  and CondRule [Hoare_Tac.CondRule]
  and WhileRule [Hoare_Tac.WhileRule]

declare BasicRuleTC [Hoare_Tac.BasicRuleTC]
  and SkipRuleTC [Hoare_Tac.SkipRuleTC]
  and SeqRuleTC [Hoare_Tac.SeqRuleTC]
  and CondRuleTC [Hoare_Tac.CondRuleTC]
  and WhileRuleTC [Hoare_Tac.WhileRuleTC]

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

method_setup vcg_tc = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_tc_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

end


(*  Title:      Simple Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SimpleGroups
imports
  "SubgroupsAndNormalSubgroups"
  "../Secondary_Sylow/SndSylow"
  "SndIsomorphismGrp"
begin

section {*Simple Groups*}

locale simple_group = group +
  assumes order_gt_one:"order G > 1"
  assumes no_real_normal_subgroup:"\<And>H. H \<lhd> G \<Longrightarrow> (H = carrier G \<or> H = {\<one>})"

lemma (in simple_group) is_simple_group: "simple_group G" by (rule simple_group_axioms)

text {* Simple groups are non-trivial. *}

lemma (in simple_group) simple_not_triv: "carrier G \<noteq> {\<one>}" using order_gt_one unfolding order_def by auto

text {* Every group of prime order is simple *}

lemma (in group) prime_order_simple:
  assumes prime:"prime (order G)"
  shows "simple_group G"
proof
  from prime show "1 < order G" unfolding prime_def by auto
next
  fix H
  assume "H \<lhd> G"
  hence HG:"subgroup H G" unfolding normal_def by simp
  hence "card H dvd order G" by (rule card_subgrp_dvd)
  with prime have "card H = 1 \<or> card H = order G" unfolding prime_def by simp
  thus "H = carrier G \<or> H = {\<one>}"
  proof
    assume "card H = 1"
    moreover from HG have "\<one> \<in> H" by (metis subgroup.one_closed)
    ultimately show ?thesis by (auto simp: card_Suc_eq)
  next
    assume "card H = order G"
    moreover from HG have "H \<subseteq> carrier G" unfolding subgroup_def by simp
    moreover from prime have "card (carrier G) > 1" unfolding order_def prime_def..
    hence "finite (carrier G)" by (auto simp:card_ge_0_finite)
    ultimately show ?thesis unfolding order_def by (metis card_subset_eq)
  qed
qed

text {* Being simple is a property that is preserved by isomorphisms. *}

lemma (in simple_group) iso_simple:
  assumes H:"group H"
  assumes iso:"\<phi> \<in> G \<cong> H"
  shows "simple_group H"
unfolding simple_group_def simple_group_axioms_def using assms(1)
proof (auto del: equalityI)
  from iso have "order G = order H" unfolding iso_def order_def using bij_betw_same_card by auto
  with order_gt_one show "Suc 0 < order H" by simp
next
  have inv_iso:"(inv_into (carrier G) \<phi>) \<in> H \<cong> G" using iso by (rule iso_sym)
  fix N
  assume NH:"N \<lhd> H" and Nneq1:"N \<noteq> {\<one>\<^bsub>H\<^esub>}"
  then interpret Nnormal: normal N H by simp
  def M \<equiv> "(inv_into (carrier G) \<phi>) ` N"
  hence MG:"M \<lhd> G" using inv_iso NH H by (metis is_group iso_normal_subgroup)
  have surj:"\<phi> ` carrier G = carrier H" using iso unfolding iso_def bij_betw_def by simp
  hence MN:"\<phi> ` M = N" unfolding M_def using Nnormal.subset image_inv_into_cancel by metis
  moreover have "M \<noteq> {\<one>}"
  proof(rule notI)
    assume "M = {\<one>}"
    hence "\<phi> ` M = {\<phi> \<one>}" by (metis (full_types) image_empty image_insert)
    hence "\<phi> ` M = {\<one>\<^bsub>H\<^esub>}" by (metis (lifting) Nnormal.is_subgroup MN calculation singleton_iff subgroup.one_closed)
    thus False using Nneq1 MN by simp
  qed
  hence "M = carrier G" using no_real_normal_subgroup MG by auto
  ultimately show "N = carrier H" using surj by simp
qed

text {* As a corollary of this: Factorizing a group by itself does not result in a simple group! *}

lemma (in group) self_factor_not_simple:"\<not> simple_group (G Mod (carrier G))"
proof
  assume assm:"simple_group (G Mod (carrier G))"
  have "group (G\<lparr>carrier :=  {\<one>}\<rparr>)" by (metis subgroup_imp_group triv_subgroup)
  with assm self_factor_iso simple_group.iso_simple have "simple_group (G\<lparr>carrier := {\<one>}\<rparr>)" by auto
  thus "False" using simple_group.simple_not_triv by force
qed

end


(*  Title:      Presburger-Automata/DFS.thy
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Author:     Stefan Berghofer and Alex Krauss, TU Muenchen, 2008-2009
*)

section \<open> Depth First Search \<close>

theory DFS
imports Main
begin

definition
  "succsr succs = {(x, y). y \<in> set (succs x)}"

partial_function (tailrec)
  gen_dfs
where
  "gen_dfs succs ins memb S wl = (case wl of
     [] \<Rightarrow> S
   | (x # xs) \<Rightarrow>
       if memb x S then gen_dfs succs ins memb S xs
       else gen_dfs succs ins memb (ins x S) (succs x @ xs))"

lemma gen_dfs_simps[simp]:
  "gen_dfs succs ins memb S [] = S"
  "gen_dfs succs ins memb S (x # xs) =
    (if memb x S then gen_dfs succs ins memb S xs
     else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
  by (simp_all add: gen_dfs.simps)

locale DFS =
  fixes succs :: "'a \<Rightarrow> 'a list"
  and is_node :: "'a \<Rightarrow> bool"
  and invariant :: "'b \<Rightarrow> bool"
  and ins :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  and empt :: 'b
  assumes ins_eq: "\<And>x y S. is_node x \<Longrightarrow> is_node y \<Longrightarrow> invariant S \<Longrightarrow> \<not> memb y S \<Longrightarrow>
    memb x (ins y S) = ((x = y) \<or> memb x S)"
  and empt: "\<And>x. is_node x \<Longrightarrow> \<not> memb x empt"
  and succs_is_node: "\<And>x. is_node x \<Longrightarrow> list_all is_node (succs x)"
  and empt_invariant: "invariant empt"
  and ins_invariant: "\<And>x S. is_node x \<Longrightarrow> invariant S \<Longrightarrow> \<not> memb x S \<Longrightarrow> invariant (ins x S)"
  and graph_finite: "finite {x. is_node x}"

context DFS
begin

definition rel where
  "rel = inv_image finite_psubset (\<lambda>S. {n. is_node n \<and> \<not> memb n S})"

abbreviation
  "dfs \<equiv> gen_dfs succs ins memb"

lemma dfs_induct[consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all is_node xs"
  and I1: "\<And>S. invariant S \<Longrightarrow> P S []"
  and I2: "\<And>S x xs. invariant S \<Longrightarrow> is_node x \<Longrightarrow> list_all is_node xs \<Longrightarrow>
    (memb x S \<Longrightarrow> P S xs) \<Longrightarrow> (\<not> memb x S \<Longrightarrow> P (ins x S) (succs x @ xs)) \<Longrightarrow> P S (x # xs)"
  shows "P S xs" using I1 I2 S xs
  apply induction_schema
  apply atomize_elim
  apply (case_tac xs, simp+)
  apply atomize_elim
  apply (rule conjI)
  apply (rule ins_invariant, assumption+)
  apply (rule succs_is_node, assumption)
  apply (relation "rel <*lex*> measure length")
  apply (simp add: wf_lex_prod rel_def)
  apply simp
  apply simp
  apply (rule disjI1)
  apply (simp add: rel_def finite_psubset_def)
  apply (rule conjI)
  apply (auto simp add: ins_eq cong: conj_cong)
  apply (subst Collect_conj_eq)
  apply (rule finite_Int)
  apply (rule disjI1)
  apply (rule graph_finite)
  done

definition
  "succss xs = (\<Union>x\<in>xs. set (succs x))"

definition
  "set_of S = {x. is_node x \<and> memb x S}"

definition
  "reachable xs = {(x, y). y \<in> set (succs x)}\<^sup>* `` xs"

lemma visit_subset_dfs: "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow>
  is_node y \<Longrightarrow> memb y S \<Longrightarrow> memb y (dfs S xs)"
  by (induct S xs rule: dfs_induct) (simp_all add: ins_eq)

lemma next_subset_dfs: "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow>
  x \<in> set xs \<Longrightarrow> memb x (dfs S xs)"
proof (induct S xs rule: dfs_induct)
  case (step S y xs)
  then show ?case
    by (auto simp add: visit_subset_dfs ins_eq ins_invariant succs_is_node)
qed simp

lemma succss_closed_dfs':
  "invariant ys \<Longrightarrow> list_all is_node xs \<Longrightarrow>
   succss (set_of ys) \<subseteq> set xs \<union> set_of ys \<Longrightarrow> succss (set_of (dfs ys xs)) \<subseteq> set_of (dfs ys xs)"
  by (induct ys xs rule: dfs_induct) (auto simp add: ins_eq succss_def set_of_def cong: conj_cong)

lemma succss_closed_dfs: "list_all is_node xs \<Longrightarrow>
  succss (set_of (dfs empt xs)) \<subseteq> set_of (dfs empt xs)"
  apply (rule succss_closed_dfs')
  apply (rule empt_invariant)
  apply assumption
  apply (simp add: succss_def)
  apply (rule subsetI)
  apply (erule UN_E)
  apply (simp add: set_of_def empt cong: conj_cong)
  done

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof(unfold Image_def, auto)
    fix x y
    assume y: "y \<in> X"
    assume "(y,x) \<in> r\<^sup>*"
    thus "x \<in> X" using assms y
      by (induct, auto simp add: Image_def)
  qed
qed auto

lemma reachable_closed_dfs:
  assumes xs: "list_all is_node xs"
  shows "reachable (set xs) \<subseteq> set_of (dfs empt xs)"
proof -
  from xs have "reachable (set xs) \<subseteq> reachable (set_of (dfs empt xs))"
    apply (unfold reachable_def)
    apply (rule Image_mono)
    apply (auto simp add: set_of_def next_subset_dfs empt_invariant list_all_iff)
    done
  also from succss_closed_dfs xs have "\<dots> = set_of (dfs empt xs)"
    apply (unfold reachable_def)
    apply (rule Image_closed_trancl)
    apply (auto simp add: succss_def set_of_def)
    done
  finally show ?thesis .
qed

lemma reachable_succs: "reachable (set (succs x)) \<subseteq> reachable {x}"
  by (auto simp add: reachable_def intro: converse_rtrancl_into_rtrancl)

lemma dfs_subset_reachable_visit_nodes:
  "invariant ys \<Longrightarrow> list_all is_node xs \<Longrightarrow>
   set_of (dfs ys xs) \<subseteq> reachable (set xs) \<union> set_of ys"
proof(induct ys xs rule: dfs_induct)
  case (step S x xs)
  show ?case
  proof (cases "memb x S")
    case True
    with step show ?thesis
      by (auto simp add: reachable_def)
  next
    case False
    have "reachable (set (succs x)) \<subseteq> reachable {x}"
      by (rule reachable_succs)
    then have "reachable (set (succs x @ xs)) \<subseteq> reachable (set (x # xs))"
      by (auto simp add: reachable_def)
    then show ?thesis using step
      by (auto simp add: reachable_def ins_eq set_of_def cong: conj_cong)
  qed
qed (simp add: reachable_def)

theorem dfs_eq_reachable:
  assumes y: "is_node y"
  and xs: "list_all is_node xs"
  shows "memb y (dfs empt xs) = (y \<in> reachable (set xs))"
proof
  assume "memb y (dfs empt xs)"
  with dfs_subset_reachable_visit_nodes [OF empt_invariant xs] y
  show "y \<in> reachable (set xs)"
    by (auto simp add: empt set_of_def)
next
  assume "y \<in> reachable (set xs)"
  with reachable_closed_dfs [OF xs] show "memb y (dfs empt xs)"
    by (auto simp add: set_of_def)
qed

theorem dfs_eq_rtrancl:
  assumes y: "is_node y"
  and x: "is_node x"
  shows "memb y (dfs empt [x]) = ((x,y) \<in> (succsr succs)\<^sup>*)"
proof -
  from x have x': "list_all is_node [x]" by simp
  show ?thesis
    by (simp only: dfs_eq_reachable [OF y x'] reachable_def succsr_def) (auto simp add: empt)
qed

theorem dfs_invariant [consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all is_node xs"
  and H: "I S"
  and I: "\<And>S x. \<not> memb x S \<Longrightarrow> is_node x \<Longrightarrow> invariant S \<Longrightarrow> I S \<Longrightarrow> I (ins x S)"
  shows "I (dfs S xs)"
proof -
  from S xs H
  have "I (dfs S xs) \<and> invariant (dfs S xs)"
  proof (induct S xs rule: dfs_induct)
    case (step S x xs)
    show ?case
    proof (cases "memb x S")
      case False
      then show ?thesis
        apply simp
        apply (rule step)
        apply assumption
        apply (rule I)
        apply assumption
        apply (rule step)+
        done
    qed (simp add: step)
  qed simp
  then show ?thesis ..
qed

theorem dfs_invariant': "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow> invariant (dfs S xs)"
  by (induct S xs rule: dfs_induct) auto

theorem succsr_is_node:
  assumes xy: "(x, y) \<in> (succsr succs)\<^sup>*"
  shows "is_node x \<Longrightarrow> is_node y" using xy
proof induct
  case (step y z)
  then have "is_node y" by simp
  then have "list_all is_node (succs y)"
    by (rule succs_is_node)
  with step show ?case
    by (simp add: succsr_def list_all_iff)
qed

end

declare gen_dfs_simps [simp del]

end


theory Chapter13_3_additional
  imports "HOL-IMP.Complete_Lattice"
begin

text \<open>
Exercise 13.1

0:
  A0: {}
  A1: {}
  A2: {}
  A3: {}
  A4: {}

1:
  A0: {<x:=0,y:=2>}

2:
  A1: {<x:=0,y:=2>}

3:
  A2: {<x:=0,y:=2>}

4:
  A3: {<x:=2,y:=1>}

5:
  A2: {<x:=0,y:=2>, <x:=2,y:=1>}

6:
  A3: {<x:=2,y:=1>, <x:=3,y:=0>}

7:
  A4: {<x:=3,y:=0>}

8:
  Fixpoint reached

Exercise 13.3
\<close>

context Complete_Lattice
begin

definition Lub :: "'a set \<Rightarrow> 'a" where
  "Lub S = Glb {u\<in>L. \<forall>s\<in>S. s \<le> u}"

theorem Lub_greater: "\<lbrakk>A \<subseteq> L; a \<in> A\<rbrakk> \<Longrightarrow> a \<le> Lub A"
  unfolding Lub_def by (auto intro!: Glb_greatest)

theorem Lub_least: "\<lbrakk>b \<in> L; \<forall>a\<in>A. a \<le> b\<rbrakk> \<Longrightarrow> Lub A \<le> b"
  unfolding Lub_def by (auto intro!: Glb_lower)

theorem Lub_in_L: "\<lbrakk>A \<subseteq> L\<rbrakk> \<Longrightarrow> Lub A \<in> L"
  unfolding Lub_def by (auto intro!: Glb_in_L)

end

text \<open>
Exercise 13.4: The flaw in the argument is that there is no least element
in the empty set. More generally, there is no greatest lower bound of the
empty set. For if n is a lower bound of the empty set, then Suc n is a
greater lower bound of the empty set.
\<close>

text \<open>13.5: -Inf is a lower bound of any set of extended integers.
Every number that is not -Inf is an integer or +Inf, and either of these
are greater than -Inf. If a set does not have an integer glb, or has +Inf as their glb, then -Inf is
the greatest among its lower bounds.\<close>

text \<open>13.6:

Let P be a set of pre-fixpoints in a complete lattice.
Show that m = \<Sqinter>P is a pre-fixpoint.

Proof is the same as in 10.27. First, for all p \<in> P, we have
m \<le> p. By monotonicity, f m \<le> f p, and by pre-fixpoint property of p,
f p \<le> p. So f m is a lower bound of p. Since m is the greatest lower bound,
we have f m \<le> m. Thus m is a pre-fixpoint under f.

13.7.1:
Consider f: x \<mapsto> x - 1 on Z. Then f is monotone and each n is a pre-fixpoint,
but not a fixpoint.

13.7.2:
Consider the order with basis {a<b, b<c} on {a, b, c, d}. Then c and d are
both least fixpoints, but the pre-fixpoints are b, c, d, so that b and d
are least pre-fixpoints

13.8:
We show that P is a least fixpoint of f iff P is a least fixpoint of g = \<lambda>S. S \<union> f S. Then
the least fixpoint of f is also the least fixpoint of g.

First, if f P = P, we have g P = P \<union> f P = P \<union> P = P, so that
P is a fixpoint of g. So the least fixpoint of g is weakly less than the
least fixpoint of f.

Suppose that P is the least fixpoint of g. From g P = P we have P = P \<union> f P, so must have
f P \<subseteq> P. By Theorem 10.29, since f is monotone, the lfp of P is weakly less than P as well,
that is, the least fixpoint of f is weakly less than the least fixpoint of f.

By antisymmetry, we have lfp f = lfp g.
\<close>


theory Kauffman_Invariance
imports  Link_Algebra Linkrel_kauffman
begin

text{*In the following theorem, we prove that the kauffman matrix
 is invariant of framed link invariance*}

theorem kauffman_invariance:"(w1::wall) ~f w2 \<Longrightarrow> kauff_mat w1 = kauff_mat w2"
proof(induction rule:Framed_Tangle_Equivalence.induct)
case refl
  show ?case using refl by auto
next
case sym
 show ?case using sym by auto
next
case trans
 show ?case using trans by auto
  next
case compose_eq
  show ?case using compose_eq tangle_compose_matrix by auto
next
case codomain_compose
  show ?case using codomain_compose left_mat_compose by auto
next
case domain_compose
  show ?case using domain_compose right_mat_compose by auto
next
case tensor_eq
  show ?case using  tensor_eq.IH Tensor_Invariance by (metis)
next
case equality
  show ?case using framed_linkrel_inv equality by auto
qed

lemma "rat_poly_times A B = 1"
      using inverse1  by (metis )

text{* we calculate kauffman bracket of a few links*}

text{*kauffman bracket of an unknot with zero crossings *}
lemma "kauff_mat ([cup]*(basic [cap])) = [[-(A^2) - (B^2)]]"
       apply(simp add:mat_multI_def)
       apply(simp add:matT_vec_multI_def)
       apply(auto simp add:replicate_def rat_poly.row_length_def)
       apply(auto simp add:scalar_prod)
       by (metis comm_ring_1_class.normalizing_ring_rules(2) power2_eq_square)

text{*kauffman bracket of an a two component unlinked unknot
    with zero crossings *}
lemma "kauff_mat ([cup,cup]*(basic [cap,cap]))= [[((A^4)+(B^4)) + 2]]"
       apply(simp add:mat_multI_def)
       apply(simp add:matT_vec_multI_def)
       apply(auto simp add:replicate_def rat_poly.row_length_def)
       apply(auto simp add:scalar_prod)
       apply(auto simp add:unlink_computation)
       done

definition trefoil_polynomial::"rat_poly"
where
"trefoil_polynomial \<equiv>
rat_poly_plus
     (rat_poly_times (rat_poly_times A A)
       (rat_poly_plus
         (rat_poly_times B
           (rat_poly_times B
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times A A))))
         (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
           (rat_poly_plus (rat_poly_times B (rat_poly_times B (rat_poly_times A A)))
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A)))))))
     (rat_poly_plus
       (rat_poly_times 2
         (rat_poly_times A
           (rat_poly_times A
             (rat_poly_times A
               (rat_poly_times A (rat_poly_times A (rat_poly_times B B)))))))
       (rat_poly_times (rat_poly_times B B)
         (rat_poly_times B
           (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
             (rat_poly_times B (rat_poly_times B B))))))"

text{*kauffman bracket of trefoil*}
lemma trefoil:
"kauff_mat ([cup,cup]*[vert,over,vert]*[vert,over,vert]*[vert,over,vert]
              *(basic [cap,cap]))
          = [[trefoil_polynomial]]"
    apply(simp add:mat_multI_def)
    apply(simp add:matT_vec_multI_def)
    apply(auto simp add:replicate_def rat_poly.row_length_def)
    apply(auto simp add:scalar_prod)
    apply(simp add:trefoil_polynomial_def)
    done

end


theory Functions_MainHC
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"o_def\", \"id_def\", \"X3comp_def\", \"X3comp_assoc1\",
     \"X3comp_assoc2\", \"o_assoc\", \"id_neut\", \"inj\", \"surj\"]"

consts
X__o__X :: "('b => 'c partial) * ('a => 'b partial) => 'a => 'c partial"
X_id :: "'a => 'a partial" ("id''/'(_')" [3] 999)
comp3 :: "(('c => 'd partial) * ('b => 'c partial)) * ('a => 'b partial) => 'a => 'd partial"

axioms
o_def [rule_format] :
"ALL f.
 ALL g.
 X__o__X (g, f) =
 (% x. restrictOp (g (makeTotal (f x))) (defOp (f x)))"

id_def [rule_format] : "X_id = makePartial o (% x. x)"

X3comp_def [rule_format] :
"ALL f.
 ALL g.
 ALL h.
 comp3 ((h, g), f) =
 (% x. restrictOp (h (makeTotal (g (makeTotal (f x)))))
       (defOp (g (makeTotal (f x))) & defOp (f x)))"

theorem restrict1 : "restrictOp (restrictOp a (defOp b)) c = restrictOp (restrictOp a c) (defOp (restrictOp b c))"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_trivial [simp]: "restrictOp t True = t"
apply (simp add: restrictOp_def)
done

theorem restrict_assoc[simp] : "restrictOp a (defOp (restrictOp b c)) = restrictOp (restrictOp a (defOp b)) c"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def noneOp_def defOp.simps undefinedOp_def)
done

theorem restrict_out[simp] : "restrictOp (t b) b = restrictOp (t True) b"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_out2[simp] : "restrictOp (t b) (a&b) = restrictOp (t True) (a&b)"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_out_general : "(b-->a) ==> (restrictOp (t a) b) = (restrictOp (t True) b)"
apply (case_tac "b")
apply (simp only: restrictOp_def)
apply (simp only: restrictOp_def)
apply (simp)
done

theorem mkpartial_cancel [simp]: "makeTotal(makePartial x) = x"
apply (simp add: makeTotal_def makePartial_def)
done

theorem mkpartial_cancel2 [simp]: "defOp(x) ==> makePartial(makeTotal x) = x"
apply (simp add: makeTotal_def makePartial_def)
apply (case_tac x)
apply (simp)
apply (simp)
done

theorem mkpartial_cancel3 [simp] : "((makePartial x) = (makePartial y)) = (x = y)"
apply (simp add: makePartial_def)
done

theorem defOp_trivial [simp]: "defOp(makePartial x) = True"
apply (simp add: makePartial_def makeTotal_def)
done

theorem restrictOp_add_def: "(restrictOp f b) = (makePartial x) ==> b"
apply (simp add: makePartial_def restrictOp_def)
apply (simp only: undefinedOp_def)
apply (case_tac b)
apply (auto)
done

theorem restrictOp_mkpartial_defined: "(restrictOp f b) = (makePartial x) ==> f = (makePartial x)"
apply (simp add: makePartial_def restrictOp_def)
apply (simp only: undefinedOp_def)
apply (case_tac b)
apply (auto)
done

theorem restrictOp_outbool [simp]: "(restrictOp (restrictOp a b) c) = (restrictOp a (b & c))"
apply (case_tac "c")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem o_assoc  :
"ALL f.
 ALL g.
 ALL h. X__o__X (h, X__o__X (g, f)) = X__o__X (X__o__X (h, g), f)"
apply (auto)
apply (rule ext)
apply (simp add: o_def comp_def)
apply (subst restrict_out2 [of _ "defOp (f x)"])
apply (subst restrict_trivial)
apply (simp)
done

theorem id_neut [rule_format] : "ALL f'. X__o__X (f', X_id) = f'"
by (simp add: o_def comp_def id_def)

theorem inj [rule_format] :
"ALL f'.
 X__o__X (f', f') = X_id --> (ALL x. ALL y. f' x = f' y --> x = y)"
apply (auto)
apply (rule injD [of X_id])
apply (rule injI)
apply (simp add: o_def comp_def id_def)
apply (drule_tac sym)
apply (frule_tac x = "x" in fun_cong)
apply (drule_tac x = "y" in fun_cong)
apply (simp)
apply (simp (no_asm_simp) add: o_def comp_def id_def)
done

theorem surj [rule_format] :
"ALL f'.
 X__o__X (f', f') = X_id --> (ALL x. EX y. f' y = makePartial x)"
apply (auto)
apply (rule_tac x="makeTotal (f' x)" in exI)
apply (drule_tac x = "x" in fun_cong)
apply (simp add: o_def comp_def id_def restrictOp_mkpartial_defined)
done

theorem X3comp_assoc1  :
"ALL f.
 ALL g. ALL h. comp3 ((h, g), f) = X__o__X (X__o__X (h, g), f)"
apply (auto)
apply (rule ext)
apply (simp add: o_def X3comp_def)
done

theorem X3comp_assoc2 :
"ALL f.
 ALL g. ALL h. comp3 ((h, g), f) = X__o__X (h, X__o__X (g, f))"
apply (auto)
apply (rule ext)
apply (simp add: o_def X3comp_def)
apply (subst restrict_out_general [of "(defOp (g (makeTotal (f x))) & defOp (f x))" "defOp (f x)"]) back back back back
apply (simp)
apply (simp)
done

end


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

section \<open>The Reflection Theorem\<close>

theory Reflection imports Normal begin

lemma all_iff_not_ex_not: "(\<forall>x. P(x)) \<longleftrightarrow> (~ (\<exists>x. ~ P(x)))"
by blast

lemma ball_iff_not_bex_not: "(\<forall>x\<in>A. P(x)) \<longleftrightarrow> (~ (\<exists>x\<in>A. ~ P(x)))"
by blast

text\<open>From the notes of A. S. Kechris, page 6, and from
      Andrzej Mostowski, \emph{Constructible Sets with Applications},
      North-Holland, 1969, page 23.\<close>

subsection\<open>Basic Definitions\<close>

text\<open>First part: the cumulative hierarchy defining the class \<open>M\<close>.
To avoid handling multiple arguments, we assume that \<open>Mset(l)\<close> is
closed under ordered pairing provided \<open>l\<close> is limit.  Possibly this
could be avoided: the induction hypothesis @{term Cl_reflects}
(in locale \<open>ex_reflection\<close>) could be weakened to
@{term "\<forall>y\<in>Mset(a). \<forall>z\<in>Mset(a). P(<y,z>) \<longleftrightarrow> Q(a,<y,z>)"}, removing most
uses of @{term Pair_in_Mset}.  But there isn't much point in doing so, since
ultimately the \<open>ex_reflection\<close> proof is packaged up using the
predicate \<open>Reflects\<close>.
\<close>
locale reflection =
  fixes Mset and M and Reflects
  assumes Mset_mono_le : "mono_le_subset(Mset)"
      and Mset_cont    : "cont_Ord(Mset)"
      and Pair_in_Mset : "[| x \<in> Mset(a); y \<in> Mset(a); Limit(a) |]
                          ==> <x,y> \<in> Mset(a)"
  defines "M(x) == \<exists>a. Ord(a) & x \<in> Mset(a)"
      and "Reflects(Cl,P,Q) == Closed_Unbounded(Cl) &
                              (\<forall>a. Cl(a) \<longrightarrow> (\<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)))"
  fixes F0 \<comment>\<open>ordinal for a specific value @{term y}\<close>
  fixes FF \<comment>\<open>sup over the whole level, @{term "y\<in>Mset(a)"}\<close>
  fixes ClEx \<comment>\<open>Reflecting ordinals for the formula @{term "\<exists>z. P"}\<close>
  defines "F0(P,y) == \<mu> b. (\<exists>z. M(z) & P(<y,z>)) \<longrightarrow>
                               (\<exists>z\<in>Mset(b). P(<y,z>))"
      and "FF(P)   == \<lambda>a. \<Union>y\<in>Mset(a). F0(P,y)"
      and "ClEx(P,a) == Limit(a) & normalize(FF(P),a) = a"

lemma (in reflection) Mset_mono: "i\<le>j ==> Mset(i) \<subseteq> Mset(j)"
apply (insert Mset_mono_le)
apply (simp add: mono_le_subset_def leI)
done

text\<open>Awkward: we need a version of \<open>ClEx_def\<close> as an equality
      at the level of classes, which do not really exist\<close>
lemma (in reflection) ClEx_eq:
     "ClEx(P) == \<lambda>a. Limit(a) & normalize(FF(P),a) = a"
by (simp add: ClEx_def [symmetric])

subsection\<open>Easy Cases of the Reflection Theorem\<close>

theorem (in reflection) Triv_reflection [intro]:
     "Reflects(Ord, P, \<lambda>a x. P(x))"
by (simp add: Reflects_def)

theorem (in reflection) Not_reflection [intro]:
     "Reflects(Cl,P,Q) ==> Reflects(Cl, \<lambda>x. ~P(x), \<lambda>a x. ~Q(a,x))"
by (simp add: Reflects_def)

theorem (in reflection) And_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a), \<lambda>x. P(x) & P'(x),
                                      \<lambda>a x. Q(a,x) & Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Or_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a), \<lambda>x. P(x) | P'(x),
                                      \<lambda>a x. Q(a,x) | Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Imp_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a),
                   \<lambda>x. P(x) \<longrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Iff_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a),
                   \<lambda>x. P(x) \<longleftrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longleftrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

subsection\<open>Reflection for Existential Quantifiers\<close>

lemma (in reflection) F0_works:
     "[| y\<in>Mset(a); Ord(a); M(z); P(<y,z>) |] ==> \<exists>z\<in>Mset(F0(P,y)). P(<y,z>)"
apply (unfold F0_def M_def, clarify)
apply (rule LeastI2)
  apply (blast intro: Mset_mono [THEN subsetD])
 apply (blast intro: lt_Ord2, blast)
done

lemma (in reflection) Ord_F0 [intro,simp]: "Ord(F0(P,y))"
by (simp add: F0_def)

lemma (in reflection) Ord_FF [intro,simp]: "Ord(FF(P,y))"
by (simp add: FF_def)

lemma (in reflection) cont_Ord_FF: "cont_Ord(FF(P))"
apply (insert Mset_cont)
apply (simp add: cont_Ord_def FF_def, blast)
done

text\<open>Recall that @{term F0} depends upon @{term "y\<in>Mset(a)"},
while @{term FF} depends only upon @{term a}.\<close>
lemma (in reflection) FF_works:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Ord(a) |] ==> \<exists>z\<in>Mset(FF(P,a)). P(<y,z>)"
apply (simp add: FF_def)
apply (simp_all add: cont_Ord_Union [of concl: Mset]
                     Mset_cont Mset_mono_le not_emptyI Ord_F0)
apply (blast intro: F0_works)
done

lemma (in reflection) FFN_works:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Ord(a) |]
      ==> \<exists>z\<in>Mset(normalize(FF(P),a)). P(<y,z>)"
apply (drule FF_works [of concl: P], assumption+)
apply (blast intro: cont_Ord_FF le_normalize [THEN Mset_mono, THEN subsetD])
done

text\<open>Locale for the induction hypothesis\<close>

locale ex_reflection = reflection +
  fixes P  \<comment>"the original formula"
  fixes Q  \<comment>"the reflected formula"
  fixes Cl \<comment>"the class of reflecting ordinals"
  assumes Cl_reflects: "[| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)"

lemma (in ex_reflection) ClEx_downward:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Cl(a); ClEx(P,a) |]
      ==> \<exists>z\<in>Mset(a). Q(a,<y,z>)"
apply (simp add: ClEx_def, clarify)
apply (frule Limit_is_Ord)
apply (frule FFN_works [of concl: P], assumption+)
apply (drule Cl_reflects, assumption+)
apply (auto simp add: Limit_is_Ord Pair_in_Mset)
done

lemma (in ex_reflection) ClEx_upward:
     "[| z\<in>Mset(a); y\<in>Mset(a); Q(a,<y,z>); Cl(a); ClEx(P,a) |]
      ==> \<exists>z. M(z) & P(<y,z>)"
apply (simp add: ClEx_def M_def)
apply (blast dest: Cl_reflects
             intro: Limit_is_Ord Pair_in_Mset)
done

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma (in ex_reflection) ZF_ClEx_iff:
     "[| y\<in>Mset(a); Cl(a); ClEx(P,a) |]
      ==> (\<exists>z. M(z) & P(<y,z>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,<y,z>))"
by (blast intro: dest: ClEx_downward ClEx_upward)

text\<open>...and it is closed and unbounded\<close>
lemma (in ex_reflection) ZF_Closed_Unbounded_ClEx:
     "Closed_Unbounded(ClEx(P))"
apply (simp add: ClEx_eq)
apply (fast intro: Closed_Unbounded_Int Normal_imp_fp_Closed_Unbounded
                   Closed_Unbounded_Limit Normal_normalize)
done

text\<open>The same two theorems, exported to locale \<open>reflection\<close>.\<close>

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma (in reflection) ClEx_iff:
     "[| y\<in>Mset(a); Cl(a); ClEx(P,a);
        !!a. [| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x) |]
      ==> (\<exists>z. M(z) & P(<y,z>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,<y,z>))"
apply (unfold ClEx_def FF_def F0_def M_def)
apply (rule ex_reflection.ZF_ClEx_iff
  [OF ex_reflection.intro, OF reflection.intro ex_reflection_axioms.intro,
    of Mset Cl])
apply (simp_all add: Mset_mono_le Mset_cont Pair_in_Mset)
done

(*Alternative proof, less unfolding:
apply (rule Reflection.ZF_ClEx_iff [of Mset _ _ Cl, folded M_def])
apply (fold ClEx_def FF_def F0_def)
apply (rule ex_reflection.intro, assumption)
apply (simp add: ex_reflection_axioms.intro, assumption+)
*)

lemma (in reflection) Closed_Unbounded_ClEx:
     "(!!a. [| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x))
      ==> Closed_Unbounded(ClEx(P))"
apply (unfold ClEx_eq FF_def F0_def M_def)
apply (rule ex_reflection.ZF_Closed_Unbounded_ClEx [of Mset _ _ Cl])
apply (rule ex_reflection.intro, rule reflection_axioms)
apply (blast intro: ex_reflection_axioms.intro)
done

subsection\<open>Packaging the Quantifier Reflection Rules\<close>

lemma (in reflection) Ex_reflection_0:
     "Reflects(Cl,P0,Q0)
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(P0,a),
                   \<lambda>x. \<exists>z. M(z) & P0(<x,z>),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q0(a,<x,z>))"
apply (simp add: Reflects_def)
apply (intro conjI Closed_Unbounded_Int)
  apply blast
 apply (rule Closed_Unbounded_ClEx [of Cl P0 Q0], blast, clarify)
apply (rule_tac Cl=Cl in  ClEx_iff, assumption+, blast)
done

lemma (in reflection) All_reflection_0:
     "Reflects(Cl,P0,Q0)
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x.~P0(x), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P0(<x,z>),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q0(a,<x,z>))"
apply (simp only: all_iff_not_ex_not ball_iff_not_bex_not)
apply (rule Not_reflection, drule Not_reflection, simp)
apply (erule Ex_reflection_0)
done

theorem (in reflection) Ex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z. M(z) & P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (rule Ex_reflection_0 [of _ " \<lambda>x. P(fst(x),snd(x))"
                               "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

theorem (in reflection) All_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. ~P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (rule All_reflection_0 [of _ "\<lambda>x. P(fst(x),snd(x))"
                                "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

text\<open>And again, this time using class-bounded quantifiers\<close>

theorem (in reflection) Rex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z[M]. P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (unfold rex_def, blast)

theorem (in reflection) Rall_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. ~P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z[M]. P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (unfold rall_def, blast)

text\<open>No point considering bounded quantifiers, where reflection is trivial.\<close>

subsection\<open>Simple Examples of Reflection\<close>

text\<open>Example 1: reflecting a simple formula.  The reflecting class is first
given as the variable \<open>?Cl\<close> and later retrieved from the final
proof state.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Problem here: there needs to be a conjunction (class intersection)
in the class of reflecting ordinals.  The @{term "Ord(a)"} is redundant,
though harmless.\<close>
lemma (in reflection)
     "Reflects(\<lambda>a. Ord(a) & ClEx(\<lambda>x. fst(x) \<in> snd(x), a),
               \<lambda>x. \<exists>y. M(y) & x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Example 2\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2'.  We give the reflecting class explicitly.\<close>
lemma (in reflection)
  "Reflects
    (\<lambda>a. (Ord(a) &
          ClEx(\<lambda>x. ~ (snd(x) \<subseteq> fst(fst(x)) \<longrightarrow> snd(x) \<in> snd(fst(x))), a)) &
          ClEx(\<lambda>x. \<forall>z. M(z) \<longrightarrow> z \<subseteq> fst(x) \<longrightarrow> z \<in> snd(x), a),
            \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
            \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2''.  We expand the subset relation.\<close>
schematic_goal (in reflection)
  "Reflects(?Cl,
        \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> (\<forall>w. M(w) \<longrightarrow> w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y),
        \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). (\<forall>w\<in>Mset(a). w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y)"
by fast

text\<open>Example 2'''.  Single-step version, to reveal the reflecting class.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
apply (rule Ex_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule All_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule Triv_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
done

text\<open>Example 3.  Warning: the following examples make sense only
if @{term P} is quantifier-free, since it is not being relativized.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<in> y \<longleftrightarrow> z \<in> x & P(z)),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<in> y \<longleftrightarrow> z \<in> x & P(z))"
by fast

text\<open>Example 3'\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & y = Collect(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Collect(x,P))"
by fast

text\<open>Example 3''\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & y = Replace(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Replace(x,P))"
by fast

text\<open>Example 4: Axiom of Choice.  Possibly wrong, since \<open>\<Pi>\<close> needs
to be relativized.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>A. 0\<notin>A \<longrightarrow> (\<exists>f. M(f) & f \<in> (\<Prod>X \<in> A. X)),
               \<lambda>a A. 0\<notin>A \<longrightarrow> (\<exists>f\<in>Mset(a). f \<in> (\<Prod>X \<in> A. X)))"
by fast

end