theory FL_Equivalence_Implies_Bisimilarity
imports
  FL_Logical_Equivalence
begin

section \<open>Logical Equivalence Implies \texorpdfstring{$F/L$}{F/L}-Bisimilarity\<close>

context indexed_effect_nominal_ts
begin

  definition is_distinguishing_formula :: "('idx, 'pred, 'act, 'effect) formula \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool"
    ("_ distinguishes _ from _" [100,100,100] 100)
  where
    "x distinguishes P from Q \<equiv> P \<Turnstile> x \<and> \<not> Q \<Turnstile> x"

  lemma is_distinguishing_formula_eqvt (*[eqvt]*):
    assumes "x distinguishes P from Q" shows "(p \<bullet> x) distinguishes (p \<bullet> P) from (p \<bullet> Q)"
  using assms unfolding is_distinguishing_formula_def
  by (metis permute_minus_cancel(2) FL_valid_eqvt)

  lemma FL_equivalent_iff_not_distinguished:
    "FL_logically_equivalent F P Q \<longleftrightarrow> \<not>(\<exists>x. x \<in> \<A>[F] \<and> x distinguishes P from Q)"
  by (meson FL_logically_equivalent_def Not is_distinguishing_formula_def FL_valid_Not)

  text \<open>There exists a distinguishing formula for~@{term P} and~@{term Q} in~\<open>\<A>[F]\<close> whose
    support is contained in~@{term "supp (F,P)"}.\<close>

  lemma FL_distinguished_bounded_support:
    assumes "x \<in> \<A>[F]" and "x distinguishes P from Q"
    obtains y where "y \<in> \<A>[F]" and "supp y \<subseteq> supp (F,P)" and "y distinguishes P from Q"
  proof -
    let ?B = "{p \<bullet> x|p. supp (F,P) \<sharp>* p}"
    have "supp (F,P) supports ?B"
    unfolding supports_def proof (clarify)
      fix a b
      assume a: "a \<notin> supp (F,P)" and b: "b \<notin> supp (F,P)"
      have "(a \<rightleftharpoons> b) \<bullet> ?B \<subseteq> ?B"
      proof
        fix x'
        assume "x' \<in> (a \<rightleftharpoons> b) \<bullet> ?B"
        then obtain p where 1: "x' = (a \<rightleftharpoons> b) \<bullet> p \<bullet> x" and 2: "supp (F,P) \<sharp>* p"
          by (auto simp add: permute_set_def)
        let ?q = "(a \<rightleftharpoons> b) + p"
        from 1 have "x' = ?q \<bullet> x"
          by simp
        moreover from a and b and 2 have "supp (F,P) \<sharp>* ?q"
          by (metis fresh_perm fresh_star_def fresh_star_plus swap_atom_simps(3))
        ultimately show "x' \<in> ?B" by blast
      qed
      moreover have "?B \<subseteq> (a \<rightleftharpoons> b) \<bullet> ?B"
      proof
        fix x'
        assume "x' \<in> ?B"
        then obtain p where 1: "x' = p \<bullet> x" and 2: "supp (F,P) \<sharp>* p"
          by auto
        let ?q = "(a \<rightleftharpoons> b) + p"
        from 1 have "x' = (a \<rightleftharpoons> b) \<bullet> ?q \<bullet> x"
          by simp
        moreover from a and b and 2 have "supp (F,P) \<sharp>* ?q"
          by (metis fresh_perm fresh_star_def fresh_star_plus swap_atom_simps(3))
        ultimately show "x' \<in> (a \<rightleftharpoons> b) \<bullet> ?B"
          using mem_permute_iff by blast
      qed
      ultimately show "(a \<rightleftharpoons> b) \<bullet> ?B = ?B" ..
    qed
    then have supp_B_subset_supp_P: "supp ?B \<subseteq> supp (F,P)"
      by (metis (erased, lifting) finite_supp supp_is_subset)
    then have finite_supp_B: "finite (supp ?B)"
      using finite_supp rev_finite_subset by blast

    have "?B \<subseteq> (\<lambda>p. p \<bullet> x) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: perm set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: perm set| <o |UNIV :: 'idx set|"
      by (metis card_idx_perm)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally have card_B: "|?B| <o natLeq +c |UNIV :: 'idx set|" .

    let ?y = "Conj (Abs_bset ?B) :: ('idx, 'pred, 'act, 'effect) formula"

    from finite_supp_B and card_B and supp_B_subset_supp_P have "supp ?y \<subseteq> supp (F,P)"
      by simp
    moreover have "?y \<in> \<A>[F]"
      proof
        show "finite (supp (Abs_bset ?B :: (_,_,_,_) formula set['idx]))"
          using finite_supp_B card_B by simp
      next
        fix x'
        assume "x' \<in> set_bset (Abs_bset ?B :: (_,_,_,_) formula set['idx])"
        then obtain p where p_x: "x' = p \<bullet> x" and fresh_p: "supp (F,P) \<sharp>* p"
          using card_B by auto
        from fresh_p have "p \<bullet> F = F"
          using fresh_star_Pair fresh_star_supp_conv perm_supp_eq by blast
        with \<open>x \<in> \<A>[F]\<close> show "x' \<in> \<A>[F]"
          using p_x by (metis is_FL_formula_eqvt)
      qed
    moreover have "?y distinguishes P from Q"
      unfolding is_distinguishing_formula_def proof
        from \<open>x distinguishes P from Q\<close> show "P \<Turnstile> ?y"
          by (auto simp add: card_B finite_supp_B) (metis is_distinguishing_formula_def fresh_star_Un supp_Pair supp_perm_eq FL_valid_eqvt)
      next
        from \<open>x distinguishes P from Q\<close> show "\<not> Q \<Turnstile> ?y"
          by (auto simp add: card_B finite_supp_B) (metis is_distinguishing_formula_def permute_zero fresh_star_zero)
      qed
    ultimately show ?thesis
      using that by blast
  qed

  lemma FL_equivalence_is_L_bisimulation: "is_L_bisimulation FL_logically_equivalent"
  proof -
    {
      fix F have "symp (FL_logically_equivalent F)"
        by (rule sympI) (metis FL_logically_equivalent_def)
    }
    moreover
    {
      fix F P Q f \<phi>
      assume "FL_logically_equivalent F P Q" and "f \<in>\<^sub>f\<^sub>s F" and "\<langle>f\<rangle>P \<turnstile> \<phi>"
      then have "\<langle>f\<rangle>Q \<turnstile> \<phi>"
        by (metis FL_logically_equivalent_def Pred FL_valid_Pred)
    }
    moreover
    {
      fix F P Q f \<alpha> P'
      assume "FL_logically_equivalent F P Q" and "f \<in>\<^sub>f\<^sub>s F" and "bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)" and "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
      then have "\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> FL_logically_equivalent (L (\<alpha>,F,f)) P' Q'"
        proof -
          {
            let ?Q' = "{Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>}"
            assume "\<forall>Q'\<in>?Q'. \<not> FL_logically_equivalent (L (\<alpha>,F,f)) P' Q'"
            then have "\<forall>Q'\<in>?Q'. \<exists>x :: ('idx, 'pred, 'act, 'effect) formula. x \<in> \<A>[L (\<alpha>,F,f)] \<and> x distinguishes P' from Q'"
              by (metis FL_equivalent_iff_not_distinguished)
            then have "\<forall>Q'\<in>?Q'. \<exists>x :: ('idx, 'pred, 'act, 'effect) formula. x \<in> \<A>[L (\<alpha>,F,f)] \<and> supp x \<subseteq> supp (L (\<alpha>,F,f), P') \<and> x distinguishes P' from Q'"
              by (metis FL_distinguished_bounded_support)
            then obtain g :: "'state \<Rightarrow> ('idx, 'pred, 'act, 'effect) formula" where
              *: "\<forall>Q'\<in>?Q'. g Q' \<in> \<A>[L (\<alpha>,F,f)] \<and> supp (g Q') \<subseteq> supp (L (\<alpha>,F,f), P') \<and> (g Q') distinguishes P' from Q'"
              by metis
            have "supp (g ` ?Q') \<subseteq> supp (L (\<alpha>,F,f), P')"
              by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)
            then have finite_supp_image: "finite (supp (g ` ?Q'))"
              using finite_supp rev_finite_subset by blast
            have "|g ` ?Q'| \<le>o |UNIV :: 'state set|"
              by (metis card_of_UNIV card_of_image ordLeq_transitive)
            also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
              by (metis card_idx_state)
            also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
              by (metis Cnotzero_UNIV ordLeq_csum2)
            finally have card_image: "|g ` ?Q'| <o natLeq +c |UNIV :: 'idx set|" .
            let ?y = "Conj (Abs_bset (g ` ?Q')) :: ('idx, 'pred, 'act, 'effect) formula"
            have "Act f \<alpha> ?y \<in> \<A>[F]"
              proof
                from \<open>f \<in>\<^sub>f\<^sub>s F\<close> show "f \<in>\<^sub>f\<^sub>s F" .
              next
                from \<open>bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)\<close> show "bn \<alpha> \<sharp>* (F, f)"
                  using fresh_star_Pair by blast
              next
                show "Conj (Abs_bset (g ` ?Q')) \<in> \<A>[L (\<alpha>, F, f)]"
                  proof
                    show "finite (supp (Abs_bset (g ` ?Q') :: (_,_,_,_) formula set['idx]))"
                      using finite_supp_image card_image by simp
                  next
                    fix x'
                    assume "x' \<in> set_bset (Abs_bset (g ` ?Q') :: (_,_,_,_) formula set['idx])"
                    then obtain Q' where "x' = g Q'" and "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>"
                      using card_image by auto
                    with "*" show "x' \<in> \<A>[L (\<alpha>, F, f)]"
                      using mem_Collect_eq by blast
                  qed
              qed
            moreover have "P \<Turnstile> Act f \<alpha> ?y"
              unfolding FL_valid_Act proof (standard+)
                show "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle>" by fact
              next
                {
                  fix Q'
                  assume "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>"
                  with "*" have "P' \<Turnstile> g Q'"
                    by (metis is_distinguishing_formula_def mem_Collect_eq)
                }
                then show "P' \<Turnstile> ?y"
                  by (simp add: finite_supp_image card_image)
              qed
            moreover have "\<not> Q \<Turnstile> Act f \<alpha> ?y"
              proof
                assume "Q \<Turnstile> Act f \<alpha> ?y"
                then obtain Q' where 1: "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>" and 2: "Q' \<Turnstile> ?y"
                  using \<open>bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)\<close> by (metis fresh_star_Pair FL_valid_Act_fresh)
                from 2 have "\<And>Q''. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q''\<rangle> \<longrightarrow> Q' \<Turnstile> g Q''"
                  by (simp add: finite_supp_image card_image)
                with 1 and "*" show False
                  using is_distinguishing_formula_def by blast
              qed
            ultimately have False
              by (metis \<open>FL_logically_equivalent F P Q\<close> FL_logically_equivalent_def)
          }
          then show ?thesis by auto
        qed
    }
    ultimately show ?thesis
      unfolding is_L_bisimulation_def by metis
  qed

  theorem FL_equivalence_implies_bisimilarity: assumes "FL_logically_equivalent F P Q" shows "P \<sim>\<cdot>[F] Q"
  using assms by (metis FL_bisimilar_def FL_equivalence_is_L_bisimulation)

end

end


theory (*calc_name*)
imports Main (*calc_name_core*) "~~/src/HOL/Library/Multiset" "~~/src/HOL/Library/Code_Char" "~~/src/HOL/Code_Numeral" (*always keep Code_char import last! its added for code generator to output Haskell strings instead of the isabelle nibble stuff *)
begin

(*calc_structure_rules*)

(*This function simply returns the sequent at the root of a proof tree *)
fun concl :: "Prooftree \<Rightarrow> Sequent" where
"concl (a \<Longleftarrow> PT ( b ) c) = a"

datatype ruleder = ruleder      Sequent "Sequent \<Rightarrow> Sequent list option" (infix "\<Longrightarrow>RD" 300) |
                   ruleder_cond "Sequent \<Rightarrow> bool" Sequent "Sequent \<Rightarrow> Sequent list option" ("_ \<Longrightarrow>C _ \<Longrightarrow>RD _" 300)

(*(*uncommentL?Atprop?Formula?Formula_Atprop?Formula_Action_Formula*)
(*This function is an auxillary function which tries to unwrap any Structure_Action_Structure constructors and
will return an Atprop if the structure contains no other constructors otherwise it will return None*)
fun is_act_mod :: "Structure \<Rightarrow> Atprop option" where
"is_act_mod (Structure_Formula (Formula_Atprop p)) = Some p"|
"is_act_mod (Structure_Action_Structure _ _ s) = is_act_mod s"|
"is_act_mod _ = None"

(*The atom function is used by the atom rule. to check that the sequent is of a certain form.*)
fun atom :: "Sequent \<Rightarrow> bool" where
"atom (l \<turnstile>\<^sub>S r) = ( (is_act_mod l) \<noteq> None \<and> (is_act_mod l) = (is_act_mod r) )"|
"atom _ = False"
(*uncommentR?Atprop?Formula?Formula_Atprop?Formula_Action_Formula*)*)

(*(*uncommentL?Action?Action_Freevar?Agent?Agent_Freevar?Formula_Action?Formula_Agent?Sequent_Structure?Sequent*)
(*relAKACheck takes in a an action structure and a list deconstructed parts of a sequent and checks
whether the list contains an Action alpha, Agent a and Action beta that are in the action structure*)

fun relAKACheck :: "(Action \<Rightarrow> Agent => Action list) \<Rightarrow> ((Sequent \<times> Sequent) list) \<Rightarrow> bool" where
"relAKACheck fun mlist = (case List.find ( \<lambda>(x::Sequent \<times> Sequent). fst x = Sequent_Structure (Formula_Action (?\<^sub>Act ''alpha'') \<^sub>S) ) mlist of
                   Some (_, Sequent_Structure (Formula_Action alpha \<^sub>S)) \<Rightarrow>
                      (case List.find ( \<lambda>(x::Sequent \<times> Sequent). fst x = Sequent_Structure(Structure_Formula(Formula_Agent(Agent_Freevar ''a''))) ) mlist of
                         Some (_, Sequent_Structure (Formula_Agent a \<^sub>S)) \<Rightarrow>
                            (case List.find ( \<lambda>(x::Sequent \<times> Sequent). fst x = Sequent_Structure (Formula_Action (?\<^sub>Act ''beta'') \<^sub>S) ) mlist of
                                Some (_, Sequent_Structure (Formula_Action beta \<^sub>S)) \<Rightarrow> (case List.find ( \<lambda>(x::Action). x = beta ) (fun alpha a) of Some res \<Rightarrow> True | None \<Rightarrow> False)
                              |  _ \<Rightarrow> False )
                       | _ \<Rightarrow> False)
                 | _ \<Rightarrow> False)"

fun swapin :: "(Action \<Rightarrow> Agent => Action list) \<Rightarrow> Sequent \<Rightarrow> Sequent \<Rightarrow> bool" where
"swapin fun m s = relAKACheck fun (match m s)"
(*uncommentR?Action?Action_Freevar?Agent?Agent_Freevar?Formula_Action?Formula_Agent?Sequent_Structure?Sequent*)*)

(*(*uncommentL?Structure_Bigcomma*)
(* These are custom rules for the bigcomma *)
fun bigcomma_cons_L :: "Sequent \<Rightarrow> Sequent list option" where
"bigcomma_cons_L ( (B\<^sub>S X (;\<^sub>S) (;;\<^sub>S Xs)) \<turnstile>\<^sub>S Y ) = Some [(;;\<^sub>S (X#Xs) \<turnstile>\<^sub>S Y)]"|
"bigcomma_cons_L _ = None"

fun bigcomma_cons_L2 :: "Sequent \<Rightarrow> Sequent list option" where
"bigcomma_cons_L2 ( ;;\<^sub>S (X#Xs) \<turnstile>\<^sub>S Y ) = Some [((B\<^sub>S X (;\<^sub>S) (;;\<^sub>S Xs)) \<turnstile>\<^sub>S Y)]"|
"bigcomma_cons_L2 _ = None"

fun bigcomma_cons_R :: "Sequent \<Rightarrow> Sequent list option" where
"bigcomma_cons_R ( Y \<turnstile>\<^sub>S (B\<^sub>S X (;\<^sub>S) (;;\<^sub>S Xs)) ) = Some [(Y \<turnstile>\<^sub>S ;;\<^sub>S (X#Xs))]"|
"bigcomma_cons_R _ = None"

fun bigcomma_cons_R2 :: "Sequent \<Rightarrow> Sequent list option" where
"bigcomma_cons_R2 ( Y \<turnstile>\<^sub>S ;;\<^sub>S (X#Xs) ) = Some [(Y \<turnstile>\<^sub>S (B\<^sub>S X (;\<^sub>S) (;;\<^sub>S Xs)))]"|
"bigcomma_cons_R2 _ = None"
(*uncommentR?Structure_Bigcomma*)*)

(*(*uncommentL?RuleSwapout*)
fun swapout_L' :: "Action list \<Rightarrow> Action \<Rightarrow> Agent \<Rightarrow> Structure \<Rightarrow> Structure list \<Rightarrow> Sequent list option" where
"swapout_L' [] alpha a X [] = Some ([])" |
"swapout_L' (beta#actionList) alpha a X [] = None" |
"swapout_L' [] alpha a X (Y # Ys) = None" |
"swapout_L' (beta#actionList) alpha a X (Y # Ys) = (case swapout_L' actionList alpha a X Ys of
   Some list \<Rightarrow> Some ((AgS\<^sub>S forwK\<^sub>S a ActS\<^sub>S forwA\<^sub>S beta X \<turnstile>\<^sub>S Y) #list) | None \<Rightarrow> None )"

fun swapout_L :: "(Action \<Rightarrow> Agent => Action list) \<Rightarrow> Sequent \<Rightarrow> Sequent list option" where
"swapout_L relAKA ( ActS\<^sub>S forwA\<^sub>S alpha (AgS\<^sub>S forwK\<^sub>S a X ) \<turnstile>\<^sub>S ;;\<^sub>S list ) = swapout_L' (relAKA alpha a) alpha a X list" |
"swapout_L _ _ = None"

fun swapout_R' :: "Action list \<Rightarrow> Action \<Rightarrow> Agent \<Rightarrow> Structure \<Rightarrow> Structure list \<Rightarrow> Sequent list option" where
"swapout_R' [] alpha a X [] = Some ([])" |
"swapout_R' (beta#actionList) alpha a X [] = None" |
"swapout_R' [] alpha a X (Y # Ys) = None" |
"swapout_R' (beta#actionList) alpha a X (Y # Ys) = (case swapout_R' actionList alpha a X Ys of
   Some list \<Rightarrow> Some ((Y \<turnstile>\<^sub>S AgS\<^sub>S forwK\<^sub>S a ActS\<^sub>S forwA\<^sub>S beta X) #list) | None \<Rightarrow> None )"

fun swapout_R :: "(Action \<Rightarrow> Agent => Action list) \<Rightarrow> Sequent \<Rightarrow> Sequent list option" where
"swapout_R relAKA ( ;;\<^sub>S list \<turnstile>\<^sub>S ActS\<^sub>S forwA\<^sub>S alpha (AgS\<^sub>S forwK\<^sub>S a X ) ) = swapout_R' (relAKA alpha a) alpha a X list" |
"swapout_R _ _ = None"
(*uncommentR?RuleSwapout*)*)

(*(*uncommentL?Pre_L*)
fun pre_l :: "Action \<Rightarrow> Sequent \<Rightarrow> bool" where
"pre_l a ((One\<^sub>F alpha)\<^sub>S \<turnstile>\<^sub>S X) = (a = alpha)"|
"pre_l a _ = False"
(*uncommentR?Pre_L*)*)

(*(*uncommentL?Pre_R*)
fun pre_r :: "Action \<Rightarrow> Sequent \<Rightarrow> bool" where
"pre_r a (X \<turnstile>\<^sub>S (One\<^sub>F alpha)\<^sub>S) = (a = alpha)"|
"pre_r a _ = False"
(*uncommentR?Pre_R*)*)

datatype Locale = (*(*uncommentL?Formula?RuleCut*)
                  CutFormula Formula |
                  (*uncommentR?Formula?RuleCut*)*)
                  (*(*uncommentL?Sequent*)
                  Premise Sequent |
                  (*uncommentR?Sequent*)*)
                  (*(*uncommentL?Structure*)
                  Part Structure |
                  (*uncommentR?Structure*)*)
                  (*(*uncommentL?Action?Agent*)
                  RelAKA "Action \<Rightarrow> Agent \<Rightarrow> Action list" |
                  (*uncommentR?Action?Agent*)*)
                  (*(*uncommentL?Action?Formula*)
                  PreFormula Action Formula |
                  (*uncommentR?Action?Formula*)*)
                  (*(*uncommentL?Agent*)
                  LAgent Agent |
                  (*uncommentR?Agent*)*)
                  Empty

(*rules_rule_fun*)

fun fst :: "ruleder \<Rightarrow> Sequent" and snd :: "ruleder \<Rightarrow> Sequent \<Rightarrow> Sequent list option" and cond :: "ruleder \<Rightarrow> (Sequent \<Rightarrow> bool) option" where
"fst (ruleder x _) = x" |
"fst (ruleder_cond _ x _) = x" |
"snd (ruleder _ y) = y" |
"snd (ruleder_cond _ _ y) = y" |
"cond (ruleder_cond c _ _) = Some c" |
"cond (ruleder _ _) = None"

fun der :: "Locale \<Rightarrow> Rule \<Rightarrow> Sequent \<Rightarrow> (Rule * Sequent list)"
where
"der l r s =( case (snd (rule l r)) s of
                None \<Rightarrow> (Fail, [])
              | Some conclusion \<Rightarrow>
                  if (ruleMatch (fst (rule l r)) s) then
                    case cond (rule l r) of
                      None \<Rightarrow> ( r, map (replaceAll (match (fst (rule l r)) s) ) conclusion )
                    | Some condition \<Rightarrow> ( if condition s
                        then (r, map (replaceAll (match (fst (rule l r)) s) ) conclusion )
                        else (Fail, []) )
                  else (Fail, []) )"

primrec ant :: "Sequent \<Rightarrow> Structure" where
"ant (Sequent x y) = x" |
"ant (Sequent_Structure x) = x"
primrec consq :: "Sequent \<Rightarrow> Structure" where
"consq (Sequent x y) = y"|
"consq (Sequent_Structure x) = x"

(*collectPremises returns all the leaves of a prooftree where the Prem rule has been applied *)
fun collectPremises :: "Prooftree \<Rightarrow> Sequent list" where
"collectPremises (Prooftree p (RuleZer Prem) []) = [p]" |
"collectPremises (Prooftree _ (RuleMacro _ pt) list) = foldr append (map collectPremises list) []" |
"collectPremises (Prooftree _ _ list) = foldr append (map collectPremises list) []"

fun collectPremisesToLocale :: "Prooftree \<Rightarrow> Locale list" where
"collectPremisesToLocale pt = map Premise (collectPremises pt)"

(*collectCutFormulas returns all cut formulas used in a prooftree,
by checking for a matching branch on the left and the right hand side of the turnstyle of the two leaves *)

fun collectCutFormulas :: "Prooftree \<Rightarrow> Formula list" where
"collectCutFormulas (Prooftree _ (RuleCut _) [l, r]) = (
  (case (consq (concl l)) of (Structure_Formula f) \<Rightarrow> (case (ant (concl r)) of (Structure_Formula f') \<Rightarrow> (if f = f' then [f] @ (collectCutFormulas l) @ (collectCutFormulas r) else (collectCutFormulas l) @ (collectCutFormulas r)) |  _ \<Rightarrow> (collectCutFormulas l) @ (collectCutFormulas r) ) |
    _ \<Rightarrow> (case (consq (concl r)) of (Structure_Formula f) \<Rightarrow> (case (ant (concl l)) of (Structure_Formula f') \<Rightarrow> (if f = f' then [f] @ (collectCutFormulas l) @ (collectCutFormulas r) else (collectCutFormulas l) @ (collectCutFormulas r)) |  _ \<Rightarrow> (collectCutFormulas l) @ (collectCutFormulas r)))
  )
)" |
"collectCutFormulas (Prooftree _ (RuleMacro _ pt) list) = foldr append (map collectCutFormulas list) (collectCutFormulas pt)" |
"collectCutFormulas (Prooftree _ _ list) = foldr append (map collectCutFormulas list) []"

fun collectCutFormulasToLocale :: "Prooftree \<Rightarrow> Locale list" where
"collectCutFormulasToLocale pt = map CutFormula (collectCutFormulas pt)"

fun isProofTree :: "Locale list \<Rightarrow> Prooftree \<Rightarrow> bool" where
"isProofTree loc (s \<Longleftarrow> PT(RuleMacro n pt) ptlist) = (
  s = (concl pt) \<and>
  isProofTree (append loc (collectPremisesToLocale pt)) pt \<and>
  set (collectPremises pt) = set (map concl ptlist) \<and>
  foldr (op \<and>) (map (isProofTree loc) ptlist) True
)"|
"isProofTree loc (s \<Longleftarrow> PT(r) l) = (
  foldr (op \<and>) (map (isProofTree loc) l) True \<and>
  foldr (op \<or>) (map (\<lambda>x. (
    set (Product_Type.snd (der x r s)) = set (map concl l) \<and>
    Fail \<noteq> Product_Type.fst (der x r s)
  )) loc) False
)"

fun isProofTreeWoMacro :: "Locale list \<Rightarrow> Prooftree \<Rightarrow> bool" where
"isProofTreeWoMacro loc (s \<Longleftarrow> PT(RuleMacro n pt) ptlist) = False"|
"isProofTreeWoMacro loc (s \<Longleftarrow> PT(r) l) = (
  foldr (op \<and>) (map (isProofTreeWoMacro loc) l) True \<and>
  foldr (op \<or>) (map (\<lambda>x. (
    set (Product_Type.snd (der x r s)) = set (map concl l) \<and>
    Fail \<noteq> Product_Type.fst (der x r s)
  )) loc) False
)"

fun isProofTreeWithCut :: "Locale list \<Rightarrow> Prooftree \<Rightarrow> bool" where
"isProofTreeWithCut loc pt = isProofTree (append loc (collectCutFormulasToLocale pt)) pt"

definition "ruleList = (*rules_rule_list*)"

lemma Atprop_without_Freevar[simp]: "\<And>a. freevars a = {} \<Longrightarrow> \<exists>q. a = Atprop q"
  by (metis Atprop.exhaust freevars_Atprop.simps(1) insert_not_empty)

(* The rulify_ definitions are used for creating macros in the UI,
by turning a proof tree of concrete terms into a proof tree containing free variables.
This is done by converting every leaf of a Sequent into a Freevar term of the highest level of that term
(i.e. if a sequent contains an atprop it it will be turned into a sequent freevar). *)

(*(*uncommentL?Agent?Agent_Freevar*)
primrec rulifyAgent :: "Agent \<Rightarrow> Agent" where
"rulifyAgent (Agent a) = Agent_Freevar a" |
"rulifyAgent (Agent_Freevar a) = Agent_Freevar a"
(*uncommentR?Agent?Agent_Freevar*)*)

(*(*uncommentL?Action?Action_Freevar*)
primrec rulifyAction :: "Action \<Rightarrow> Action" where
"rulifyAction (Action a) = Action_Freevar a" |
"rulifyAction (Action_Freevar a) = Action_Freevar a"
(*uncommentR?Action?Action_Freevar*)*)

(*(*uncommentL?Formula*)
fun rulifyFormula :: "Formula \<Rightarrow> Formula" where
(*(*uncommentL?Formula_Atprop*)
"rulifyFormula (Formula_Atprop(Atprop (f#a))) =
(if CHR ''A'' \<le> f \<and> f \<le> CHR ''Z'' then (Formula_Freevar (f#a)) else (Formula_Atprop (Atprop_Freevar (f#a)))
)" |
(*uncommentR?Formula_Atprop*)*)
(*(*uncommentL?Formula_Un*)
"rulifyFormula (Formula_Un c y) = (Formula_Un c (rulifyFormula y))" |
(*uncommentR?Formula_Un*)*)
(*uncommentR?Formula_Bin*)*)
(*(*uncommentL?Formula_Bin*)
"rulifyFormula (Formula_Bin x c y) = (Formula_Bin (rulifyFormula x) c (rulifyFormula y))" |
(*uncommentR?Formula_Bin*)*)
(*(*uncommentL?Formula_Agent_Formula*)
"rulifyFormula (Formula_Agent_Formula c a x) = (Formula_Agent_Formula c (rulifyAgent a) (rulifyFormula x) )" |
(*uncommentR?Formula_Agent_Formula*)*)
(*(*uncommentL?Formula_Action_Formula*)
"rulifyFormula (Formula_Action_Formula c a x) = (Formula_Action_Formula c (rulifyAction a) (rulifyFormula x) )" |
(*uncommentR?Formula_Action_Formula*)*)
(*(*uncommentL?Formula_Precondition*)
"rulifyFormula (Formula_Precondition a) = (Formula_Precondition (rulifyAction a))" |
(*uncommentR?Formula_Precondition*)*)
"rulifyFormula x = x"
(*uncommentR?Formula*)*)

(*(*uncommentL?Structure*)
(*if the leaf is a formula with a name beginning with 'F',
the term will be turned into a Formula_Freevar, else it will become a Structure_Freevar*)

fun rulifyStructure :: "Structure \<Rightarrow> Structure" where
(*(*uncommentL?Structure_Formula?Formula_Atprop*)
"rulifyStructure (Structure_Formula (Formula_Atprop(Atprop (f#a)))) =
(if CHR ''A'' \<le> f \<and> f \<le> CHR ''Z'' then (
  if f = CHR ''F'' then Structure_Formula (Formula_Freevar (f#a)) else Structure_Freevar (f#a)
  ) else Structure_Formula (Formula_Atprop (Atprop_Freevar (f#a)))
)" |
(*uncommentR?Structure_Formula?Formula_Atprop*)*)
(*(*uncommentL?Structure_Formula*)
"rulifyStructure (Structure_Formula x) = Structure_Formula (rulifyFormula x)" |
(*uncommentR?Structure_Formula*)*)
(*(*uncommentL?Structure_Bin*)
"rulifyStructure (Structure_Bin x c y) = (Structure_Bin (rulifyStructure x) c (rulifyStructure y))" |
(*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Agent_Structure*)
"rulifyStructure (Structure_Agent_Structure c a x) = (Structure_Agent_Structure c (rulifyAgent a) (rulifyStructure x) )" |
(*uncommentR?Structure_Agent_Structure*)*)
(*(*uncommentL?Structure_Action_Structure*)
"rulifyStructure (Structure_Action_Structure c a x) = (Structure_Action_Structure c (rulifyAction a) (rulifyStructure x) )" |
(*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Bigcomma*)
"rulifyStructure (Structure_Bigcomma list) = (Structure_Bigcomma (map rulifyStructure list))" |
(*uncommentR?Structure_Bigcomma*)*)
(*(*uncommentL?Structure_Phi*)
"rulifyStructure (Structure_Phi a) = (Structure_Phi (rulifyAction a))" |
(*uncommentR?Structure_Phi*)*)
"rulifyStructure x = x"
(*uncommentR?Structure*)*)

(*(*uncommentL?Sequent*)
primrec rulifySequent :: "Sequent \<Rightarrow> Sequent" where
"rulifySequent (Sequent x y) = Sequent (rulifyStructure x) (rulifyStructure y)"|
"rulifySequent (Sequent_Structure x) = (Sequent_Structure x)"
(*uncommentR?Sequent*)*)

fun rulifyProoftree :: "Prooftree \<Rightarrow> Prooftree" where
"rulifyProoftree (Prooftree s (RuleMacro str pt) list) = Prooftree (rulifySequent s) (RuleMacro str (rulifyProoftree pt)) (map rulifyProoftree list)" |
"rulifyProoftree (Prooftree s r list) = (Prooftree (rulifySequent s) r (map rulifyProoftree list))"

(*This function is used to replace any freevar terms in a sequent by a given term, but does this throughout a whole prooftree.
The function is used when applying a macro, where the freevars are substituted by concrete terms of the sequent that the macro is being used on *)

fun replaceSequentIntoPT_aux :: "(Sequent \<times> Sequent) list \<Rightarrow> Prooftree \<Rightarrow> Prooftree" and
  replaceSequentIntoPT_list :: "(Sequent \<times> Sequent) list \<Rightarrow> Prooftree list \<Rightarrow> Prooftree list" where
"replaceSequentIntoPT_aux list (Prooftree c (RuleMacro s pt) ptlist) = Prooftree (replaceAll list c) (RuleMacro s (replaceSequentIntoPT_aux list pt)) (replaceSequentIntoPT_list list ptlist)" |
"replaceSequentIntoPT_aux list (Prooftree c r ptlist) = Prooftree (replaceAll list c) r (replaceSequentIntoPT_list list ptlist)" |
"replaceSequentIntoPT_list list [] = []" |
"replaceSequentIntoPT_list list (l#ist) = (replaceSequentIntoPT_aux list l)#(replaceSequentIntoPT_list list ist)"

fun replaceSequentIntoPT :: "Sequent \<Rightarrow> Prooftree \<Rightarrow> Prooftree" where
"replaceSequentIntoPT seq (Prooftree c r ptlist) = replaceSequentIntoPT_aux (match c seq) (Prooftree c r ptlist)"

(* The following two functions are used to turn a pt containing macros into a one which doesnt, by merging any proof trees found in RulMacro into the main pt*)
fun replacePTIntoPT :: "Prooftree list \<Rightarrow> Prooftree \<Rightarrow> Prooftree"  where
"replacePTIntoPT [] (Prooftree s (RuleZer Prem) []) = (Prooftree s (RuleZer Prem) [])" |
"replacePTIntoPT (l#ist) (Prooftree s (RuleZer Prem) []) = (if (concl l) = s then l else replacePTIntoPT ist (Prooftree s (RuleZer Prem) []))" |
"replacePTIntoPT list (Prooftree s r []) =  (Prooftree s r [])" |
"replacePTIntoPT list (Prooftree s r l) =  (Prooftree s r (map (replacePTIntoPT list) l))"

fun expandProoftree :: "Prooftree \<Rightarrow> Prooftree"  where
"expandProoftree (Prooftree _ (RuleMacro n (Prooftree s r l)) list) = (Prooftree s r (map (replacePTIntoPT (map expandProoftree list)) (map expandProoftree l)))" |
"expandProoftree (Prooftree s r list) = Prooftree s r (map expandProoftree list)"

(* collect_freevars_Structure and collect_freevars_Sequent are used to analyze the shape of a rule by the is_display_rule function *)
fun collect_freevars_Structure :: "Structure \<Rightarrow> Structure list" where
(*(*uncommentL?Structure_Formula*)  "collect_freevars_Structure (Structure_Formula f) = [Structure_Formula f]" (*uncommentR?Structure_Formula*)*)
(*(*uncommentL?Structure_Bin*) | "collect_freevars_Structure (Structure_Bin l _ r) = (collect_freevars_Structure l) @ (collect_freevars_Structure r)" (*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Freevar*) | "collect_freevars_Structure (Structure_Freevar free) = [Structure_Freevar free]" (*uncommentR?Structure_Freevar*)*)
(*(*uncommentL?Structure_Action_Structure*) | "collect_freevars_Structure (Structure_Action_Structure oper ac struct) = [Structure_Formula (Formula_Action ac)] @ (collect_freevars_Structure struct)" (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) | "collect_freevars_Structure (Structure_Agent_Structure oper ag struct) = [Structure_Formula (Formula_Agent ag)] @ (collect_freevars_Structure struct)" (*uncommentR?Structure_Agent_Structure*)*)
(*(*uncommentL?Structure_Phi*) | "collect_freevars_Structure (Structure_Phi a) = [Structure_Phi a]"  (*uncommentR?Structure_Phi*)*)
(*(*uncommentL?Structure_Zer*) | "collect_freevars_Structure (Structure_Zer z) = [Structure_Zer z]" (*uncommentR?Structure_Zer*)*)
(*(*uncommentL?Structure_Bigcomma*) | "collect_freevars_Structure (Structure_Bigcomma list) = foldr (op @) (map collect_freevars_Structure list) []" (*uncommentR?Structure_Bigcomma*)*)

fun collect_freevars_Sequent :: "Sequent \<Rightarrow> Structure list" where
"collect_freevars_Sequent (Sequent l r) = (collect_freevars_Structure l) @ (collect_freevars_Structure r)" |
"collect_freevars_Sequent (Sequent_Structure _) = []"

fun is_display_rule :: "Rule \<Rightarrow> Rule list" where
"is_display_rule r =
(if (case (snd (rule Empty r) (fst (rule Empty r)) ) of Some list \<Rightarrow>
  (case list of h#rest \<Rightarrow>
  mset (collect_freevars_Sequent (fst (rule Empty r))) =
  mset (collect_freevars_Sequent h ) | _ \<Rightarrow> False ) | _ \<Rightarrow> False )
then [r]
else [])"

definition displayRules :: "Rule list" where
"displayRules = foldr (op @) (map is_display_rule ruleList) []"

(* The following definitions are used for the display_tac in the GUI *)

datatype polarity = Plus ("+p") | Minus ("-p") | N

fun polarity_weird_xor :: "polarity \<Rightarrow> polarity \<Rightarrow> polarity" (infix "\<or>p" 400) where
"polarity_weird_xor +p N = +p" |
"polarity_weird_xor -p N = -p" |
"polarity_weird_xor N x = x" |
"polarity_weird_xor +p _ = N" |
"polarity_weird_xor -p _ = N"

fun polarity_not :: "polarity \<Rightarrow> polarity" ( "\<not>p _") where
"polarity_not -p = +p" |
"polarity_not +p = -p" |
"polarity_not N = N"

fun polarity_weird_and :: "polarity \<Rightarrow> polarity \<Rightarrow> polarity" (infix "\<and>p" 400) where
"polarity_weird_and -p x = \<not>p x" |
"polarity_weird_and +p x = x" |
"polarity_weird_and N _ = N"

lemma polarity_weird_xor_comm: "a \<or>p b = b \<or>p a"
apply (cases a, (cases b, auto)+)
done

lemma polarity_weird_and_comm: "a \<and>p b = b \<and>p a"
apply (cases a, (cases b, auto)+)
done

(*this function defines the polarity of the different structural connectives in the display calculus*)
fun structure_Op_polarity :: "Structure_Bin_Op \<Rightarrow> (polarity \<times> polarity)" where
(*(*uncommentL?Structure_Comma*)
   "structure_Op_polarity Structure_Comma = (+p, +p)"
(*uncommentR?Structure_Comma*)*)
(*(*uncommentL?Structure_ImpL*)
 | "structure_Op_polarity Structure_ImpL = (+p, -p)"
(*uncommentR?Structure_ImpL*)*)
(*(*uncommentL?Structure_ImpR*)
 | "structure_Op_polarity Structure_ImpR = (-p, +p)"
(*uncommentR?Structure_ImpR*)*)

(*we assume the structure appears in the sequent exactly once*)
fun polarity_Structure :: "Structure \<Rightarrow> Structure \<Rightarrow> polarity" where
(*(*uncommentL?Structure_Bin*)
"polarity_Structure s (Structure_Bin l oper r) = (
  if l = s then prod.fst (structure_Op_polarity oper)
  else if r = s then prod.snd (structure_Op_polarity oper)
  else ((prod.fst (structure_Op_polarity oper)) \<and>p (polarity_Structure s l)) \<or>p ((prod.snd (structure_Op_polarity oper)) \<and>p (polarity_Structure s r)) )" |
(*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Action_Structure*) "polarity_Structure s (Structure_Action_Structure oper ac struct) = (polarity_Structure s struct)" | (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) "polarity_Structure s (Structure_Agent_Structure oper ag struct) = (polarity_Structure s struct)" | (*uncommentR?Structure_Agent_Structure*)*)
"polarity_Structure s x = (if s = x then +p else N)"

fun polarity_Sequent :: "Structure \<Rightarrow> Sequent \<Rightarrow> polarity" where
"polarity_Sequent s (Sequent lhs rhs) = (\<not>p(polarity_Structure s lhs)) \<or>p (polarity_Structure s rhs)" |
"polarity_Sequent s _ = N"

(*given a structure s we want to isolate and another structure s', where s is a subterm of s',
this function will return a subterm of s' which has had the top most constructor removed.
ie if s' = A ; Forw x B and s = B, partial_goal will return Forw x B*)
fun partial_goal :: "Structure \<Rightarrow> Structure \<Rightarrow> Structure" where
(*(*uncommentL?Structure_Bin*)
"partial_goal s (Structure_Bin l oper r) = (case (polarity_Structure s l) of N \<Rightarrow> (if s = l then l else r) | _ \<Rightarrow> l)" |
(*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Action_Structure*) "partial_goal s (Structure_Action_Structure oper ac struct) = struct" | (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) "partial_goal s (Structure_Agent_Structure oper ag struct) = struct" | (*uncommentR?Structure_Agent_Structure*)*)
"partial_goal s x = x"

fun partial_goal_complement :: "Structure \<Rightarrow> Structure \<Rightarrow> Structure" where
(*(*uncommentL?Structure_Bin*)
"partial_goal_complement s (Structure_Bin l oper r) = (case (polarity_Structure s l) of N \<Rightarrow> (if s = l then r else l) | _ \<Rightarrow> r)" |
(*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Action_Structure*) "partial_goal_complement s (Structure_Action_Structure oper ac struct) = struct" | (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) "partial_goal_complement s (Structure_Agent_Structure oper ag struct) = struct" | (*uncommentR?Structure_Agent_Structure*)*)
"partial_goal_complement s x = x"

lemma partial_goal:
  fixes oper x y s
  shows "((partial_goal s (Structure_Bin x oper y)) = x) \<or> (partial_goal s (Structure_Bin x oper y)) = y"
proof auto
assume "s = x" "(case polarity_Structure x x of +p \<Rightarrow> x | _ \<Rightarrow> x) \<noteq> y"
then show "(case polarity_Structure x x of +p \<Rightarrow> x | _ \<Rightarrow> x) = x" by (metis polarity.exhaust polarity.simps(7) polarity.simps(8) polarity.simps(9))
next
assume "s \<noteq> x" "(case polarity_Structure s x of N \<Rightarrow> y | _ \<Rightarrow> x) \<noteq> y"
then show "(case polarity_Structure s x of N \<Rightarrow> y | _ \<Rightarrow> x) = x" by (metis polarity.exhaust polarity.simps(7) polarity.simps(8) polarity.simps(9))
qed

lemma partial_goal_complement:
  fixes oper x y s
  shows "((partial_goal_complement s (Structure_Bin x oper y)) = x) \<or> (partial_goal_complement s (Structure_Bin x oper y)) = y"
proof auto
assume "s = x" "(case polarity_Structure x x of +p \<Rightarrow> y | _ \<Rightarrow> y) \<noteq> y"
then show "(case polarity_Structure x x of +p \<Rightarrow> y | _ \<Rightarrow> y) = x"
  by (metis polarity.exhaust polarity.simps(7) polarity.simps(8) polarity.simps(9))
next
assume "s \<noteq> x" "(case polarity_Structure s x of N \<Rightarrow> x | _ \<Rightarrow> y) \<noteq> y"
then show "(case polarity_Structure s x of N \<Rightarrow> x | _ \<Rightarrow> y) = x" by (metis polarity.exhaust polarity.simps(7) polarity.simps(8) polarity.simps(9))
qed

lemma partial_goal_and_complement:
  fixes oper x y s
  defines "struct \<equiv> Structure_Bin x oper y"
  shows "( (partial_goal s struct) = x \<and> (partial_goal_complement s struct) = y ) \<or>
         ( (partial_goal_complement s struct) = x \<and> (partial_goal s struct) = y )"
using struct_def
apply auto
apply (metis polarity.exhaust polarity.simps(7) polarity.simps(8) polarity.simps(9))+
done

(*checks the polarity of a structure inside a sequent*)
fun position_in_Sequent :: "Structure \<Rightarrow> Sequent \<Rightarrow> polarity" where
"position_in_Sequent s (Sequent l r) = (
  if s = l then -p
  else if (polarity_Structure s l) \<noteq> N then -p
  else if s = r then +p
  else if (polarity_Structure s r) \<noteq> N then +p
  else N )" |
"position_in_Sequent s _ = N"

(*the following functions are used to create fresh names for an atprop, given a sequent.
These functions are used by the ui for the display_tac tactic*)
fun fresh_name_aux :: "string list \<Rightarrow> string \<Rightarrow> string set \<Rightarrow> string" where
"fresh_name_aux [] s _ = s" |
"fresh_name_aux (x#xs) s full = (if (s@x) \<notin> full then s@x else (fresh_name_aux xs (s@x) full) )"

definition fresh_name :: "string list \<Rightarrow> string" where
"fresh_name list = fresh_name_aux list ''X'' (set list)"

fun collect_SFAtprop_names :: "Structure \<Rightarrow> string list" where
(*(*uncommentL?Structure_Formula?Formula_Atprop?Atprop*)  "collect_SFAtprop_names (Structure_Formula (Formula_Atprop (Atprop x))) = [x]" |(*uncommentR?Structure_Formula?Formula_Atprop?Atprop*)*)
(*(*uncommentL?Structure_Bin*) "collect_SFAtprop_names (Structure_Bin l oper r) = (collect_SFAtprop_names l) @ (collect_SFAtprop_names r)" | (*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Action_Structure*) "collect_SFAtprop_names (Structure_Action_Structure oper ac struct) = collect_SFAtprop_names struct" | (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) "collect_SFAtprop_names (Structure_Agent_Structure oper ag struct) = collect_SFAtprop_names struct" | (*uncommentR?Structure_Agent_Structure*)*)
"collect_SFAtprop_names s = []"

fun replace_SFAtprop_into_Structure :: "Structure \<Rightarrow> Structure \<Rightarrow> Structure \<Rightarrow> Structure" where
(*(*uncommentL?Structure_Bin*) "replace_SFAtprop_into_Structure sfa repl (Structure_Bin l oper r) = Structure_Bin (replace_SFAtprop_into_Structure sfa repl l) oper (replace_SFAtprop_into_Structure sfa repl r)" | (*uncommentR?Structure_Bin*)*)
(*(*uncommentL?Structure_Action_Structure*) "replace_SFAtprop_into_Structure sfa repl (Structure_Action_Structure oper ac struct) = Structure_Action_Structure oper ac (replace_SFAtprop_into_Structure sfa repl struct)" | (*uncommentR?Structure_Action_Structure*)*)
(*(*uncommentL?Structure_Agent_Structure*) "replace_SFAtprop_into_Structure sfa repl (Structure_Agent_Structure oper ag struct) = Structure_Agent_Structure oper ag (replace_SFAtprop_into_Structure sfa repl struct)" | (*uncommentR?Structure_Agent_Structure*)*)
"replace_SFAtprop_into_Structure sfa repl s = (if sfa = s then repl else s)"

fun replace_SFAtprop_into_Sequent :: "Structure \<Rightarrow> Structure \<Rightarrow> Sequent \<Rightarrow> Sequent" where
"replace_SFAtprop_into_Sequent sfa repl (Sequent l r) = Sequent (replace_SFAtprop_into_Structure sfa repl l) (replace_SFAtprop_into_Structure sfa repl r)" |
"replace_SFAtprop_into_Sequent sfa relp x = x"

fun replace_SFAtprop_into_PT :: "Structure \<Rightarrow> Structure \<Rightarrow> Prooftree \<Rightarrow> Prooftree" where
"replace_SFAtprop_into_PT sfa repl (Prooftree s r list) = (Prooftree (replace_SFAtprop_into_Sequent sfa repl s) r (map (replace_SFAtprop_into_PT sfa repl) list))"

fun sequent_fresh_name :: "Sequent \<Rightarrow> Structure" where
"sequent_fresh_name (Sequent l r) = (Structure_Formula (Formula_Atprop (Atprop (fresh_name ((collect_SFAtprop_names l)@(collect_SFAtprop_names r)) ))))" |
"sequent_fresh_name _ = (Structure_Formula (Formula_Atprop (Atprop ''X'')))"

export_code open der isProofTree ruleList displayRules ant consq rulifyProoftree replaceSequentIntoPT isProofTreeWithCut
expandProoftree polarity_Sequent position_in_Sequent partial_goal partial_goal_complement sequent_fresh_name replace_SFAtprop_into_PT in Scala
module_name (*calc_name*) file (*export_path*)
end


theory Regular_Relation_Impl
  imports Tree_Automata_Impl
    Regular_Relation_Abstract_Impl
    Horn_Fset
begin

section \<open>Computing the epsilon transitions for the composition of GTT's\<close>

definition \<Delta>\<^sub>\<epsilon>_infer0_cont where
  "\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B =
    (let arules = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>\<^sub>A) in
     let brules = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>\<^sub>B) in
    (map (map_prod r_rhs r_rhs) (filter (\<lambda>(ra, rb). r_root ra = r_root rb) (List.product arules brules))))"

definition \<Delta>\<^sub>\<epsilon>_infer1_cont where
  "\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
   (let (arules, aeps) = (sorted_list_of_fset \<Delta>\<^sub>A, sorted_list_of_fset \<Delta>\<^sub>A\<^sub>\<epsilon>) in
    let (brules, beps) = (sorted_list_of_fset \<Delta>\<^sub>B, sorted_list_of_fset \<Delta>\<^sub>B\<^sub>\<epsilon>) in
    let prules = List.product arules brules in
   (\<lambda> pq bs.
      map (map_prod r_rhs r_rhs) (filter (\<lambda>(ra, rb). case (ra, rb) of (TA_rule f ps p, TA_rule g qs q) \<Rightarrow>
        f = g \<and> length ps = length qs \<and> (fst pq, snd pq) \<in> set (zip ps qs) \<and>
        set (zip ps qs) \<subseteq> insert (fst pq, snd pq) (fset bs)) prules) @
      map (\<lambda>(p, p'). (p', snd pq)) (filter (\<lambda>(p, p') \<Rightarrow> p = fst pq) aeps) @
      map (\<lambda>(q, q'). (fst pq, q')) (filter (\<lambda>(q, q') \<Rightarrow> q = snd pq) beps)))"

locale \<Delta>\<^sub>\<epsilon>_fset =
  fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
    and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin

abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"

sublocale \<Delta>\<^sub>\<epsilon>_horn A B .

sublocale l: horn_fset "\<Delta>\<^sub>\<epsilon>_rules A B" "\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B" "\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
  apply (unfold_locales)
  unfolding \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_infer0 \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_infer1 \<Delta>\<^sub>\<epsilon>_infer0_cont_def \<Delta>\<^sub>\<epsilon>_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding sorted_list_of_fset_simps union_fset
  subgoal
    apply (auto split!: prod.splits ta_rule.splits simp: comp_def fset_of_list_elem r_rhs_def
       map_prod_def fSigma.rep_eq image_def Bex_def simp flip: fmember_iff_member_fset)
    apply (metis ta_rule.exhaust_sel)
    done
  unfolding Let_def prod.case set_append Un_assoc
  apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
  subgoal
    apply (auto split!: prod.splits ta_rule.splits simp flip: fmember_iff_member_fset )
    apply (smt (verit, del_insts) Pair_inject map_prod_imageI mem_Collect_eq ta_rule.inject ta_rule.sel(3))
    done
by (force simp add: image_def fmember_iff_member_fset split!: prod.splits)+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition \<Delta>\<^sub>\<epsilon>_impl where
  "\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = horn_fset_impl.saturate_impl (\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B) (\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"

lemma \<Delta>\<^sub>\<epsilon>_impl_sound:
  assumes "\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
  shows "xs = \<Delta>\<^sub>\<epsilon> (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
  using \<Delta>\<^sub>\<epsilon>_fset.saturate_impl_sound[OF assms[unfolded \<Delta>\<^sub>\<epsilon>_impl_def]]
  unfolding \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_sound[symmetric]
  by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq simp: fmember_iff_member_fset)

lemma \<Delta>\<^sub>\<epsilon>_impl_complete:
  fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset"
    and \<Delta>\<^sub>\<epsilon>\<^sub>A :: "('q \<times> 'q) fset" and \<Delta>\<^sub>\<epsilon>\<^sub>B :: "('q \<times> 'q) fset"
  shows "\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>\<epsilon>\<^sub>A \<Delta>\<^sub>B \<Delta>\<^sub>\<epsilon>\<^sub>B \<noteq> None" unfolding \<Delta>\<^sub>\<epsilon>_impl_def
  by (intro \<Delta>\<^sub>\<epsilon>_fset.saturate_impl_complete)
     (auto simp flip: \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_sound)

lemma \<Delta>\<^sub>\<epsilon>_impl [code]:
  "\<Delta>\<^sub>\<epsilon> (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = the (\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
  using \<Delta>\<^sub>\<epsilon>_impl_complete[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>] \<Delta>\<^sub>\<epsilon>_impl_sound[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
  by force

section \<open>Computing the epsilon transitions for the transitive closure of GTT's\<close>

definition \<Delta>_trancl_infer0 where
  "\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B = \<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B"

definition \<Delta>_trancl_infer1 :: "('q :: linorder , 'f  :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow>  ('q, 'f) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset
  \<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
  "\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs =
    \<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs @
    sorted_list_of_fset (
      (\<lambda>(r, p'). (r, snd pq)) |`| (ffilter (\<lambda>(r, p') \<Rightarrow> p' = fst pq) bs) |\<union>|
      (\<lambda>(q', r). (fst pq, r)) |`| (ffilter (\<lambda>(q', r) \<Rightarrow> q' = snd pq) (finsert pq bs)))"

locale \<Delta>_trancl_list =
  fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
    and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin

abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"

sublocale \<Delta>_trancl_horn A B .

sublocale l: horn_fset "\<Delta>_trancl_rules A B"
   "\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B" "\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
  apply (unfold_locales)
  unfolding \<Delta>_trancl_rules_def horn_infer0_union horn_infer1_union
    \<Delta>_trancl_infer0_def \<Delta>_trancl_infer1_def \<Delta>\<^sub>\<epsilon>_fset.infer set_append
  by (auto simp flip: ex_simps(1) simp: horn.infer0_def horn.infer1_def intro!: arg_cong2[of _ _ _ _ "(\<union>)"])

lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
   horn_fset_impl.saturate_impl (\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B) (\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"

lemma \<Delta>_trancl_impl_sound:
  assumes "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
  shows "xs = \<Delta>_trancl (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
  using \<Delta>_trancl_list.saturate_impl_sound[OF assms[unfolded \<Delta>_trancl_impl_def]]
  unfolding \<Delta>_trancl_horn.\<Delta>_trancl_sound[symmetric] \<Delta>_trancl.rep_eq[symmetric]
  by (auto simp: fmember_iff_member_fset)

lemma \<Delta>_trancl_impl_complete:
  fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset"
    and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
  shows "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<noteq> None"
  unfolding \<Delta>_trancl_impl_def
  by (intro \<Delta>_trancl_list.saturate_impl_complete)
     (auto simp flip: \<Delta>_trancl_horn.\<Delta>_trancl_sound)

lemma \<Delta>_trancl_impl [code]:
  "\<Delta>_trancl (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = (the (\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>))"
  using \<Delta>_trancl_impl_complete[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
  using \<Delta>_trancl_impl_sound[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
  by force

section \<open>Computing the epsilon transitions for the transitive closure of pair automata\<close>

definition \<Delta>_Atr_infer1_cont :: "('q :: linorder \<times> 'q) fset \<Rightarrow> ('q, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow>
  ('q, 'f) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
  "\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
  (let G = sorted_list_of_fset (the (\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>)) in
  (\<lambda> pq bs.
    (let bs_list = sorted_list_of_fset bs in
      map (\<lambda> (p, q). (fst p, snd pq))  (filter (\<lambda> (p, q). snd p = fst q \<and> snd q = fst pq) (List.product bs_list G)) @
      map (\<lambda> (p, q). (fst pq, snd q))  (filter (\<lambda> (p, q). snd p = fst q \<and> fst p = snd pq) (List.product G bs_list)) @
      map (\<lambda> (p, q). (fst pq, snd pq)) (filter (\<lambda> (p, q). snd pq = p \<and> fst pq = q) G))))"

locale \<Delta>_Atr_fset =
  fixes Q :: "('q :: linorder \<times> 'q) fset" and  \<Delta>\<^sub>A :: "('q, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
    and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin

abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"

sublocale \<Delta>_Atr_horn Q A B .

lemma infer1:
  "infer1 pq (fset bs) = set (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs)"
proof -
  have "{(p, snd pq) | p q. (p, q) \<in> (fset bs) \<and> (q, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} \<union>
   {(fst pq, v) | q r v. (snd pq, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A \<and> (r, v) \<in> (fset bs)} \<union>
   {(fst pq, snd pq) | q . (snd pq, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} = set (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs)"
    unfolding \<Delta>_Atr_infer1_cont_def set_append Un_assoc[symmetric] Let_def
    unfolding sorted_list_of_fset_simps union_fset
    apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
    apply (simp_all add: fSigma_repeq fmember_iff_member_fset flip: \<Delta>\<^sub>\<epsilon>_impl fset_of_list_elem)
    apply force+
    done
  then show ?thesis
    using \<Delta>_Atr_horn.\<Delta>_Atr_infer1[of Q A B pq "fset bs"]
    by simp
qed

sublocale l: horn_fset "\<Delta>_Atr_rules Q A B" "sorted_list_of_fset Q" "\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
  apply (unfold_locales)
  unfolding \<Delta>_Atr_horn.\<Delta>_Atr_infer0 fset_of_list.rep_eq
  using infer1
  by auto

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
   horn_fset_impl.saturate_impl (sorted_list_of_fset Q) (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"

lemma \<Delta>_Atr_impl_sound:
  assumes "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
  shows "xs = \<Delta>_Atrans Q (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
  using \<Delta>_Atr_fset.saturate_impl_sound[OF assms[unfolded \<Delta>_Atr_impl_def]]
  unfolding \<Delta>_Atr_horn.\<Delta>_Atr_sound[symmetric] \<Delta>_Atrans.rep_eq[symmetric]
  by (simp add: fset_inject)

lemma \<Delta>_Atr_impl_complete:
  shows "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<noteq> None" unfolding \<Delta>_Atr_impl_def
  by (intro \<Delta>_Atr_fset.saturate_impl_complete)
     (auto simp: finite_\<Delta>_Atrans_set simp flip: \<Delta>_Atr_horn.\<Delta>_Atr_sound)

lemma \<Delta>_Atr_impl [code]:
  "\<Delta>_Atrans Q (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = (the (\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>))"
  using \<Delta>_Atr_impl_complete[of Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>] \<Delta>_Atr_impl_sound[of Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
  by force

section \<open>Computing the Q infinity set for the infinity predicate automaton\<close>

definition Q_infer0_cont  :: "('q :: linorder, 'f :: linorder option \<times> 'g :: linorder option) ta_rule fset \<Rightarrow> ('q \<times> 'q) list" where
  "Q_infer0_cont \<Delta> = concat (sorted_list_of_fset (
     (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> map (\<lambda> x. Pair x p) ps) |`|
     (ffilter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> fst f = None \<and> snd f \<noteq> None \<and> ps \<noteq> []) \<Delta>)))"

definition Q_infer1_cont :: "('q ::linorder \<times> 'q) fset \<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
  "Q_infer1_cont \<Delta>\<epsilon> =
  (let eps = sorted_list_of_fset \<Delta>\<epsilon> in
  (\<lambda> pq bs.
    let bs_list = sorted_list_of_fset bs in
    map (\<lambda> (q, r). (fst pq, r)) (filter (\<lambda> (q, r) \<Rightarrow> q = snd pq) eps) @
    map (\<lambda>(r, p'). (r, snd pq)) (filter (\<lambda>(r, p') \<Rightarrow> p' = fst pq) bs_list) @
    map (\<lambda>(q', r). (fst pq, r)) (filter (\<lambda>(q', r) \<Rightarrow> q' = snd pq) (pq # bs_list))))"

locale Q_fset =
  fixes \<Delta> :: "('q :: linorder, 'f :: linorder option \<times> 'g :: linorder option) ta_rule fset" and \<Delta>\<epsilon> :: "('q \<times> 'q) fset"
begin

abbreviation A where "A \<equiv> TA \<Delta> \<Delta>\<epsilon>"
sublocale Q_horn A .

sublocale l: horn_fset "Q_inf_rules A" "Q_infer0_cont \<Delta>" "Q_infer1_cont \<Delta>\<epsilon>"
  apply (unfold_locales)
  unfolding Q_horn.Q_infer0 Q_horn.Q_infer1 Q_infer0_cont_def Q_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding sorted_list_of_fset_simps union_fset
  subgoal
    apply (auto simp add: Bex_def fmember_iff_member_fset split!: ta_rule.splits)
    apply (rule_tac x = "TA_rule (lift_None_Some f) ps p" in exI)
    apply (force dest: in_set_idx)+
    done
  unfolding Let_def set_append Un_assoc
  by (intro arg_cong2[of _ _ _ _ "(\<union>)"]) (auto simp add: fmember_iff_member_fset)

lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition Q_impl where
  "Q_impl \<Delta> \<Delta>\<epsilon> = horn_fset_impl.saturate_impl (Q_infer0_cont \<Delta>) (Q_infer1_cont \<Delta>\<epsilon>)"

lemma Q_impl_sound:
  "Q_impl \<Delta> \<Delta>\<epsilon> = Some xs \<Longrightarrow> fset xs = Q_inf (TA \<Delta> \<Delta>\<epsilon>)"
  using Q_fset.saturate_impl_sound unfolding Q_impl_def Q_horn.Q_sound .

lemma Q_impl_complete:
  "Q_impl \<Delta> \<Delta>\<epsilon> \<noteq> None"
proof -
  let ?A = "TA \<Delta> \<Delta>\<epsilon>"
  have *: "Q_inf ?A \<subseteq> fset (\<Q> ?A |\<times>| \<Q> ?A)"
    by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember_iff_member_fset)
  have "finite (Q_inf ?A)"
    by (intro finite_subset[OF *]) simp
  then show ?thesis unfolding Q_impl_def
    by (intro Q_fset.saturate_impl_complete) (auto simp: Q_horn.Q_sound)
qed

definition "Q_infinity_impl \<Delta> \<Delta>\<epsilon> = (let Q = the (Q_impl \<Delta> \<Delta>\<epsilon>) in
   snd |`| ((ffilter (\<lambda> (p, q). p = q) Q) |O| Q))"

lemma Q_infinity_impl_fmember:
  "q |\<in>| Q_infinity_impl \<Delta> \<Delta>\<epsilon> \<longleftrightarrow> (\<exists> p. (p, p) |\<in>| the (Q_impl \<Delta> \<Delta>\<epsilon>) \<and>
    (p, q) |\<in>| the (Q_impl \<Delta> \<Delta>\<epsilon>))"
  unfolding Q_infinity_impl_def
  by (auto simp: Let_def fimage_iff fBex_def) fastforce

lemma loop_sound_correct [simp]:
  "fset (Q_infinity_impl \<Delta> \<Delta>\<epsilon>) = Q_inf_e (TA \<Delta> \<Delta>\<epsilon>)"
proof -
  obtain Q where [simp]: "Q_impl \<Delta> \<Delta>\<epsilon> = Some Q" using Q_impl_complete[of \<Delta> \<Delta>\<epsilon>]
    by blast
  have "fset Q = (Q_inf (TA \<Delta> \<Delta>\<epsilon>))"
    using Q_impl_sound[of \<Delta> \<Delta>\<epsilon>]
    by (auto simp: fset_of_list.rep_eq)
  then show ?thesis
    by (force simp: Q_infinity_impl_fmember Let_def fset_of_list_elem
          fset_of_list.rep_eq simp flip: fmember_iff_member_fset)
qed

lemma fQ_inf_e_code [code]:
  "fQ_inf_e (TA \<Delta> \<Delta>\<epsilon>) = Q_infinity_impl \<Delta> \<Delta>\<epsilon>"
  using loop_sound_correct
  by (auto simp add: fQ_inf_e.rep_eq fmember_iff_member_fset)

end


subsection\<open>Formal Study of Version No.2 of Gödel’s Argument as
  Reported by Kanckos and Lethen, 2019 \<^cite>\<open>"KanckosLethen19"\<close> (Fig.~11 in \<^cite>\<open>"C85"\<close>)\<close>

theory KanckosLethenNo2Possibilist imports
  HOML
  MFilter
  BaseDefs
begin
text\<open>Axioms of Version No. 2 \<^cite>\<open>"KanckosLethen19"\<close>.\<close>
abbreviation delta ("\<Delta>") where "\<Delta> A \<equiv> \<lambda>x.(\<^bold>\<forall>\<psi>. ((A \<psi>) \<^bold>\<rightarrow> (\<psi> x)))"
abbreviation N ("\<N>") where "\<N> \<phi> \<equiv> \<lambda>x.(\<^bold>\<box>(\<phi> x))"

axiomatization where
  Axiom1: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(((\<P> \<phi>) \<^bold>\<and> (\<^bold>\<box>(\<^bold>\<forall>x. ((\<phi> x) \<^bold>\<rightarrow> (\<psi> x))))) \<^bold>\<rightarrow> (\<P> \<psi>))\<rfloor>" and \<comment>\<open>The \<open>\<^bold>\<box>\<close> can be omitted here; the proofs still work.\<close>
  Axiom2: "\<lfloor>\<^bold>\<forall>A .(\<^bold>\<box>((\<^bold>\<forall>\<phi>.((A \<phi>) \<^bold>\<rightarrow>  (\<P> \<phi>))) \<^bold>\<rightarrow> (\<P> (\<Delta> A))))\<rfloor>" and  \<comment>\<open>The \<open>\<^bold>\<box>\<close> can be omitted here; the proofs still work.\<close>
  Axiom3: "\<lfloor>\<^bold>\<forall>\<phi>.((\<P> \<phi>) \<^bold>\<rightarrow> (\<P> (\<N> \<phi>)))\<rfloor>" and
  Axiom4: "\<lfloor>\<^bold>\<forall>\<phi>.((\<P> \<phi>) \<^bold>\<rightarrow> (\<^bold>\<not>(\<P>(\<^bold>\<rightharpoondown>\<phi>))))\<rfloor>" and
  \<comment>\<open>Logic S5\<close>
  axB:  "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>)\<rfloor>" and axM: "\<lfloor>\<^bold>\<forall>\<phi>.((\<^bold>\<box>\<phi>) \<^bold>\<rightarrow> \<phi>)\<rfloor>" and ax4:  "\<lfloor>\<^bold>\<forall>\<phi>.((\<^bold>\<box>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<box>\<^bold>\<box>\<phi>))\<rfloor>"

text\<open>Sahlqvist correspondences: they are better suited for proof automation.\<close>
lemma axB': "\<forall>x y. \<not>(x\<^bold>ry) \<or> (y\<^bold>rx)" using axB by fastforce
lemma axM': "\<forall>x. (x\<^bold>rx)" using axM by blast
lemma ax4': "\<forall>x y z. (((x\<^bold>ry) \<and> (y\<^bold>rz)) \<longrightarrow> (x\<^bold>rz))" using ax4 by auto

text\<open>Proofs for all theorems for No.2 from \<^cite>\<open>"KanckosLethen19"\<close>.\<close>
theorem Theorem0: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<^bold>\<forall>Q. ((Q \<phi>)  \<^bold>\<rightarrow> (Q \<psi>))) \<^bold>\<rightarrow>  ((\<P> \<phi>) \<^bold>\<rightarrow> (\<P>  \<phi>)))\<rfloor>" by auto \<comment>\<open>not needed\<close>
theorem Theorem1: "\<lfloor>\<P> \<G>\<rfloor>"  unfolding G_def  using Axiom2 axM by blast
theorem Theorem2: "\<lfloor>\<^bold>\<forall>x. ((\<G> x)\<^bold>\<rightarrow>(\<^bold>\<exists>y. \<G> y))\<rfloor>" by blast  \<comment>\<open>not needed\<close>
theorem Theorem3a: "\<lfloor>\<P> (\<lambda>x. (\<^bold>\<exists>y. \<G> y))\<rfloor>"  by (metis (no_types, lifting) Axiom1 Theorem1)
theorem Theorem3b: "\<lfloor>\<^bold>\<box>(\<P> (\<lambda>x.(\<^bold>\<box>(\<^bold>\<exists>y. \<G> y))))\<rfloor>" by (smt Axiom1 G_def Theorem3a  Axiom3 Theorem1 axB')
theorem Theorem4: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<box>((\<G> x) \<^bold>\<rightarrow> ((\<P> (\<lambda>x.(\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))) \<^bold>\<rightarrow>  (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y))))\<rfloor>" using G_def by fastforce \<comment>\<open>not needed\<close>
theorem Theorem5: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<box>((\<G> x) \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))\<rfloor>" by (smt (verit) G_def Theorem3a Theorem3b)  \<comment>\<open>not needed\<close>
theorem Theorem6: "\<lfloor>\<^bold>\<box>((\<^bold>\<exists>y. \<G> y) \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))\<rfloor>" by (smt G_def Theorem3a Theorem3b)
theorem Theorem7: "\<lfloor>\<^bold>\<box>((\<^bold>\<diamond>(\<^bold>\<exists>y. \<G> y)) \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))\<rfloor>" using Theorem6 axB' by blast
theorem Theorem8: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>" by (metis Axiom1 Axiom4 Theorem1 Theorem7 axB')
theorem Theorem9: "\<lfloor>\<^bold>\<forall>\<phi>. ((\<P> \<phi>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>x. \<phi> x))\<rfloor>" using Axiom1 Axiom4 axM' by metis

text\<open>Short proof of Theorem8; analogous to the one presented in Sec. 7 of Benzmüller 2020.\<close>
theorem "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>" \<comment>\<open>Note: this version of the proof uses only \<open>axB'\<close> and \<open>axM'\<close>.\<close>
proof -
  have L1: "\<lfloor>(\<^bold>\<exists>X.((\<P> X)\<^bold>\<and>\<^bold>\<not>(\<^bold>\<exists>X)))\<^bold>\<rightarrow>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>"  using Axiom1 Axiom3 axB' by blast  \<comment>\<open>Use metis here if \<open>\<^bold>\<box>\<close> is omitted in Axiom1 and Axiom 2\<close>
  have L2:  "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" using Axiom1 Axiom4 by metis
  have L3: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>X.((\<P> X) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists> X)))\<rfloor>" using L1 L2 by blast
  have T2: "\<lfloor>\<P> \<G>\<rfloor>" by (smt Axiom1 Axiom2 G_def axM')
  have T3: "\<lfloor>\<^bold>\<exists>y. \<G> y\<rfloor>" using L3 T2 by blast
  have T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>" by (simp add: T3)
  thus ?thesis by blast qed

theorem T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>y. \<G> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>" \<comment>\<open>Obvious: If we can prove Theorem8, then we also have T5.\<close>
proof -
  have L1: "\<lfloor>(\<^bold>\<exists>X.((\<P> X)\<^bold>\<and>\<^bold>\<not>(\<^bold>\<exists>X)))\<^bold>\<rightarrow>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>"  using Axiom1 Axiom3 axB' by blast  \<comment>\<open>Use metis here if \<open>\<^bold>\<box>\<close> is omitted in Axiom1 and Axiom 2\<close>
  have L2:  "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" using Axiom1 Axiom4 by metis
  have L3: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>X.((\<P> X) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists> X)))\<rfloor>" using L1 L2 by blast
  have T2: "\<lfloor>\<P> \<G>\<rfloor>" by (smt Axiom1 Axiom2 G_def axM')
  have T3: "\<lfloor>\<^bold>\<exists>y. \<G> y\<rfloor>" using L3 T2 by blast
  have T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>" by (simp add: T3)
  thus ?thesis by blast qed

text\<open>Another short proof of Theorem8.\<close>
theorem "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)\<rfloor>"  \<comment>\<open>Note: fewer assumptions used in some cases than in \cite{KanckosLethen19}.\<close>
proof -
  have T1: "\<lfloor>\<P> \<G>\<rfloor>"  unfolding G_def  using Axiom2 axM by blast
  have T3a: "\<lfloor>\<P> (\<lambda>x. (\<^bold>\<exists>y. \<G> y))\<rfloor>" by (metis (no_types, lifting) Axiom1 T1)
  have T3b: "\<lfloor>\<^bold>\<box>(\<P> (\<lambda>x.(\<^bold>\<box>(\<^bold>\<exists>y. \<G> y))))\<rfloor>" by (smt Axiom1 G_def T3a  Axiom3 T1 axB')
  have T6: "\<lfloor>\<^bold>\<box>((\<^bold>\<exists>y. \<G> y) \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))\<rfloor>" by (smt G_def T3a T3b)
  have T7: "\<lfloor>\<^bold>\<box>((\<^bold>\<diamond>(\<^bold>\<exists>y. \<G> y)) \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>y. \<G> y)))\<rfloor>" using T6 axB' by blast
  thus ?thesis  by (smt Axiom1 Axiom4 T3b axB') qed

text\<open>Are the axioms of the simplified versions implied?\<close>
text\<open>Actualist version of the axioms.\<close>
lemma A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" using Theorem9 by blast
lemma A2': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> ((X\<^bold>\<sqsubseteq>Y)\<^bold>\<or>(X\<Rrightarrow>Y))) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" nitpick oops  \<comment>\<open>Countermodel\<close>
lemma A3:  "\<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>" nitpick oops  \<comment>\<open>Countermodel\<close>

text\<open>Possibilist version of the axioms.\<close>
abbreviation a ("_\<^bold>\<sqsubseteq>\<^sup>p_") where "X\<^bold>\<sqsubseteq>\<^sup>pY \<equiv> \<^bold>\<forall>z.((X z) \<^bold>\<rightarrow> (Y z))"
abbreviation b ("_\<Rrightarrow>\<^sup>p_") where "X\<Rrightarrow>\<^sup>pY \<equiv> \<^bold>\<box>(X\<^bold>\<sqsubseteq>\<^sup>pY)"
abbreviation d ("_\<Sqinter>\<^sup>p_") where "X\<Sqinter>\<^sup>p\<Z> \<equiv> \<^bold>\<box>(\<^bold>\<forall>u.((X u) \<^bold>\<leftrightarrow> (\<^bold>\<forall>Y.((\<Z> Y) \<^bold>\<rightarrow> (Y u)))))"

lemma A1'P: "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" using Theorem9 by blast
lemma A2'P: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> ((X\<^bold>\<sqsubseteq>\<^sup>pY)\<^bold>\<or>(X\<Rrightarrow>\<^sup>pY))) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" oops \<comment>\<open>no answer, yet by sledgehammer and nitpick\<close>
lemma A2'aP: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<Rrightarrow>\<^sup>pY)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" using Axiom1 axM' by metis
lemma A2'bP: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<^bold>\<sqsubseteq>\<^sup>pY)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" oops \<comment>\<open>no answer, yet by sledgehammer and nitpick\<close>
lemma A3P:  "\<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<^sup>p\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>"
  by (smt (verit, del_insts) Axiom1 Axiom2 axM') \<comment>\<open>proof found\<close>

text\<open>Are Axiom2 and A3 equivalent? Only when assuming Axiom1 and axiom M.\<close>
lemma  "\<lfloor>\<^bold>\<forall>A .(\<^bold>\<box>((\<^bold>\<forall>\<phi>.((A \<phi>) \<^bold>\<rightarrow>  (\<P> \<phi>))) \<^bold>\<rightarrow> (\<P> (\<Delta> A))))\<rfloor> \<equiv> \<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<^sup>p\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>"
  by (smt (verit, ccfv_threshold) Axiom1 axM') \<comment>\<open>proof found\<close>
end