theory FMAutomat

imports automaton.eventAutomat automaton.dAutomaton_causal fmAutomat_inc

begin

section\<open>evenAutomat \<close>

datatype Single = Si bool nat

(*Setter for M_pure? Nondeterminism in last two cases necessary?*)
fun eventMT :: "Single \<Rightarrow> inFM \<Rightarrow> nat  \<Rightarrow> (Single \<times> outFM\<^sup>\<Omega>) set" where
"eventMT (Si True  0      ) FMin1 m  = { (Si False   i, fmOutSB.setter (\<up>(Some m))) | i. True}" |
"eventMT (Si True  (Suc n)) FMin1 m  = { (Si True    n, fmOutSB.setter (\<up>(Some m)))          }" |
"eventMT (Si False 0      ) FMin2 m  = { (Si True    i, fmOutSB.setter (\<up>(Some m))) | i. True}" |
"eventMT (Si False (Suc n)) FMin2 m  = { (Si False   n, fmOutSB.setter (\<up>(Some m)))          }" |
"eventMT (Si True  n      ) FMin2 m  = { (Si True    n, fmOutSB.setter (\<up>(Some m)))          }" |
"eventMT (Si False n      ) FMin1 m  = { (Si False   n, fmOutSB.setter (\<up>(Some m)))          }"

text\<open>Automaton takes Transition:
 \<^item> State True  n ch2  => no message on ch1
 \<^item> State False n ch1  => no message on ch2

Else, another transitions would have been taken in eventMT.

==> Longest possible stream of messages from one channel is n and hence, finite.\<close>

definition "eventMerge = eventAut (\<lambda> s c m_pure. eventMT s c (inv \<N> m_pure)) ({(Si bool n,\<bottom>)| bool n. True})"

section\<open>ugly transition function\<close>
setup_lifting type_definition_ndAutomaton

fun dAfm_case::"bool \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> (nat\<times> nat) \<Rightarrow> nat \<Rightarrow>(S_fm \<times> nat option)"where
"dAfm_case True  [] l2 (nat1, nat2) = (\<lambda>n. (S True  n []          (l2@[nat2]),Some nat1))"|
"dAfm_case False l1 [] (nat1, nat2) = (\<lambda>n. (S False n (l1@[nat1]) []         ,Some nat2))"|

"dAfm_case True  (nhd#l1) l2       (nat1, nat2) = (\<lambda>n. (S True  n (l1@[nat1]) (l2@[nat2]),Some nhd))"|
"dAfm_case False l1       (nhd#l2) (nat1, nat2) = (\<lambda>n. (S False n (l1@[nat1]) (l2@[nat2]),Some nhd))"

fun dAfm_case_option::"bool \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> (nat option\<times> nat option) \<Rightarrow> nat \<Rightarrow>(S_fm \<times> nat option)" where
"dAfm_case_option bool l1 l2 (Some nat1, Some nat2) = dAfm_case bool l1 l2 (nat1, nat2)"|

"dAfm_case_option bool [] [] (None            , None)      = (\<lambda>n. (S bool  n [] []        ,None     ))"|
"dAfm_case_option bool [] [] (Some nat1       , None)      = (\<lambda>n. (S True  n [] []        ,Some nat1))"|
"dAfm_case_option bool [] [] (None            , Some nat2) = (\<lambda>n. (S False n [] []        ,Some nat2))"|

"dAfm_case_option False (nhd#l1) [] (None     , None)      = (\<lambda>n. (S True  n l1          []          ,Some nhd ))"|
"dAfm_case_option True  (nhd#l1) l2 (None     , None)      = (\<lambda>n. (S True  n l1          l2          ,Some nhd ))"|
"dAfm_case_option False (nhd#l1) [] (Some nat1, None)      = (\<lambda>n. (S True  n (l1@[nat1]) []          ,Some nhd ))"|
"dAfm_case_option True  (nhd#l1) l2 (Some nat1, None)      = (\<lambda>n. (S True  n (l1@[nat1]) l2          ,Some nhd ))"|
"dAfm_case_option True  (nhd#l1) l2 (None     , Some nat2) = (\<lambda>n. (S True  n l1          (l2@[nat2]) ,Some nhd ))"|
"dAfm_case_option False l1       [] (None     , Some nat2) = (\<lambda>n. (S False n l1          []          ,Some nat2))"|

"dAfm_case_option True  [] (nhd#l2) (None     , None)      = (\<lambda>n. (S False n []          l2          ,Some nhd ))"|
"dAfm_case_option False l1 (nhd#l2) (None     , None)      = (\<lambda>n. (S False n l1          l2          ,Some nhd ))"|
"dAfm_case_option False l1 (nhd#l2) (Some nat1, None)      = (\<lambda>n. (S False n (l1@[nat1]) l2          ,Some nhd ))"|
"dAfm_case_option True  []  l2      (Some nat1, None)      = (\<lambda>n. (S True  n []          l2          ,Some nat1))"|
"dAfm_case_option True  [] (nhd#l2) (None     , Some nat2) = (\<lambda>n. (S False n []          (l2@[nat2]) ,Some nhd ))"|
"dAfm_case_option False l1 (nhd#l2) (None     , Some nat2) = (\<lambda>n. (S True  n l1          (l2@[nat2]) ,Some nhd ))"

(*FM automaton*)
fun dAfm_transition::"S_fm \<Rightarrow> (nat option\<times> nat option) \<Rightarrow> (S_fm \<times> nat option )set"where
"dAfm_transition (S bool 0       buf1 buf2) input = {(dAfm_case_option (\<not>bool) buf1 buf2 input) n | n. True} "|
"dAfm_transition (S bool (Suc n) buf1 buf2) input = {(dAfm_case_option bool    buf1 buf2 input) n}"

definition fairmergetransition::"(S_fm \<Rightarrow> inFM\<^sup>\<surd> \<Rightarrow> ((S_fm \<times> outFM\<^sup>\<Omega>) set))"where
"fairmergetransition state insbe = ( let Set = (dAfm_transition state (fmInSBE.getter(insbe))) in
                                   (\<lambda>e. (fst e, fmOutSB.setter(\<up>(snd e))))` Set)"

definition fairmergeinit::"(S_fm \<times> outFM\<^sup>\<Omega>) set" where
"fairmergeinit = {(S bool n [] [], \<bottom>) | bool n. True}"

definition FairMerge::"(S_fm,inFM,outFM) ndAutomaton_incomplete" where
"FairMerge = (|ndaiTransition = fairmergetransition, ndaiInitConfig = fairmergeinit|)"

lift_definition FairMergelift::"(S_fm,inFM,outFM) ndAutomaton" is
"(fairmergetransition, fairmergeinit)"
  apply auto
  apply(simp add: fairmergetransition_def)
  apply(case_tac state;case_tac x1;case_tac x2;case_tac x3;case_tac x4,auto)
  apply (metis (mono_tags)old.prod.exhaust)+
  by(simp add: fairmergeinit_def,auto)

section \<open>Broy specification\<close>
text\<open>Assumes that stream domains are disjoint, non-strict if we use timed streams\<close>
definition FM_broy::"('a::countable stream \<rightarrow> 'a stream \<rightarrow> 'a stream) set" where
"FM_broy = {f | f. \<forall>s1 s2. (#s1=\<infinity> \<and> #s2=\<infinity> \<and> (sValues\<cdot>s1 \<inter> sValues\<cdot>s2 = {}))
            \<longrightarrow> (s1=(sValues\<cdot>s1) \<ominus> (f\<cdot>s1\<cdot>s2) \<and> s2=(sValues\<cdot>s2) \<ominus> (f\<cdot>s1\<cdot>s2))}"

text \<open>Case we want to merge nat and bool stream:\<close>

datatype NB= \<N> nat | \<B> bool

instance NB::countable
  by(countable_datatype)

definition FM_broynb::"(nat stream \<rightarrow> bool stream \<rightarrow> NB stream)set" where
"FM_broynb = {f | f. \<exists>g. \<forall>s1 s2. f\<cdot>s1\<cdot>s2 = g\<cdot>(smap \<N>\<cdot>s1)\<cdot>(smap \<B>\<cdot>s2) \<and> g \<in> FM_broy}"

lemma assumes "f\<in>FM_broynb" and "#s1 = \<infinity>" and "#s2 = \<infinity>" shows "(\<N> `(sValues\<cdot>s1)) \<ominus> (f\<cdot>s1\<cdot>s2) = smap \<N>\<cdot>s1"
  apply(insert assms, simp add: FM_broynb_def FM_broy_def,auto)
  apply(subgoal_tac "sValues\<cdot>(smap NB.\<N>\<cdot>s1)\<inter> sValues\<cdot>(smap NB.\<B>\<cdot>s2) = {}",auto)
  apply (metis slen_smap smap_sValues)
  by(auto simp add: smap_sValues)

lemma assumes "f\<in>FM_broynb" and "#s1 = \<infinity>" and "#s2 = \<infinity>" shows "(\<B> `(sValues\<cdot>s2)) \<ominus> (f\<cdot>s1\<cdot>s2) = smap \<B>\<cdot>s2"
  apply(insert assms, simp add: FM_broynb_def FM_broy_def,auto)
  apply(subgoal_tac "sValues\<cdot>(smap NB.\<N>\<cdot>s1)\<inter> sValues\<cdot>(smap NB.\<B>\<cdot>s2) = {}",auto)
  apply (metis slen_smap smap_sValues)
  by(auto simp add: smap_sValues)

fixrec
smerge :: "'a::countable stream \<rightarrow> 'a stream \<rightarrow> 'a stream"
where
"smerge\<cdot>\<bottom>\<cdot>l2 = \<bottom>"|
"smerge\<cdot>l1\<cdot>\<bottom> = \<bottom>"|
"smerge\<cdot>((up\<cdot>l1)&&ls1)\<cdot>((up\<cdot>l2)&&ls2) = (up\<cdot>l1)&&((up\<cdot>l2)&&(smerge\<cdot>ls1\<cdot>ls2))"

lemma "smerge\<cdot>(\<up>a \<bullet> as)\<cdot>(\<up>b \<bullet>bs) = \<up>a \<bullet> \<up>b \<bullet> (smerge\<cdot>as\<cdot>bs)"
  unfolding smerge_def
  sorry

lemma "snth (2*n) (smerge\<cdot>(s1)\<cdot>(s2)) = snth n s1"
  sorry

lemma "snth (2*n +1) (smerge\<cdot>(s1)\<cdot>(s2)) = snth (n+1) s2"
  sorry

lemma smerge_well1:"#s1 = \<infinity> \<Longrightarrow> #s2 = \<infinity> \<Longrightarrow> sValues\<cdot>s1 \<inter> sValues\<cdot>s2 = {} \<Longrightarrow> s1 = sValues\<cdot>s1 \<ominus> smerge\<cdot>s1\<cdot>s2"
  sorry

lemma smerge_well2:"#s1 = \<infinity> \<Longrightarrow> #s2 = \<infinity> \<Longrightarrow> sValues\<cdot>s1 \<inter> sValues\<cdot>s2 = {} \<Longrightarrow> s2 = sValues\<cdot>s2 \<ominus> smerge\<cdot>s1\<cdot>s2"
  sorry

lemma "\<exists>f. f\<in>FM_broy"
  apply(rule_tac x="smerge"in exI)
  by(simp add: FM_broy_def smerge_well1 smerge_well2)

section \<open>Rumpe specification\<close>

primrec Select:: "bool list \<Rightarrow> 'a::countable list \<Rightarrow> 'a list" where
"Select bs [] = []" |
"Select bs (x # xs) = (if hd bs then x # Select (tl bs) xs else Select (tl bs) xs)"

definition merge::"nat list \<times> nat list \<Rightarrow> nat list set"where
"merge \<equiv> \<lambda>(in1,in2). {s  | s. \<exists>org. in1 = Select org s \<and> in2 = Select (map Not org) s}"

datatype S_rum = s

fun Rum_transition::"S_rum \<Rightarrow> (nat list \<times> nat list) \<Rightarrow> (S_rum \<times> nat list)set"where
"Rum_transition s input = {(s,out) | out. out \<in> merge input}"

end


theory Rushby
imports Main
begin

typedecl u -- "U_beings"

consts "g" :: "u \<Rightarrow> u \<Rightarrow> bool" (infixr "\<^bold>>" 54)
consts "k" :: "u \<Rightarrow> u \<Rightarrow> bool" (infixr "\<^bold><" 54)
consts "e" :: "u \<Rightarrow> u \<Rightarrow> bool" (infixr "\<^bold>=" 54)

abbreviation Greater0 where
  "Greater0 \<equiv> \<forall> x y. x \<^bold>> y \<or> y \<^bold>> x \<or> x \<^bold>= y"

abbreviation God :: "u\<Rightarrow>bool" ("G") where
  "G \<equiv> \<lambda>x.  \<not>(\<exists> y. (y \<^bold>> x))"

consts "re" :: "u \<Rightarrow> bool"

abbreviation ExUnd where
  "ExUnd \<equiv> \<exists> x . God x"

abbreviation Greater1 where
  "Greater1 \<equiv> \<forall> x . (\<not>re x) \<longrightarrow> (\<exists> y . y \<^bold>> x)"

theorem "God!":
  assumes ExUnd
  assumes "Greater1"
  shows "\<exists> x. (G x \<and> re x)"
(*sledgehammer*)
using assms by blast

abbreviation Greater2 where
  "Greater2 \<equiv> (\<forall> x y. (re x \<and> \<not> re y) \<longrightarrow> (x \<^bold>> y))"

abbreviation "Ex_re" where
  "Ex_re \<equiv> \<exists> x. re x"

theorem "God!2":
  assumes ExUnd
  assumes "Greater2" and "Ex_re"
  shows "\<exists> x. (G x \<and> re x)"
(*sledgehammer*)
using assms by blast

abbreviation "P1" where
  "P1 \<equiv> \<exists> x. G x"

theorem "P1!":
  assumes ExUnd
  shows P1 using assms by -

consts "P" :: "(u \<Rightarrow> bool) \<Rightarrow> bool" -- "greater making property"

abbreviation "P_re" where
  "P_re \<equiv> P re"

abbreviation "subsetP" where
  "subsetP \<equiv> \<lambda> FF. \<forall>x. FF x \<longrightarrow> P x"

abbreviation "Greater3" where
  "Greater3 \<equiv> \<forall> x y . x \<^bold>> y \<longleftrightarrow> ((\<forall>F. P F \<longrightarrow> (F y \<longrightarrow> F x)) \<and> (\<exists>F. P F \<and> (F x \<and> \<not>F y)))"

abbreviation "Realization" where
  "Realization \<equiv> \<forall> FF. subsetP FF \<longrightarrow> (\<exists>x. \<forall>f. P f \<longrightarrow> (f x \<longleftrightarrow> FF f))"
(*  "Realization \<equiv> \<forall> FF \<subseteq> {x . P x} . \<exists>x. \<forall>f. f(x) \<longleftrightarrow> f \<in> FF"*)

abbreviation aG where
  "aG \<equiv> \<lambda>x . \<forall>y. x \<^bold>> y"

abbreviation ExUndA where
  "ExUndA \<equiv> \<exists>x. aG x"

theorem "God!3":
  assumes P_re
  assumes Greater3
  assumes Realization
  assumes ExUndA
  shows "\<exists> x. (aG x \<and> re x)"
proof -
    from assms(4) have "\<exists>x. aG x" by -
    moreover {
      fix x
      assume gx: "aG x"
      then have "\<forall> y. (x \<^bold>> y)" by -
      from this assms(2) have "\<forall>y.(\<forall>F. P F \<longrightarrow> (F y \<longrightarrow> F x)) \<and> (\<exists>F. P F \<and> (F x \<and> \<not>F y))" by blast
      from this assms(1) have rx: "re x" by blast
      from gx rx have "aG x \<and> re x" by (rule conjI)
      hence "\<exists> x. (aG x \<and> re x)" by (rule exI)
    }
    ultimately show ?thesis by (rule exE)
qed

theorem "GodCanDoItAll":
  assumes P_re
  assumes Greater3
  assumes Realization
  assumes ExUndA
  shows "\<forall>f. P f \<longrightarrow> (\<exists>x. aG x \<and> f x)"
proof -
  {
    fix f
    assume "P f"
    from assms(4) have "\<exists>x. aG x" by -
    moreover {
      fix x
      assume gx: "aG x"
      from this assms(2) assms(3) have "\<forall> y. x \<^bold>> y" by blast
      from this assms(2) have "\<forall>y.(\<forall>F. P F \<longrightarrow> (F y \<longrightarrow> F x)) \<and> (\<exists>F. P F \<and> (F x \<and> \<not>F y))" by blast
      from this assms(1) have rx: "f x" by blast
      from gx rx have "aG x \<and> f x" by (rule conjI)
      hence "\<exists> x. (aG x \<and> f x)" by (rule exI)
    }
    ultimately have "(\<exists>x. aG x \<and> f x)" by (rule exE)
  }
  thus ?thesis by blast
qed

consts D :: "(u \<Rightarrow> bool) \<Rightarrow> bool"

axiomatization where
  dsubstP: "\<forall>f. D f \<longrightarrow> P f"

(* do not further consider quasi id, because we have a different proof *)
abbreviation quasi_id where
  "quasi_id \<equiv> \<lambda>x y. \<forall>f. P f \<and> \<not>D f \<longrightarrow> f x = f y"

abbreviation Realization_W where
  "Realization_W \<equiv> \<forall> FF. subsetP FF \<longrightarrow> (\<exists>x. \<forall>f. FF f \<longrightarrow> f x)"

end


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

Weak LeadsTo relation (restricted to the set of reachable states)
*)

section{*Weak Progress*}

theory SubstAx imports WFair Constrains begin

definition Ensures :: "['a set, 'a set] => 'a program set" (infixl "Ensures" 60) where
    "A Ensures B == {F. F \<in> (reachable F \<inter> A) ensures B}"

definition LeadsTo :: "['a set, 'a set] => 'a program set" (infixl "LeadsTo" 60) where
    "A LeadsTo B == {F. F \<in> (reachable F \<inter> A) leadsTo B}"

notation (xsymbols)
  LeadsTo  (infixl " \<longmapsto>w " 60)

text{*Resembles the previous definition of LeadsTo*}
lemma LeadsTo_eq_leadsTo:
     "A LeadsTo B = {F. F \<in> (reachable F \<inter> A) leadsTo (reachable F \<inter> B)}"
apply (unfold LeadsTo_def)
apply (blast dest: psp_stable2 intro: leadsTo_weaken)
done

subsection{*Specialized laws for handling invariants*}

(** Conjoining an Always property **)

lemma Always_LeadsTo_pre:
     "F \<in> Always INV ==> (F \<in> (INV \<inter> A) LeadsTo A') = (F \<in> A LeadsTo A')"
by (simp add: LeadsTo_def Always_eq_includes_reachable Int_absorb2
              Int_assoc [symmetric])

lemma Always_LeadsTo_post:
     "F \<in> Always INV ==> (F \<in> A LeadsTo (INV \<inter> A')) = (F \<in> A LeadsTo A')"
by (simp add: LeadsTo_eq_leadsTo Always_eq_includes_reachable Int_absorb2
              Int_assoc [symmetric])

(* [| F \<in> Always C;  F \<in> (C \<inter> A) LeadsTo A' |] ==> F \<in> A LeadsTo A' *)
lemmas Always_LeadsToI = Always_LeadsTo_pre [THEN iffD1]

(* [| F \<in> Always INV;  F \<in> A LeadsTo A' |] ==> F \<in> A LeadsTo (INV \<inter> A') *)
lemmas Always_LeadsToD = Always_LeadsTo_post [THEN iffD2]

subsection{*Introduction rules: Basis, Trans, Union*}

lemma leadsTo_imp_LeadsTo: "F \<in> A leadsTo B ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_L)
done

lemma LeadsTo_Trans:
     "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |] ==> F \<in> A LeadsTo C"
apply (simp add: LeadsTo_eq_leadsTo)
apply (blast intro: leadsTo_Trans)
done

lemma LeadsTo_Union:
     "(!!A. A \<in> S ==> F \<in> A LeadsTo B) ==> F \<in> (Union S) LeadsTo B"
apply (simp add: LeadsTo_def)
apply (subst Int_Union)
apply (blast intro: leadsTo_UN)
done

subsection{*Derived rules*}

lemma LeadsTo_UNIV [simp]: "F \<in> A LeadsTo UNIV"
by (simp add: LeadsTo_def)

text{*Useful with cancellation, disjunction*}
lemma LeadsTo_Un_duplicate:
     "F \<in> A LeadsTo (A' \<union> A') ==> F \<in> A LeadsTo A'"
by (simp add: Un_ac)

lemma LeadsTo_Un_duplicate2:
     "F \<in> A LeadsTo (A' \<union> C \<union> C) ==> F \<in> A LeadsTo (A' \<union> C)"
by (simp add: Un_ac)

lemma LeadsTo_UN:
     "(!!i. i \<in> I ==> F \<in> (A i) LeadsTo B) ==> F \<in> (\<Union>i \<in> I. A i) LeadsTo B"
apply (unfold SUP_def)
apply (blast intro: LeadsTo_Union)
done

text{*Binary union introduction rule*}
lemma LeadsTo_Un:
     "[| F \<in> A LeadsTo C; F \<in> B LeadsTo C |] ==> F \<in> (A \<union> B) LeadsTo C"
  using LeadsTo_UN [of "{A, B}" F id C] by auto

text{*Lets us look at the starting state*}
lemma single_LeadsTo_I:
     "(!!s. s \<in> A ==> F \<in> {s} LeadsTo B) ==> F \<in> A LeadsTo B"
by (subst UN_singleton [symmetric], rule LeadsTo_UN, blast)

lemma subset_imp_LeadsTo: "A \<subseteq> B ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_def)
apply (blast intro: subset_imp_leadsTo)
done

lemmas empty_LeadsTo = empty_subsetI [THEN subset_imp_LeadsTo, simp]

lemma LeadsTo_weaken_R:
     "[| F \<in> A LeadsTo A';  A' \<subseteq> B' |] ==> F \<in> A LeadsTo B'"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_R)
done

lemma LeadsTo_weaken_L:
     "[| F \<in> A LeadsTo A';  B \<subseteq> A |]
      ==> F \<in> B LeadsTo A'"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_L)
done

lemma LeadsTo_weaken:
     "[| F \<in> A LeadsTo A';
         B  \<subseteq> A;   A' \<subseteq> B' |]
      ==> F \<in> B LeadsTo B'"
by (blast intro: LeadsTo_weaken_R LeadsTo_weaken_L LeadsTo_Trans)

lemma Always_LeadsTo_weaken:
     "[| F \<in> Always C;  F \<in> A LeadsTo A';
         C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B LeadsTo B'"
by (blast dest: Always_LeadsToI intro: LeadsTo_weaken intro: Always_LeadsToD)

(** Two theorems for "proof lattices" **)

lemma LeadsTo_Un_post: "F \<in> A LeadsTo B ==> F \<in> (A \<union> B) LeadsTo B"
by (blast intro: LeadsTo_Un subset_imp_LeadsTo)

lemma LeadsTo_Trans_Un:
     "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |]
      ==> F \<in> (A \<union> B) LeadsTo C"
by (blast intro: LeadsTo_Un subset_imp_LeadsTo LeadsTo_weaken_L LeadsTo_Trans)

(** Distributive laws **)

lemma LeadsTo_Un_distrib:
     "(F \<in> (A \<union> B) LeadsTo C)  = (F \<in> A LeadsTo C & F \<in> B LeadsTo C)"
by (blast intro: LeadsTo_Un LeadsTo_weaken_L)

lemma LeadsTo_UN_distrib:
     "(F \<in> (\<Union>i \<in> I. A i) LeadsTo B)  =  (\<forall>i \<in> I. F \<in> (A i) LeadsTo B)"
by (blast intro: LeadsTo_UN LeadsTo_weaken_L)

lemma LeadsTo_Union_distrib:
     "(F \<in> (Union S) LeadsTo B)  =  (\<forall>A \<in> S. F \<in> A LeadsTo B)"
by (blast intro: LeadsTo_Union LeadsTo_weaken_L)

(** More rules using the premise "Always INV" **)

lemma LeadsTo_Basis: "F \<in> A Ensures B ==> F \<in> A LeadsTo B"
by (simp add: Ensures_def LeadsTo_def leadsTo_Basis)

lemma EnsuresI:
     "[| F \<in> (A-B) Co (A \<union> B);  F \<in> transient (A-B) |]
      ==> F \<in> A Ensures B"
apply (simp add: Ensures_def Constrains_eq_constrains)
apply (blast intro: ensuresI constrains_weaken transient_strengthen)
done

lemma Always_LeadsTo_Basis:
     "[| F \<in> Always INV;
         F \<in> (INV \<inter> (A-A')) Co (A \<union> A');
         F \<in> transient (INV \<inter> (A-A')) |]
  ==> F \<in> A LeadsTo A'"
apply (rule Always_LeadsToI, assumption)
apply (blast intro: EnsuresI LeadsTo_Basis Always_ConstrainsD [THEN Constrains_weaken] transient_strengthen)
done

text{*Set difference: maybe combine with @{text leadsTo_weaken_L}??
  This is the most useful form of the "disjunction" rule*}
lemma LeadsTo_Diff:
     "[| F \<in> (A-B) LeadsTo C;  F \<in> (A \<inter> B) LeadsTo C |]
      ==> F \<in> A LeadsTo C"
by (blast intro: LeadsTo_Un LeadsTo_weaken)

lemma LeadsTo_UN_UN:
     "(!! i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i))
      ==> F \<in> (\<Union>i \<in> I. A i) LeadsTo (\<Union>i \<in> I. A' i)"
apply (simp only: Union_image_eq [symmetric])
apply (blast intro: LeadsTo_Union LeadsTo_weaken_R)
done

text{*Version with no index set*}
lemma LeadsTo_UN_UN_noindex:
     "(!!i. F \<in> (A i) LeadsTo (A' i)) ==> F \<in> (\<Union>i. A i) LeadsTo (\<Union>i. A' i)"
by (blast intro: LeadsTo_UN_UN)

text{*Version with no index set*}
lemma all_LeadsTo_UN_UN:
     "\<forall>i. F \<in> (A i) LeadsTo (A' i)
      ==> F \<in> (\<Union>i. A i) LeadsTo (\<Union>i. A' i)"
by (blast intro: LeadsTo_UN_UN)

text{*Binary union version*}
lemma LeadsTo_Un_Un:
     "[| F \<in> A LeadsTo A'; F \<in> B LeadsTo B' |]
            ==> F \<in> (A \<union> B) LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un LeadsTo_weaken_R)

(** The cancellation law **)

lemma LeadsTo_cancel2:
     "[| F \<in> A LeadsTo (A' \<union> B); F \<in> B LeadsTo B' |]
      ==> F \<in> A LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un_Un subset_imp_LeadsTo LeadsTo_Trans)

lemma LeadsTo_cancel_Diff2:
     "[| F \<in> A LeadsTo (A' \<union> B); F \<in> (B-A') LeadsTo B' |]
      ==> F \<in> A LeadsTo (A' \<union> B')"
apply (rule LeadsTo_cancel2)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

lemma LeadsTo_cancel1:
     "[| F \<in> A LeadsTo (B \<union> A'); F \<in> B LeadsTo B' |]
      ==> F \<in> A LeadsTo (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: LeadsTo_cancel2)
done

lemma LeadsTo_cancel_Diff1:
     "[| F \<in> A LeadsTo (B \<union> A'); F \<in> (B-A') LeadsTo B' |]
      ==> F \<in> A LeadsTo (B' \<union> A')"
apply (rule LeadsTo_cancel1)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

text{*The impossibility law*}

text{*The set "A" may be non-empty, but it contains no reachable states*}
lemma LeadsTo_empty: "[|F \<in> A LeadsTo {}; all_total F|] ==> F \<in> Always (-A)"
apply (simp add: LeadsTo_def Always_eq_includes_reachable)
apply (drule leadsTo_empty, auto)
done

subsection{*PSP: Progress-Safety-Progress*}

text{*Special case of PSP: Misra's "stable conjunction"*}
lemma PSP_Stable:
     "[| F \<in> A LeadsTo A';  F \<in> Stable B |]
      ==> F \<in> (A \<inter> B) LeadsTo (A' \<inter> B)"
apply (simp add: LeadsTo_eq_leadsTo Stable_eq_stable)
apply (drule psp_stable, assumption)
apply (simp add: Int_ac)
done

lemma PSP_Stable2:
     "[| F \<in> A LeadsTo A'; F \<in> Stable B |]
      ==> F \<in> (B \<inter> A) LeadsTo (B \<inter> A')"
by (simp add: PSP_Stable Int_ac)

lemma PSP:
     "[| F \<in> A LeadsTo A'; F \<in> B Co B' |]
      ==> F \<in> (A \<inter> B') LeadsTo ((A' \<inter> B) \<union> (B' - B))"
apply (simp add: LeadsTo_def Constrains_eq_constrains)
apply (blast dest: psp intro: leadsTo_weaken)
done

lemma PSP2:
     "[| F \<in> A LeadsTo A'; F \<in> B Co B' |]
      ==> F \<in> (B' \<inter> A) LeadsTo ((B \<inter> A') \<union> (B' - B))"
by (simp add: PSP Int_ac)

lemma PSP_Unless:
     "[| F \<in> A LeadsTo A'; F \<in> B Unless B' |]
      ==> F \<in> (A \<inter> B) LeadsTo ((A' \<inter> B) \<union> B')"
apply (unfold Unless_def)
apply (drule PSP, assumption)
apply (blast intro: LeadsTo_Diff LeadsTo_weaken subset_imp_LeadsTo)
done

lemma Stable_transient_Always_LeadsTo:
     "[| F \<in> Stable A;  F \<in> transient C;
         F \<in> Always (-A \<union> B \<union> C) |] ==> F \<in> A LeadsTo B"
apply (erule Always_LeadsTo_weaken)
apply (rule LeadsTo_Diff)
   prefer 2
   apply (erule
          transient_imp_leadsTo [THEN leadsTo_imp_LeadsTo, THEN PSP_Stable2])
   apply (blast intro: subset_imp_LeadsTo)+
done

subsection{*Induction rules*}

(** Meta or object quantifier ????? **)
lemma LeadsTo_wf_induct:
     "[| wf r;
         \<forall>m. F \<in> (A \<inter> f-`{m}) LeadsTo
                    ((A \<inter> f-`(r^-1 `` {m})) \<union> B) |]
      ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_eq_leadsTo)
apply (erule leadsTo_wf_induct)
apply (blast intro: leadsTo_weaken)
done

lemma Bounded_induct:
     "[| wf r;
         \<forall>m \<in> I. F \<in> (A \<inter> f-`{m}) LeadsTo
                      ((A \<inter> f-`(r^-1 `` {m})) \<union> B) |]
      ==> F \<in> A LeadsTo ((A - (f-`I)) \<union> B)"
apply (erule LeadsTo_wf_induct, safe)
apply (case_tac "m \<in> I")
apply (blast intro: LeadsTo_weaken)
apply (blast intro: subset_imp_LeadsTo)
done

lemma LessThan_induct:
     "(!!m::nat. F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(lessThan m)) \<union> B))
      ==> F \<in> A LeadsTo B"
by (rule wf_less_than [THEN LeadsTo_wf_induct], auto)

text{*Integer version.  Could generalize from 0 to any lower bound*}
lemma integ_0_le_induct:
     "[| F \<in> Always {s. (0::int) \<le> f s};
         !! z. F \<in> (A \<inter> {s. f s = z}) LeadsTo
                   ((A \<inter> {s. f s < z}) \<union> B) |]
      ==> F \<in> A LeadsTo B"
apply (rule_tac f = "nat o f" in LessThan_induct)
apply (simp add: vimage_def)
apply (rule Always_LeadsTo_weaken, assumption+)
apply (auto simp add: nat_eq_iff nat_less_iff)
done

lemma LessThan_bounded_induct:
     "!!l::nat. \<forall>m \<in> greaterThan l.
                   F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(lessThan m)) \<union> B)
            ==> F \<in> A LeadsTo ((A \<inter> (f-`(atMost l))) \<union> B)"
apply (simp only: Diff_eq [symmetric] vimage_Compl
                  Compl_greaterThan [symmetric])
apply (rule wf_less_than [THEN Bounded_induct], simp)
done

lemma GreaterThan_bounded_induct:
     "!!l::nat. \<forall>m \<in> lessThan l.
                 F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(greaterThan m)) \<union> B)
      ==> F \<in> A LeadsTo ((A \<inter> (f-`(atLeast l))) \<union> B)"
apply (rule_tac f = f and f1 = "%k. l - k"
       in wf_less_than [THEN wf_inv_image, THEN LeadsTo_wf_induct])
apply (simp add: Image_singleton, clarify)
apply (case_tac "m<l")
 apply (blast intro: LeadsTo_weaken_R diff_less_mono2)
apply (blast intro: not_leE subset_imp_LeadsTo)
done

subsection{*Completion: Binary and General Finite versions*}

lemma Completion:
     "[| F \<in> A LeadsTo (A' \<union> C);  F \<in> A' Co (A' \<union> C);
         F \<in> B LeadsTo (B' \<union> C);  F \<in> B' Co (B' \<union> C) |]
      ==> F \<in> (A \<inter> B) LeadsTo ((A' \<inter> B') \<union> C)"
apply (simp add: LeadsTo_eq_leadsTo Constrains_eq_constrains Int_Un_distrib)
apply (blast intro: completion leadsTo_weaken)
done

lemma Finite_completion_lemma:
     "finite I
      ==> (\<forall>i \<in> I. F \<in> (A i) LeadsTo (A' i \<union> C)) -->
          (\<forall>i \<in> I. F \<in> (A' i) Co (A' i \<union> C)) -->
          F \<in> (\<Inter>i \<in> I. A i) LeadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
apply (erule finite_induct, auto)
apply (rule Completion)
   prefer 4
   apply (simp only: INT_simps [symmetric])
   apply (rule Constrains_INT, auto)
done

lemma Finite_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i \<union> C);
         !!i. i \<in> I ==> F \<in> (A' i) Co (A' i \<union> C) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) LeadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
by (blast intro: Finite_completion_lemma [THEN mp, THEN mp])

lemma Stable_completion:
     "[| F \<in> A LeadsTo A';  F \<in> Stable A';
         F \<in> B LeadsTo B';  F \<in> Stable B' |]
      ==> F \<in> (A \<inter> B) LeadsTo (A' \<inter> B')"
apply (unfold Stable_def)
apply (rule_tac C1 = "{}" in Completion [THEN LeadsTo_weaken_R])
apply (force+)
done

lemma Finite_stable_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i);
         !!i. i \<in> I ==> F \<in> Stable (A' i) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) LeadsTo (\<Inter>i \<in> I. A' i)"
apply (unfold Stable_def)
apply (rule_tac C1 = "{}" in Finite_completion [THEN LeadsTo_weaken_R])
apply (simp_all, blast+)
done

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Example
imports System_S
begin

definition "id0 \<equiv> 0"
definition  "id1 \<equiv> 1"
definition  "id2 \<equiv> 2"

definition "e0 \<equiv> Entity {\<lparr> target = id1, rights = {Store}\<rparr>}"
definition "e1 \<equiv> Entity {\<lparr> target = id2, rights = {Grant}\<rparr>}"
definition "e2 \<equiv> Entity {}"

lemmas id_defs = id0_def id1_def id2_def
lemmas entity_defs = e0_def e1_def e2_def

definition example_state :: "state" where
"example_state \<equiv> [0 \<mapsto> e0, 1 \<mapsto> e1, 2 \<mapsto> e2] "

lemma de0:
  "direct_caps_of example_state id0 =
   {\<lparr> target = id1, rights = {Store}\<rparr>}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma de1:
  "direct_caps_of example_state id1 =
   {\<lparr> target = id2, rights = {Grant}\<rparr>}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma de2: "direct_caps_of example_state id2 = {}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma scd:
  "store_connected_direct example_state = {(id0,id1)}"
  by (auto simp: store_connected_direct_def direct_caps_of_def
                 example_state_def id_defs entity_defs
          split: if_split_asm option.splits
           cong: conj_cong)

lemma sc:
  "store_connected example_state = {(id0,id1)} \<union> Id"
  apply simp
  apply (rule equalityI)
  apply (insert scd)
   apply (simp add: store_connected_def)
   apply clarsimp
   apply (erule converse_rtranclE)
    apply simp
   apply clarsimp
   apply (erule rtranclE)
    apply simp
   apply clarsimp
  apply (fastforce simp: store_connected_def)
  done

lemma sc': "store_connected example_state = Id \<union> {(0,1)}"
  by (clarsimp simp: sc id_defs)

lemma ce0:
  "caps_of example_state id0 =
   {\<lparr>target = id1, rights = {Store}\<rparr>,
    \<lparr>target = id2, rights = {Grant}\<rparr>}"
  by (fastforce simp: caps_of_def sc Collect_disj_eq de0 de1)

lemma ce1:
  "caps_of example_state id1 =
   {\<lparr> target = id2, rights = {Grant}\<rparr>}"
  apply (clarsimp simp: caps_of_def sc Collect_disj_eq de0 de1)
  apply (simp add: id0_def id1_def)
  done

lemma ce2: "caps_of example_state id2 = {}"
  apply (simp add: caps_of_def sc)
  apply (rule allI)
  apply (rule conjI)
   apply (simp add: id0_def id2_def)
  apply (simp add: de2)
  done

end


\<comment> \<open>SPA: Students' Proof Assistant - Anders Schlichtkrull & Jørgen Villadsen, DTU Compute, Denmark\<close>

\<comment> \<open>Based on our Archive of Formal Proofs entry https://www.isa-afp.org/entries/FOL_Harrison.shtml\<close>

\<comment> \<open>Acknowledgement: Thanks to Alexander Birch Jensen for collaboration on the first formalization\<close>

theory SPA_Examples imports SPA
begin

section \<open>Pelletier's Problem 1\<close>

ML_val \<open>

auto "p ==> q <=> ~q ==> ~p"

\<close>

section \<open>Pelletier's Problem 2\<close>

ML_val \<open>

auto "~ ~p <=> p"

\<close>

section \<open>Pelletier's Problem 3\<close>

ML_val \<open>

auto "~(p ==> q) ==> q ==> p"

\<close>

section \<open>Pelletier's Problem 4\<close>

ML_val \<open>

auto "~p ==> q <=> ~q ==> p"

\<close>

section \<open>Pelletier's Problem 5\<close>

ML_val \<open>

auto "(p \\/ q ==> p \\/ r) ==> p \\/ (q ==> r)"

\<close>

section \<open>Pelletier's Problem 6\<close>

ML_val \<open>

auto "p \\/ ~p"

\<close>

section \<open>Pelletier's Problem 7\<close>

ML_val \<open>

auto "p \\/ ~ ~ ~p"

\<close>

section \<open>Pelletier's Problem 8\<close>

ML_val \<open>

auto "((p ==> q) ==> p) ==> p"

\<close>

section \<open>Pelletier's Problem 9\<close>

ML_val \<open>

auto "(p \\/ q) /\\ (~p \\/ q) /\\ (p \\/ ~q) ==> ~(~q \\/ ~q)"

\<close>

section \<open>Pelletier's Problem 10\<close>

ML_val \<open>

auto "(q ==> r) /\\ (r ==> p /\\ q) /\\ (p ==> q /\\ r) ==> (p <=> q)"

\<close>

section \<open>Pelletier's Problem 11\<close>

ML_val \<open>

auto "p <=> p"

\<close>

section \<open>Pelletier's Problem 12\<close>

ML_val \<open>

auto "((p <=> q) <=> r) <=> (p <=> (q <=> r))"

\<close>

section \<open>Pelletier's Problem 13\<close>

ML_val \<open>

auto "p \\/ q /\\ r <=> (p \\/ q) /\\ (p \\/ r)"

\<close>

section \<open>Pelletier's Problem 14\<close>

ML_val \<open>

auto "(p <=> q) <=> (q \\/ ~p) /\\ (~q \\/ p)"

\<close>

section \<open>Pelletier's Problem 15\<close>

ML_val \<open>

auto "p ==> q <=> ~p \\/ q"

\<close>

section \<open>Pelletier's Problem 16\<close>

ML_val \<open>

auto "(p ==> q) \\/ (q ==> p)"

\<close>

section \<open>Pelletier's Problem 17\<close>

ML_val \<open>

auto "p /\\ (q ==> r) ==> s <=> (~p \\/ q \\/ s) /\\ (~p \\/ ~r \\/ s)"

\<close>

section \<open>Pelletier's Problem 18\<close>

ML_val \<open>

auto "exists y. forall x. P(y) ==> P(x)"

\<close>

section \<open>Pelletier's Problem 19\<close>

ML_val \<open>

auto "exists x. forall y z. (P(y) ==> Q(z)) ==> P(x) ==> Q(x)"

\<close>

section \<open>Pelletier's Problem 20\<close>

ML_val \<open>

auto ("(forall x y. exists z. forall w. P(x) /\\ Q(y) ==> R(z) /\\ U(w)) " ^
      "==> (exists x y. P(x) /\\ Q(y)) ==> (exists z. R(z))")

\<close>

section \<open>Pelletier's Problem 21\<close>

ML_val \<open>

auto "(exists x. P ==> Q(x)) /\\ (exists x. Q(x) ==> P) ==> (exists x. P <=> Q(x))"

\<close>

section \<open>Pelletier's Problem 22\<close>

ML_val \<open>

auto "(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))"

\<close>

section \<open>Pelletier's Problem 23\<close>

ML_val \<open>

auto "(forall x. P \\/ Q(x)) <=> P \\/ (forall x. Q(x))"

\<close>

section \<open>Pelletier's Problem 24\<close>

ML_val \<open>

auto ("~(exists x. U(x) /\\ Q(x)) /\\ " ^
      "(forall x. P(x) ==> Q(x) \\/ R(x)) /\\ " ^
      "~(exists x. P(x) ==> (exists x. Q(x))) /\\ " ^
      "(forall x. Q(x) /\\ R(x) ==> U(x)) " ^
      "==> (exists x. P(x) /\\ R(x))")

\<close>

section \<open>Pelletier's Problem 25\<close>

ML_val \<open>

auto ("(exists x. P(x)) /\\ " ^
      "(forall x. U(x) ==> ~G(x) /\\ R(x)) /\\ " ^
      "(forall x. P(x) ==> G(x) /\\ U(x)) /\\ " ^
      "((forall x. P(x) ==> Q(x)) \\/ (exists x. Q(x) /\\ P(x))) " ^
      "==> (exists x. Q(x) /\\ P(x))")

\<close>

section \<open>Pelletier's Problem 26\<close>

ML_val \<open>

auto ("((exists x. P(x)) <=> (exists x. Q(x))) /\\ " ^
      "(forall x y. P(x) /\\ Q(y) ==> (R(x) <=> U(y))) " ^
      "==> ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))")

\<close>

section \<open>Pelletier's Problem 27\<close>

ML_val \<open>

auto ("(exists x. P(x) /\\ ~Q(x)) /\\ " ^
      "(forall x. P(x) ==> R(x)) /\\ " ^
      "(forall x. U(x) /\\ V(x) ==> P(x)) /\\ " ^
      "(exists x. R(x) /\\ ~Q(x)) " ^
      "==> (forall x. V(x) ==> ~R(x)) ==> (forall x. U(x) ==> ~V(x))")

\<close>

section \<open>Pelletier's Problem 28\<close>

ML_val \<open>

auto ("(forall x. P(x) ==> (forall x. Q(x))) /\\ " ^
      "((forall x. Q(x) \\/ R(x)) ==> (exists x. Q(x) /\\ R(x))) /\\ " ^
      "((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) " ^
      "==> (forall x. P(x) /\\ L(x) ==> M(x))")

\<close>

section \<open>Pelletier's Problem 29\<close>

ML_val \<open>

auto ("(exists x. P(x)) /\\ (exists x. G(x)) ==> " ^
      "((forall x. P(x) ==> H(x)) /\\ (forall x. G(x) ==> J(x)) " ^
      "<=> (forall x y. P(x) /\\ G(y) ==> H(x) /\\ J(y)))")

\<close>

section \<open>Pelletier's Problem 30\<close>

ML_val \<open>

auto ("(forall x. P(x) \\/ G(x) ==> ~H(x)) /\\ " ^
      "(forall x. (G(x) ==> ~U(x)) ==> P(x) /\\ H(x)) " ^
      "==> (forall x. U(x))")

\<close>

section \<open>Pelletier's Problem 31\<close>

ML_val \<open>

auto ("~(exists x. P(x) /\\ (G(x) \\/ H(x))) /\\ " ^
      "(exists x. Q(x) /\\ P(x)) /\\ " ^
      "(forall x. ~H(x) ==> J(x)) " ^
      "==> (exists x. Q(x) /\\ J(x))")

\<close>

section \<open>Pelletier's Problem 32\<close>

ML_val \<open>

auto ("(forall x. P(x) /\\ (G(x) \\/ H(x)) ==> Q(x)) /\\ " ^
      "(forall x. Q(x) /\\ H(x) ==> J(x)) /\\ " ^
      "(forall x. R(x) ==> H(x)) " ^
      "==> (forall x. P(x) /\\ R(x) ==> J(x))")

\<close>

section \<open>Pelletier's Problem 33\<close>

ML_val \<open>

auto ("(forall x. P(a) /\\ (P(x) ==> P(b)) ==> P(c)) " ^
      "<=> (forall x. P(a) ==> P(x) \\/ P(c)) /\\ (P(a) ==> P(b) ==> P(c))")

\<close>

section \<open>Pelletier's Problem 34\<close>

ML_val \<open>

prove
(<!("((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) <=>"
  ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y))))")!>)
[

  note ("directions",
  <!("(((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) ==>"
   ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y))))) /\\"
   ^ "(((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))) ==>"
   ^ "((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))))")!>)
  proof
  [
    conclude
    (<!("((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) ==>"
      ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y))))")!>)
    proof
    [
      assume [("A",
      <!"(exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))"!>)],

      note ("ant",
      <!("((exists x. forall y. Q(x) <=> Q(y)) ==> ((exists x. P(x)) <=> (forall y. P(y)))) /\\"
       ^ "(((exists x. P(x)) <=> (forall y. P(y))) ==> ((exists x. forall y. Q(x) <=> Q(y))))")!>)
      proof
      [

        conclude
        (<!"(exists x. forall y. Q(x) <=> Q(y)) ==> ((exists x. P(x)) <=> (forall y. P(y)))"!>)
        proof
        [
          assume [("", <!"exists x. forall y. Q(x) <=> Q(y)"!>)],
          so have (<!"(exists x. Q(x)) <=> (forall y. Q(y))"!>) at once,
          so have (<!"exists x. forall y. P(x) <=> P(y)"!>) by ["A"],
          so our thesis at once,
          qed
        ],

        conclude
        (<!"((exists x. P(x)) <=> (forall y. P(y))) ==> (exists x. forall y. Q(x) <=> Q(y))"!>)
        proof
        [
          note ("imp",
          <!("((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) ==>"
           ^ "((exists x. forall y. P(x) <=> P(y)) ==> ((exists x. Q(x)) <=> (forall y. Q(y))))")!>)
          using [axiom_iffimp1
            (<!"exists x. forall y. P(x) <=> P(y)"!>)
            (<!"(exists x. Q(x)) <=> (forall y. Q(y))"!>)],
          note ("A1",
           <!"(exists x. forall y. P(x) <=> P(y)) ==> ((exists x. Q(x)) <=> (forall y. Q(y)))"!>)
          by_mp ("imp", "A"),

          assume [("", <!"((exists x. P(x)) <=> (forall y. P(y)))"!>)],
          so have (<!"(exists x. forall y. P(x) <=> P(y))"!>) at once,
          so have (<!"((exists x. Q(x)) <=> (forall y. Q(y)))"!>) by ["A1"],
          so our thesis at once,
          qed
        ],
        qed
      ],

      note ("imp",
      <!("((exists x. forall y. Q(x) <=> Q(y)) ==> ((exists x. P(x)) <=> (forall y. P(y)))) /\\"
       ^ "(((exists x. P(x)) <=> (forall y. P(y))) ==> ((exists x. forall y. Q(x) <=> Q(y)))) ==>"
       ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y))))")!>)
      using [unshunt (axiom_impiff
        (<!"exists x. forall y. Q(x) <=> Q(y)"!>)
        (<!"(exists x. P(x)) <=> (forall y. P(y))"!>))],

      our thesis by_mp ("imp", "ant"),
      qed
    ],

    conclude
    (<!("((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))) ==>"
      ^ "((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y))))")!>)
    proof
    [
      assume [("A",
       <!"(exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))"!>)],

      note ("ant",
      <!("((exists x. forall y. P(x) <=> P(y)) ==> ((exists x. Q(x)) <=> (forall y. Q(y)))) /\\"
       ^ "(((exists x. Q(x)) <=> (forall y. Q(y))) ==> (exists x. forall y. P(x) <=> P(y)))")!>)
      proof
      [

        conclude
        (<!"(exists x. forall y. P(x) <=> P(y)) ==> ((exists x. Q(x)) <=> (forall y. Q(y)))"!>)
        proof
        [
          assume [("", <!"exists x. forall y. P(x) <=> P(y)"!>)],
          so have (<!"(exists x. P(x)) <=> (forall y. P(y))"!>) at once,
          so have (<!"exists x. forall y. Q(x) <=> Q(y)"!>) by ["A"],
          so our thesis at once,
          qed
        ],

        conclude
        (<!"((exists x. Q(x)) <=> (forall y. Q(y))) ==> (exists x. forall y. P(x) <=> P(y))"!>)
        proof
        [
          note ("imp",
          <!("((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))) ==>"
           ^ "((exists x. forall y. Q(x) <=> Q(y)) ==> ((exists x. P(x)) <=> (forall y. P(y))))")!>)
          using [axiom_iffimp1
            (<!"exists x. forall y. Q(x) <=> Q(y)"!>)
            (<!"(exists x. P(x)) <=> (forall y. P(y))"!>)],
          note ("A1",
          <!"(exists x. forall y. Q(x) <=> Q(y)) ==> ((exists x. P(x)) <=> (forall y. P(y)))"!>)
          by_mp ("imp", "A"),

          assume [("", <!"(exists x. Q(x)) <=> (forall y. Q(y))"!>)],
          so have (<!"(exists x. forall y. Q(x) <=> Q(y))"!>) at once,
          so have (<!"((exists x. P(x)) <=> (forall y. P(y)))"!>) by ["A1"],
          so our thesis at once,
          qed
        ],
        qed
      ],

      note ("imp",
      <!("((exists x. forall y. P(x) <=> P(y)) ==> ((exists x. Q(x)) <=> (forall y. Q(y)))) /\\"
       ^ "(((exists x. Q(x)) <=> (forall y. Q(y))) ==> (exists x. forall y. P(x) <=> P(y))) ==>"
       ^ "((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y))))")!>)
      using [unshunt (axiom_impiff
        (<!"exists x. forall y. P(x) <=> P(y)"!>)
        (<!"(exists x. Q(x)) <=> (forall y. Q(y))"!>))],

      our thesis by_mp ("imp", "ant"),
      qed
    ],
    qed
  ],

  note ("impiff",
  <!(("(((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) ==>"
    ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y))))) /\\"
    ^ "(((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))) ==>"
    ^ "((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y))))) ==>"
    ^ "(((exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))) <=>"
    ^ "((exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))))"))!>)
  using [unshunt (axiom_impiff
    (<!("(exists x. forall y. P(x) <=> P(y)) <=> ((exists x. Q(x)) <=> (forall y. Q(y)))")!>)
    (<!("(exists x. forall y. Q(x) <=> Q(y)) <=> ((exists x. P(x)) <=> (forall y. P(y)))")!>))],

  our thesis by_mp ("impiff", "directions"),
  qed
]

\<close>

section \<open>Pelletier's Problem 35\<close>

ML_val \<open>

auto "exists x y. P(x,y) ==> (forall x y. P(x,y))"

\<close>

section \<open>Pelletier's Problem 36\<close>

ML_val \<open>

auto ("(forall x. exists y. P(x,y)) /\\ " ^
      "(forall x. exists y. G(x,y)) /\\ " ^
      "(forall x y. P(x,y) \\/ G(x,y) ==> (forall z. P(y,z) \\/ G(y,z) ==> H(x,z))) " ^
      "==> (forall x. exists y. H(x,y))")

\<close>

section \<open>Pelletier's Problem 37\<close>

ML_val \<open>

auto ("(forall z. " ^
        "exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\\ P(y,z) /\\ " ^
        "(P(y,w) ==> (exists u. Q(u,w)))) /\\ " ^
      "(forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\\ " ^
      "((exists x y. Q(x,y)) ==> (forall x. R(x,x))) " ^
      "==> (forall x. exists y. R(x,y))")

\<close>

section \<open>Pelletier's Problem 38\<close>

ML_val \<open>

auto ("(forall x. " ^
        "P(a) /\\ (P(x) ==> (exists y. P(y) /\\ R(x,y))) ==> " ^
        "(exists z w. P(z) /\\ R(x,w) /\\ R(w,z))) <=> " ^
      "(forall x. " ^
        "(~P(a) \\/ P(x) \\/ (exists z w. P(z) /\\ R(x,w) /\\ R(w,z))) /\\ " ^
        "(~P(a) \\/ ~(exists y. P(y) /\\ R(x,y)) \\/ " ^
        "(exists z w. P(z) /\\ R(x,w) /\\ R(w,z))))")

\<close>

section \<open>Pelletier's Problem 39\<close>

ML_val \<open>

auto "~(exists x. forall y. P(y,x) <=> ~P(y,y))"

\<close>

section \<open>Pelletier's Problem 40\<close>

ML_val \<open>

auto ("(exists y. forall x. P(x,y) <=> P(x,x)) " ^
      "==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))")

\<close>

section \<open>Pelletier's Problem 41\<close>

ML_val \<open>

auto ("(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\\ ~P(x,x)) " ^
      "==> ~(exists z. forall x. P(x,z))")

\<close>

section \<open>Pelletier's Problem 42\<close>

ML_val \<open>

auto "~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\\ P(z,x)))"

\<close>

section \<open>Pelletier's Problem 43\<close>

ML_val \<open>

prove
  (<!"(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)) ==> forall x y. Q(x,y) <=> Q(y,x)"!>)
  [
    assume [("A", <!"forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)"!>)],
    conclude (<!"forall x y. Q(x,y) <=> Q(y,x)"!>) proof
    [
      fix "x", fix "y",
      conclude (<!"Q(x,y) <=> Q(y,x)"!>) proof
      [
        have (<!"(Q(x,y) ==> Q(y,x)) /\\ (Q(y,x) ==> Q(x,y))"!>) proof
        [
          conclude (<!"Q(x,y) ==> Q(y,x)"!>) proof
          [
            assume [("", <!"Q(x,y)"!>)],
            so have (<!"forall z. P(z,x) <=> P(z,y)"!>) by ["A"],
            so have (<!"forall z. P(z,y) <=> P(z,x)"!>) at once,
            so conclude (<!"Q(y,x)"!>) by ["A"],
            qed
          ],
          conclude (<!"Q(y,x) ==> Q(x,y)"!>) proof
          [
            assume [("", <!"Q(y,x)"!>)],
            so have (<!"forall z. P(z,y) <=> P(z,x)"!>) by ["A"],
            so have (<!"forall z. P(z,x) <=> P(z,y)"!>) at once,
            so conclude (<!"Q(x,y)"!>) by ["A"],
            qed
          ],
          qed
        ],
        so our thesis at once,
        qed
      ],
      qed
    ],
    qed
  ]

\<close>

section \<open>Pelletier's Problem 44\<close>

ML_val \<open>

auto ("(forall x. P(x) ==> (exists y. G(y) /\\ H(x,y)) /\\ " ^
      "(exists y. G(y) /\\ ~H(x,y))) /\\ " ^
      "(exists x. J(x) /\\ (forall y. G(y) ==> H(x,y))) ==> " ^
      "(exists x. J(x) /\\ ~P(x))")

\<close>

section \<open>Pelletier's Problem 45\<close>

ML_val \<open>

auto ("(forall x. " ^
        "P(x) /\\ (forall y. G(y) /\\ H(x,y) ==> J(x,y)) ==> " ^
             "(forall y. G(y) /\\ H(x,y) ==> R(y))) /\\ " ^
      "~(exists y. L(y) /\\ R(y)) /\\ " ^
      "(exists x. P(x) /\\ (forall y. H(x,y) ==> " ^
        "L(y)) /\\ (forall y. G(y) /\\ H(x,y) ==> J(x,y))) ==> " ^
      "(exists x. P(x) /\\ ~(exists y. G(y) /\\ H(x,y)))")

\<close>

section \<open>Pelletier's Problem 46\<close>

ML_val \<open>

  prove
    (<!("(forall x. P(x) /\\ (forall y. P(y) /\\ H(y,x) ==> G(y)) ==> G(x)) /\\ " ^
          "((exists x. P(x) /\\ ~G(x)) ==> " ^
            "(exists x. P(x) /\\ ~G(x) /\\ (forall y. P(y) /\\ ~G(y) ==> J(x,y)))) /\\ " ^
          "(forall x y. P(x) /\\ P(y) /\\ H(x,y) ==> ~J(y,x)) ==> " ^
          "(forall x. P(x) ==> G(x))")!>)
    [
      assume [("A", <!("(forall x. P(x) /\\ (forall y. P(y) /\\ H(y,x) ==> G(y)) ==> G(x)) /\\ " ^
          "((exists x. P(x) /\\ ~G(x)) ==> " ^
            "(exists x. P(x) /\\ ~G(x) /\\ (forall y. P(y) /\\ ~G(y) ==> J(x,y)))) /\\ " ^
          "(forall x y. P(x) /\\ P(y) /\\ H(x,y) ==> ~J(y,x))")!>)],
      conclude (<!"(forall x. P(x) ==> G(x))"!>) proof
      [
        fix "x",
        conclude (<!"P(x) ==> G(x)"!>) proof
        [
          assume [("B", <!"P(x)"!>)],
          conclude (<!"G(x)"!>) by ["B","A"], qed
        ], qed
      ], qed
    ]

\<close>

section \<open>Pelletier's Problem 55\<close>

ML_val \<open>

auto ("lives(agatha) /\\ lives(butler) /\\ lives(charles) /\\ " ^
      "(killed(agatha,agatha) \\/ killed(butler,agatha) \\/ " ^
       "killed(charles,agatha)) /\\ " ^
      "(forall x y. killed(x,y) ==> hates(x,y) /\\ ~richer(x,y)) /\\ " ^
      "(forall x. hates(agatha,x) ==> ~hates(charles,x)) /\\ " ^
      "(hates(agatha,agatha) /\\ hates(agatha,charles)) /\\ " ^
      "(forall x. lives(x) /\\ ~richer(x,agatha) ==> hates(butler,x)) /\\ " ^
      "(forall x. hates(agatha,x) ==> hates(butler,x)) /\\ " ^
      "(forall x. ~hates(x,agatha) \\/ ~hates(x,butler) \\/ ~hates(x,charles)) " ^
      "==> killed(agatha,agatha) /\\ " ^
             "~killed(butler,agatha) /\\ " ^
             "~killed(charles,agatha)")

\<close>

section \<open>Pelletier's Problem 57\<close>

ML_val \<open>

auto ("P(f(a,b),f(b,c)) /\\ " ^
      "P(f(b,c),f(a,c)) /\\ " ^
      "(forall x y z. P(x,y) /\\ P(y,z) ==> P(x,z)) " ^
      "==> P(f(a,b),f(a,c))")

\<close>

section \<open>Pelletier's Problem 59\<close>

ML_val \<open>

auto "(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\\ ~P(f(x)))"

\<close>

section \<open>Pelletier's Problem 60\<close>

ML_val \<open>

auto "forall x. P(x,f(x)) <=> exists y. (forall z. P(z,y) ==> P(z,f(x))) /\\ P(x,y)"

\<close>

section \<open>Appendix\<close>

ML_val \<open> \<comment> \<open>Test gilmore_3\<close>

auto ("exists x. forall y z. " ^
              "((F(y,z) ==> (G(y) ==> H(x))) ==> F(x,x)) /\\ " ^
              "((F(z,x) ==> G(x)) ==> H(z)) /\\ " ^
              "F(x,y) " ^
              "==> F(z,z)")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_4\<close>

auto ("exists x y. forall z. " ^
              "(F(x,y) ==> F(y,z) /\\ F(z,z)) /\\ " ^
              "(F(x,y) /\\ G(x,y) ==> G(x,z) /\\ G(z,z))")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_5\<close>

auto ("(forall x. exists y. F(x,y) \\/ F(y,x)) /\\ " ^
      "(forall x y. F(y,x) ==> F(y,y)) " ^
      "==> exists z. F(z,z)")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_6\<close>

auto ("forall x. exists y. " ^
              "(exists u. forall v. F(u,x) ==> G(v,u) /\\ G(u,x)) " ^
              "==> (exists u. forall v. F(u,y) ==> G(v,u) /\\ G(u,y)) \\/ " ^
                        "(forall u v. exists w. G(v,u) \\/ H(w,y,u) ==> G(u,w))")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_7\<close>

auto ("(forall x. K(x) ==> exists y. L(y) /\\ (F(x,y) ==> G(x,y))) /\\ " ^
      "(exists z. K(z) /\\ forall u. L(u) ==> F(z,u)) " ^
      "==> exists v w. K(v) /\\ L(w) /\\ G(v,w)")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_8\<close>

auto ("exists x. forall y z. " ^
              "((F(y,z) ==> (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\\ " ^
              "((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\\ " ^
              "F(x,y) " ^
              "==> F(z,z)")

\<close>

ML_val \<open> \<comment> \<open>Test gilmore_9\<close>

auto ("forall x. exists y. forall z. " ^
              "((forall u. exists v. F(y,u,v) /\\ G(y,u) /\\ ~H(y,x)) " ^
                   "==> (forall u. exists v. F(x,u,v) /\\ G(z,u) /\\ ~H(x,z)) " ^
                   "==> (forall u. exists v. F(x,u,v) /\\ G(y,u) /\\ ~H(x,y))) /\\ " ^
              "((forall u. exists v. F(x,u,v) /\\ G(y,u) /\\ ~H(x,y)) " ^
                  "==> ~(forall u. exists v. F(x,u,v) /\\ G(z,u) /\\ ~H(x,z)) " ^
                  "==> (forall u. exists v. F(y,u,v) /\\ G(y,u) /\\ ~H(y,x)) /\\ " ^
                         "(forall u. exists v. F(z,u,v) /\\ G(y,u) /\\ ~H(z,y)))")

\<close>

ML_val \<open> \<comment> \<open>Test davis_putnam_example\<close>

auto ("exists x. exists y. forall z. " ^
      "(F(x,y) ==> (F(y,z) /\\ F(z,z))) /\\ " ^
      "((F(x,y) /\\ G(x,y)) ==> (G(x,z) /\\ G(z,z)))")

\<close>

ML_val \<open> \<comment> \<open>Hoare's Exercise ewd1062_1 & ewd1062_2\<close>

prove
  (<!("(forall x. x <= x) /\\ " ^
      "(forall x y z. x <= y /\\ y <= z ==> x <= z) /\\ " ^
      "(forall x y. f(x) <= y <=> x <= g(y)) " ^
      "==> (forall x y. x <= y ==> f(x) <= f(y)) /\\ " ^
          "(forall x y. x <= y ==> g(x) <= g(y))")!>)
  [
    assume [("A", <!("(forall x. x <= x) /\\ " ^
             "(forall x y z. x <= y /\\ y <= z ==> x <= z) /\\ " ^
             "(forall x y. f(x) <= y <=> x <= g(y))")!>)],
    conclude (<!("(forall x y. x <= y ==> f(x) <= f(y)) /\\ " ^
                 "(forall x y. x <= y ==> g(x) <= g(y))")!>) proof
    [
      conclude (<!"(forall x y. x <= y ==> f(x) <= f(y))"!>) by ["A"],
      conclude (<!"(forall x y. x <= y ==> g(x) <= g(y))"!>) by ["A"],
      qed
    ],
    qed
  ]

\<close>

ML_val \<open> \<comment> \<open>Hoare's Exercise ewd1062_1\<close>

auto ("(forall x. x <= x) /\\ " ^
      "(forall x y z. x <= y /\\ y <= z ==> x <= z) /\\ " ^
      "(forall x y. f(x) <= y <=> x <= g(y)) " ^
      "==> (forall x y. x <= y ==> f(x) <= f(y))")

\<close>

ML_val \<open> \<comment> \<open>Hoare's Exercise ewd1062_2\<close>

auto ("(forall x. x <= x) /\\ " ^
      "(forall x y z. x <= y /\\ y <= z ==> x <= z) /\\ " ^
      "(forall x y. f(x) <= y <=> x <= g(y)) " ^
      "==> (forall x y. x <= y ==> g(x) <= g(y))")

\<close>

ML_val \<open> \<comment> \<open>A simple example\<close>

val ewd954 = prove
 (<!("(forall x y. x <= y <=> x * y = x) /\\ " ^
   "(forall x y. f(x * y) = f(x) * f(y)) " ^
   "==> forall x y. x <= y ==> f(x) <= f(y)")!>)
 [note("eq_sym",<!"forall x y. x = y ==> y = x"!>)
    using [eq_sym (<!|"x"|!>) (<!|"y"|!>)],
  note("eq_trans",<!"forall x y z. x = y /\\ y = z ==> x = z"!>)
    using [eq_trans (<!|"x"|!>) (<!|"y"|!>) (<!|"z"|!>)],
  note("eq_cong",<!"forall x y. x = y ==> f(x) = f(y)"!>)
    using [axiom_funcong "f" [(<!|"x"|!>)] [(<!|"y"|!>)]],
  assume [("le",<!"forall x y. x <= y <=> x * y = x"!>),
          ("hom",<!"forall x y. f(x * y) = f(x) * f(y)"!>)],
  fix "x", fix "y",
  assume [("xy",<!"x <= y"!>)],
  so have (<!"x * y = x"!>) by ["le"],
  so have (<!"f(x * y) = f(x)"!>) by ["eq_cong"],
  so have (<!"f(x) = f(x * y)"!>) by ["eq_sym"],
  so have (<!"f(x) = f(x) * f(y)"!>) by ["eq_trans", "hom"],
  so have (<!"f(x) * f(y) = f(x)"!>) by ["eq_sym"],
  so conclude (<!"f(x) <= f(y)"!>) by ["le"],
  qed];

\<close>

ML_val \<open> \<comment> \<open>Example not in the main text\<close>

prove
 (<!("(exists x. p(x)) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(f(f(f(y)))))")!>)
  [assume [("A",<!"exists x. p(x)"!>)],
   assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
   note ("C",<!"forall x. p(x) ==> p(f(f(f(f(x)))))"!>)
   proof
    [have (<!"forall x. p(x) ==> p(f(f(x)))"!>) by ["B"],
     so conclude (<!"forall x. p(x) ==> p(f(f(f(f(x)))))"!>) at once,
     qed],
   consider ("a",<!"p(a)"!>) by ["A"],
   take (<!|"a"|!>),
   so conclude (<!"p(f(f(f(f(a)))))"!>) by ["C"],
   qed];

\<close>

ML_val \<open> \<comment> \<open>Alternative formulation with lemma construct\<close>

prove
 (<!("(exists x. p(x)) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(f(f(f(y)))))")!>)
  [assume [("A",<!"exists x. p(x)"!>)],
   assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
   lemma ("C",<!"forall x. p(x) ==> p(f(f(f(f(x)))))"!>),
     have (<!"forall x. p(x) ==> p(f(f(x)))"!>) by ["B"],
     so conclude (<!"forall x. p(x) ==> p(f(f(f(f(x)))))"!>) at once,
     qed,
   consider ("a",<!"p(a)"!>) by ["A"],
   take (<!|"a"|!>),
   so conclude (<!"p(f(f(f(f(a)))))"!>) by ["C"],
   qed]

\<close>

ML_val \<open> \<comment> \<open>Yet another formulation\<close>

prove
 (<!("(exists x. p(x)) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(f(f(f(y)))))")!>)
  [assume [("A",<!"exists x. p(x)"!>)],
   assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
   note ("C",<!"forall x. p(x) ==> p(f(f(f(f(x)))))"!>) proof
    [have (<!"forall x. p(x) ==> p(f(f(x)))"!>) by ["B"],
     so our thesis at once,
     qed],
   consider ("a",<!"p(a)"!>) by ["A"],
   take (<!|"a"|!>),
   so our thesis by ["C"],
   qed];

\<close>

ML_val \<open> \<comment> \<open>And finally automatic\<close>

auto "(exists x. p(x)) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(f(f(f(y)))))"

\<close>

ML_val \<open> \<comment> \<open>Harrison\<close>

auto "forall x. exists v w. forall y z. P(x) /\\ Q(y) ==> (P(v) \\/ R(w)) /\\ (R(z) ==> Q(v))"

\<close>

ML_val \<open>

prove (<!("forall a. p(a) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(y) /\\ p(f(y))")!>)
      [fix "c",
       assume [("A",<!"p(c)"!>)],
       assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
       take (<!|"c"|!>),
       conclude (<!"p(c)"!>) by ["A"],
       note ("C",<!"p(c) ==> p(f(c))"!>) by ["B"],
       so our thesis by ["C", "A"],
       qed];

\<close>

ML_val \<open>

prove (<!("p(c) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(y) /\\ p(f(y))")!>)
      [assume [("A",<!"p(c)"!>)],
       assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
       take (<!|"c"|!>),
       conclude (<!"p(c)"!>) by ["A"],
       our thesis by ["A", "B"],
       qed];

\<close>

ML_val \<open>

prove (<!("forall a. p(a) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(y) /\\ p(f(y))")!>)
      [fix "c",
       assume [("A",<!"p(c)"!>)],
       assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
       take (<!|"c"|!>),
       conclude (<!"p(c)"!>) by ["A"],
       note ("C",<!"p(c) ==> p(f(c))"!>) by ["B"],
       our thesis by ["C", "A"],
       qed];

\<close>

ML_val \<open>

prove (<!("forall a. p(a) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(y) /\\ p(f(y))")!>)
      [fix "c",
       assume [("A",<!"p(c)"!>)],
       assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
       take (<!|"c"|!>),
       note ("D",<!"p(c)"!>) by ["A"],
       note ("C",<!"p(c) ==> p(f(c))"!>) by ["B"],
       our thesis by ["C", "A", "D"],
       qed];

\<close>

ML_val \<open>

prove (<!"(p(a) \\/ p(b)) ==> q ==> exists y. p(y)"!>)
  [assume [("A",<!"p(a) \\/ p(b)"!>)],
   assume [("",<!"q"!>)],
   cases (<!"p(a) \\/ p(b)"!>) by ["A"],
     take (<!|"a"|!>),
     so our thesis at once,
     qed,
     take (<!|"b"|!>),
     so our thesis at once,
     qed];

\<close>

ML_val \<open>

prove (<!"(p(a) \\/ p(b)) /\\ (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(y))"!>)
  [assume [("base",<!"p(a) \\/ p(b)"!>),
           ("Step",<!"forall x. p(x) ==> p(f(x))"!>)],
   cases (<!"p(a) \\/ p(b)"!>) by ["base"],
     so note("A",<!"p(a)"!>) at once,
     note ("X",<!"p(a) ==> p(f(a))"!>) by ["Step"],
     take (<!|"a"|!>),
     our thesis by ["A", "X"],
     qed,
     take (<!|"b"|!>),
     so our thesis by ["Step"],
     qed];

\<close>

ML_val \<open>

prove (<!"(exists x. p(x)) ==> (forall x. p(x) ==> p(f(x))) ==> exists y. p(f(y))"!>)
  [assume [("A",<!"exists x. p(x)"!>)],
   assume [("B",<!"forall x. p(x) ==> p(f(x))"!>)],
   consider ("a",<!"p(a)"!>) by ["A"],
   so note ("concl",<!"p(f(a))"!>) by ["B"],
   take (<!|"a"|!>),
   our thesis by ["concl"],
   qed];

\<close>

ML_val \<open>

prove (<!("(forall x. p(x) ==> q(x)) ==> (forall x. q(x) ==> p(x)) ==> (p(a) <=> q(a))")!>)
  [assume [("A",<!"forall x. p(x) ==> q(x)"!>)],
   assume [("B",<!"forall x. q(x) ==> p(x)"!>)],
   note ("von",<!"p(a) ==> q(a)"!>) by ["A"],
   note ("bis",<!"q(a) ==> p(a)"!>) by ["B"],
   our thesis by ["von", "bis"],
   qed];

\<close>

ML_val \<open>

auto "forall x. exists y. (P(x) \\/ P(y)) ==> exists x. P(x)"

\<close>

end


section \<open>Reducing Rewrite Properties to Properties on Ground Terms over Left-Linear Right-Ground Systems\<close>
theory Ground_Reduction_on_LLRG
  imports
    Rewriting_Properties
    Rewriting_LLRG_LV_Mondaic
begin

lemma llrg_linear_sys:
  "llrg \<R> \<Longrightarrow> linear_sys \<R>"
  by (auto simp: llrg_def)

section \<open>LLRG results\<close>

lemma llrg_commute:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" "funas_rel \<S> \<subseteq> \<F>"
   and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>" "llrg \<S>"
   and com: "commute (gsrstep (insert (c, 0) \<F>) \<R>) (gsrstep (insert (c, 0) \<F>) \<S>)"
  shows "commute (srstep \<F> \<R>) (srstep \<F> \<S>)"
proof -
  let ?\<sigma> = "\<lambda> _. Fun c []" let ?\<H> = "insert (c, 0) \<F>"
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<S>" "(c, 0) \<notin> funas_rel (\<R>\<inverse>)" using sig
    by (auto simp: funas_rel_def)
  have linear: "linear_sys \<S>" "linear_sys (\<R>\<inverse>)" using llrg unfolding llrg_def by auto
  have sig': "funas_rel \<S> \<subseteq> \<F>" "funas_rel (\<R>\<inverse>) \<subseteq> \<F>" using sig by (auto simp: funas_rel_def)
  have mono: "\<F> \<subseteq> ?\<H>" by auto
  {fix s t assume ass: "(s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<S>"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
      by (metis Un_iff relcomp.cases srstepsD srsteps_with_root_step_srstepsD)+
    from ass have m: "(s, t) \<in> (srstep ?\<H> (\<R>\<inverse>))\<^sup>* O (srstep ?\<H> \<S>)\<^sup>*"
      using rtrancl_mono[OF sig_step_mono[OF mono]]
      by (auto dest!: srsteps_with_root_step_sresteps_eqD trancl_into_rtrancl)
    have gr: "ground s \<or> ground t" using ass llrg
      unfolding srstep_converse_dist trancl_converse
      by (auto simp: llrg_srsteps_with_root_step_inv_ground llrg_srsteps_with_root_step_ground)
    have gstep: "(s \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (gsrstep ?\<H> \<S>)\<^sup>* O (gsrstep ?\<H> (\<R>\<inverse>))\<^sup>*"
      using srsteps_eq_subst_relcomp_closed[OF m, THEN srsteps_eq_relcomp_gsrsteps_relcomp, of ?\<sigma>,
        THEN subsetD[OF com[unfolded commute_def], unfolded rew_converse_inwards]]
      by (auto simp: ground_substI)
    have [simp]: "ground s \<Longrightarrow> (c, 0) \<notin> funas_term s" "ground t \<Longrightarrow> (c, 0) \<notin> funas_term t"
      using funas fresh by auto
    have "(s, t) \<in> (rstep \<S>)\<^sup>* O (rstep (\<R>\<inverse>))\<^sup>*"
      using remove_const_subst_relcomp_lhs[OF linear fresh_sys, of t s]
      using gsrsteps_eq_relcomp_to_rsteps_relcomp[OF gstep] gr
      using remove_const_subst_relcomp_lhs[OF linear fresh_sys, of t s]
      using remove_const_subst_relcomp_rhs[OF linear fresh_sys, of s t]
        by (cases "ground s") (simp_all add: ground_subst_apply)
    from rsteps_eq_relcomp_srsteps_eq_relcompI[OF sig' funas this]
    have "commute_redp \<F> \<R> \<S> s t" unfolding commute_redp_def
      by (simp add: rew_converse_inwards)}
  then show ?thesis by (intro commute_rrstep_intro) simp
qed

lemma llrg_CR:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>"
   and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>"
   and com: "CR (gsrstep (insert (c, 0) \<F>) \<R>)"
  shows "CR (srstep \<F> \<R>)"
  using assms llrg_commute unfolding CR_iff_self_commute
  by metis

lemma llrg_SCR:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>"
   and scr: "SCR (gsrstep (insert (c, 0) \<F>) \<R>)"
  shows "SCR (srstep \<F> \<R>)"
proof -
  let ?\<sigma> = "const_subst c" let ?\<H> = "insert (c, 0) \<F>"
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<R>" using sig
    by (auto simp: funas_rel_def)
  have mono: "\<F> \<subseteq> ?\<H>" by auto note sig_trans = subsetD[OF srstep_monp[OF mono]]
  {fix s t u assume ass: "(s, t) \<in> srstep \<F> \<R>" "(s, u) \<in> srstep \<F> \<R>"
    and root: "(s, t) \<in> sig_step \<F> (rrstep \<R>) \<or> (s, u) \<in> sig_step \<F> (rrstep \<R>)"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>"
      by (force dest: sig_stepE)+
    from root have gr: "ground t \<or> ground u" using ass llrg llrg_rrsteps_groundness
      unfolding srstep_converse_dist trancl_converse by blast
    have *: "ground (s \<cdot> ?\<sigma>)" "ground (t \<cdot> ?\<sigma>)" "ground (u \<cdot> ?\<sigma>)" by auto
    from this scr obtain v where v: "(t \<cdot> ?\<sigma>, v) \<in> (gsrstep ?\<H> \<R>)\<^sup>= \<and> (u \<cdot> ?\<sigma>, v) \<in> (gsrstep ?\<H> \<R>)\<^sup>*"
      using srstep_subst_closed[OF sig_trans[OF ass(1)], of ?\<sigma>]
      using srstep_subst_closed[OF sig_trans[OF ass(2)], of ?\<sigma>]
      using ass unfolding SCR_on_def
      by auto (metis (no_types, lifting) * )
    then have fv: "funas_term v \<subseteq> \<F>" using gr llrg_funas_term_step_pres[OF llrg, of _ v]
      using llrg_funas_term_steps_pres[OF llrg, of _ v] funas sig
      by (auto simp: ground_subst_apply elim!: sig_stepE dest!: gsrsteps_eq_to_rsteps_eq) blast+
    then have c_free: "(c, 0) \<notin> funas_term v" using fresh by blast
    then have "v = t \<cdot> const_subst c \<Longrightarrow> ground t" using arg_cong[of v "t \<cdot> ?\<sigma>" funas_term]
      by (auto simp: funas_term_subst vars_term_empty_ground split: if_splits)
    from this v have "(t, v) \<in> (srstep \<F> \<R>)\<^sup>=" "(u, v) \<in> (srstep \<F> \<R>)\<^sup>*"
      using remove_const_subst_steps_eq_lhs[OF llrg_linear_sys[OF llrg] fresh_sys c_free, of u,
        THEN rsteps_eq_srsteps_eqI[OF sig funas(3) fv]]
      using remove_const_subst_step_lhs[OF llrg_linear_sys[OF llrg] fresh_sys c_free, of t,
        THEN sig_stepI[OF funas(2) fv]]
      by (auto simp: ground_subst_apply dest: srstepD gsrsteps_eq_to_rsteps_eq)
    then have "SCRp \<F> \<R> t u" by blast}
  then show ?thesis by (intro SCR_rrstep_intro) (metis srrstep_to_srestep)+
qed

lemma llrg_WCR:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>"
   and wcr: "WCR (gsrstep (insert (c, 0) \<F>) \<R>)"
  shows "WCR (srstep \<F> \<R>)"
proof -
  let ?\<sigma> = "const_subst c" let ?\<H> = "insert (c, 0) \<F>"
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<R>" "(c, 0) \<notin> funas_rel (\<R>\<inverse>)" using sig
    by (auto simp: funas_rel_def)
  have lin: "linear_sys \<R>" "linear_sys (\<R>\<inverse>)" using llrg unfolding llrg_def by auto
  have mono: "\<F> \<subseteq> ?\<H>" by auto note sig_trans = subsetD[OF srstep_monp[OF mono]]
  {fix s t u assume ass: "(s, t) \<in> sig_step \<F> (rrstep \<R>)" "(s, u) \<in> srstep \<F> \<R>"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>"
      by blast+
    then have c_free: "(c, 0) \<notin> funas_term t" using fresh by blast
    from ass have gr: "ground t" using ass llrg llrg_rrsteps_groundness by blast
    have *: "ground (s \<cdot> ?\<sigma>)" "ground (u \<cdot> ?\<sigma>)" by auto
    from this wcr have w: "(t, u \<cdot> ?\<sigma>) \<in> (gsrstep ?\<H> \<R>)\<^sup>\<down>"
      using srstep_subst_closed[OF sig_trans[OF srrstep_to_srestep[OF ass(1)]], of ?\<sigma>]
      using srstep_subst_closed[OF sig_trans[OF ass(2)], of ?\<sigma>]
      using ass unfolding WCR_on_def
      by auto (metis * gr ground_subst_apply)
    have "(t, u) \<in> (srstep \<F> \<R>)\<^sup>\<down>" unfolding join_def
      using remove_const_subst_relcomp_rhs[OF lin fresh_sys c_free
        gsrsteps_eq_relcomp_to_rsteps_relcomp[OF w[unfolded join_def rew_converse_inwards]],
        THEN rsteps_eq_relcomp_srsteps_eq_relcompI[OF sig funas_rel_converse[OF sig] funas(2-)]]
      by (metis (no_types, lifting) srstep_converse_dist)}
  then show ?thesis by (intro WCR_rrstep_intro) simp
qed

lemma llrg_UNF:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>"
   and unf: "UNF (gsrstep (insert (c, 0) \<F>) \<R>)"
  shows "UNF (srstep \<F> \<R>)"
proof -
  let ?\<sigma> = "const_subst c" let ?\<H> = "insert (c, 0) \<F>"
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<R>" using sig
    by (auto simp: funas_rel_def)
  have mono: "\<F> \<subseteq> ?\<H>" by auto
  {fix s t assume ass: "(s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<R>"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
      by (metis Un_iff relcomp.cases srstepsD srsteps_with_root_step_srstepsD)+
    from ass have m: "(s, t) \<in> (srstep ?\<H> (\<R>\<inverse>))\<^sup>* O (srstep ?\<H> \<R>)\<^sup>*"
      using rtrancl_mono[OF sig_step_mono[OF mono]]
      by (auto dest!: srsteps_with_root_step_sresteps_eqD trancl_into_rtrancl)
    have gr: "ground s \<or> ground t" using ass llrg
      unfolding srstep_converse_dist trancl_converse
      by (auto simp: llrg_srsteps_with_root_step_inv_ground llrg_srsteps_with_root_step_ground)
    have wit: "s \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>) \<Longrightarrow> t \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>) \<Longrightarrow> s \<cdot> ?\<sigma> = t \<cdot> ?\<sigma>" using unf
      using srsteps_eq_subst_relcomp_closed[OF m, THEN srsteps_eq_relcomp_gsrsteps_relcomp, of ?\<sigma>]
      by (auto simp: UNF_on_def rew_converse_outwards normalizability_def)
    from funas NF_to_fresh_const_subst_NF[OF llrg_linear_sys[OF llrg] fresh_sys sig(1)]
    have "s \<in> NF (srstep \<F> \<R>) \<Longrightarrow> s \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>)" "t \<in> NF (srstep \<F> \<R>) \<Longrightarrow> t \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>)"
      by auto
    moreover have "s \<cdot> ?\<sigma> = t \<cdot> ?\<sigma> \<Longrightarrow> s = t" using gr funas fresh
      by (cases "ground s") (auto simp: ground_subst_apply funas_term_subst vars_term_empty_ground split: if_splits)
    ultimately have "UN_redp \<F> \<R> s t" using wit unfolding UN_redp_def
      by auto}
  then show ?thesis by (intro UNF_rrstep_intro) simp
qed

lemma llrg_NFP:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>"
   and nfp: "NFP (gsrstep (insert (c, 0) \<F>) \<R>)"
  shows "NFP (srstep \<F> \<R>)"
proof -
  let ?\<sigma> = "const_subst c" let ?\<H> = "insert (c, 0) \<F>"
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<R>"
    using sig by (auto simp: funas_rel_def)
  have mono: "\<F> \<subseteq> ?\<H>" by auto
  {fix s t assume ass: "(s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<R>"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
      by (metis Un_iff relcomp.cases srstepsD srsteps_with_root_step_srstepsD)+
    from ass have m: "(s, t) \<in> (srstep ?\<H> (\<R>\<inverse>))\<^sup>* O (srstep ?\<H> \<R>)\<^sup>*"
      using rtrancl_mono[OF sig_step_mono[OF mono]]
      by (auto dest!: srsteps_with_root_step_sresteps_eqD trancl_into_rtrancl)
    have gr: "ground s \<or> ground t" using ass llrg
      unfolding srstep_converse_dist trancl_converse
      by (auto simp: llrg_srsteps_with_root_step_inv_ground llrg_srsteps_with_root_step_ground)
    have wit: "t \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>) \<Longrightarrow> (s \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (gsrstep (insert (c, 0) \<F>) \<R>)\<^sup>*"
      using NFP_stepD[OF nfp]
      using srsteps_eq_subst_relcomp_closed[OF m, THEN srsteps_eq_relcomp_gsrsteps_relcomp, of ?\<sigma>]
      by (auto simp: rew_converse_outwards)
    from funas NF_to_fresh_const_subst_NF[OF llrg_linear_sys[OF llrg] fresh_sys(1) sig(1)]
    have "t \<in> NF (srstep \<F> \<R>) \<Longrightarrow> t \<cdot> ?\<sigma> \<in> NF (gsrstep ?\<H> \<R>)" by auto
    moreover have "(s \<cdot> ?\<sigma>, t \<cdot> ?\<sigma>) \<in> (rstep \<R>)\<^sup>* \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>*" using gr funas fresh
      using remove_const_subst_steps_eq_lhs[OF llrg_linear_sys[OF llrg] fresh_sys, THEN rsteps_eq_srsteps_eqI[OF sig funas]]
      using remove_const_subst_steps_eq_rhs[OF llrg_linear_sys[OF llrg] fresh_sys, THEN rsteps_eq_srsteps_eqI[OF sig funas]]
      by (cases "ground s") (auto simp: ground_subst_apply)
    ultimately have "NFP_redp \<F> \<R> s t" using wit unfolding NFP_redp_def
      by (auto dest: gsrsteps_eq_to_rsteps_eq)}
  then show ?thesis by (intro NFP_rrstep_intro) simp
qed

lemma llrg_NE_aux:
  assumes "(s, t) \<in> srsteps_with_root_step \<F> \<R>"
   and  sig: "funas_rel \<R> \<subseteq> \<F>" "funas_rel \<S> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>" "llrg \<S>"
   and ne: "NE (gsrstep (insert (c, 0) \<F>) \<R>) (gsrstep (insert (c, 0) \<F>) \<S>)"
  shows "NE_redp \<F> \<R> \<S> s t"
proof -
  from fresh have fresh_sys: "(c, 0) \<notin> funas_rel \<R>" "(c, 0) \<notin> funas_rel \<S>"
    using sig by (auto simp: funas_rel_def)
  let ?\<sigma> = "const_subst c" let ?\<H> = "insert (c, 0) \<F>"
  let ?\<H> = "insert (c, 0) \<F>"  have mono: "\<F> \<subseteq> ?\<H>" by auto
  from assms(1) have gr: "ground t" and funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
    using llrg_srsteps_with_root_step_ground[OF llrg(1)]
    by (meson srstepsD srsteps_with_root_step_srstepsD)+
  from funas have fresh_t: "(c, 0) \<notin> funas_term t" using fresh by auto
  from srsteps_subst_closed[OF srsteps_monp[OF mono, THEN subsetD, OF srsteps_with_root_step_srstepsD[OF assms(1)]], of ?\<sigma>]
  have "(s \<cdot> ?\<sigma>, t) \<in> (gsrstep?\<H> \<R>)\<^sup>+" using gr
    by (auto simp: ground_subst_apply intro!: ground_srsteps_gsrsteps)
  then have "t \<in> NF (srstep \<F> \<R>) \<Longrightarrow> (s \<cdot> ?\<sigma>, t) \<in> (gsrstep (insert (c, 0) \<F>) \<S>)\<^sup>*"
    using NF_to_fresh_const_subst_NF[OF llrg_linear_sys[OF llrg(1)] fresh_sys(1) sig(1) funas(2), of ?\<H>]
    using gr NE_NF_eq[OF ne, symmetric] ne unfolding NE_on_def
    by (auto simp: normalizability_def ground_subst_apply dest!: trancl_into_rtrancl)
  then show "NE_redp \<F> \<R> \<S> s t" unfolding NE_redp_def
    using remove_const_subst_steps_eq_lhs[OF llrg_linear_sys[OF llrg(2)] fresh_sys(2) fresh_t,
      THEN rsteps_eq_srsteps_eqI[OF sig(2) funas]]
    by (auto dest: gsrsteps_eq_to_rsteps_eq)
qed

lemma llrg_NE:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" "funas_rel \<S> \<subseteq> \<F>" and fresh: "(c, 0) \<notin> \<F>"
   and llrg: "llrg \<R>" "llrg \<S>"
   and ne: "NE (gsrstep (insert (c, 0) \<F>) \<R>) (gsrstep (insert (c, 0) \<F>) \<S>)"
  shows "NE (srstep \<F> \<R>) (srstep \<F> \<S>)"
proof -
  have f: "(c, 0) \<notin> funas_rel \<R>" "(c, 0) \<notin> funas_rel \<S>" using fresh sig
    by (auto simp: funas_rel_def)
  {fix s t assume "(s, t) \<in> srsteps_with_root_step \<F> \<R>"
    from llrg_NE_aux[OF this sig fresh llrg ne] have "NE_redp \<F> \<R> \<S> s t"
      by simp}
  moreover
  {fix s t assume "(s, t) \<in> srsteps_with_root_step \<F> \<S>"
    from llrg_NE_aux[OF this sig(2, 1) fresh llrg(2, 1) NE_symmetric[OF ne]]
    have "NE_redp \<F> \<S> \<R> s t" by simp}
  ultimately show ?thesis using linear_sys_gNF_eq_NF_eq[OF llrg_linear_sys[OF llrg(1)]
    llrg_linear_sys[OF llrg(2)] sig f _ _ NE_NF_eq[OF ne]]
    by (intro NE_rrstep_intro) auto
qed

subsection \<open>Specialized for monadic signature\<close>

lemma monadic_commute:
  assumes "llrg \<R>" "llrg \<S>" "monadic \<F>"
   and com: "commute (gsrstep \<F> \<R>) (gsrstep \<F> \<S>)"
  shows "commute (srstep \<F> \<R>) (srstep \<F> \<S>)"
proof -
  {fix s t assume ass: "(s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<S>"
    then obtain u where steps: "(s, u) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>+" "(u, t) \<in> (srstep \<F> \<S>)\<^sup>+"
      by (auto simp: sig_step_converse_rstep dest: srsteps_with_root_step_srstepsD)
    have gr: "ground s" "ground t" using steps assms(1 - 3)
      unfolding rew_converse_outwards
      by (auto simp: llrg_srsteps_with_root_step_ground llrg_monadic_rsteps_groundness)
    from steps(1) have f: "funas_term s \<subseteq> \<F>" using srstepsD by blast
    let ?\<sigma> = "\<lambda> _. s"
    from steps gr have "(s, u \<cdot> ?\<sigma>) \<in> (gsrstep \<F> (\<R>\<inverse>))\<^sup>+" "(u \<cdot> ?\<sigma>, t) \<in> (gsrstep \<F> \<S>)\<^sup>+"
      unfolding rew_converse_outwards
      using srsteps_subst_closed[where ?\<sigma> = ?\<sigma> and ?s = u, of _ \<F>] f
      by (force simp: ground_subst_apply intro: ground_srsteps_gsrsteps)+
    then have "(s, t) \<in> (gsrstep \<F> \<S>)\<^sup>* O (gsrstep \<F> (\<R>\<inverse>))\<^sup>*" using com
      unfolding commute_def rew_converse_inwards
      by (meson relcomp.relcompI subsetD trancl_into_rtrancl)
    from gsrsteps_eq_relcomp_srsteps_relcompD[OF this]
    have "commute_redp \<F> \<R> \<S> s t" unfolding commute_redp_def
      by (simp add: rew_converse_inwards)}
  then show ?thesis by (intro commute_rrstep_intro) simp
qed

lemma monadic_CR:
  assumes "llrg \<R>" "monadic \<F>"
   and "CR (gsrstep \<F> \<R>)"
  shows "CR (srstep \<F> \<R>)" using monadic_commute assms
  unfolding CR_iff_self_commute
  by blast

lemma monadic_SCR:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" "monadic \<F>"
   and llrg: "llrg \<R>"
   and scr: "SCR (gsrstep \<F> \<R>)"
  shows "SCR (srstep \<F> \<R>)"
proof -
  {fix s t u assume ass: "(s, t) \<in> srstep \<F> \<R>" "(s, u) \<in> srstep \<F> \<R>"
    and root: "(s, t) \<in> sig_step \<F> (rrstep \<R>) \<or> (s, u) \<in> sig_step \<F> (rrstep \<R>)"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>" by blast+
    from root have gr: "ground t" "ground u" using ass sig(2) llrg
      by (metis llrg_monadic_rstep_pres_groundness)+
    let ?\<sigma> = "\<lambda> _. t" have grs: "ground (s \<cdot> ?\<sigma>)" using gr by auto
    from this scr obtain v where v: "(t, v) \<in> (gsrstep \<F> \<R>)\<^sup>= \<and> (u, v) \<in> (gsrstep \<F> \<R>)\<^sup>*"
      using srstep_subst_closed[OF ass(1), of ?\<sigma>]
      using srstep_subst_closed[OF ass(2), of ?\<sigma>]
      using gr unfolding SCR_on_def
      by (metis Int_iff UNIV_I funas(2) ground_subst_apply mem_Collect_eq mem_Sigma_iff)
    then have "SCRp \<F> \<R> t u"
      by (metis Int_iff Un_iff gsrsteps_eq_to_srsteps_eq)}
  then show ?thesis by (intro SCR_rrstep_intro) (metis srrstep_to_srestep)+
qed

lemma monadic_WCR:
  assumes sig: "funas_rel \<R> \<subseteq> \<F>" "monadic \<F>"
   and llrg: "llrg \<R>"
   and wcr: "WCR (gsrstep \<F> \<R>)"
  shows "WCR (srstep \<F> \<R>)"
proof -
  {fix s t u assume ass: "(s, t) \<in> sig_step \<F> (rrstep \<R>)" "(s, u) \<in> srstep \<F> \<R>"
    from ass have funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>" "funas_term u \<subseteq> \<F>" by blast+
    from srrstep_to_srestep ass have gr: "ground t" "ground u"using ass sig(2) llrg
      by (metis llrg_monadic_rstep_pres_groundness)+
    let ?\<sigma> = "\<lambda> _. t" have grs: "ground (s \<cdot> ?\<sigma>)" using gr by auto
    from this wcr have w: "(t, u) \<in> (gsrstep \<F> \<R>)\<^sup>\<down>" using gr ass(2) funas
      using srstep_subst_closed[OF srrstep_to_srestep[OF ass(1)], of ?\<sigma>]
      using srstep_subst_closed[OF ass(2), of ?\<sigma>]
      unfolding WCR_on_def
      by (metis IntI SigmaI UNIV_I ground_subst_apply mem_Collect_eq)
    then have "(t, u) \<in> (srstep \<F> \<R>)\<^sup>\<down>" unfolding join_def
      by (metis gsrsteps_eq_to_srsteps_eq joinD joinI join_def)}
  then show ?thesis by (intro WCR_rrstep_intro) simp
qed

lemma monadic_UNF:
  assumes "llrg \<R>" "monadic \<F>"
   and unf: "UNF (gsrstep \<F> \<R>)"
  shows "UNF (srstep \<F> \<R>)"
proof -
  {fix s t assume ass: "(s, t) \<in> comp_rrstep_rel' \<F> (\<R>\<inverse>) \<R>"
    then obtain u where steps: "(s, u) \<in> (srstep \<F> (\<R>\<inverse>))\<^sup>+" "(u, t) \<in> (srstep \<F> \<R>)\<^sup>+"
      by (auto simp: sig_step_converse_rstep dest: srsteps_with_root_step_srstepsD)
    have gr: "ground s" "ground t" using steps assms(1, 2)
      unfolding rew_converse_outwards
      by (auto simp: llrg_srsteps_with_root_step_ground llrg_monadic_rsteps_groundness)
    from steps(1) have f: "funas_term s \<subseteq> \<F>" using srstepsD by blast
    let ?\<sigma> = "\<lambda> _. s"
    from steps gr have "(s, u \<cdot> ?\<sigma>) \<in> (gsrstep \<F> (\<R>\<inverse>))\<^sup>+" "(u \<cdot> ?\<sigma>, t) \<in> (gsrstep \<F> \<R>)\<^sup>+"
      unfolding rew_converse_outwards
      using srsteps_subst_closed[where ?\<sigma> = ?\<sigma> and ?s = u, of _ \<F>] f
      by (force simp: ground_subst_apply intro: ground_srsteps_gsrsteps)+
    then have "UN_redp \<F> \<R> s t" using unf ground_NF_srstep_gsrstep[OF gr(1), of \<F> \<R>]
      using ground_NF_srstep_gsrstep[OF gr(2), of \<F> \<R>]
        by (auto simp: UNF_on_def UN_redp_def normalizability_def rew_converse_outwards)
           (meson trancl_into_rtrancl)}
  then show ?thesis by (intro UNF_rrstep_intro) simp
qed

lemma monadic_UNC:
  assumes "llrg \<R>" "monadic \<F>"
   and well: "funas_rel \<R> \<subseteq> \<F>"
   and unc: "UNC (gsrstep \<F> \<R>)"
  shows "UNC (srstep \<F> \<R>)"
proof -
  {fix s t assume ass: "(s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*" "s \<in> NF (srstep \<F> \<R>)" "t \<in> NF (srstep \<F> \<R>)"
    then have "s = t"
    proof (cases "s = t")
      case False
      then have "\<exists> s' t'. (s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>* \<and> (s', s) \<in> (srstep \<F> \<R>) \<and> (t', t) \<in> (srstep \<F> \<R>)"
        using ass by (auto simp: conversion_def rtrancl_eq_or_trancl dest: tranclD tranclD2)
      then obtain s' t' where split: "(s, t) \<in> (srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*" "(s', s) \<in> (srstep \<F> \<R>)" "(t', t) \<in> (srstep \<F> \<R>)" by blast
      from split(2, 3) have gr: "ground s" "ground t" using llrg_monadic_rstep_pres_groundness[OF assms(1, 2)]
        by blast+
      from ground_srsteps_eq_gsrsteps_eq[OF this ass(1)[unfolded sig_step_conversion_dist]]
      have "(s, t) \<in> (gsrstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>*"
        unfolding conversion_def Restr_smycl_dist
        by (simp add: rstep_converse_dist srstep_symcl_dist)
      then show ?thesis using ass(2-) unc gr
        by (auto simp: UNC_def ground_NF_srstep_gsrstep)
    qed auto}
  then show ?thesis by (auto simp: UNC_def UN_redp_def)
qed

lemma monadic_NFP:
  assumes "llrg \<R>" "monadic \<F>"
   and nfp: "NFP (gsrstep \<F> \<R>)"
  shows "NFP (srstep \<F> \<R>)"
proof -
  {fix s t u assume ass: "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*" "(s, u) \<in> (srstep \<F> \<R>)\<^sup>*" "u \<in> NF (srstep \<F> \<R>)"
    have "(t, u) \<in> (srstep \<F> \<R>)\<^sup>*"
    proof (cases "s = u \<or> s = t")
      case [simp]: True show ?thesis using ass
        by (metis NF_not_suc True rtrancl.rtrancl_refl)
    next
      case False
      then have steps:"(s, t) \<in> (srstep \<F> \<R>)\<^sup>+" "(s, u) \<in> (srstep \<F> \<R>)\<^sup>+" using ass(1, 2)
        by (auto simp add: rtrancl_eq_or_trancl)
      then have gr: "ground t" "ground u" using assms(1, 2) llrg_monadic_rsteps_groundness
        by blast+
      let ?\<sigma> = "\<lambda> _. t" from steps gr have "(s \<cdot> ?\<sigma>, t) \<in> (gsrstep \<F> \<R>)\<^sup>+" "(s \<cdot> ?\<sigma>, u) \<in> (gsrstep \<F> \<R>)\<^sup>+"
        by (auto intro!: ground_srsteps_gsrsteps)
           (metis ground_subst_apply srstepsD srsteps_subst_closed)+
      then have "(t, u) \<in> (gsrstep \<F> \<R>)\<^sup>*" using nfp ass(3) gr
        by (auto simp: NFP_on_def) (metis ground_NF_srstep_gsrstep normalizability_I trancl_into_rtrancl)
      then show ?thesis by (auto dest: gsrsteps_eq_to_srsteps_eq)
    qed}
  then show ?thesis unfolding NFP_on_def
    by auto
qed

end