(*
    Author: Asta Halkjær From, DTU Compute, 2019-2021
    Contributors: Alexander Birch Jensen, Anders Schlichtkrull & Jørgen Villadsen

    See also the Natural Deduction Assistant (NaDeA) and the Sequent Calculus Verifier (SeCaV):

      https://nadea.compute.dtu.dk/
      https://secav.compute.dtu.dk/
*)

section \<open>Tableau Calculus\<close>

theory Tableau imports Common begin

inductive TC :: \<open>('a, 'b) form list \<Rightarrow> bool\<close> (\<open>\<stileturn> _\<close> 0) where
  Basic: \<open>\<stileturn> Pred i l # Neg (Pred i l) # G\<close>
| BasicFF: \<open>\<stileturn> \<bottom> # G\<close>
| BasicNegTT: \<open>\<stileturn> Neg \<top> # G\<close>
| AlphaNegNeg: \<open>\<stileturn> A # G \<Longrightarrow> \<stileturn> Neg (Neg A) # G\<close>
| AlphaAnd: \<open>\<stileturn> A # B # G \<Longrightarrow> \<stileturn> And A B # G\<close>
| AlphaNegOr: \<open>\<stileturn> Neg A # Neg B # G \<Longrightarrow> \<stileturn> Neg (Or A B) # G\<close>
| AlphaNegImpl: \<open>\<stileturn> A # Neg B # G \<Longrightarrow> \<stileturn> Neg (Impl A B) # G\<close>
| BetaNegAnd: \<open>\<stileturn> Neg A # G \<Longrightarrow> \<stileturn> Neg B # G \<Longrightarrow> \<stileturn> Neg (And A B) # G\<close>
| BetaOr: \<open>\<stileturn> A # G \<Longrightarrow> \<stileturn> B # G \<Longrightarrow> \<stileturn> Or A B # G\<close>
| BetaImpl: \<open>\<stileturn> Neg A # G \<Longrightarrow> \<stileturn> B # G \<Longrightarrow> \<stileturn> Impl A B # G\<close>
| GammaForall: \<open>\<stileturn> subst A t 0 # G \<Longrightarrow> \<stileturn> Forall A # G\<close>
| GammaNegExists: \<open>\<stileturn> Neg (subst A t 0) # G \<Longrightarrow> \<stileturn> Neg (Exists A) # G\<close>
| DeltaExists: \<open>\<stileturn> subst A (App n []) 0 # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<stileturn> Exists A # G\<close>
| DeltaNegForall: \<open>\<stileturn> Neg (subst A (App n []) 0) # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<stileturn> Neg (Forall A) # G\<close>
| Order: \<open>\<stileturn> G \<Longrightarrow> set G = set G' \<Longrightarrow> \<stileturn> G'\<close>

lemma Shift: \<open>\<stileturn> rotate1 G \<Longrightarrow> \<stileturn> G\<close>
  by (simp add: Order)

lemma Swap: \<open>\<stileturn> B # A # G \<Longrightarrow> \<stileturn> A # B # G\<close>
  by (simp add: Order insert_commute)

definition tableauproof :: \<open>('a, 'b) form list \<Rightarrow> ('a, 'b) form \<Rightarrow> bool\<close> where
  \<open>tableauproof ps p \<equiv> (\<stileturn> Neg p # ps)\<close>

theorem tableauNotAA: \<open>\<stileturn> [Neg (Pred ''A'' []), Pred ''A'' []]\<close>
  by (rule Shift, simp) (rule Basic)

theorem AndAnd:
  \<open>\<stileturn> [And (Pred ''A'' []) (Pred ''B'' []), Neg (And (Pred ''B'' []) (Pred ''A'' []))]\<close>
  apply (rule AlphaAnd)
  apply (rule Shift, rule Shift, simp)
  apply (rule BetaNegAnd)
   apply (rule Shift, rule Shift, simp)
   apply (rule Basic)
  apply (rule Swap)
  apply (rule Basic)
  done

subsection \<open>Soundness\<close>

lemma TC_soundness:
  \<open>\<stileturn> G \<Longrightarrow> \<exists>p \<in> set G. \<not> eval e f g p\<close>
proof (induct G arbitrary: f rule: TC.induct)
  case (DeltaExists A n G)
  show ?case
  proof (rule ccontr)
    assume \<open>\<not> (\<exists>p \<in> set (Exists A # G). \<not> eval e f g p)\<close>
    then have *: \<open>\<forall>p \<in> set (Exists A # G). eval e f g p\<close>
      by simp

    then obtain x where \<open>eval (shift e 0 x) (f(n := \<lambda>w. x)) g A\<close>
      using \<open>news n (A # G)\<close> by auto
    then have **: \<open>eval e (f(n := \<lambda>w. x)) g (subst A (App n []) 0)\<close>
      by simp

    have \<open>\<exists>p \<in> set (subst A (App n []) 0 # G). \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      using DeltaExists by fast
    then consider
      \<open>\<not> eval e (f(n := \<lambda>w. x)) g (subst A (App n []) 0)\<close> |
      \<open>\<exists>p \<in> set G. \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      by auto
    then show False
    proof cases
      case 1
      then show ?thesis
        using ** ..
    next
      case 2
      then obtain p where \<open>\<not> eval e (f(n := \<lambda>w. x)) g p\<close> \<open>p \<in> set G\<close>
        by blast
      then have \<open>\<not> eval e f g p\<close>
        using \<open>news n (A # G)\<close> by (metis Ball_set set_subset_Cons subsetCE upd_lemma)
      then show ?thesis
        using * \<open>p \<in> set G\<close> by simp
    qed
  qed
next
  case (DeltaNegForall A n G)
  show ?case
  proof (rule ccontr)
    assume \<open>\<not> (\<exists>p \<in> set (Neg (Forall A) # G). \<not> eval e f g p)\<close>
    then have *: \<open>\<forall>p \<in> set (Neg (Forall A) # G). eval e f g p\<close>
      by simp

    then obtain x where \<open>eval (shift e 0 x) (f(n := \<lambda>w. x)) g (Neg A)\<close>
      using \<open>news n (A # G)\<close> by auto
    then have **: \<open>eval e (f(n := \<lambda>w. x)) g (Neg (subst A (App n []) 0))\<close>
      by simp

    have \<open>\<exists>p \<in> set (Neg (subst A (App n []) 0) # G). \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      using DeltaNegForall by fast
    then consider
      \<open>\<not> eval e (f(n := \<lambda>w. x)) g (Neg (subst A (App n []) 0))\<close> |
      \<open>\<exists>p \<in> set G. \<not> eval e (f(n := \<lambda>w. x)) g p\<close>
      by auto
    then show False
    proof cases
      case 1
      then show ?thesis
        using ** ..
    next
      case 2
      then obtain p where \<open>\<not> eval e (f(n := \<lambda>w. x)) g p\<close> \<open>p \<in> set G\<close>
        by blast
      then have \<open>\<not> eval e f g p\<close>
        using \<open>news n (A # G)\<close> by (metis Ball_set set_subset_Cons subsetCE upd_lemma)
      then show ?thesis
        using * \<open>p \<in> set G\<close> by simp
    qed
  qed
qed auto

theorem tableau_soundness:
  \<open>tableauproof ps p \<Longrightarrow> list_all (eval e f g) ps \<Longrightarrow> eval e f g p\<close>
  using TC_soundness unfolding tableauproof_def list_all_def by fastforce

subsection \<open>Completeness for Closed Formulas\<close>

theorem infinite_nonempty: \<open>infinite A \<Longrightarrow> \<exists>x. x \<in> A\<close>
  by (simp add: ex_in_conv infinite_imp_nonempty)

theorem TCd_consistency:
  assumes inf_param: \<open>infinite (UNIV::'a set)\<close>
  shows \<open>consistency {S::('a, 'b) form set. \<exists>G. S = set G \<and> \<not> (\<stileturn> G)}\<close>
  unfolding consistency_def
proof (intro conjI allI impI notI)
  fix S :: \<open>('a, 'b) form set\<close>
  assume \<open>S \<in> {set G | G. \<not> (\<stileturn> G)}\<close> (is \<open>S \<in> ?C\<close>)
  then obtain G :: \<open>('a, 'b) form list\<close>
    where *: \<open>S = set G\<close> and \<open>\<not> (\<stileturn> G)\<close>
    by blast

  { fix p ts
    assume \<open>Pred p ts \<in> S \<and> Neg (Pred p ts) \<in> S\<close>
    then show False
      using * Basic Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { assume \<open>\<bottom> \<in> S\<close>
    then show False
      using * BasicFF Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { assume \<open>Neg \<top> \<in> S\<close>
    then show False
      using * BasicNegTT Order \<open>\<not> (\<stileturn> G)\<close> by fastforce }

  { fix Z
    assume \<open>Neg (Neg Z) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Z # G)\<close>
      using * AlphaNegNeg Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Z} = set (Z # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Z} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>And A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # B # G)\<close>
      using * AlphaAnd Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {A, B} = set (A # B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {A, B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Neg (Or A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # Neg B # G)\<close>
      using * AlphaNegOr Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg A, Neg B} = set (Neg A # Neg B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Neg A, Neg B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Neg (Impl A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # Neg B # G)\<close>
      using * AlphaNegImpl Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>{A, Neg B} \<union> S = set (A # Neg B # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {A, Neg B} \<in> ?C\<close>
      by blast }

  { fix A B
    assume \<open>Or A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> A # G) \<or> \<not> (\<stileturn> B # G)\<close>
      using * BetaOr Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {A} \<in> ?C \<or> S \<union> {B} \<in> ?C\<close>
      using * by auto }

  { fix A B
    assume \<open>Neg (And A B) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # G) \<or> \<not> (\<stileturn> Neg B # G)\<close>
      using * BetaNegAnd Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {Neg A} \<in> ?C \<or> S \<union> {Neg B} \<in> ?C\<close>
      using * by auto }

  { fix A B
    assume \<open>Impl A B \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg A # G) \<or> \<not> (\<stileturn> B # G)\<close>
      using * BetaImpl Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    then show \<open>S \<union> {Neg A} \<in> ?C \<or> S \<union> {B} \<in> ?C\<close>
      using * by auto }

  { fix P and t :: \<open>'a term\<close>
    assume \<open>Forall P \<in> S\<close>
    then have \<open>\<not> (\<stileturn> subst P t 0 # G)\<close>
      using * GammaForall Order\<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {subst P t 0} = set (subst P t 0 # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {subst P t 0} \<in> ?C\<close>
      by blast }

  { fix P and t :: \<open>'a term\<close>
    assume \<open>Neg (Exists P) \<in> S\<close>
    then have \<open>\<not> (\<stileturn> Neg (subst P t 0) # G)\<close>
      using * GammaNegExists Order \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg (subst P t 0)} = set (Neg (subst P t 0) # G)\<close>
      using * by simp
    ultimately show \<open>S \<union> {Neg (subst P t 0)} \<in> ?C\<close>
      by blast }

  { fix P
    assume \<open>Exists P \<in> S\<close>
    have \<open>finite ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      by simp
    then have \<open>infinite (- ((\<Union>p \<in> set G. params p) \<union> params P))\<close>
      using inf_param Diff_infinite_finite finite_compl infinite_UNIV_listI by blast
    then obtain x where **: \<open>x \<in> - ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      using infinite_imp_nonempty by blast
    then have \<open>news x (P # G)\<close>
      using Ball_set_list_all by auto
    then have \<open>\<not> (\<stileturn> subst P (App x []) 0 # G)\<close>
      using * \<open>Exists P \<in> S\<close> Order DeltaExists \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {subst P (App x []) 0} = set (subst P (App x []) 0 # G)\<close>
      using * by simp
    ultimately show \<open>\<exists>x. S \<union> {subst P (App x []) 0} \<in> ?C\<close>
      by blast }

  { fix P
    assume \<open>Neg (Forall P) \<in> S\<close>
    have \<open>finite ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      by simp
    then have \<open>infinite (- ((\<Union>p \<in> set G. params p) \<union> params P))\<close>
      using inf_param Diff_infinite_finite finite_compl infinite_UNIV_listI by blast
    then obtain x where **: \<open>x \<in> - ((\<Union>p \<in> set G. params p) \<union> params P)\<close>
      using infinite_imp_nonempty by blast
    then have \<open>news x (P # G)\<close>
      using Ball_set_list_all by auto
    then have \<open>\<not> (\<stileturn> Neg (subst P (App x []) 0) # G)\<close>
      using * \<open>Neg (Forall P) \<in> S\<close> Order DeltaNegForall \<open>\<not> (\<stileturn> G)\<close>
      by (metis insert_absorb list.set(2))
    moreover have \<open>S \<union> {Neg (subst P (App x []) 0)} = set (Neg (subst P (App x []) 0) # G)\<close>
      using * by simp
    ultimately show \<open>\<exists>x. S \<union> {Neg (subst P (App x []) 0)} \<in> ?C\<close>
      by blast }
qed

theorem tableau_completeness':
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>closed 0 p\<close>
    and \<open>list_all (closed 0) ps\<close>
    and mod: \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) ps \<longrightarrow> eval e f g p\<close>
  shows \<open>tableauproof ps p\<close>
proof (rule ccontr)
  fix e
  assume \<open>\<not> tableauproof ps p\<close>

  let ?S = \<open>set (Neg p # ps)\<close>
  let ?C = \<open>{set (G :: (nat, nat) form list) | G. \<not> (\<stileturn> G)}\<close>
  let ?f = HApp
  let ?g = \<open>(\<lambda>a ts. Pred a (terms_of_hterms ts) \<in> Extend ?S
              (mk_finite_char (mk_alt_consistency (close ?C))) from_nat)\<close>

  from \<open>list_all (closed 0) ps\<close>
  have \<open>\<forall>p \<in> set ps. closed 0 p\<close>
    by (simp add: list_all_iff)

  { fix x
    assume \<open>x \<in> ?S\<close>
    moreover have \<open>consistency ?C\<close>
      using TCd_consistency by blast
    moreover have \<open>?S \<in> ?C\<close>
      using \<open>\<not> tableauproof ps p\<close> unfolding tableauproof_def by blast
    moreover have \<open>infinite (- (\<Union>p \<in> ?S. params p))\<close>
      by (simp add: Compl_eq_Diff_UNIV infinite_UNIV_listI)
    moreover note \<open>closed 0 p\<close> \<open>\<forall>p \<in> set ps. closed 0 p\<close> \<open>x \<in> ?S\<close>
    then have \<open>closed 0 x\<close> by auto
    ultimately have \<open>eval e ?f ?g x\<close>
      using model_existence by blast }
  then have \<open>list_all (eval e ?f ?g) (Neg p # ps)\<close>
    by (simp add: list_all_iff)
  moreover have \<open>eval e ?f ?g (Neg p)\<close>
    using calculation by simp
  moreover have \<open>list_all (eval e ?f ?g) ps\<close>
    using calculation by simp
  then have \<open>eval e ?f ?g p\<close>
    using mod by blast
  ultimately show False by simp
qed

subsection \<open>Open Formulas\<close>

lemma TC_psubst:
  fixes f :: \<open>'a \<Rightarrow> 'a\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (psubst f) G\<close>
proof (induct G arbitrary: f rule: TC.induct)
  case (DeltaExists A n G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p)\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where *: \<open>fresh \<notin> ?params \<union> {n} \<union> image f ?params\<close>
    using ex_new_if_finite inf_params
    by (metis finite.emptyI finite.insertI finite_UnI finite_imageI)

  let ?f = \<open>f(n := fresh)\<close>

  have \<open>news n (A # G)\<close>
    using DeltaExists by blast
  then have \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close>
    using * new_psubst_image news_psubst by (fastforce simp add: image_Un)+
  then have G: \<open>map (psubst ?f) G = map (psubst f) G\<close>
    using DeltaExists
    by (metis (mono_tags, lifting) Ball_set insertCI list.set(2) map_eq_conv psubst_upd)

  have \<open>\<stileturn> psubst ?f (subst A (App n []) 0) # map (psubst ?f) G\<close>
    using DeltaExists by (metis list.simps(9))
  then have \<open>\<stileturn> subst (psubst ?f A) (App fresh []) 0 # map (psubst ?f) G\<close>
    by simp
  moreover have \<open>news fresh (map (psubst ?f) (A # G))\<close>
    using \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close> by simp
  then have \<open>news fresh (psubst ?f A # map (psubst ?f) G)\<close>
    by simp
  ultimately have \<open>\<stileturn> map (psubst ?f) (Exists A # G)\<close>
    using TC.DeltaExists by fastforce
  then show ?case
    using DeltaExists G by simp
next
  case (DeltaNegForall A n G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p)\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where *: \<open>fresh \<notin> ?params \<union> {n} \<union> image f ?params\<close>
    using ex_new_if_finite inf_params
    by (metis finite.emptyI finite.insertI finite_UnI finite_imageI)

  let ?f = \<open>f(n := fresh)\<close>

  have \<open>news n (A # G)\<close>
    using DeltaNegForall by blast
  then have \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close>
    using * new_psubst_image news_psubst by (fastforce simp add: image_Un)+
  then have G: \<open>map (psubst ?f) G = map (psubst f) G\<close>
    using DeltaNegForall
    by (metis (mono_tags, lifting) Ball_set insertCI list.set(2) map_eq_conv psubst_upd)

  have \<open>\<stileturn> psubst ?f (Neg (subst A (App n []) 0)) # map (psubst ?f) G\<close>
    using DeltaNegForall by (metis list.simps(9))
  then have \<open>\<stileturn> Neg (subst (psubst ?f A) (App fresh []) 0) # map (psubst ?f) G\<close>
    by simp
  moreover have \<open>news fresh (map (psubst ?f) (A # G))\<close>
    using \<open>new fresh (psubst ?f A)\<close> \<open>news fresh (map (psubst ?f) G)\<close> by simp
  then have \<open>news fresh (psubst ?f A # map (psubst ?f) G)\<close>
    by simp
  ultimately have \<open>\<stileturn> map (psubst ?f) (Neg (Forall A) # G)\<close>
    using TC.DeltaNegForall by fastforce
  then show ?case
    using DeltaNegForall G by simp
next
  case (Order G G')
  then show ?case
    using Order TC.Order set_map by metis
qed (auto intro: TC.intros)

lemma subcs_map: \<open>subcs c s G = map (subc c s) G\<close>
  by (induct G) simp_all

lemma TC_subcs:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> subcs c s G\<close>
proof (induct G arbitrary: c s rule: TC.induct)
  case (GammaForall A t G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> paramst t \<union> {c}\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
    using ex_new_if_finite inf_params by metis

  let ?f = \<open>id(c := fresh)\<close>
  let ?g = \<open>id(fresh := c)\<close>
  let ?s = \<open>psubstt ?f s\<close>

  have s: \<open>psubstt ?g ?s = s\<close>
    using fresh psubst_new_away' by simp
  have \<open>subc (?g c) (psubstt ?g ?s) (psubst ?g (Forall A)) = subc c s (Forall A)\<close>
    using fresh by simp
  then have A: \<open>psubst ?g (subc c ?s (Forall A)) = subc c s (Forall A)\<close>
    using fun_upd_apply id_def subc_psubst UnCI fresh params.simps(8) by metis
  have \<open>\<forall>x \<in> (\<Union>p \<in> set (Forall A # G). params p). x \<noteq> c \<longrightarrow> ?g x \<noteq> ?g c\<close>
    using fresh by auto
  moreover have \<open>map (psubst ?g) (Forall A # G) = Forall A # G\<close>
    using fresh by (induct G) simp_all
  ultimately have G: \<open>map (psubst ?g) (subcs c ?s (Forall A # G)) = subcs c s (Forall A # G)\<close>
    using s A by (simp add: subcs_psubst)

  have \<open>new_term c ?s\<close>
    using fresh psubst_new_free' by fast
  then have \<open>\<stileturn> subc c ?s (subst A (subc_term c ?s t) 0) # subcs c ?s G\<close>
    using GammaForall by (metis new_subc_put subcs.simps(2))
  moreover have \<open>new_term c (subc_term c ?s t)\<close>
    using \<open>new_term c ?s\<close> new_subc_same' by simp
  ultimately have \<open>\<stileturn> subst (subc c (liftt ?s) A) (subc_term c ?s t) 0 # subcs c ?s G\<close>
    by simp
  moreover have \<open>Forall (subc c (liftt ?s) A) \<in> set (subcs c ?s (Forall A # G))\<close>
    by simp
  ultimately have \<open>\<stileturn> subcs c ?s (Forall A # G)\<close>
    using TC.GammaForall by simp
  then have \<open>\<stileturn> map (psubst ?g) (subcs c ?s (Forall A # G))\<close>
    using TC_psubst inf_params by blast
  then show \<open>\<stileturn> subcs c s (Forall A # G)\<close>
    using G by simp
next
  case (GammaNegExists A t G)
  let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> paramst t \<union> {c}\<close>

  have \<open>finite ?params\<close>
    by simp
  then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
    using ex_new_if_finite inf_params by metis

  let ?f = \<open>id(c := fresh)\<close>
  let ?g = \<open>id(fresh := c)\<close>
  let ?s = \<open>psubstt ?f s\<close>

  have s: \<open>psubstt ?g ?s = s\<close>
    using fresh psubst_new_away' by simp
  have \<open>subc (?g c) (psubstt ?g ?s) (psubst ?g (Neg (Exists A))) = subc c s (Neg (Exists A))\<close>
    using fresh by simp
  then have A: \<open>psubst ?g (subc c ?s (Neg (Exists A))) = subc c s (Neg (Exists A))\<close>
    using fun_upd_apply id_def subc_psubst UnCI fresh params.simps(7,9) by metis

  have \<open>\<forall>x \<in> (\<Union>p \<in> set (Neg (Exists A) # G). params p). x \<noteq> c \<longrightarrow> ?g x \<noteq> ?g c\<close>
    using fresh by auto
  moreover have \<open>map (psubst ?g) (Neg (Exists A) # G) = Neg (Exists A) # G\<close>
    using fresh by (induct G) simp_all
  ultimately have G: \<open>map (psubst ?g) (subcs c ?s (Neg (Exists A) # G)) =
      subcs c s (Neg (Exists A) # G)\<close>
    using s A by (simp add: subcs_psubst)

  have \<open>new_term c ?s\<close>
    using fresh psubst_new_free' by fast
  then have \<open>\<stileturn> Neg (subc c ?s (subst A (subc_term c ?s t) 0)) # subcs c ?s G\<close>
    using GammaNegExists by (metis new_subc_put subc.simps(4) subcs.simps(2))
  moreover have \<open>new_term c (subc_term c ?s t)\<close>
    using \<open>new_term c ?s\<close> new_subc_same' by simp
  ultimately have \<open>\<stileturn> Neg (subst (subc c (liftt ?s) A) (subc_term c ?s t) 0) # subcs c ?s G\<close>
    by simp
  moreover have \<open>Neg (Exists (subc c (liftt ?s) A)) \<in> set (subcs c ?s (Neg (Exists A) # G))\<close>
    by simp
  ultimately have \<open>\<stileturn> subcs c ?s (Neg (Exists A) # G)\<close>
    using TC.GammaNegExists by simp
  then have \<open>\<stileturn> map (psubst ?g) (subcs c ?s (Neg (Exists A) # G))\<close>
    using TC_psubst inf_params by blast
  then show \<open>\<stileturn> subcs c s (Neg (Exists A) # G)\<close>
    using G by simp
next
  case (DeltaExists A n G)
  then show ?case
  proof (cases \<open>c = n\<close>)
    case True
    then have \<open>\<stileturn> Exists A # G\<close>
      using DeltaExists TC.DeltaExists by metis
    moreover have \<open>new c A\<close> and \<open>news c G\<close>
      using DeltaExists True by simp_all
    ultimately show ?thesis
      by (simp add: subcs_news)
  next
    case False
    let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> {c} \<union> {n}\<close>

    have \<open>finite ?params\<close>
      by simp
    then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
      using ex_new_if_finite inf_params by metis

    let ?s = \<open>psubstt (id(n := fresh)) s\<close>
    let ?f = \<open>id(n := fresh, fresh := n)\<close>

    have f: \<open>\<forall>x \<in> ?params. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      using fresh by simp

    have \<open>new_term n ?s\<close>
      using fresh psubst_new_free' by fast
    then have \<open>psubstt ?f ?s = psubstt (id(fresh := n)) ?s\<close>
      by (metis fun_upd_twist psubstt_upd(1))
    then have psubst_s: \<open>psubstt ?f ?s = s\<close>
      using fresh psubst_new_away' by simp

    have \<open>?f c = c\<close> and \<open>new_term c (App fresh [])\<close>
      using False fresh by auto

    have \<open>psubst ?f (subc c ?s (subst A (App n []) 0)) =
      subc (?f c) (psubstt ?f ?s) (psubst ?f (subst A (App n []) 0))\<close>
      by (simp add: subc_psubst)
    also have \<open>\<dots> = subc c s (subst (psubst ?f A) (App fresh []) 0)\<close>
      using \<open>?f c = c\<close> psubst_subst psubst_s by simp
    also have \<open>\<dots> = subc c s (subst A (App fresh []) 0)\<close>
      using DeltaExists fresh by simp
    finally have psubst_A: \<open>psubst ?f (subc c ?s (subst A (App n []) 0)) =
        subst (subc c (liftt s) A) (App fresh []) 0\<close>
      using \<open>new_term c (App fresh [])\<close> by simp

    have \<open>news n G\<close>
      using DeltaExists by simp
    moreover have \<open>news fresh G\<close>
      using fresh by (induct G) simp_all
    ultimately have \<open>map (psubst ?f) G = G\<close>
      by (induct G) simp_all
    moreover have \<open>\<forall>x \<in> \<Union>p \<in> set G. params p. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      by auto
    ultimately have psubst_G: \<open>map (psubst ?f) (subcs c ?s G) = subcs c s G\<close>
      using \<open>?f c = c\<close> psubst_s by (simp add: subcs_psubst)

    have \<open>\<stileturn> subc c ?s (subst A (App n []) 0) # subcs c ?s G\<close>
      using DeltaExists by simp
    then have \<open>\<stileturn> psubst ?f (subc c ?s (subst A (App n []) 0)) # map (psubst ?f) (subcs c ?s G)\<close>
      using TC_psubst inf_params DeltaExists.hyps(3) by fastforce
    then have \<open>\<stileturn> psubst ?f (subc c ?s (subst A (App n []) 0)) # subcs c s G\<close>
      using psubst_G by simp
    then have sub_A: \<open>\<stileturn> subst (subc c (liftt s) A) (App fresh []) 0 # subcs c s G\<close>
      using psubst_A by simp

    have \<open>new_term fresh s\<close>
      using fresh by simp
    then have \<open>new_term fresh (liftt s)\<close>
      by simp
    then have \<open>new fresh (subc c (liftt s) A)\<close>
      using fresh new_subc by simp
    moreover have \<open>news fresh (subcs c s G)\<close>
      using \<open>news fresh G\<close> \<open>new_term fresh s\<close> news_subcs by fast
    ultimately show \<open>\<stileturn> subcs c s (Exists A # G)\<close>
      using TC.DeltaExists sub_A by fastforce
  qed
next
  case (DeltaNegForall A n G)
  then show ?case
  proof (cases \<open>c = n\<close>)
    case True
    then have \<open>\<stileturn> Neg (Forall A) # G\<close>
      using DeltaNegForall TC.DeltaNegForall by metis
    moreover have \<open>new c A\<close> and \<open>news c G\<close>
      using DeltaNegForall True by simp_all
    ultimately show ?thesis
      by (simp add: subcs_news)
  next
    case False
    let ?params = \<open>params A \<union> (\<Union>p \<in> set G. params p) \<union> paramst s \<union> {c} \<union> {n}\<close>

    have \<open>finite ?params\<close>
      by simp
    then obtain fresh where fresh: \<open>fresh \<notin> ?params\<close>
      using ex_new_if_finite inf_params by metis

    let ?s = \<open>psubstt (id(n := fresh)) s\<close>
    let ?f = \<open>id(n := fresh, fresh := n)\<close>

    have f: \<open>\<forall>x \<in> ?params. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      using fresh by simp

    have \<open>new_term n ?s\<close>
      using fresh psubst_new_free' by fast
    then have \<open>psubstt ?f ?s = psubstt (id(fresh := n)) ?s\<close>
      using fun_upd_twist psubstt_upd(1) by metis
    then have psubst_s: \<open>psubstt ?f ?s = s\<close>
      using fresh psubst_new_away' by simp

    have \<open>?f c = c\<close> and \<open>new_term c (App fresh [])\<close>
      using False fresh by auto

    have \<open>psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) =
      subc (?f c) (psubstt ?f ?s) (psubst ?f (Neg (subst A (App n []) 0)))\<close>
      by (simp add: subc_psubst)
    also have \<open>\<dots> = subc c s (Neg (subst (psubst ?f A)(App fresh []) 0))\<close>
      using \<open>?f c = c\<close> psubst_subst psubst_s by simp
    also have \<open>\<dots> = subc c s (Neg (subst A (App fresh []) 0))\<close>
      using DeltaNegForall fresh by simp
    finally have psubst_A: \<open>psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) =
        Neg (subst (subc c (liftt s) A) (App fresh []) 0)\<close>
      using \<open>new_term c (App fresh [])\<close> by simp

    have \<open>news n G\<close>
      using DeltaNegForall by simp
    moreover have \<open>news fresh G\<close>
      using fresh by (induct G) simp_all
    ultimately have \<open>map (psubst ?f) G = G\<close>
      by (induct G) simp_all
    moreover have \<open>\<forall>x \<in> \<Union>p \<in> set G. params p. x \<noteq> c \<longrightarrow> ?f x \<noteq> ?f c\<close>
      by auto
    ultimately have psubst_G: \<open>map (psubst ?f) (subcs c ?s G) = subcs c s G\<close>
      using \<open>?f c = c\<close> psubst_s by (simp add: subcs_psubst)

    have \<open>\<stileturn> subc c ?s (Neg (subst A (App n []) 0)) # subcs c ?s G\<close>
      using DeltaNegForall by simp
    then have \<open>\<stileturn> psubst ?f (subc c ?s (Neg (subst A (App n []) 0)))
                # map (psubst ?f) (subcs c ?s G)\<close>
      using TC_psubst inf_params DeltaNegForall.hyps(3) by fastforce
    then have \<open>\<stileturn> psubst ?f (subc c ?s (Neg (subst A (App n []) 0))) # subcs c s G\<close>
      using psubst_G by simp
    then have sub_A: \<open>\<stileturn> Neg (subst (subc c (liftt s) A) (App fresh []) 0) # subcs c s G\<close>
      using psubst_A by simp

    have \<open>new_term fresh s\<close>
      using fresh by simp
    then have \<open>new_term fresh (liftt s)\<close>
      by simp
    then have \<open>new fresh (subc c (liftt s) A)\<close>
      using fresh new_subc by simp
    moreover have \<open>news fresh (subcs c s G)\<close>
      using \<open>news fresh G\<close> \<open>new_term fresh s\<close> news_subcs by fast
    ultimately show \<open>\<stileturn> subcs c s (Neg (Forall A) # G)\<close>
      using TC.DeltaNegForall sub_A by fastforce
  qed
next
  case (Order G G')
  then show ?case
    using TC.Order set_map subcs_map by metis
qed (auto intro: TC.intros)

lemma TC_map_subc:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes inf_params: \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (subc c s) G\<close>
  using assms TC_subcs subcs_map by metis

lemma ex_all_closed: \<open>\<exists>m. list_all (closed m) G\<close>
proof (induct G)
  case Nil
  then show ?case
    by simp
next
  case (Cons a G)
  then show ?case
    unfolding list_all_def
    using ex_closed closed_mono
    by (metis Ball_set list_all_simps(1) nat_le_linear)
qed

primrec sub_consts :: \<open>'a list \<Rightarrow> ('a, 'b) form \<Rightarrow> ('a, 'b) form\<close> where
  \<open>sub_consts [] p = p\<close>
| \<open>sub_consts (c # cs) p = sub_consts cs (subst p (App c []) (length cs))\<close>

lemma valid_sub_consts:
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p\<close>
  shows \<open>eval (e :: nat => 'a) f g (sub_consts cs p)\<close>
  using assms by (induct cs arbitrary: p) simp_all

lemma closed_sub' [simp]:
  assumes \<open>k \<le> m\<close> shows
    \<open>closedt (Suc m) t = closedt m (substt t (App c []) k)\<close>
    \<open>closedts (Suc m) l = closedts m (substts l (App c []) k)\<close>
  using assms by (induct t and l rule: closedt.induct closedts.induct) auto

lemma closed_sub: \<open>k \<le> m \<Longrightarrow> closed (Suc m) p = closed m (subst p (App c []) k)\<close>
  by (induct p arbitrary: m k) simp_all

lemma closed_sub_consts: \<open>length cs = k \<Longrightarrow> closed m (sub_consts cs p) = closed (m + k) p\<close>
proof (induct cs arbitrary: k p)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  then show ?case
    using closed_sub by fastforce
qed

lemma map_sub_consts_Nil: \<open>map (sub_consts []) G = G\<close>
  by (induct G) simp_all

primrec conjoin :: \<open>('a, 'b) form list \<Rightarrow> ('a, 'b) form\<close> where
  \<open>conjoin [] = Neg \<bottom>\<close>
| \<open>conjoin (p # ps) = And p (conjoin ps)\<close>

lemma eval_conjoin: \<open>list_all (eval e f g) G = eval e f g (conjoin G)\<close>
  by (induct G) simp_all

lemma valid_sub:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p \<longrightarrow> eval e f g q\<close>
  shows \<open>eval e f g (subst p t m) \<longrightarrow> eval e f g (subst q t m)\<close>
  using assms by simp

lemma eval_sub_consts:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. eval e f g p \<longrightarrow> eval e f g q\<close>
    and \<open>eval e f g (sub_consts cs p)\<close>
  shows \<open>eval e f g (sub_consts cs q)\<close>
  using assms
proof (induct cs arbitrary: p q)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  then show ?case
    by (metis sub_consts.simps(2) subst_lemma)
qed

lemma sub_consts_And [simp]: \<open>sub_consts cs (And p q) = And (sub_consts cs p) (sub_consts cs q)\<close>
  by (induct cs arbitrary: p q) simp_all

lemma sub_consts_conjoin:
  \<open>eval e f g (sub_consts cs (conjoin G)) = eval e f g (conjoin (map (sub_consts cs) G))\<close>
proof (induct G)
  case Nil
  then show ?case
    by (induct cs) simp_all
next
  case (Cons p G)
  then show ?case
    using sub_consts_And by simp
qed

lemma all_sub_consts_conjoin:
  \<open>list_all (eval e f g) (map (sub_consts cs) G) = eval e f g (sub_consts cs (conjoin G))\<close>
  by (induct G) (simp_all add: valid_sub_consts)

lemma valid_all_sub_consts:
  fixes e :: \<open>nat \<Rightarrow> 'a\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> 'a) f g. list_all (eval e f g) G \<longrightarrow> eval e f g p\<close>
  shows \<open>list_all (eval e f g) (map (sub_consts cs) G) \<longrightarrow> eval e f g (sub_consts cs p)\<close>
  using assms eval_conjoin eval_sub_consts all_sub_consts_conjoin by metis

lemma TC_vars_for_consts:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<stileturn> G \<Longrightarrow> \<stileturn> map (\<lambda>p. vars_for_consts p cs) G\<close>
proof (induct cs)
  case Nil
  then show ?case
    by simp
next
  case (Cons c cs)
  have \<open>(\<stileturn> map (\<lambda>p. vars_for_consts p (c # cs)) G) =
      (\<stileturn> map (\<lambda>p. subc c (Var (length cs)) (vars_for_consts p cs)) G)\<close>
    by simp
  also have \<open>\<dots> = (\<stileturn> map (subc c (Var (length cs)) o (\<lambda>p. vars_for_consts p cs)) G)\<close>
    unfolding comp_def by simp
  also have \<open>\<dots> = (\<stileturn> map (subc c (Var (length cs))) (map (\<lambda>p. vars_for_consts p cs) G))\<close>
    by simp
  finally show ?case
    using Cons TC_map_subc assms by metis
qed

lemma vars_for_consts_sub_consts:
  \<open>closed (length cs) p \<Longrightarrow> list_all (\<lambda>c. new c p) cs \<Longrightarrow> distinct cs \<Longrightarrow>
   vars_for_consts (sub_consts cs p) cs = p\<close>
proof (induct cs arbitrary: p)
  case (Cons c cs)
  then show ?case
    using subst_new_all closed_sub by force
qed simp

lemma all_vars_for_consts_sub_consts:
  \<open>list_all (closed (length cs)) G \<Longrightarrow> list_all (\<lambda>c. list_all (new c) G) cs \<Longrightarrow> distinct cs \<Longrightarrow>
   map (\<lambda>p. vars_for_consts p cs) (map (sub_consts cs) G) = G\<close>
  using vars_for_consts_sub_consts unfolding list_all_def
  by (induct G) fastforce+

lemma new_conjoin: \<open>new c (conjoin G) \<Longrightarrow> list_all (new c) G\<close>
  by (induct G) simp_all

lemma all_fresh_constants:
  fixes G :: \<open>('a, 'b) form list\<close>
  assumes \<open>infinite (UNIV :: 'a set)\<close>
  shows \<open>\<exists>cs. length cs = m \<and> list_all (\<lambda>c. list_all (new c) G) cs \<and> distinct cs\<close>
proof -
  obtain cs where \<open>length cs = m\<close> \<open>list_all (\<lambda>c. new c (conjoin G)) cs\<close> \<open>distinct cs\<close>
    using assms fresh_constants by blast
  then show ?thesis
    using new_conjoin unfolding list_all_def by metis
qed

lemma sub_consts_Neg: \<open>sub_consts cs (Neg p) = Neg (sub_consts cs p)\<close>
  by (induct cs arbitrary: p) simp_all

subsection \<open>Completeness\<close>

  moreover have \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) (map (sub_consts cs) G) \<longrightarrow>
    eval e f g (sub_consts cs p)\<close>
    using assms valid_all_sub_consts by blast
  ultimately have \<open>\<stileturn> Neg (sub_consts cs p) # map (sub_consts cs) G\<close>
    using tableau_completeness' unfolding tableauproof_def by simp
  then have \<open>\<stileturn> map (sub_consts cs) (Neg p # G)\<close>
    by (simp add: sub_consts_Neg)
  then have \<open>\<stileturn> map (\<lambda>p. vars_for_consts p cs) (map (sub_consts cs) (Neg p # G))\<close>
    using TC_vars_for_consts by blast
  then show ?thesis
    unfolding tableauproof_def
    using all_vars_for_consts_sub_consts[where G=\<open>Neg p # G\<close>] * ** by simp
qed

corollary
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. eval e f g p\<close>
  shows \<open>\<stileturn> [Neg p]\<close>
  using assms tableau_completeness unfolding tableauproof_def by simp

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Connection\<close>
theory Transport_Compositions_Generic_Galois_Connection
  imports
    HOL_Basics.Galois_Equivalences
    Transport_Compositions_Generic_Galois_Property
    Transport_Compositions_Generic_Monotone
begin

context transport_comp
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1
  rewrites "flip.t2.unit = \<epsilon>\<^sub>1" and "flip.t1.counit \<equiv> \<eta>\<^sub>2"
  by (simp_all only: t1.flip_unit_eq_counit t2.flip_counit_eq_unit)

lemma galois_connection_left_rightI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "rel_equivalence_on (in_codom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>) \<epsilon>\<^sub>1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>R2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "inflationary_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>) \<eta>\<^sub>2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_connectionI galois_prop_left_rightI
    mono_wrt_rel_leftI flip.mono_wrt_rel_leftI)
  (auto intro: inflationary_on_if_le_pred_if_inflationary_on
    in_field_if_in_dom in_field_if_in_codom)

lemma galois_connection_left_rightI':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and "inflationary_on (in_dom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>) \<eta>\<^sub>1"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>) \<epsilon>\<^sub>1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>R2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "inflationary_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>) \<eta>\<^sub>2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_dom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_connectionI galois_prop_left_rightI'
    mono_wrt_rel_leftI' flip.mono_wrt_rel_leftI')
  (auto elim!: preorder_on_in_fieldE
    intro!: reflexive_on_in_field_if_transitive_if_rel_equivalence_on
    intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_dom)

corollary galois_connection_left_right_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_connection_left_rightI)
  (auto elim!: galois.galois_connectionE
    intro!: flip.t2.rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence
      t2.inflationary_on_unit_if_reflexive_on_if_galois_equivalence
    intro: rel_equivalence_on_if_le_pred_if_rel_equivalence_on
      in_field_if_in_codom)

corollary galois_connection_left_right_if_order_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_connection_left_rightI')
  (auto elim!: rel_equivalence_onE
    intro!: t1.half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel
      flip.t1.half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel
      t2.half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel
      flip.t2.half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel
      preorder_on_in_field_if_transitive_if_rel_equivalence_on
      rel_comp_comp_le_assms_if_in_codom_rel_comp_comp_leI
    intro: inflationary_on_if_le_pred_if_inflationary_on
      deflationary_on_if_le_pred_if_deflationary_on
      in_field_if_in_dom in_field_if_in_codom)

end

end


theory ASC_Example
  imports ASC_Hoare
begin

section \<open> Example product machines and properties \<close>

text \<open>
This section provides example FSMs and shows that the assumptions on the inputs of the adaptive
state counting algorithm are not vacuous.
\<close>

subsection \<open> Constructing FSMs from transition relations \<close>

text \<open>
This subsection provides a function to more easily create FSMs, only requiring a set of
transition-tuples and an initial state.
\<close>

fun from_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> 'state \<Rightarrow> ('in, 'out, 'state) FSM" where
"from_rel rel q0 = \<lparr> succ = \<lambda> io p . { q . (p,io,q) \<in> rel },
                    inputs = image (fst \<circ> fst \<circ> snd) rel,
                    outputs = image (snd \<circ> fst \<circ> snd) rel,
                    initial = q0 \<rparr>"

lemma nodes_from_rel : "nodes (from_rel rel q0) \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
  (is "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)")
proof -
  have "\<And> q io p . q \<in> succ ?M io p \<Longrightarrow> q \<in> image (snd \<circ> snd) rel"
    by force
  have "\<And> q . q \<in> nodes ?M \<Longrightarrow> q = q0 \<or> q \<in> image (snd \<circ> snd) rel"
  proof -
    fix q assume "q \<in> nodes ?M"
    then show "q = q0 \<or> q \<in> image (snd \<circ> snd) rel"
    proof (cases rule: FSM.nodes.cases)
      case initial
      then show ?thesis by auto
    next
      case (execute p a)
      then show ?thesis
        using \<open>\<And> q io p . q \<in> succ ?M io p \<Longrightarrow> q \<in> image (snd \<circ> snd) rel\<close> by blast
    qed
  qed
  then show "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
    by blast
qed

fun well_formed_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> bool" where
  "well_formed_rel rel = (finite rel
                          \<and> (\<forall> s1 x y . (x \<notin> image (fst \<circ> fst \<circ> snd) rel
                                            \<or> y \<notin> image (snd \<circ> fst \<circ> snd) rel)
                                        \<longrightarrow> \<not>(\<exists> s2 . (s1,(x,y),s2) \<in> rel))
                          \<and> rel \<noteq> {})"

lemma well_formed_from_rel :
  assumes "well_formed_rel rel"
  shows "well_formed (from_rel rel q0)"  (is "well_formed ?M")
proof -
  have "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
    using nodes_from_rel[of rel q0] by auto
  moreover have "finite (insert q0 (image (snd \<circ> snd) rel))"
    using assms by auto
  ultimately have "finite (nodes ?M)"
    by (simp add: Finite_Set.finite_subset)
  moreover have "finite (inputs ?M)" "finite (outputs ?M)"
    using assms by auto
  ultimately have "finite_FSM ?M"
    by auto

  moreover have "inputs ?M \<noteq> {}"
    using assms by auto
  moreover have "outputs ?M \<noteq> {}"
    using assms by auto
  moreover have "\<And> s1 x y . (x \<notin> inputs ?M \<or> y \<notin> outputs ?M) \<longrightarrow> succ ?M (x,y) s1 = {}"
    using assms by auto

  ultimately show ?thesis
    by auto
qed

fun completely_specified_rel_over :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> 'state set \<Rightarrow> bool"
  where
  "completely_specified_rel_over rel nods = (\<forall> s1 \<in> nods .
                                                \<forall> x \<in> image (fst \<circ> fst \<circ> snd) rel .
                                                  \<exists> y \<in> image (snd \<circ> fst \<circ> snd) rel .
                                                    \<exists> s2 . (s1,(x,y),s2) \<in> rel)"

lemma completely_specified_from_rel :
  assumes "completely_specified_rel_over rel (nodes ((from_rel rel q0)))"
  shows "completely_specified (from_rel rel q0)"  (is "completely_specified ?M")
  unfolding completely_specified.simps
proof
  fix s1 assume "s1 \<in> nodes (from_rel rel q0)"
  show  "\<forall>x\<in>inputs ?M. \<exists>y\<in>outputs ?M. \<exists>s2. s2 \<in> succ ?M (x, y) s1"
  proof
    fix x assume "x \<in> inputs (from_rel rel q0)"
    then have "x \<in>  image (fst \<circ> fst \<circ> snd) rel"
      using assms by auto

    obtain y s2 where "y \<in> image (snd \<circ> fst \<circ> snd) rel" "(s1,(x,y),s2) \<in> rel"
      using assms \<open>s1 \<in> nodes (from_rel rel q0)\<close> \<open>x \<in>  image (fst \<circ> fst \<circ> snd) rel\<close>
      by (meson completely_specified_rel_over.elims(2))

    then have "y \<in> outputs (from_rel rel q0)" "s2 \<in> succ (from_rel rel q0) (x, y) s1"
      by auto

    then show "\<exists>y\<in>outputs (from_rel rel q0). \<exists>s2. s2 \<in> succ (from_rel rel q0) (x, y) s1"
      by blast
  qed
qed

fun observable_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> bool" where
  "observable_rel rel = (\<forall> io s1 . { s2 . (s1,io,s2) \<in> rel } = {}
                                    \<or> (\<exists> s2 . { s2' . (s1,io,s2') \<in> rel } = {s2}))"

lemma observable_from_rel :
  assumes "observable_rel rel"
  shows "observable (from_rel rel q0)"  (is "observable ?M")
proof -
  have "\<And> io s1 . { s2 . (s1,io,s2) \<in> rel } = succ ?M io s1"
    by auto
  then show ?thesis using assms by auto
qed

abbreviation "OFSM_rel rel q0 \<equiv> well_formed_rel rel
                                \<and> completely_specified_rel_over rel (nodes (from_rel rel q0))
                                \<and> observable_rel rel"

lemma OFMS_from_rel :
  assumes "OFSM_rel rel q0"
  shows "OFSM (from_rel rel q0)"
  by (metis assms completely_specified_from_rel observable_from_rel well_formed_from_rel)

subsection \<open> Example FSMs and properties \<close>

abbreviation "M\<^sub>S_rel :: (nat\<times>(nat\<times>nat)\<times>nat) set \<equiv> {(0,(0,0),1), (0,(0,1),1), (1,(0,2),1)}"
abbreviation "M\<^sub>S :: (nat,nat,nat) FSM \<equiv> from_rel M\<^sub>S_rel 0"

abbreviation "M\<^sub>I_rel :: (nat\<times>(nat\<times>nat)\<times>nat) set \<equiv> {(0,(0,0),1), (0,(0,1),1), (1,(0,2),0)}"
abbreviation "M\<^sub>I :: (nat,nat,nat) FSM \<equiv> from_rel M\<^sub>I_rel 0"

lemma example_nodes :
  "nodes M\<^sub>S = {0,1}" "nodes M\<^sub>I = {0,1}"
proof -
  have "0 \<in> nodes M\<^sub>S" by auto
  have "1 \<in> succ M\<^sub>S (0,0) 0" by auto
  have "1 \<in> nodes M\<^sub>S"
    by (meson \<open>0 \<in> nodes M\<^sub>S\<close> \<open>1 \<in> succ M\<^sub>S (0, 0) 0\<close> succ_nodes)

  have "{0,1} \<subseteq> nodes M\<^sub>S"
    using \<open>0 \<in> nodes M\<^sub>S\<close> \<open>1 \<in> nodes M\<^sub>S\<close> by auto
  moreover have "nodes M\<^sub>S \<subseteq> {0,1}"
    using nodes_from_rel[of M\<^sub>S_rel 0] by auto
  ultimately show "nodes M\<^sub>S = {0,1}"
    by blast
next
  have "0 \<in> nodes M\<^sub>I" by auto
  have "1 \<in> succ M\<^sub>I (0,0) 0" by auto
  have "1 \<in> nodes M\<^sub>I"
    by (meson \<open>0 \<in> nodes M\<^sub>I\<close> \<open>1 \<in> succ M\<^sub>I (0, 0) 0\<close> succ_nodes)

  have "{0,1} \<subseteq> nodes M\<^sub>I"
    using \<open>0 \<in> nodes M\<^sub>I\<close> \<open>1 \<in> nodes M\<^sub>I\<close> by auto
  moreover have "nodes M\<^sub>I \<subseteq> {0,1}"
    using nodes_from_rel[of M\<^sub>I_rel 0] by auto
  ultimately show "nodes M\<^sub>I = {0,1}"
    by blast
qed

lemma example_OFSM :
  "OFSM M\<^sub>S" "OFSM M\<^sub>I"
proof -
  have "well_formed_rel M\<^sub>S_rel"
    unfolding well_formed_rel.simps by auto

  moreover have "completely_specified_rel_over M\<^sub>S_rel (nodes (from_rel M\<^sub>S_rel 0))"
    unfolding completely_specified_rel_over.simps
  proof
    fix s1 assume "(s1::nat) \<in> nodes (from_rel M\<^sub>S_rel 0)"
    then have "s1 \<in> (insert 0 (image (snd \<circ> snd) M\<^sub>S_rel))"
      using nodes_from_rel[of M\<^sub>S_rel 0] by blast
    moreover have "completely_specified_rel_over M\<^sub>S_rel (insert 0 (image (snd \<circ> snd) M\<^sub>S_rel))"
      unfolding completely_specified_rel_over.simps by auto
    ultimately show "\<forall>x\<in>(fst \<circ> fst \<circ> snd) ` M\<^sub>S_rel.
                      \<exists>y\<in>(snd \<circ> fst \<circ> snd) ` M\<^sub>S_rel. \<exists>s2. (s1, (x, y), s2) \<in> M\<^sub>S_rel"
      by simp
  qed

  moreover have "observable_rel M\<^sub>S_rel"
    by auto

  ultimately have "OFSM_rel M\<^sub>S_rel 0"
    by auto

  then show "OFSM M\<^sub>S"
    using OFMS_from_rel[of M\<^sub>S_rel 0] by linarith
next
  have "well_formed_rel M\<^sub>I_rel"
    unfolding well_formed_rel.simps by auto

  moreover have "completely_specified_rel_over M\<^sub>I_rel (nodes (from_rel M\<^sub>I_rel 0))"
    unfolding completely_specified_rel_over.simps
  proof
    fix s1 assume "(s1::nat) \<in> nodes (from_rel M\<^sub>I_rel 0)"
    then have "s1 \<in> (insert 0 (image (snd \<circ> snd) M\<^sub>I_rel))"
      using nodes_from_rel[of M\<^sub>I_rel 0] by blast
    have "completely_specified_rel_over M\<^sub>I_rel (insert 0 (image (snd \<circ> snd) M\<^sub>I_rel))"
      unfolding completely_specified_rel_over.simps by auto
    show "\<forall>x\<in>(fst \<circ> fst \<circ> snd) ` M\<^sub>I_rel.
            \<exists>y\<in>(snd \<circ> fst \<circ> snd) ` M\<^sub>I_rel. \<exists>s2. (s1, (x, y), s2) \<in> M\<^sub>I_rel"
      by (meson \<open>completely_specified_rel_over M\<^sub>I_rel (insert 0 ((snd \<circ> snd) ` M\<^sub>I_rel))\<close>
          \<open>s1 \<in> insert 0 ((snd \<circ> snd) ` M\<^sub>I_rel)\<close> completely_specified_rel_over.elims(2))
  qed

  moreover have "observable_rel M\<^sub>I_rel"
    by auto

  ultimately have "OFSM_rel M\<^sub>I_rel 0"
    by auto

  then show "OFSM M\<^sub>I"
    using OFMS_from_rel[of M\<^sub>I_rel 0] by linarith
qed

lemma example_fault_domain : "asc_fault_domain M\<^sub>S M\<^sub>I 2"
proof -
  have "inputs M\<^sub>S = inputs M\<^sub>I"
    by auto
  moreover have "card (nodes M\<^sub>I) \<le> 2"
    using example_nodes(2) by auto
  ultimately show "asc_fault_domain M\<^sub>S M\<^sub>I 2"
    by auto
qed

abbreviation "FAIL\<^sub>I :: (nat\<times>nat) \<equiv> (3,3)"
abbreviation "PM\<^sub>I :: (nat, nat, nat\<times>nat) FSM \<equiv> \<lparr>
            succ = (\<lambda> a (p1,p2) . (if (p1 \<in> nodes M\<^sub>S \<and> p2 \<in> nodes M\<^sub>I \<and> (fst a \<in> inputs M\<^sub>S)
                                        \<and> (snd a \<in> outputs M\<^sub>S \<union> outputs M\<^sub>I))
                                    then (if (succ M\<^sub>S a p1 = {} \<and> succ M\<^sub>I a p2 \<noteq> {})
                                      then {FAIL\<^sub>I}
                                      else (succ M\<^sub>S a p1 \<times> succ M\<^sub>I a p2))
                                    else {})),
            inputs = inputs M\<^sub>S,
            outputs = outputs M\<^sub>S \<union> outputs M\<^sub>I,
            initial = (initial M\<^sub>S, initial M\<^sub>I)
          \<rparr>"

lemma example_productF : "productF M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I"
proof -
  have "inputs M\<^sub>S = inputs M\<^sub>I"
    by auto
  moreover have "fst FAIL\<^sub>I \<notin> nodes M\<^sub>S"
    using example_nodes(1) by auto
  moreover have "snd FAIL\<^sub>I \<notin> nodes M\<^sub>I"
    using example_nodes(2) by auto
  ultimately show ?thesis
    unfolding productF.simps by blast
qed

abbreviation "V\<^sub>I :: nat list set \<equiv> {[],[0]}"

lemma example_det_state_cover : "is_det_state_cover M\<^sub>S V\<^sub>I"
proof -
  have "d_reaches M\<^sub>S (initial M\<^sub>S) [] (initial M\<^sub>S)"
    by auto
  then have "initial M\<^sub>S \<in> d_reachable M\<^sub>S (initial M\<^sub>S)"
    unfolding d_reachable.simps by blast

  have "d_reached_by M\<^sub>S (initial M\<^sub>S) [0] 1 [1] [0]"
  proof
    show "length [0] = length [0] \<and>
    length [0] = length [1] \<and> path M\<^sub>S (([0] || [0]) || [1]) (initial M\<^sub>S)
                            \<and> target (([0] || [0]) || [1]) (initial M\<^sub>S) = 1"
      by auto

    have "\<And>ys2 tr2.
       length [0] = length ys2
          \<and> length [0] = length tr2
          \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)
            \<longrightarrow> target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
    proof
      fix ys2 tr2 assume "length [0] = length ys2 \<and> length [0] = length tr2
                            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)"
      then have "length ys2 = 1" "length tr2 = 1" "path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)"
        by auto
      moreover obtain y2 where "ys2 = [y2]"
        using \<open>length ys2 = 1\<close>
        by (metis One_nat_def \<open>length [0] = length ys2 \<and> length [0] = length tr2
            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)\<close> append.simps(1) append_butlast_last_id
            butlast_snoc length_butlast length_greater_0_conv list.size(3) nat.simps(3))
      moreover obtain t2 where "tr2 = [t2]"
        using \<open>length tr2 = 1\<close>
        by (metis One_nat_def \<open>length [0] = length ys2 \<and> length [0] = length tr2
            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)\<close> append.simps(1) append_butlast_last_id
            butlast_snoc length_butlast length_greater_0_conv list.size(3) nat.simps(3))
      ultimately have "path M\<^sub>S [((0,y2),t2)] (initial M\<^sub>S)"
        by auto
      then have "t2 \<in> succ M\<^sub>S (0,y2) (initial M\<^sub>S)"
        by auto
      moreover have "\<And> y . succ M\<^sub>S (0,y) (initial M\<^sub>S) \<subseteq> {1}"
        by auto
      ultimately have "t2 = 1"
        by blast

      show "target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
        using \<open>ys2 = [y2]\<close> \<open>tr2 = [t2]\<close> \<open>t2 = 1\<close> by auto
    qed
    then show "\<forall>ys2 tr2.
       length [0] = length ys2 \<and> length [0] = length tr2
          \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)
            \<longrightarrow> target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
      by auto
  qed

  then have "d_reaches M\<^sub>S (initial M\<^sub>S) [0] 1"
    unfolding d_reaches.simps by blast
  then have "1 \<in> d_reachable M\<^sub>S (initial M\<^sub>S)"
    unfolding d_reachable.simps by blast

  then have "{0,1} \<subseteq> d_reachable M\<^sub>S (initial M\<^sub>S)"
    using \<open>initial M\<^sub>S \<in> d_reachable M\<^sub>S (initial M\<^sub>S)\<close> by auto
  moreover have "d_reachable M\<^sub>S (initial M\<^sub>S) \<subseteq> nodes M\<^sub>S"
  proof
    fix s assume "s\<in>d_reachable M\<^sub>S (initial M\<^sub>S)"
    then have "s \<in> reachable M\<^sub>S (initial M\<^sub>S)"
      using d_reachable_reachable by auto
    then show "s \<in> nodes M\<^sub>S"
      by blast
  qed
  ultimately have "d_reachable M\<^sub>S (initial M\<^sub>S) = {0,1}"
    using example_nodes(1) by blast

  fix f' :: "nat \<Rightarrow> nat list"
  let ?f = "f'( 0 := [], 1 := [0])"

  have "is_det_state_cover_ass M\<^sub>S ?f"
    unfolding is_det_state_cover_ass.simps
  proof
    show "?f (initial M\<^sub>S) = []" by auto
    show "\<forall>s\<in>d_reachable M\<^sub>S (initial M\<^sub>S). d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
    proof
      fix s assume "s\<in>d_reachable M\<^sub>S (initial M\<^sub>S)"
      then have "s \<in> reachable M\<^sub>S (initial M\<^sub>S)"
        using d_reachable_reachable by auto
      then have "s \<in> nodes M\<^sub>S"
        by blast
      then have "s = 0 \<or> s = 1"
        using example_nodes(1) by blast
      then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
      proof
        assume "s = 0"
        then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
          using \<open>d_reaches M\<^sub>S (initial M\<^sub>S) [] (initial M\<^sub>S)\<close> by auto
      next
        assume "s = 1"
        then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
          using \<open>d_reaches M\<^sub>S (initial M\<^sub>S) [0] 1\<close> by auto
      qed
    qed
  qed

  moreover have "V\<^sub>I = image ?f (d_reachable M\<^sub>S (initial M\<^sub>S))"
    using \<open>d_reachable M\<^sub>S (initial M\<^sub>S) = {0,1}\<close> by auto

  ultimately show ?thesis
    unfolding is_det_state_cover.simps by blast
qed

abbreviation "\<Omega>\<^sub>I::(nat,nat) ATC set \<equiv> { Node 0 (\<lambda> y . Leaf) }"

lemma "applicable_set M\<^sub>S \<Omega>\<^sub>I"
  by auto

lemma example_test_tools : "test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>\<^sub>I"
  using example_productF example_det_state_cover by auto

lemma OFSM_not_vacuous :
  "\<exists> M :: (nat,nat,nat) FSM . OFSM M"
  using example_OFSM(1) by blast

lemma fault_domain_not_vacuous :
  "\<exists> (M2::(nat,nat,nat) FSM) (M1::(nat,nat,nat) FSM) m . asc_fault_domain M2 M1 m"
  using example_fault_domain by blast

lemma test_tools_not_vacuous :
  "\<exists> (M2::(nat,nat,nat) FSM)
     (M1::(nat,nat,nat) FSM)
     (FAIL::(nat\<times>nat))
     (PM::(nat,nat,nat\<times>nat) FSM)
     (V::(nat list set))
     (\<Omega>::(nat,nat) ATC set) . test_tools M2 M1 FAIL PM V \<Omega>"
proof (rule exI, rule exI)
  show "\<exists> FAIL PM V \<Omega>. test_tools M\<^sub>S M\<^sub>I FAIL PM V \<Omega>"
    using example_test_tools by blast
qed

lemma precondition_not_vacuous :
  shows "\<exists> (M2::(nat,nat,nat) FSM)
           (M1::(nat,nat,nat) FSM)
           (FAIL::(nat\<times>nat))
           (PM::(nat,nat,nat\<times>nat) FSM)
           (V::(nat list set))
           (\<Omega>::(nat,nat) ATC set)
           (m :: nat) .
              OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>"
proof (intro exI)
  show "OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I 2 \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>\<^sub>I"
    using example_OFSM(2,1) example_fault_domain example_test_tools by linarith
qed

end


(*  Title:      HOL/UNITY/ELT.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge

leadsTo strengthened with a specification of the allowable sets transient parts

TRY INSTEAD (to get rid of the {} and to gain strong induction)

  elt :: "['a set set, 'a program, 'a set] => ('a set) set"

inductive "elt CC F B"
  intros

    Weaken:  "A <= B ==> A : elt CC F B"

    ETrans:  "[| F : A ensures A';  A-A' : CC;  A' : elt CC F B |]
              ==> A : elt CC F B"

    Union:  "{A. A: S} : Pow (elt CC F B) ==> (Union S) : elt CC F B"

  monos Pow_mono
*)

section{*Progress Under Allowable Sets*}

theory ELT imports Project begin

inductive_set
  (*LEADS-TO constant for the inductive definition*)
  elt :: "['a set set, 'a program] => ('a set * 'a set) set"
  for CC :: "'a set set" and F :: "'a program"
 where

   Basis:  "[| F : A ensures B;  A-B : (insert {} CC) |] ==> (A,B) : elt CC F"

 | Trans:  "[| (A,B) : elt CC F;  (B,C) : elt CC F |] ==> (A,C) : elt CC F"

 | Union:  "ALL A: S. (A,B) : elt CC F ==> (Union S, B) : elt CC F"

definition
  (*the set of all sets determined by f alone*)
  givenBy :: "['a => 'b] => 'a set set"
  where "givenBy f = range (%B. f-` B)"

definition
  (*visible version of the LEADS-TO relation*)
  leadsETo :: "['a set, 'a set set, 'a set] => 'a program set"
                                        ("(3_/ leadsTo[_]/ _)" [80,0,80] 80)
  where "leadsETo A CC B = {F. (A,B) : elt CC F}"

definition
  LeadsETo :: "['a set, 'a set set, 'a set] => 'a program set"
                                        ("(3_/ LeadsTo[_]/ _)" [80,0,80] 80)
  where "LeadsETo A CC B =
      {F. F : (reachable F Int A) leadsTo[(%C. reachable F Int C) ` CC] B}"

(*** givenBy ***)

lemma givenBy_id [simp]: "givenBy id = UNIV"
by (unfold givenBy_def, auto)

lemma givenBy_eq_all: "(givenBy v) = {A. ALL x:A. ALL y. v x = v y --> y: A}"
apply (unfold givenBy_def, safe)
apply (rule_tac [2] x = "v ` ?u" in image_eqI, auto)
done

lemma givenByI: "(!!x y. [| x:A;  v x = v y |] ==> y: A) ==> A: givenBy v"
by (subst givenBy_eq_all, blast)

lemma givenByD: "[| A: givenBy v;  x:A;  v x = v y |] ==> y: A"
by (unfold givenBy_def, auto)

lemma empty_mem_givenBy [iff]: "{} : givenBy v"
by (blast intro!: givenByI)

lemma givenBy_imp_eq_Collect: "A: givenBy v ==> EX P. A = {s. P(v s)}"
apply (rule_tac x = "%n. EX s. v s = n & s : A" in exI)
apply (simp (no_asm_use) add: givenBy_eq_all)
apply blast
done

lemma Collect_mem_givenBy: "{s. P(v s)} : givenBy v"
by (unfold givenBy_def, best)

lemma givenBy_eq_Collect: "givenBy v = {A. EX P. A = {s. P(v s)}}"
by (blast intro: Collect_mem_givenBy givenBy_imp_eq_Collect)

(*preserving v preserves properties given by v*)
lemma preserves_givenBy_imp_stable:
     "[| F : preserves v;  D : givenBy v |] ==> F : stable D"
by (force simp add: preserves_subset_stable [THEN subsetD] givenBy_eq_Collect)

lemma givenBy_o_subset: "givenBy (w o v) <= givenBy v"
apply (simp (no_asm) add: givenBy_eq_Collect)
apply best
done

lemma givenBy_DiffI:
     "[| A : givenBy v;  B : givenBy v |] ==> A-B : givenBy v"
apply (simp (no_asm_use) add: givenBy_eq_Collect)
apply safe
apply (rule_tac x = "%z. ?R z & ~ ?Q z" in exI)
unfolding set_diff_eq
apply auto
done

(** Standard leadsTo rules **)

lemma leadsETo_Basis [intro]:
     "[| F: A ensures B;  A-B: insert {} CC |] ==> F : A leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (blast intro: elt.Basis)
done

lemma leadsETo_Trans:
     "[| F : A leadsTo[CC] B;  F : B leadsTo[CC] C |] ==> F : A leadsTo[CC] C"
apply (unfold leadsETo_def)
apply (blast intro: elt.Trans)
done

(*Useful with cancellation, disjunction*)
lemma leadsETo_Un_duplicate:
     "F : A leadsTo[CC] (A' Un A') ==> F : A leadsTo[CC] A'"
by (simp add: Un_ac)

lemma leadsETo_Un_duplicate2:
     "F : A leadsTo[CC] (A' Un C Un C) ==> F : A leadsTo[CC] (A' Un C)"
by (simp add: Un_ac)

(*The Union introduction rule as we should have liked to state it*)
lemma leadsETo_Union:
    "(!!A. A : S ==> F : A leadsTo[CC] B) ==> F : (Union S) leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (blast intro: elt.Union)
done

lemma leadsETo_UN:
    "(!!i. i : I ==> F : (A i) leadsTo[CC] B)
     ==> F : (UN i:I. A i) leadsTo[CC] B"
apply (subst Union_image_eq [symmetric])
apply (blast intro: leadsETo_Union)
done

(*The INDUCTION rule as we should have liked to state it*)
lemma leadsETo_induct:
  "[| F : za leadsTo[CC] zb;
      !!A B. [| F : A ensures B;  A-B : insert {} CC |] ==> P A B;
      !!A B C. [| F : A leadsTo[CC] B; P A B; F : B leadsTo[CC] C; P B C |]
               ==> P A C;
      !!B S. ALL A:S. F : A leadsTo[CC] B & P A B ==> P (Union S) B
   |] ==> P za zb"
apply (unfold leadsETo_def)
apply (drule CollectD)
apply (erule elt.induct, blast+)
done

(** New facts involving leadsETo **)

lemma leadsETo_mono: "CC' <= CC ==> (A leadsTo[CC'] B) <= (A leadsTo[CC] B)"
apply safe
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union)
prefer 2 apply (blast intro: leadsETo_Trans)
apply blast
done

lemma leadsETo_Trans_Un:
     "[| F : A leadsTo[CC] B;  F : B leadsTo[DD] C |]
      ==> F : A leadsTo[CC Un DD] C"
by (blast intro: leadsETo_mono [THEN subsetD] leadsETo_Trans)

lemma leadsETo_Union_Int:
 "(!!A. A : S ==> F : (A Int C) leadsTo[CC] B)
  ==> F : (Union S Int C) leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (simp only: Int_Union_Union)
apply (blast intro: elt.Union)
done

(*Binary union introduction rule*)
lemma leadsETo_Un:
     "[| F : A leadsTo[CC] C; F : B leadsTo[CC] C |]
      ==> F : (A Un B) leadsTo[CC] C"
  using leadsETo_Union [of "{A, B}" F CC C] by auto

lemma single_leadsETo_I:
     "(!!x. x : A ==> F : {x} leadsTo[CC] B) ==> F : A leadsTo[CC] B"
by (subst UN_singleton [symmetric], rule leadsETo_UN, blast)

lemma subset_imp_leadsETo: "A<=B ==> F : A leadsTo[CC] B"
by (simp add: subset_imp_ensures [THEN leadsETo_Basis]
              Diff_eq_empty_iff [THEN iffD2])

lemmas empty_leadsETo = empty_subsetI [THEN subset_imp_leadsETo, simp]

(** Weakening laws **)

lemma leadsETo_weaken_R:
     "[| F : A leadsTo[CC] A';  A'<=B' |] ==> F : A leadsTo[CC] B'"
by (blast intro: subset_imp_leadsETo leadsETo_Trans)

lemma leadsETo_weaken_L:
     "[| F : A leadsTo[CC] A'; B<=A |] ==> F : B leadsTo[CC] A'"
by (blast intro: leadsETo_Trans subset_imp_leadsETo)

(*Distributes over binary unions*)
lemma leadsETo_Un_distrib:
     "F : (A Un B) leadsTo[CC] C  =
      (F : A leadsTo[CC] C & F : B leadsTo[CC] C)"
by (blast intro: leadsETo_Un leadsETo_weaken_L)

lemma leadsETo_UN_distrib:
     "F : (UN i:I. A i) leadsTo[CC] B  =
      (ALL i : I. F : (A i) leadsTo[CC] B)"
by (blast intro: leadsETo_UN leadsETo_weaken_L)

lemma leadsETo_Union_distrib:
     "F : (Union S) leadsTo[CC] B  =  (ALL A : S. F : A leadsTo[CC] B)"
by (blast intro: leadsETo_Union leadsETo_weaken_L)

lemma leadsETo_weaken:
     "[| F : A leadsTo[CC'] A'; B<=A; A'<=B';  CC' <= CC |]
      ==> F : B leadsTo[CC] B'"
apply (drule leadsETo_mono [THEN subsetD], assumption)
apply (blast del: subsetCE
             intro: leadsETo_weaken_R leadsETo_weaken_L leadsETo_Trans)
done

lemma leadsETo_givenBy:
     "[| F : A leadsTo[CC] A';  CC <= givenBy v |]
      ==> F : A leadsTo[givenBy v] A'"
by (blast intro: leadsETo_weaken)

(*Set difference*)
lemma leadsETo_Diff:
     "[| F : (A-B) leadsTo[CC] C; F : B leadsTo[CC] C |]
      ==> F : A leadsTo[CC] C"
by (blast intro: leadsETo_Un leadsETo_weaken)

(*Binary union version*)
lemma leadsETo_Un_Un:
     "[| F : A leadsTo[CC] A';  F : B leadsTo[CC] B' |]
      ==> F : (A Un B) leadsTo[CC] (A' Un B')"
by (blast intro: leadsETo_Un leadsETo_weaken_R)

(** The cancellation law **)

lemma leadsETo_cancel2:
     "[| F : A leadsTo[CC] (A' Un B); F : B leadsTo[CC] B' |]
      ==> F : A leadsTo[CC] (A' Un B')"
by (blast intro: leadsETo_Un_Un subset_imp_leadsETo leadsETo_Trans)

lemma leadsETo_cancel1:
     "[| F : A leadsTo[CC] (B Un A'); F : B leadsTo[CC] B' |]
    ==> F : A leadsTo[CC] (B' Un A')"
apply (simp add: Un_commute)
apply (blast intro!: leadsETo_cancel2)
done

lemma leadsETo_cancel_Diff1:
     "[| F : A leadsTo[CC] (B Un A'); F : (B-A') leadsTo[CC] B' |]
    ==> F : A leadsTo[CC] (B' Un A')"
apply (rule leadsETo_cancel1)
 prefer 2 apply assumption
apply simp_all
done

(** PSP: Progress-Safety-Progress **)

(*Special case of PSP: Misra's "stable conjunction"*)
lemma e_psp_stable:
   "[| F : A leadsTo[CC] A';  F : stable B;  ALL C:CC. C Int B : CC |]
    ==> F : (A Int B) leadsTo[CC] (A' Int B)"
apply (unfold stable_def)
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union_Int)
prefer 2 apply (blast intro: leadsETo_Trans)
apply (rule leadsETo_Basis)
prefer 2 apply (force simp add: Diff_Int_distrib2 [symmetric])
apply (simp add: ensures_def Diff_Int_distrib2 [symmetric]
                 Int_Un_distrib2 [symmetric])
apply (blast intro: transient_strengthen constrains_Int)
done

lemma e_psp_stable2:
     "[| F : A leadsTo[CC] A'; F : stable B;  ALL C:CC. C Int B : CC |]
      ==> F : (B Int A) leadsTo[CC] (B Int A')"
by (simp (no_asm_simp) add: e_psp_stable Int_ac)

lemma e_psp:
     "[| F : A leadsTo[CC] A'; F : B co B';
         ALL C:CC. C Int B Int B' : CC |]
      ==> F : (A Int B') leadsTo[CC] ((A' Int B) Un (B' - B))"
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union_Int)
(*Transitivity case has a delicate argument involving "cancellation"*)
apply (rule_tac [2] leadsETo_Un_duplicate2)
apply (erule_tac [2] leadsETo_cancel_Diff1)
prefer 2
 apply (simp add: Int_Diff Diff_triv)
 apply (blast intro: leadsETo_weaken_L dest: constrains_imp_subset)
(*Basis case*)
apply (rule leadsETo_Basis)
apply (blast intro: psp_ensures)
apply (subgoal_tac "A Int B' - (Ba Int B Un (B' - B)) = (A - Ba) Int B Int B'")
apply auto
done

lemma e_psp2:
     "[| F : A leadsTo[CC] A'; F : B co B';
         ALL C:CC. C Int B Int B' : CC |]
      ==> F : (B' Int A) leadsTo[CC] ((B Int A') Un (B' - B))"
by (simp add: e_psp Int_ac)

(*** Special properties involving the parameter [CC] ***)

(*??IS THIS NEEDED?? or is it just an example of what's provable??*)
lemma gen_leadsETo_imp_Join_leadsETo:
     "[| F: (A leadsTo[givenBy v] B);  G : preserves v;
         F\<squnion>G : stable C |]
      ==> F\<squnion>G : ((C Int A) leadsTo[(%D. C Int D) ` givenBy v] B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (subst Int_Union)
  apply (blast intro: leadsETo_UN)
prefer 2
 apply (blast intro: e_psp_stable2 [THEN leadsETo_weaken_L] leadsETo_Trans)
apply (rule leadsETo_Basis)
apply (auto simp add: Diff_eq_empty_iff [THEN iffD2]
                      Int_Diff ensures_def givenBy_eq_Collect)
prefer 3 apply (blast intro: transient_strengthen)
apply (drule_tac [2] P1 = P in preserves_subset_stable [THEN subsetD])
apply (drule_tac P1 = P in preserves_subset_stable [THEN subsetD])
apply (unfold stable_def)
apply (blast intro: constrains_Int [THEN constrains_weaken])+
done

(**** Relationship with traditional "leadsTo", strong & weak ****)

(** strong **)

lemma leadsETo_subset_leadsTo: "(A leadsTo[CC] B) <= (A leadsTo B)"
apply safe
apply (erule leadsETo_induct)
  prefer 3 apply (blast intro: leadsTo_Union)
 prefer 2 apply (blast intro: leadsTo_Trans, blast)
done

lemma leadsETo_UNIV_eq_leadsTo: "(A leadsTo[UNIV] B) = (A leadsTo B)"
apply safe
apply (erule leadsETo_subset_leadsTo [THEN subsetD])
(*right-to-left case*)
apply (erule leadsTo_induct)
  prefer 3 apply (blast intro: leadsETo_Union)
 prefer 2 apply (blast intro: leadsETo_Trans, blast)
done

(**** weak ****)

lemma LeadsETo_eq_leadsETo:
     "A LeadsTo[CC] B =
        {F. F : (reachable F Int A) leadsTo[(%C. reachable F Int C) ` CC]
        (reachable F Int B)}"
apply (unfold LeadsETo_def)
apply (blast dest: e_psp_stable2 intro: leadsETo_weaken)
done

(*** Introduction rules: Basis, Trans, Union ***)

lemma LeadsETo_Trans:
     "[| F : A LeadsTo[CC] B;  F : B LeadsTo[CC] C |]
      ==> F : A LeadsTo[CC] C"
apply (simp add: LeadsETo_eq_leadsETo)
apply (blast intro: leadsETo_Trans)
done

lemma LeadsETo_Union:
     "(!!A. A : S ==> F : A LeadsTo[CC] B) ==> F : (Union S) LeadsTo[CC] B"
apply (simp add: LeadsETo_def)
apply (subst Int_Union)
apply (blast intro: leadsETo_UN)
done

lemma LeadsETo_UN:
     "(!!i. i : I ==> F : (A i) LeadsTo[CC] B)
      ==> F : (UN i:I. A i) LeadsTo[CC] B"
apply (simp only: Union_image_eq [symmetric])
apply (blast intro: LeadsETo_Union)
done

(*Binary union introduction rule*)
lemma LeadsETo_Un:
     "[| F : A LeadsTo[CC] C; F : B LeadsTo[CC] C |]
      ==> F : (A Un B) LeadsTo[CC] C"
  using LeadsETo_Union [of "{A, B}" F CC C] by auto

(*Lets us look at the starting state*)
lemma single_LeadsETo_I:
     "(!!s. s : A ==> F : {s} LeadsTo[CC] B) ==> F : A LeadsTo[CC] B"
by (subst UN_singleton [symmetric], rule LeadsETo_UN, blast)

lemma subset_imp_LeadsETo:
     "A <= B ==> F : A LeadsTo[CC] B"
apply (simp (no_asm) add: LeadsETo_def)
apply (blast intro: subset_imp_leadsETo)
done

lemmas empty_LeadsETo = empty_subsetI [THEN subset_imp_LeadsETo]

lemma LeadsETo_weaken_R:
     "[| F : A LeadsTo[CC] A';  A' <= B' |] ==> F : A LeadsTo[CC] B'"
apply (simp add: LeadsETo_def)
apply (blast intro: leadsETo_weaken_R)
done

lemma LeadsETo_weaken_L:
     "[| F : A LeadsTo[CC] A';  B <= A |] ==> F : B LeadsTo[CC] A'"
apply (simp add: LeadsETo_def)
apply (blast intro: leadsETo_weaken_L)
done

lemma LeadsETo_weaken:
     "[| F : A LeadsTo[CC'] A';
         B <= A;  A' <= B';  CC' <= CC |]
      ==> F : B LeadsTo[CC] B'"
apply (simp (no_asm_use) add: LeadsETo_def)
apply (blast intro: leadsETo_weaken)
done

lemma LeadsETo_subset_LeadsTo: "(A LeadsTo[CC] B) <= (A LeadsTo B)"
apply (unfold LeadsETo_def LeadsTo_def)
apply (blast intro: leadsETo_subset_leadsTo [THEN subsetD])
done

(*Postcondition can be strengthened to (reachable F Int B) *)
lemma reachable_ensures:
     "F : A ensures B ==> F : (reachable F Int A) ensures B"
apply (rule stable_ensures_Int [THEN ensures_weaken_R], auto)
done

lemma lel_lemma:
     "F : A leadsTo B ==> F : (reachable F Int A) leadsTo[Pow(reachable F)] B"
apply (erule leadsTo_induct)
  apply (blast intro: reachable_ensures)
 apply (blast dest: e_psp_stable2 intro: leadsETo_Trans leadsETo_weaken_L)
apply (subst Int_Union)
apply (blast intro: leadsETo_UN)
done

lemma LeadsETo_UNIV_eq_LeadsTo: "(A LeadsTo[UNIV] B) = (A LeadsTo B)"
apply safe
apply (erule LeadsETo_subset_LeadsTo [THEN subsetD])
(*right-to-left case*)
apply (unfold LeadsETo_def LeadsTo_def)
apply (blast intro: lel_lemma [THEN leadsETo_weaken])
done

(**** EXTEND/PROJECT PROPERTIES ****)

context Extend
begin

lemma givenBy_o_eq_extend_set:
     "givenBy (v o f) = extend_set h ` (givenBy v)"
apply (simp add: givenBy_eq_Collect)
apply (rule equalityI, best)
apply blast
done

lemma givenBy_eq_extend_set: "givenBy f = range (extend_set h)"
by (simp add: givenBy_eq_Collect, best)

lemma extend_set_givenBy_I:
     "D : givenBy v ==> extend_set h D : givenBy (v o f)"
apply (simp (no_asm_use) add: givenBy_eq_all, blast)
done

lemma leadsETo_imp_extend_leadsETo:
     "F : A leadsTo[CC] B
      ==> extend h F : (extend_set h A) leadsTo[extend_set h ` CC]
                       (extend_set h B)"
apply (erule leadsETo_induct)
  apply (force intro: subset_imp_ensures
               simp add: extend_ensures extend_set_Diff_distrib [symmetric])
 apply (blast intro: leadsETo_Trans)
apply (simp add: leadsETo_UN extend_set_Union)
done

(*This version's stronger in the "ensures" precondition
  BUT there's no ensures_weaken_L*)
lemma Join_project_ensures_strong:
     "[| project h C G ~: transient (project_set h C Int (A-B)) |
           project_set h C Int (A - B) = {};
         extend h F\<squnion>G : stable C;
         F\<squnion>project h C G : (project_set h C Int A) ensures B |]
      ==> extend h F\<squnion>G : (C Int extend_set h A) ensures (extend_set h B)"
apply (subst Int_extend_set_lemma [symmetric])
apply (rule Join_project_ensures)
apply (auto simp add: Int_Diff)
done

(*NOT WORKING.  MODIFY AS IN Project.thy
lemma pld_lemma:
     "[| extend h F\<squnion>G : stable C;
         F\<squnion>project h C G : (project_set h C Int A) leadsTo[(%D. project_set h C Int D)`givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G :
            (C Int extend_set h (project_set h C Int A))
            leadsTo[(%D. C Int extend_set h D)`givenBy v]  (extend_set h B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (simp del: UN_simps add: Int_UN_distrib leadsETo_UN extend_set_Union)
 prefer 2
 apply (blast intro: e_psp_stable2 [THEN leadsETo_weaken_L] leadsETo_Trans)
txt{*Base case is hard*}
apply auto
apply (force intro: leadsETo_Basis subset_imp_ensures)
apply (rule leadsETo_Basis)
 prefer 2
 apply (simp add: Int_Diff Int_extend_set_lemma extend_set_Diff_distrib [symmetric])
apply (rule Join_project_ensures_strong)
apply (auto intro: project_stable_project_set simp add: Int_left_absorb)
apply (simp (no_asm_simp) add: stable_ensures_Int [THEN ensures_weaken_R] Int_lower2 project_stable_project_set extend_stable_project_set)
done

lemma project_leadsETo_D_lemma:
     "[| extend h F\<squnion>G : stable C;
         F\<squnion>project h C G :
             (project_set h C Int A)
             leadsTo[(%D. project_set h C Int D)`givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G : (C Int extend_set h A)
            leadsTo[(%D. C Int extend_set h D)`givenBy v] (extend_set h B)"
apply (rule pld_lemma [THEN leadsETo_weaken])
apply (auto simp add: split_extended_all)
done

lemma project_leadsETo_D:
     "[| F\<squnion>project h UNIV G : A leadsTo[givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G : (extend_set h A)
            leadsTo[givenBy (v o f)] (extend_set h B)"
apply (cut_tac project_leadsETo_D_lemma [of _ _ UNIV], auto)
apply (erule leadsETo_givenBy)
apply (rule givenBy_o_eq_extend_set [THEN equalityD2])
done

lemma project_LeadsETo_D:
     "[| F\<squnion>project h (reachable (extend h F\<squnion>G)) G
             : A LeadsTo[givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G :
            (extend_set h A) LeadsTo[givenBy (v o f)] (extend_set h B)"
apply (cut_tac subset_refl [THEN stable_reachable, THEN project_leadsETo_D_lemma])
apply (auto simp add: LeadsETo_def)
 apply (erule leadsETo_mono [THEN [2] rev_subsetD])
 apply (blast intro: extend_set_givenBy_I)
apply (simp add: project_set_reachable_extend_eq [symmetric])
done

lemma extending_leadsETo:
     "(ALL G. extend h F ok G --> G : preserves (v o f))
      ==> extending (%G. UNIV) h F
                (extend_set h A leadsTo[givenBy (v o f)] extend_set h B)
                (A leadsTo[givenBy v] B)"
apply (unfold extending_def)
apply (auto simp add: project_leadsETo_D)
done

lemma extending_LeadsETo:
     "(ALL G. extend h F ok G --> G : preserves (v o f))
      ==> extending (%G. reachable (extend h F\<squnion>G)) h F
                (extend_set h A LeadsTo[givenBy (v o f)] extend_set h B)
                (A LeadsTo[givenBy v]  B)"
apply (unfold extending_def)
apply (blast intro: project_LeadsETo_D)
done
*)

(*** leadsETo in the precondition ***)

(*Lemma for the Trans case*)
lemma pli_lemma:
     "[| extend h F\<squnion>G : stable C;
         F\<squnion>project h C G
           : project_set h C Int project_set h A leadsTo project_set h B |]
      ==> F\<squnion>project h C G
            : project_set h C Int project_set h A leadsTo
              project_set h C Int project_set h B"
apply (rule psp_stable2 [THEN leadsTo_weaken_L])
apply (auto simp add: project_stable_project_set extend_stable_project_set)
done

lemma project_leadsETo_I_lemma:
     "[| extend h F\<squnion>G : stable C;
         extend h F\<squnion>G :
           (C Int A) leadsTo[(%D. C Int D)`givenBy f]  B |]
  ==> F\<squnion>project h C G
    : (project_set h C Int project_set h (C Int A)) leadsTo (project_set h B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (simp only: Int_UN_distrib project_set_Union)
  apply (blast intro: leadsTo_UN)
 prefer 2 apply (blast intro: leadsTo_Trans pli_lemma)
apply (simp add: givenBy_eq_extend_set)
apply (rule leadsTo_Basis)
apply (blast intro: ensures_extend_set_imp_project_ensures)
done

lemma project_leadsETo_I:
     "extend h F\<squnion>G : (extend_set h A) leadsTo[givenBy f] (extend_set h B)
      ==> F\<squnion>project h UNIV G : A leadsTo B"
apply (rule project_leadsETo_I_lemma [THEN leadsTo_weaken], auto)
done

lemma project_LeadsETo_I:
     "extend h F\<squnion>G : (extend_set h A) LeadsTo[givenBy f] (extend_set h B)
      ==> F\<squnion>project h (reachable (extend h F\<squnion>G)) G
           : A LeadsTo B"
apply (simp (no_asm_use) add: LeadsTo_def LeadsETo_def)
apply (rule project_leadsETo_I_lemma [THEN leadsTo_weaken])
apply (auto simp add: project_set_reachable_extend_eq [symmetric])
done

lemma projecting_leadsTo:
     "projecting (%G. UNIV) h F
                 (extend_set h A leadsTo[givenBy f] extend_set h B)
                 (A leadsTo B)"
apply (unfold projecting_def)
apply (force dest: project_leadsETo_I)
done

lemma projecting_LeadsTo:
     "projecting (%G. reachable (extend h F\<squnion>G)) h F
                 (extend_set h A LeadsTo[givenBy f] extend_set h B)
                 (A LeadsTo B)"
apply (unfold projecting_def)
apply (force dest: project_LeadsETo_I)
done

end

end