(* N. Peltier. LIG/CNRS http://membres-lig.imag.fr/peltier/ *)

section \<open>Prime Implicates  Generation\<close>

text \<open>We show that the unrestricted resolution rule is deductive complete, i.e. that it is able
to generate all (prime) implicates of any given clause set.\<close>

theory Prime_Implicates

imports Propositional_Resolution

begin

context propositional_atoms

begin

subsection \<open>Implicates and Prime Implicates\<close>

text \<open>We first introduce the definitions of implicates and prime implicates.\<close>

definition implicates :: "'at Formula \<Rightarrow> 'at Formula"
  where "implicates S = { C. entails S C }"

definition prime_implicates :: "'at Formula \<Rightarrow> 'at Formula"
  where "prime_implicates S = simplify (implicates S)"

subsection \<open>Generation of Prime Implicates\<close>

text \<open>We introduce a function simplifying a given clause set by evaluating some literals
   to false. We show that this partial evaluation operation preserves saturatedness and
that if the considered set of literals is an implicate of the initial clause set
then the partial evaluation yields a clause set that is unsatisfiable.
Then the proof follows from refutational completeness: since the partially evaluated set
is unsatisfiable and saturated it must contain the empty clause, and therefore the initial
clause set necessarily contains a clause subsuming the implicate.\<close>

fun partial_evaluation :: "'a Formula \<Rightarrow> 'a Literal set \<Rightarrow> 'a Formula"
where
  "(partial_evaluation S C) = { E. \<exists>D. D \<in> S \<and> E = D-C \<and> \<not>(\<exists>L. (L \<in> C) \<and> (complement L) \<in> D)}"

lemma partial_evaluation_is_saturated :
  assumes "saturated_binary_rule resolvent S"
  shows "saturated_binary_rule ordered_resolvent (partial_evaluation S C)"
proof (rule ccontr)
    let ?peval = "partial_evaluation S C"
    assume "\<not>saturated_binary_rule ordered_resolvent ?peval"
    from this obtain P1 and P2 and R where "P1 \<in> ?peval" and "P2 \<in> ?peval"
      and "ordered_resolvent P1 P2 R"  and "\<not>(tautology R)"
      and not_subsumed: "\<not>(\<exists>D. ((D \<in> (partial_evaluation S C)) \<and> (subsumes D R)))"
    unfolding saturated_binary_rule_def and redundant_def  by auto
    from \<open>P1 \<in> ?peval\<close> obtain PP1 where "PP1 \<in> S" and "P1 = PP1 - C"
      and i: "\<not>(\<exists>L. (L \<in> C) \<and> (complement L) \<in> PP1)" by auto
    from \<open>P2 \<in> ?peval\<close> obtain PP2 where "PP2 \<in> S" and "P2 = PP2 - C"
      and  ii: "\<not>(\<exists>L. (L \<in> C) \<and> (complement L) \<in> PP2)" by auto
    from \<open>(ordered_resolvent P1 P2 R)\<close> obtain A where
      r_def: "R = (P1 - { Pos A }) \<union> (P2 - { Neg A })" and "(Pos A) \<in> P1" and "(Neg A) \<in> P2"
    unfolding ordered_resolvent_def strictly_maximal_literal_def by auto
    let ?RR = "(PP1 - { Pos A }) \<union> (PP2 - { Neg A })"
    from \<open>P1 = PP1 - C\<close> and \<open>(Pos A) \<in> P1\<close> have "(Pos A) \<in> PP1" by auto
    from \<open>P2 = PP2 - C\<close> and \<open>(Neg A) \<in> P2\<close> have "(Neg A) \<in> PP2" by auto
    from r_def and \<open>P1 = PP1 - C\<close> and \<open>P2 = PP2 - C\<close> have "R =  ?RR - C" by auto
    from \<open>(Pos A) \<in> PP1\<close> and \<open>(Neg A) \<in> PP2\<close>
      have "resolvent PP1 PP2 ?RR" unfolding resolvent_def by auto
    with \<open>PP1 \<in> S\<close> and \<open>PP2 \<in> S\<close> and \<open>saturated_binary_rule resolvent S\<close>
      have "tautology ?RR \<or> (\<exists>D. (D \<in> S \<and> (subsumes D ?RR)))"
    unfolding saturated_binary_rule_def redundant_def by auto
    thus "False"
    proof
      assume "tautology ?RR"
      with \<open>R = ?RR - C\<close> and \<open>\<not>tautology R\<close>
        obtain X where "X \<in> C" and "complement X \<in> PP1 \<union> PP2"
        unfolding tautology_def by auto
      from \<open>X \<in> C\<close> and \<open>complement X \<in> PP1 \<union> PP2\<close> and i and ii
        show "False" by auto
    next
      assume "\<exists>D. ((D \<in> S) \<and> (subsumes D ?RR))"
      from this obtain D where "D \<in> S" and "subsumes D ?RR"
      by auto
      from \<open>subsumes D ?RR\<close> and \<open>R = ?RR - C\<close>
        have "subsumes (D - C) R" unfolding subsumes_def by auto
      from \<open>D \<in> S\<close> and ii and i and \<open>(subsumes D ?RR)\<close> have "D - C \<in> ?peval"
        unfolding subsumes_def by auto
      with \<open>subsumes (D - C) R\<close> and not_subsumed show "False" by auto
    qed
qed

lemma evaluation_wrt_implicate_is_unsat :
  assumes "entails S C"
  assumes "\<not>tautology C"
  shows "\<not>satisfiable (partial_evaluation S C)"
proof
    let ?peval = "partial_evaluation S C"
    assume "satisfiable ?peval"
    then obtain I where "validate_formula I ?peval" unfolding satisfiable_def by auto
    let ?J = "(I - { X. (Pos X) \<in> C }) \<union> { Y. (Neg Y) \<in> C }"
    have "\<not>validate_clause ?J C"
    proof
      assume "validate_clause ?J C"
      then obtain L where "L \<in> C" and "validate_literal ?J L" by auto
      obtain X where "L = (Pos X) \<or> L = (Neg X)" using Literal.exhaust [of L] by auto
      from \<open>L = (Pos X) \<or> L = (Neg X)\<close> and \<open>L \<in> C\<close> and \<open>\<not>tautology C\<close> and \<open>validate_literal ?J L\<close>
      show "False" unfolding tautology_def by auto
    qed
    have "validate_formula ?J S"
    proof (rule ccontr)
      assume "\<not> (validate_formula ?J S)"
      then obtain D where "D \<in> S" and "\<not>(validate_clause ?J D)" by auto
      from \<open>D \<in> S\<close> have "D-C \<in> ?peval \<or>  (\<exists>L. (L \<in> C) \<and> (complement L) \<in> D)"
      by auto
      thus "False"
      proof
        assume "\<exists>L. (L \<in> C) \<and> (complement L) \<in> D"
        then obtain L where "L \<in> C" and "complement L \<in> D" by auto
        obtain X where "L = (Pos X) \<or> L = (Neg X)" using Literal.exhaust [of L] by auto
        from this  and \<open>L \<in> C\<close> and \<open>\<not>(tautology C)\<close> have "validate_literal ?J (complement L)"
        unfolding tautology_def by auto
        from \<open>(validate_literal ?J (complement L))\<close> and \<open>(complement L) \<in> D\<close>
          and \<open>\<not>(validate_clause ?J D)\<close>
        show "False" by auto
      next
        assume "D-C \<in> ?peval"
        from \<open>D-C \<in> ?peval\<close> and \<open>(validate_formula I ?peval)\<close>
        have "validate_clause I (D-C)" using validate_formula.simps by blast
        from this obtain L where "L \<in> D" and "L \<notin> C" and "validate_literal I L" by auto
        obtain X where "L = (Pos X) \<or> L = (Neg X)" using Literal.exhaust [of L] by auto
        from \<open>L = (Pos X) \<or> L = (Neg X)\<close> and \<open>validate_literal I L\<close> and \<open>L \<notin> C\<close>
        have "validate_literal ?J L" unfolding tautology_def by auto
        from \<open>validate_literal ?J L\<close> and \<open>L \<in> D\<close> and \<open>\<not>(validate_clause ?J D)\<close>
        show "False" by auto
      qed
    qed
    from \<open>\<not>validate_clause ?J C\<close> and \<open>validate_formula ?J S\<close> and \<open>entails S C\<close> show "False"
    unfolding entails_def by auto
qed

lemma entailment_and_implicates:
  assumes "entails_formula S1 S2"
  shows "implicates S2 \<subseteq> implicates S1"
using assms entailed_formula_entails_implicates implicates_def by auto

lemma equivalence_and_implicates:
  assumes "equivalent S1 S2"
  shows "implicates S1 = implicates S2"
using assms entailment_and_implicates equivalent_def by blast

lemma equivalence_and_prime_implicates:
  assumes "equivalent S1 S2"
  shows "prime_implicates S1 = prime_implicates S2"
using assms equivalence_and_implicates prime_implicates_def by auto

lemma unrestricted_resolution_is_deductive_complete :
  assumes "saturated_binary_rule resolvent S"
  assumes "all_fulfill finite S"
  assumes "C \<in> implicates S"
  shows "redundant C S"
proof ((cases "tautology C"),(simp add: redundant_def))
next
  assume "\<not> tautology C"
  have "\<exists>D. (D \<in> S) \<and> (subsumes D C)"
  proof -
    let ?peval = "partial_evaluation S C"
    from \<open>saturated_binary_rule resolvent S\<close>
      have "saturated_binary_rule ordered_resolvent ?peval"
      using partial_evaluation_is_saturated by auto
    from \<open>C \<in> implicates S\<close> have "entails S C" unfolding implicates_def by auto
    from \<open>entails S C\<close> and \<open>\<not>tautology C\<close> have "\<not>satisfiable ?peval"
    using evaluation_wrt_implicate_is_unsat by auto
    from \<open>all_fulfill finite S\<close> have "all_fulfill finite ?peval" unfolding all_fulfill_def by auto
    from \<open>\<not>satisfiable ?peval\<close> and \<open>saturated_binary_rule ordered_resolvent ?peval\<close>
      and \<open>all_fulfill finite ?peval\<close>
    have "{} \<in> ?peval" using Complete_def ordered_resolution_is_complete by blast
    then show ?thesis unfolding subsumes_def by auto
  qed
  then show ?thesis unfolding redundant_def by auto
qed

lemma prime_implicates_generation_correct :
  assumes "saturated_binary_rule resolvent S"
  assumes "non_redundant S"
  assumes "all_fulfill finite S"
  shows "S \<subseteq> prime_implicates S"
proof
  fix x assume "x \<in> S"
  show "x \<in> prime_implicates S"
  proof (rule ccontr)
    assume "\<not> x \<in> prime_implicates S"
    from \<open>x \<in> S\<close> have "entails S x" unfolding entails_def implicates_def by auto
    then have "x \<in> implicates S" unfolding implicates_def by auto
    with \<open>\<not> x \<in> (prime_implicates S)\<close> have "strictly_redundant x (implicates S)"
      unfolding prime_implicates_def simplify_def by auto
    from this have "tautology x \<or> (\<exists>y. (y \<in> (implicates S)) \<and> (y \<subset> x))"
      unfolding strictly_redundant_def by auto
    then have "strictly_redundant x S"
    proof ((cases "tautology x"),(simp add: strictly_redundant_def))
    next
      assume "\<not>tautology x"
      with \<open>tautology x \<or> (\<exists>y. (y \<in> (implicates S)) \<and> (y \<subset> x))\<close>
        obtain y where "y \<in> implicates S" and "y \<subset> x" by auto
      from \<open>y \<in> implicates S\<close> and \<open>saturated_binary_rule resolvent S\<close> and \<open>all_fulfill finite S\<close>
        have "redundant y S" using unrestricted_resolution_is_deductive_complete by auto
      from \<open>y \<subset> x\<close> and \<open>\<not>tautology x\<close> have "\<not>tautology y" unfolding tautology_def by auto
      with \<open>redundant y S\<close> obtain z where "z \<in> S" and "z \<subseteq> y"
        unfolding redundant_def subsumes_def by auto
      with \<open>y \<subset> x\<close> have "z \<subset> x" by auto
      with \<open>z \<in> S\<close> show "strictly_redundant x S" using strictly_redundant_def by auto
    qed
    with \<open>non_redundant S\<close> and \<open>x \<in> S\<close> show "False" unfolding non_redundant_def by auto
 qed
qed

theorem prime_implicates_of_saturated_sets:
  assumes "saturated_binary_rule resolvent S"
  assumes "all_fulfill finite S"
  assumes "non_redundant S"
  shows "S = prime_implicates S"
proof
  from assms show "S \<subseteq> prime_implicates S" using prime_implicates_generation_correct by auto
  show "prime_implicates S \<subseteq> S"
  proof
    fix x assume "x \<in> prime_implicates S"
    from this have "x \<in> implicates S" unfolding prime_implicates_def simplify_def by auto
    with assms have "redundant x S"
      using unrestricted_resolution_is_deductive_complete by auto
    show "x \<in> S"
    proof (rule ccontr)
      assume "x \<notin> S"
      with \<open>redundant x S\<close> have "strictly_redundant x S"
        unfolding redundant_def strictly_redundant_def subsumes_def by auto
      with \<open>S \<subseteq> prime_implicates S\<close> have "strictly_redundant x (prime_implicates S)"
        unfolding strictly_redundant_def by auto
      then have "strictly_redundant x (implicates S)"
        unfolding strictly_redundant_def prime_implicates_def simplify_def by auto
      with \<open>x \<in> prime_implicates S\<close> show "False"
        unfolding prime_implicates_def simplify_def  by auto
   qed
  qed
qed

subsection \<open>Incremental Prime Implicates Computation\<close>

text \<open>We show that it is possible to compute the set of prime implicates incrementally
i.e., to fix an ordering among atoms, and to compute the set of resolvents upon each atom
one by one, without backtracking (in the sense that if the resolvents upon a given atom are
generated at some step @{ term i } then no resolvents upon the same atom are generated at
step @{ term "j>i" }.
This feature is critical in practice for the efficiency of prime implicates
generation algorithms.\<close>

text \<open>We first introduce a function computing all resolvents upon a given atom.\<close>

definition all_resolvents_upon :: "'at Formula \<Rightarrow> 'at \<Rightarrow> 'at Formula"
 where  "(all_resolvents_upon S A) = { C. \<exists>P1 P2. P1 \<in> S \<and> P2 \<in> S \<and> C = (resolvent_upon P1 P2 A) }"

lemma resolvent_upon_correct:
  assumes "P1 \<in> S"
  assumes "P2 \<in> S"
  assumes "C = resolvent_upon P1 P2 A"
  shows "entails S C"
proof cases
  assume "Pos A \<in> P1 \<and> Neg A \<in> P2"
  with \<open>C = resolvent_upon P1 P2 A\<close> have "resolvent P1 P2 C"
    unfolding resolvent_def by auto
  with \<open>P1 \<in> S\<close> and \<open>P2 \<in> S\<close> show ?thesis
    using soundness_and_entailment resolution_is_correct by auto
next
  assume "\<not> (Pos A \<in> P1 \<and> Neg A \<in> P2)"
  with \<open>C = resolvent_upon P1 P2 A\<close> have "P1 \<subseteq> C \<or> P2 \<subseteq> C" by auto
  with \<open>P1 \<in> S\<close> and \<open>P2 \<in> S\<close> have "redundant C S"
    unfolding redundant_def subsumes_def by auto
  then show ?thesis using redundancy_implies_entailment by auto
qed

lemma all_resolvents_upon_is_finite:
  assumes "all_fulfill finite S"
  shows "all_fulfill finite (S \<union> (all_resolvents_upon S A))"
using assms unfolding all_fulfill_def all_resolvents_upon_def by auto

lemma atoms_formula_resolvents:
  shows "atoms_formula (all_resolvents_upon S A) \<subseteq>  atoms_formula S"
unfolding all_resolvents_upon_def by auto

text \<open>We define a partial saturation predicate that is restricted to a specific atom.\<close>

definition partial_saturation :: "'at Formula \<Rightarrow> 'at \<Rightarrow> 'at Formula \<Rightarrow> bool"
where
  "(partial_saturation S A R) = (\<forall>P1 P2. (P1 \<in> S \<longrightarrow> P2 \<in> S
    \<longrightarrow>(redundant (resolvent_upon P1 P2 A) R)))"

text \<open>We show that the resolvent of two redundant clauses in a partially saturated set
is itself redundant.\<close>

lemma resolvent_upon_and_partial_saturation :
  assumes "redundant P1 S"
  assumes "redundant P2 S"
  assumes "partial_saturation S A (S \<union> R)"
  assumes "C = resolvent_upon P1 P2 A"
  shows "redundant C (S \<union> R)"
proof (rule ccontr)
  assume "\<not>redundant C  (S \<union> R)"
  from \<open>C = resolvent_upon P1 P2 A\<close> have "C = (P1 - { Pos A }) \<union> (P2 - { Neg A })" by auto
  from \<open>\<not>redundant C  (S \<union> R)\<close> have "\<not>tautology C" unfolding redundant_def by auto
  have "\<not> (tautology P1)"
  proof
    assume "tautology P1"
    then obtain B where "Pos B \<in> P1" and "Neg B \<in> P1" unfolding tautology_def by auto
    show "False"
    proof cases
      assume "A = B"
      with \<open>Neg B \<in> P1\<close> and \<open>C = (P1 - { Pos A }) \<union> (P2 - { Neg A })\<close> have "subsumes P2 C"
        unfolding subsumes_def using Literal.distinct by blast
      with \<open>redundant P2 S\<close> have "redundant C S"
        using subsumption_preserves_redundancy by auto
      with \<open>\<not>redundant C (S \<union> R)\<close> show "False" unfolding redundant_def by auto
    next
      assume "A \<noteq> B"
      with \<open>C = (P1 - { Pos A }) \<union> (P2 - { Neg A })\<close> and \<open>Pos B \<in> P1\<close> and \<open>Neg B \<in> P1\<close>
      have "Pos B \<in> C" and "Neg B \<in> C" by auto
      with \<open>\<not>redundant C  (S \<union> R)\<close> show "False"
        unfolding tautology_def redundant_def by auto
    qed
  qed
  with \<open>redundant P1 S\<close> obtain Q1 where "Q1 \<in> S" and "subsumes Q1 P1"
    unfolding redundant_def by auto
  have "\<not> (tautology P2)"
  proof
    assume "tautology P2"
    then obtain B where "Pos B \<in> P2" and "Neg B \<in> P2" unfolding tautology_def by auto
    show "False"
    proof cases
      assume "A = B"
      with \<open>Pos B \<in> P2\<close> and \<open>C = (P1 - { Pos A }) \<union> (P2 - { Neg A })\<close> have "subsumes P1 C"
        unfolding subsumes_def using Literal.distinct by blast
      with \<open>redundant P1 S\<close> have "redundant C S"
        using subsumption_preserves_redundancy by auto
      with \<open>\<not>redundant C  (S \<union> R)\<close> show "False" unfolding redundant_def by auto
    next
      assume "A \<noteq> B"
      with \<open>C = (P1 - { Pos A }) \<union> (P2 - { Neg A })\<close> and \<open>Pos B \<in> P2\<close> and \<open>Neg B \<in> P2\<close>
      have "Pos B \<in> C" and "Neg B \<in> C" by auto
      with \<open>\<not>redundant C  (S \<union> R)\<close> show "False"
      unfolding tautology_def redundant_def  by auto
    qed
  qed
  with \<open>redundant P2 S\<close> obtain Q2 where "Q2 \<in> S" and "subsumes Q2 P2"
    unfolding redundant_def by auto
  let ?res = "(Q1 - { Pos A }) \<union> (Q2 - { Neg A })"
  have "?res = resolvent_upon Q1 Q2 A" by auto
  from this  and \<open>partial_saturation S A  (S \<union> R)\<close> and \<open>Q1 \<in> S\<close> and  \<open>Q2 \<in> S\<close>
    have "redundant ?res  (S \<union> R)"
    unfolding partial_saturation_def by auto
  from \<open>subsumes Q1 P1\<close> and \<open>subsumes Q2 P2\<close> and \<open>C = (P1 - { Pos A }) \<union> (P2 - { Neg A })\<close>
  have "subsumes ?res C" unfolding subsumes_def by auto
  with \<open>redundant ?res  (S \<union> R)\<close> and \<open>\<not>redundant C  (S \<union> R)\<close> show False
    using subsumption_preserves_redundancy by auto
qed

text \<open>We show that if @{term R} is a set of resolvents of a set of clauses @{term S} then the
same holds for @{ term "S \<union> R"}. For the clauses in @{term S}, the premises are identical to
the resolvent and the inference is thus redundant (this trick is useful to simplify proofs).\<close>

definition in_all_resolvents_upon:: "'at Formula \<Rightarrow> 'at \<Rightarrow> 'at Clause \<Rightarrow> bool"
where
  "in_all_resolvents_upon S A C = (\<exists> P1 P2. (P1 \<in> S \<and> P2 \<in> S \<and> C = resolvent_upon P1 P2 A))"

lemma every_clause_is_a_resolvent:
  assumes "all_fulfill (in_all_resolvents_upon S A) R"
  assumes "all_fulfill (\<lambda>x. \<not>(tautology x)) S"
  assumes "P1 \<in> S \<union> R"
  shows "in_all_resolvents_upon S A P1"
proof ((cases "P1 \<in> R"),(metis all_fulfill_def assms(1)))
next
    assume "P1 \<notin> R"
    with \<open>P1 \<in> S \<union> R\<close> have "P1 \<in> S" by auto
    with \<open>(all_fulfill (\<lambda>x. \<not>(tautology x)) S )\<close> have "\<not> tautology P1"
      unfolding all_fulfill_def by auto
    from \<open>\<not> tautology P1\<close> have "Neg A \<notin> P1 \<or> Pos A \<notin> P1" unfolding tautology_def by auto
    from this have "P1 = (P1 - { Pos A }) \<union> (P1 - { Neg A })" by auto
    with \<open>P1 \<in> S\<close> show ?thesis unfolding resolvent_def
      unfolding in_all_resolvents_upon_def by auto
qed

text \<open>We show that if a formula is partially saturated then it stays so when new resolvents
are added in the set.\<close>

lemma partial_saturation_is_preserved :
  assumes "partial_saturation S E1 S"
  assumes "partial_saturation S E2 (S \<union> R)"
  assumes "all_fulfill (\<lambda>x. \<not>(tautology x)) S"
  assumes "all_fulfill (in_all_resolvents_upon S E2) R"
  shows "partial_saturation (S \<union> R) E1 (S \<union> R)"
proof (rule ccontr)
  assume "\<not> partial_saturation (S \<union> R) E1 (S \<union> R)"
  from this obtain P1 P2 C where "P1 \<in> S \<union> R" and "P2 \<in> S \<union> R" and "C = resolvent_upon P1 P2 E1"
    and "\<not> redundant C (S \<union> R)"
    unfolding partial_saturation_def by auto
  from \<open>C = resolvent_upon P1 P2 E1\<close> have "C = (P1 - { Pos E1 }) \<union> (P2 - { Neg E1 })" by auto
  from \<open>P1 \<in> S \<union> R\<close> and assms(4) and \<open>(all_fulfill (\<lambda>x. \<not>(tautology x)) S )\<close>
  have "in_all_resolvents_upon S E2 P1" using every_clause_is_a_resolvent by auto
  then obtain P1_1 P1_2 where "P1_1 \<in> S" and "P1_2 \<in> S" and "P1 = resolvent_upon P1_1 P1_2 E2"
    using every_clause_is_a_resolvent unfolding in_all_resolvents_upon_def by blast
  from \<open>P2 \<in> S \<union> R\<close> and assms(4) and \<open>(all_fulfill (\<lambda>x. \<not>(tautology x)) S )\<close>
    have "in_all_resolvents_upon S E2 P2"  using every_clause_is_a_resolvent by auto
  then obtain P2_1 P2_2 where "P2_1 \<in> S" and "P2_2 \<in> S" and  "P2 = resolvent_upon P2_1 P2_2 E2"
    using every_clause_is_a_resolvent unfolding in_all_resolvents_upon_def by blast
  let ?R1 = "resolvent_upon P1_1 P2_1 E1"
  from \<open>partial_saturation S E1 S\<close> and \<open>P1_1 \<in> S\<close> and \<open>P2_1 \<in> S\<close> have "redundant ?R1 S"
    unfolding partial_saturation_def by auto
  let ?R2 = "resolvent_upon P1_2 P2_2 E1"
  from \<open>partial_saturation S E1 S\<close> and \<open>P1_2 \<in> S\<close> and \<open>P2_2 \<in> S\<close> have "redundant ?R2 S"
    unfolding partial_saturation_def by auto
  let ?C = "resolvent_upon ?R1 ?R2 E2"
  from \<open>C = resolvent_upon P1 P2 E1\<close> and \<open>P2 = resolvent_upon P2_1 P2_2 E2\<close>
    and \<open>P1 = resolvent_upon P1_1 P1_2 E2\<close>
    have "?C = C" by auto
  with \<open>redundant ?R1 S\<close> and \<open>redundant ?R2 S\<close> and \<open>partial_saturation S E2 (S \<union> R)\<close>
    and \<open>\<not> redundant C (S \<union> R)\<close>
    show "False" using resolvent_upon_and_partial_saturation by auto
qed

text \<open>The next lemma shows that the clauses inferred by applying the resolution rule
 upon a given atom contain no occurrence of this atom, unless the inference is redundant.\<close>

lemma resolvents_do_not_contain_atom :
  assumes "\<not> tautology P1"
  assumes "\<not> tautology P2"
  assumes "C = resolvent_upon P1 P2 E2"
  assumes "\<not> subsumes P1 C"
  assumes "\<not> subsumes P2 C"
  shows "(Neg E2) \<notin> C \<and> (Pos E2) \<notin> C"
proof
  from \<open>C = resolvent_upon P1 P2 E2\<close> have "C = (P1 - { Pos E2 }) \<union> (P2 - { Neg E2 })"
    by auto
  show "(Neg E2) \<notin> C"
  proof
    assume "Neg E2 \<in> C"
    from \<open>C = resolvent_upon P1 P2 E2\<close> have "C = (P1 - { Pos E2 }) \<union> (P2 - { Neg E2 })"
      by auto
    with \<open>Neg E2 \<in> C\<close> have "Neg E2 \<in> P1" by auto
    from \<open>\<not> subsumes P1 C\<close> and  \<open>C = (P1 - { Pos E2 }) \<union> (P2 - { Neg E2 })\<close> have "Pos E2 \<in> P1"
      unfolding subsumes_def by auto
    from \<open>Neg E2 \<in> P1\<close> and \<open>Pos E2 \<in> P1\<close> and  \<open>\<not> tautology P1\<close> show "False"
      unfolding tautology_def by auto
  qed
  next show "(Pos E2) \<notin> C"
  proof
    assume "Pos E2 \<in> C"
    from \<open>C = resolvent_upon P1 P2 E2\<close> have "C = (P1 - { Pos E2 }) \<union> (P2 - { Neg E2 })"
      by auto
    with \<open>Pos E2 \<in> C\<close> have "Pos E2 \<in> P2" by auto
    from \<open>\<not> subsumes P2 C\<close> and  \<open>C = (P1 - { Pos E2 }) \<union> (P2 - { Neg E2 })\<close> have "Neg E2 \<in> P2"
      unfolding subsumes_def by auto
    from \<open>Neg E2 \<in> P2\<close> and \<open>Pos E2 \<in> P2\<close> and  \<open>\<not> tautology P2\<close> show "False"
      unfolding tautology_def by auto
  qed
qed

text \<open>The next lemma shows that partial saturation can be ensured by computing all
(non-redundant) resolvents upon the considered atom.\<close>

lemma ensures_partial_saturation :
  assumes "partial_saturation S E2 (S \<union> R)"
  assumes "all_fulfill (\<lambda>x. \<not>(tautology x)) S"
  assumes "all_fulfill (in_all_resolvents_upon S E2) R"
  assumes "all_fulfill (\<lambda>x. (\<not>redundant x S)) R"
  shows "partial_saturation (S \<union> R) E2 (S \<union> R)"
proof (rule ccontr)
  assume "\<not> partial_saturation (S \<union> R) E2 (S \<union> R)"
  from this obtain P1 P2 C where "P1 \<in> S \<union> R" and "P2 \<in> S \<union> R" and "C = resolvent_upon P1 P2 E2"
    and "\<not> redundant C (S \<union> R)"
    unfolding partial_saturation_def by auto
  have "P1 \<in> S"
  proof (rule ccontr)
    assume "P1 \<notin> S"
    with \<open>P1 \<in> S \<union> R\<close> have "P1 \<in> R" by auto
    with assms(3) obtain P1_1 and P1_2 where "P1_1 \<in> S" and "P1_2 \<in> S"
     and "P1 = resolvent_upon P1_1 P1_2 E2"
     unfolding all_fulfill_def in_all_resolvents_upon_def by auto
    from \<open>all_fulfill (\<lambda>x. \<not>(tautology x)) S\<close> and \<open>P1_1 \<in> S\<close> and \<open>P1_2 \<in> S\<close>
      have "\<not> tautology P1_1" and "\<not> tautology P1_2"
      unfolding all_fulfill_def by auto
    from \<open>all_fulfill (\<lambda>x. (\<not>redundant x S)) R\<close> and \<open>P1 \<in> R\<close> and \<open>P1_1 \<in> S\<close> and \<open>P1_2 \<in> S\<close>
      have "\<not> subsumes P1_1 P1" and "\<not> subsumes P1_2 P1"
      unfolding redundant_def all_fulfill_def by auto
    from \<open>\<not> tautology P1_1\<close> \<open>\<not> tautology P1_2\<close> \<open>\<not> subsumes P1_1 P1\<close> and \<open>\<not> subsumes P1_2 P1\<close>
      and \<open>P1 = resolvent_upon P1_1 P1_2 E2\<close>
      have "(Neg E2) \<notin> P1 \<and> (Pos E2) \<notin> P1"
      using resolvents_do_not_contain_atom [of P1_1 P1_2 P1 E2] by auto
    with \<open>C = resolvent_upon P1 P2 E2\<close> have "subsumes P1 C" unfolding subsumes_def by auto
    with \<open>\<not> redundant C (S \<union> R)\<close> and \<open>P1 \<in> S \<union> R\<close> show "False" unfolding redundant_def
      by auto
    qed
  have "P2 \<in> S"
  proof (rule ccontr)
    assume "P2 \<notin> S"
    with \<open>P2 \<in> S \<union> R\<close> have "P2 \<in> R" by auto
    with assms(3) obtain P2_1 and P2_2 where "P2_1 \<in> S" and "P2_2 \<in> S"
      and "P2 = resolvent_upon P2_1 P2_2 E2"
      unfolding all_fulfill_def in_all_resolvents_upon_def by auto
    from \<open>(all_fulfill (\<lambda>x. \<not>(tautology x)) S )\<close> and \<open>P2_1 \<in> S\<close> and \<open>P2_2 \<in> S\<close>
      have "\<not> tautology P2_1" and "\<not> tautology P2_2"
      unfolding all_fulfill_def by auto
    from \<open>all_fulfill (\<lambda>x. (\<not>redundant x S)) R\<close> and \<open>P2 \<in> R\<close> and \<open>P2_1 \<in> S\<close> and \<open>P2_2 \<in> S\<close>
      have "\<not> subsumes P2_1 P2" and "\<not> subsumes P2_2 P2"
      unfolding redundant_def all_fulfill_def by auto
    from \<open>\<not> tautology P2_1\<close> \<open>\<not> tautology P2_2\<close> \<open>\<not> subsumes P2_1 P2\<close> and \<open>\<not> subsumes P2_2 P2\<close>
      and \<open>P2 = resolvent_upon P2_1 P2_2 E2\<close>
      have "(Neg E2) \<notin> P2 \<and> (Pos E2) \<notin> P2"
      using resolvents_do_not_contain_atom [of P2_1 P2_2 P2 E2] by auto
    with \<open>C = resolvent_upon P1 P2 E2\<close> have "subsumes P2 C" unfolding subsumes_def by auto
    with \<open>\<not> redundant C (S \<union> R)\<close> and \<open>P2 \<in> S \<union> R\<close>
      show "False" unfolding redundant_def by auto
    qed
   from \<open>P1 \<in> S\<close> and \<open>P2 \<in> S\<close> and \<open>partial_saturation S E2 (S \<union> R)\<close>
    and \<open>C = resolvent_upon P1 P2 E2\<close> and \<open>\<not> redundant C (S \<union> R)\<close>
    show "False" unfolding redundant_def partial_saturation_def by auto
qed

lemma resolvents_preserve_equivalence:
  shows "equivalent S (S \<union> (all_resolvents_upon S A))"
proof -
  have "S \<subseteq> (S \<union> (all_resolvents_upon S A))" by auto
  then have "entails_formula (S \<union> (all_resolvents_upon S A)) S" using entailment_subset by auto
  have "entails_formula S (S \<union> (all_resolvents_upon S A))"
  proof (rule ccontr)
    assume "\<not>entails_formula S (S \<union> (all_resolvents_upon S A))"
    from this obtain C where "C \<in> (all_resolvents_upon S A)" and "\<not>entails S C"
      unfolding entails_formula_def using entails_member by auto
    from \<open>C \<in> (all_resolvents_upon S A)\<close> obtain P1 P2
      where "C = resolvent_upon P1 P2 A" and "P1 \<in> S" and "P2 \<in> S"
      unfolding all_resolvents_upon_def by auto
    from \<open>C = resolvent_upon P1 P2 A\<close> and \<open>P1 \<in> S\<close> and \<open>P2 \<in> S\<close> have "entails S C"
      using resolvent_upon_correct by auto
    with \<open>\<not>entails S C\<close> show "False" by auto
  qed
  from \<open>entails_formula (S \<union> (all_resolvents_upon S A)) S\<close>
    and \<open>entails_formula S (S \<union> (all_resolvents_upon S A))\<close>
    show ?thesis unfolding equivalent_def by auto
qed

text \<open>Given a sequence of atoms, we define a sequence of clauses obtained by resolving upon
each atom successively. Simplification rules are applied at each iteration step.\<close>

fun resolvents_sequence :: "(nat \<Rightarrow> 'at) \<Rightarrow> 'at Formula \<Rightarrow> nat \<Rightarrow> 'at Formula"
 where
  "(resolvents_sequence A S 0) = (simplify S)" |
  "(resolvents_sequence A S (Suc N)) =
    (simplify ((resolvents_sequence A S N)
      \<union> (all_resolvents_upon (resolvents_sequence A S N) (A N))))"

text \<open>The following lemma states that partial saturation is preserved by simplification.\<close>

lemma redundancy_implies_partial_saturation:
  assumes "partial_saturation S1 A S1"
  assumes "S2 \<subseteq> S1"
  assumes "all_fulfill (\<lambda>x. redundant x S2) S1"
  shows "partial_saturation S2 A S2"
proof (rule ccontr)
  assume "\<not>partial_saturation S2 A S2"
  then obtain P1 P2 C where "P1 \<in> S2" "P2 \<in> S2" and "C = (resolvent_upon P1 P2 A)"
    and "\<not> redundant C S2"
    unfolding partial_saturation_def by auto
  from \<open>P1 \<in> S2\<close> and \<open>S2 \<subseteq> S1\<close> have "P1 \<in> S1" by auto
  from \<open>P2 \<in> S2\<close> and \<open>S2 \<subseteq> S1\<close> have "P2 \<in> S1" by auto
  from \<open>P1 \<in> S1\<close> and \<open>P2 \<in> S1\<close> and \<open>partial_saturation S1 A S1\<close> and \<open>C = resolvent_upon P1 P2 A\<close>
    have "redundant C S1" unfolding partial_saturation_def by auto
  from \<open>\<not> redundant C S2\<close> have "\<not>tautology C" unfolding redundant_def by auto
  with \<open>redundant C S1\<close> obtain D where "D \<in> S1" and "D \<subseteq> C"
    unfolding redundant_def subsumes_def by auto
  from \<open>D \<in> S1\<close> and \<open>all_fulfill (\<lambda>x. redundant x S2) S1\<close> have "redundant D S2"
    unfolding all_fulfill_def by auto
  from \<open>\<not> tautology C\<close> and \<open>D \<subseteq> C\<close> have "\<not> tautology D" unfolding tautology_def by auto
  with \<open>redundant D S2\<close> obtain E where "E \<in> S2" and "E \<subseteq> D"
    unfolding redundant_def subsumes_def by auto
  from  \<open>E \<subseteq> D\<close> and \<open>D \<subseteq> C\<close> have "E \<subseteq> C" by auto
  from  \<open>E \<in> S2\<close> and \<open>E \<subseteq> C\<close> and \<open>\<not>redundant C S2\<close> show "False"
    unfolding redundant_def subsumes_def by auto
qed

text \<open>The next theorem finally states that the implicate generation algorithm is sound and
complete in the sense that the final clause set in the sequence is exactly the set of prime
implicates of the considered clause set.\<close>

theorem incremental_prime_implication_generation:
  assumes "atoms_formula S = { X. \<exists>I::nat. I < N \<and> X = (A I) }"
  assumes "all_fulfill finite S"
  shows "(prime_implicates S) = (resolvents_sequence A S N)"
proof -

text \<open>We define a set of invariants and show that they are satisfied by all sets in the
above sequence. For the last set in the sequence, the invariants ensure that the clause set is
saturated, which entails the desired property.\<close>

  let ?Final = "resolvents_sequence A S N"

text \<open>We define some properties and show by induction that they are satisfied by all the
clause sets in the constructed sequence\<close>

  let ?equiv_init = "\<lambda>I.(equivalent S (resolvents_sequence A S I))"
  let ?partial_saturation = "\<lambda>I. (\<forall>J::nat. (J < I
    \<longrightarrow> (partial_saturation (resolvents_sequence A S I) (A J) (resolvents_sequence A S I))))"
  let ?no_tautologies = "\<lambda>I.(all_fulfill (\<lambda>x. \<not>(tautology x)) (resolvents_sequence A S I) )"
  let ?atoms_init = "\<lambda>I.(atoms_formula (resolvents_sequence A S I)
                      \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)})"
  let ?non_redundant = "\<lambda>I.(non_redundant (resolvents_sequence A S I))"
  let ?finite ="\<lambda>I. (all_fulfill finite (resolvents_sequence A S I))"

  have "\<forall>I. (I \<le> N   \<longrightarrow> (?equiv_init I)  \<and> (?partial_saturation I) \<and>  (?no_tautologies I)
          \<and> (?atoms_init I) \<and> (?non_redundant I) \<and> (?finite I) )"

  proof (rule allI)
    fix I
    show " (I \<le> N
      \<longrightarrow> (?equiv_init I) \<and> (?partial_saturation I) \<and>  (?no_tautologies I) \<and> (?atoms_init I)
            \<and> (?non_redundant I) \<and> (?finite I) )" (is "I \<le> N \<longrightarrow> ?P I")
    proof (induction I)

text \<open>We show that the properties are all satisfied by the initial clause set
(after simplification).\<close>

      show "0 \<le> N \<longrightarrow> ?P 0"
      proof (rule impI)+
          assume "0 \<le> N"
          let ?R = "resolvents_sequence A S 0"
          from \<open>all_fulfill finite S\<close>
          have "?equiv_init 0" using simplify_preserves_equivalence  by auto
          moreover have "?no_tautologies 0"
            using simplify_def strictly_redundant_def all_fulfill_def by auto
          moreover have "?partial_saturation 0" by auto
          moreover from \<open>all_fulfill finite S\<close>  have "?finite 0" using simplify_finite by auto
          moreover have "atoms_formula ?R \<subseteq> atoms_formula S" using atoms_formula_simplify by auto
          moreover with \<open>atoms_formula S = { X. \<exists>I::nat. I < N \<and> X = (A I) }\<close>
            have v: "?atoms_init 0"  unfolding simplify_def by auto
          moreover have "?non_redundant 0" using simplify_non_redundant by auto
          ultimately show "?P 0" by auto
      qed

text \<open>We then show that the properties are preserved by induction.\<close>

      next
      fix I assume "I \<le> N \<longrightarrow> ?P I"
      show "(Suc I) \<le> N \<longrightarrow> (?P (Suc I))"
      proof (rule impI)+
        assume  "(Suc I) \<le> N"
        let ?Prec = "resolvents_sequence A S I"
        let ?R = "resolvents_sequence A S (Suc I)"
        from \<open>Suc I \<le> N\<close> and \<open>I \<le> N \<longrightarrow> ?P I\<close>
          have "?equiv_init I" and "?partial_saturation I" and "?no_tautologies I" and "?finite I"
            and "?atoms_init I" and "?non_redundant I" by auto
        have "equivalent ?Prec (?Prec \<union> (all_resolvents_upon ?Prec (A I)))"
          using resolvents_preserve_equivalence by auto
        from \<open>?finite I\<close> have "all_fulfill finite (?Prec \<union> (all_resolvents_upon ?Prec (A I)))"
          using all_resolvents_upon_is_finite by auto
        then have "all_fulfill finite (simplify (?Prec \<union> (all_resolvents_upon ?Prec (A I))))"
          using simplify_finite by auto
        then have "?finite (Suc I)" by auto
        from \<open>all_fulfill finite (?Prec \<union> (all_resolvents_upon ?Prec (A I)))\<close>
          have "equivalent (?Prec \<union> (all_resolvents_upon ?Prec (A I))) ?R"
        using simplify_preserves_equivalence by auto
        from \<open>equivalent ?Prec (?Prec \<union> (all_resolvents_upon ?Prec (A I)))\<close>
        and \<open>equivalent (?Prec \<union> (all_resolvents_upon ?Prec (A I))) ?R\<close>
          have "equivalent ?Prec ?R" by (rule equivalent_transitive)
        from \<open>?equiv_init I\<close> and this have "?equiv_init (Suc I)" by (rule equivalent_transitive)
        have "?no_tautologies (Suc I)" using simplify_def strictly_redundant_def all_fulfill_def
          by auto
        let ?Delta = "?R - ?Prec"
        have "?R \<subseteq> ?Prec \<union> ?Delta" by auto
        have "all_fulfill (\<lambda>x. (redundant x ?R)) (?Prec \<union> ?Delta)"
        proof (rule ccontr)
          assume "\<not>all_fulfill (\<lambda>x. (redundant x ?R)) (?Prec \<union> ?Delta)"
          then obtain x where "\<not>redundant x ?R" and "x \<in> ?Prec \<union> ?Delta" unfolding all_fulfill_def
            by auto
          from \<open>\<not>redundant x ?R\<close> have "\<not>x \<in> ?R" unfolding redundant_def subsumes_def by auto
          with \<open>x \<in> ?Prec \<union> ?Delta\<close> have "x \<in> (?Prec \<union> (all_resolvents_upon ?Prec (A I)))"
            by auto
          with \<open>all_fulfill finite (?Prec \<union> (all_resolvents_upon ?Prec (A I)))\<close>
            have "redundant x (simplify (?Prec \<union> (all_resolvents_upon ?Prec (A I))))"
              using simplify_and_membership by blast
          with \<open>\<not>redundant x ?R\<close> show "False" by auto
        qed
        have "all_fulfill (in_all_resolvents_upon ?Prec (A I)) ?Delta"
        proof (rule ccontr)
          assume "\<not> (all_fulfill (in_all_resolvents_upon ?Prec (A I)) ?Delta)"
          then obtain C where "C \<in> ?Delta"
            and "\<not>in_all_resolvents_upon ?Prec (A I) C"
            unfolding all_fulfill_def by auto
          then obtain C where "C \<in> ?Delta"
            and not_res: "\<forall> P1 P2. \<not>(P1 \<in> ?Prec \<and> P2 \<in> ?Prec \<and> C = resolvent_upon P1 P2 (A I))"
            unfolding all_fulfill_def in_all_resolvents_upon_def by blast
          from \<open>C \<in> ?Delta\<close> have "C \<in> ?R" and "C \<notin> ?Prec" by auto
          then have "C \<in> simplify (?Prec \<union> (all_resolvents_upon ?Prec (A I)))" by auto
          then have "C \<in> ?Prec \<union> (all_resolvents_upon ?Prec (A I))" unfolding simplify_def by auto
          with \<open>C \<notin> ?Prec\<close> have "C \<in> (all_resolvents_upon ?Prec (A I))" by auto
          with not_res show "False" unfolding all_resolvents_upon_def by auto
        qed
        have "all_fulfill (\<lambda>x. (\<not>redundant x ?Prec)) ?Delta"
        proof (rule ccontr)
          assume "\<not>all_fulfill (\<lambda>x. (\<not>redundant x ?Prec)) ?Delta"
          then obtain C where "C \<in> ?Delta" and redundant: "redundant C ?Prec"
            unfolding all_fulfill_def by auto
          from \<open>C \<in> ?Delta\<close> have "C \<in> ?R" and "C \<notin> ?Prec" by auto
            show "False"
          proof cases
            assume "strictly_redundant C ?Prec"
            then have "strictly_redundant C (?Prec \<union> (all_resolvents_upon ?Prec (A I)))"
              unfolding strictly_redundant_def by auto
            then have "C \<notin> simplify (?Prec \<union> (all_resolvents_upon ?Prec (A I)))"
              unfolding simplify_def by auto
            then have "C \<notin> ?R" by auto
            with \<open>C \<in> ?R\<close> show "False" by auto
            next assume "\<not>strictly_redundant C ?Prec"
            with redundant have "C \<in> ?Prec"
              unfolding strictly_redundant_def redundant_def subsumes_def by auto
            with \<open>C \<notin> ?Prec\<close> show "False" by auto
          qed
        qed
        have "\<forall>J::nat. (J < (Suc I)) \<longrightarrow> (partial_saturation ?R (A J) ?R)"
        proof (rule ccontr)
          assume "\<not>(\<forall>J::nat. (J < (Suc I)) \<longrightarrow> (partial_saturation ?R (A J) ?R))"
          then obtain J where "J < (Suc I)" and "\<not>(partial_saturation ?R (A J) ?R)" by auto
          from \<open>\<not>(partial_saturation ?R (A J) ?R)\<close> obtain P1 P2 C
          where "P1 \<in> ?R" and "P2 \<in> ?R" and "C = resolvent_upon P1 P2 (A J)" and "\<not> redundant C ?R"
          unfolding partial_saturation_def by auto
          have "partial_saturation ?Prec (A I) (?Prec \<union> ?Delta)"
          proof (rule ccontr)
            assume "\<not>partial_saturation ?Prec (A I) (?Prec \<union> ?Delta)"
            then obtain P1 P2 C where "P1 \<in> ?Prec" and "P2 \<in> ?Prec"
              and "C = resolvent_upon P1 P2 (A I)" and
              "\<not>redundant C (?Prec \<union> ?Delta)" unfolding partial_saturation_def by auto
            from \<open>C = resolvent_upon P1 P2 (A I)\<close> and \<open>P1 \<in> ?Prec\<close> and \<open>P2 \<in> ?Prec\<close>
              have "C \<in> ?Prec \<union> (all_resolvents_upon ?Prec (A I))"
              unfolding all_resolvents_upon_def by auto
            from \<open>all_fulfill finite (?Prec \<union> (all_resolvents_upon ?Prec (A I)))\<close>
              and this have "redundant C ?R"
              using simplify_and_membership [of "?Prec \<union> (all_resolvents_upon ?Prec (A I))" ?R C]
              by auto
            with \<open>?R \<subseteq> ?Prec \<union> ?Delta\<close> have "redundant C (?Prec \<union> ?Delta)"
            using superset_preserves_redundancy [of C ?R "(?Prec \<union> ?Delta)"] by auto
            with \<open>\<not>redundant C (?Prec \<union> ?Delta)\<close> show "False" by auto
          qed
          show "False"
          proof cases
            assume "J = I"
            from \<open>partial_saturation ?Prec (A I) (?Prec \<union> ?Delta)\<close> and \<open>?no_tautologies I\<close>
              and \<open>(all_fulfill (in_all_resolvents_upon ?Prec (A I)) ?Delta)\<close>
              and \<open>all_fulfill (\<lambda>x. (\<not>redundant x ?Prec)) ?Delta\<close>
              have "partial_saturation (?Prec \<union> ?Delta) (A I) (?Prec \<union> ?Delta)"
              using ensures_partial_saturation [of ?Prec "(A I)" ?Delta] by auto
            with \<open>?R \<subseteq> ?Prec \<union> ?Delta\<close>
              and \<open>all_fulfill (\<lambda>x. (redundant x ?R)) (?Prec \<union> ?Delta)\<close>
            have "partial_saturation ?R (A I) ?R" using redundancy_implies_partial_saturation
              by auto
            with \<open>J = I\<close> and \<open>\<not>(partial_saturation ?R (A J) ?R)\<close> show "False" by auto
          next
            assume "J \<noteq> I"
            with \<open>J < (Suc I)\<close> have "J < I" by auto
            with \<open>?partial_saturation I\<close>
              have "partial_saturation ?Prec (A J) ?Prec" by auto
            with \<open>partial_saturation ?Prec (A I) (?Prec \<union> ?Delta)\<close> and \<open>?no_tautologies I\<close>
              and \<open>(all_fulfill (in_all_resolvents_upon ?Prec (A I)) ?Delta)\<close>
              and \<open>all_fulfill (\<lambda>x. (\<not>redundant x ?Prec)) ?Delta\<close>
              have "partial_saturation (?Prec \<union> ?Delta) (A J) (?Prec \<union> ?Delta)"
              using partial_saturation_is_preserved [of ?Prec "A J" "A I" ?Delta] by auto
            with \<open>?R \<subseteq> ?Prec \<union> ?Delta\<close>
              and \<open>all_fulfill (\<lambda>x. (redundant x ?R)) (?Prec \<union> ?Delta)\<close>
              have "partial_saturation ?R (A J) ?R"
              using redundancy_implies_partial_saturation by auto
            with \<open>\<not>(partial_saturation ?R (A J) ?R)\<close> show "False" by auto
         qed
       qed
       have  "non_redundant ?R" using simplify_non_redundant by auto
       from \<open>?atoms_init I\<close> have "atoms_formula (all_resolvents_upon ?Prec (A I))
                                    \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)}"
       using atoms_formula_resolvents [of ?Prec "A I"] by auto
       with \<open>?atoms_init I\<close>
        have "atoms_formula (?Prec \<union> (all_resolvents_upon ?Prec (A I)))
                \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)}"
        using atoms_formula_union [of ?Prec "all_resolvents_upon ?Prec (A I)"]  by auto
       from this have "atoms_formula ?R \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)}"
       using atoms_formula_simplify [of "?Prec \<union> (all_resolvents_upon ?Prec (A I))"]  by auto
       from  \<open>equivalent S (resolvents_sequence A S (Suc I))\<close>
          and \<open>(\<forall>J::nat. (J < (Suc I)
            \<longrightarrow> (partial_saturation (resolvents_sequence A S (Suc I)) (A J)
                  (resolvents_sequence A S (Suc I)))))\<close>
          and \<open>(all_fulfill (\<lambda>x. \<not>(tautology x)) (resolvents_sequence A S (Suc I)) )\<close>
          and \<open>(all_fulfill finite (resolvents_sequence A S (Suc I)))\<close>
          and \<open>non_redundant ?R\<close>
          and \<open>atoms_formula (resolvents_sequence A S (Suc I))  \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)}\<close>
       show "?P (Suc I)" by auto
     qed
   qed
  qed

text \<open>Using the above invariants, we show that the final clause set is saturated.\<close>

  from this have "\<forall>J. (J < N \<longrightarrow> partial_saturation ?Final (A J) ?Final)"
    and "atoms_formula (resolvents_sequence A S N)  \<subseteq>  { X. \<exists>I::nat. I < N \<and> X = (A I)}"
    and "equivalent S ?Final"
    and "non_redundant ?Final"
    and "all_fulfill finite ?Final"
  by auto
  have "saturated_binary_rule resolvent ?Final"
  proof (rule ccontr)
    assume "\<not> saturated_binary_rule resolvent ?Final"
    then obtain P1 P2 C where "P1 \<in> ?Final" and "P2 \<in> ?Final" and "resolvent P1 P2 C"
      and "\<not>redundant C ?Final"
      unfolding saturated_binary_rule_def by auto
    from \<open>resolvent P1 P2 C\<close> obtain B where "C = resolvent_upon P1 P2 B"
      unfolding resolvent_def by auto
      show "False"
    proof cases
      assume "B \<in> (atoms_formula ?Final)"
      with \<open>atoms_formula ?Final \<subseteq> { X. \<exists>I::nat. I < N \<and> X = (A I) }\<close>
        obtain I where "B = (A I)" and "I < N"
        by auto
      from \<open>B = (A I)\<close> and \<open>C = resolvent_upon P1 P2 B\<close> have "C = resolvent_upon P1 P2 (A I)"
        by auto
      from \<open>\<forall>J. (J < N \<longrightarrow> partial_saturation ?Final (A J) ?Final)\<close> and \<open>B = (A I)\<close>and \<open>I < N\<close>
        have "partial_saturation ?Final (A I) ?Final" by auto
      with \<open>C = resolvent_upon P1 P2 (A I)\<close>and \<open>P1 \<in> ?Final\<close> and \<open>P2 \<in> ?Final\<close>
        have "redundant C ?Final" unfolding partial_saturation_def by auto
      with \<open>\<not>redundant C ?Final\<close> show "False" by auto
    next
      assume "B \<notin> atoms_formula ?Final"
      with \<open>P1 \<in> ?Final\<close> have "B \<notin> atoms_clause P1" by auto
      then have "Pos B \<notin> P1" by auto
      with \<open>C = resolvent_upon P1 P2 B\<close> have "P1 \<subseteq> C" by auto
      with \<open>P1 \<in> ?Final\<close> and  \<open>\<not>redundant C ?Final\<close> show "False"
        unfolding redundant_def subsumes_def by auto
    qed
   qed
   with \<open>all_fulfill finite ?Final\<close> and \<open>non_redundant ?Final\<close>
    have "prime_implicates ?Final = ?Final"
    using prime_implicates_of_saturated_sets [of ?Final] by auto
   with \<open>equivalent S ?Final\<close> show ?thesis using  equivalence_and_prime_implicates by auto
qed

end
end


(*  Title:      Code_Int_Integer_Conversion.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>A special case of a conversion.\<close>

theory Code_Int_Integer_Conversion
imports
  Main
begin

text \<open>
  Use this function to convert numeral @{typ integer}s quickly into @{typ int}s.
  By default, it works only for symbolic evaluation; normally generated code raises
  an exception at run-time. If theory \<^text>\<open>Code_Target_Int_Bit\<close> is imported,
  it works again, because then @{typ int} is implemented in terms of @{typ integer}
  even for symbolic evaluation.
\<close>

definition int_of_integer_symbolic :: "integer \<Rightarrow> int"
  where "int_of_integer_symbolic = int_of_integer"

lemma int_of_integer_symbolic_aux_code [code nbe]:
  "int_of_integer_symbolic 0 = 0"
  "int_of_integer_symbolic (Code_Numeral.Pos n) = Int.Pos n"
  "int_of_integer_symbolic (Code_Numeral.Neg n) = Int.Neg n"
  by (simp_all add: int_of_integer_symbolic_def)

end


theory SC_Compl_Consistency
imports Consistency SC_Cut SC_Sema
begin
(* We only need contraction, not cut, and we only need \<Turnstile>\<Rightarrow>, not the proof of completeness. :/
   And we could also separate this into two theories. But I don't think that's worth it. *)
(* It's possible to do this without contraction, but let's just say that the proof gets slightly less sledgehammerous\<dots> *)

context begin
private lemma reasonable:
  "\<forall>\<Gamma>'. F    \<triangleright> set_mset \<Gamma> = set_mset \<Gamma>' \<longrightarrow> P \<Gamma>' \<Longrightarrow> P (F, \<Gamma>)"
  "\<forall>\<Gamma>'. F \<triangleright> G \<triangleright> set_mset \<Gamma> = set_mset \<Gamma>' \<longrightarrow> P \<Gamma>' \<Longrightarrow> P (F, G, \<Gamma>)" by simp_all

lemma SC_consistent:  "pcp {set_mset \<Gamma>| \<Gamma>. \<not>(\<Gamma> \<Rightarrow> {#})}"
  unfolding pcp_def
  apply(intro ballI conjI; erule contrapos_pp; clarsimp; ((drule reasonable)+)?)
          apply(auto dest!: NotL_inv AndL_inv OrL_inv ImpL_inv NotR_inv AndR_inv OrR_inv ImpR_inv multi_member_split contractL contractR intro!: SCp.intros(3-) intro: contractR contractL)
  apply (metis add_mset_commute contract)
(* Alternatively, sledgehammer also finds slick proofs for the individual subgoals after the initial apply of the "reasonable"  lemmas
  subgoal by (simp add: SCp.BotL)
  subgoal by (metis Ax_canonical SCp.NotL contractL mset_add)
  subgoal by (metis SCp.AndL contractL insert_DiffM)
  subgoal by (metis SCp.OrL contractL insert_DiffM)
  subgoal by (metis NotL_inv SCp.ImpL contractL insert_DiffM)
  subgoal by (metis SCp.NotL SCp.NotR contractL insert_DiffM)
  subgoal by (metis NotL_inv SCp.AndR SCp.NotL contractL insert_DiffM)
  subgoal by (metis NotL_inv SCp.NotL SCp.OrR contractL inR1' insert_DiffM)
  subgoal by (metis NotL_inv SCp.ImpR SCp.NotL contractL inL1' insert_DiffM) *)
done

end

lemma
  fixes \<Gamma> \<Delta> :: "'a :: countable formula multiset"
  shows "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof(erule contrapos_pp)
  have NotInv: "\<Gamma> + image_mset Not \<Delta> \<Rightarrow> {#} \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
    by (induction \<Delta> arbitrary: \<Gamma>; simp add: NotL_inv)
  assume \<open>\<not> \<Gamma> \<Rightarrow> \<Delta>\<close>
  hence \<open>\<not> \<Gamma> + image_mset Not \<Delta> \<Rightarrow> {#}\<close> using NotInv by blast
  with pcp_sat[OF SC_consistent]
  have "sat (set_mset (\<Gamma> + image_mset \<^bold>\<not> \<Delta>))" by blast
  thus \<open>\<not> (\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>)\<close> unfolding sat_def sequent_semantics_def not_all by (force elim!: ex_forward)
qed

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header {* Sublinearity *}

theory Sublinearity imports Embedding Healthiness LoopInduction begin

subsection {* Nonrecursive Primitives *}

text {* Sublinearity of non-recursive programs is generally straightforward, and follows from the
alebraic properties of the underlying operations, together with healthiness. *}

lemma sublinear_wp_Skip:
  "sublinear (wp Skip)"
  by(auto simp:wp_eval)

lemma sublinear_wp_Abort:
  "sublinear (wp Abort)"
  by(auto simp:wp_eval)

lemma sublinear_wp_Apply:
  "sublinear (wp (Apply f))"
  by(auto simp:wp_eval)

lemma sublinear_wp_Seq:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
      and hx:  "healthy (wp x)"   and hy:  "healthy (wp y)"
  shows "sublinear (wp (x ;; y))"
proof(rule sublinearI, simp add:wp_eval)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sP: "sound P" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  with slx hy have "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                    wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s"
    by(blast intro:sublinearD)
  also {
    from sP sQ nna nnb nnc sly
    have "\<And>s. a * wp y P s + b * wp y Q s \<ominus> c \<le>
              wp y (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
      by(blast intro:sublinearD)
    moreover from sP sQ hy
    have "sound (wp y P)" and "sound (wp y Q)" by(auto)
    moreover with nna nnb nnc
    have "sound (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c)"
      by(auto intro!:sound_intros tminus_sound)
    moreover from sP sQ nna nnb nnc
    have "sound (\<lambda>s. a * P s + b * Q s \<ominus> c)"
      by(auto intro!:sound_intros tminus_sound)
    moreover with hy have "sound (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c))"
      by(blast)
    ultimately
    have "wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s \<le>
          wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s"
      by(blast intro!:le_funD[OF mono_transD[OF healthy_monoD[OF hx]]])
  }
  finally show "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s" .
qed

lemma sublinear_wp_PC:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
      and uP: "unitary P"
  shows "sublinear (wp (x \<^bsub>P\<^esub>\<oplus> y))"
proof(rule sublinearI, simp add:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  have "a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
        b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c =
        (P s * a * wp x Q s + (1 - P s) * a * wp y Q s) +
        (P s * b * wp x R s + (1 - P s) * b * wp y R s) \<ominus> c"
    by(simp add:field_simps)
  also
  have "... = (P s * a * wp x Q s + P s * b * wp x R s) +
              ((1 - P s) * a * wp y Q s + (1 - P s) * b * wp y R s) \<ominus> c"
    by(simp add:ac_simps)
  also
  have "... = P s * (a * wp x Q s + b * wp x R s) +
              (1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus>
              (P s * c + (1 - P s) * c)"
    by(simp add:field_simps)
  also
  have "... \<le> (P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
              ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c)"
    by(rule tminus_add_mono)
  also {
      from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
        by(auto simp:sign_simps)
      hence "(P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
             ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c) =
             P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
             (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c)"
        by(simp add:tminus_left_distrib)
  }
  also {
    from sQ sR nna nnb nnc slx
    have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
          wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from sQ sR nna nnb nnc sly
    have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
          wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
      by(auto simp:sign_simps)
    ultimately
    have "P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
          (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c) \<le>
          P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
          (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast intro:add_mono mult_left_mono)
  }
  finally
  show " a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
         b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c \<le>
         P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
         (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s" .
qed

lemma sublinear_wp_DC:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
  shows "sublinear (wp (x \<Sqinter> y))"
proof(rule sublinearI, simp only:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  from nna nnb
  have "a * min (wp x Q s) (wp y Q s) +
        b * min (wp x R s) (wp y R s) \<ominus> c =
        min (a * wp x Q s) (a * wp y Q s) +
        min (b * wp x R s) (b * wp y R s) \<ominus> c"
    by(simp add:min_distrib)
  also
  have "... \<le> min (a * wp x Q s + b * wp x R s)
                  (a * wp y Q s + b * wp y R s) \<ominus> c"
    by(auto intro!:tminus_left_mono)
  also
  have "... = min (a * wp x Q s + b * wp x R s \<ominus> c)
                  (a * wp y Q s + b * wp y R s \<ominus> c)"
    by(rule min_tminus_distrib)
  also {
    from slx sQ sR nna nnb nnc
    have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
          wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from sly sQ sR nna nnb nnc
    have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
          wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    ultimately
    have "min (a * wp x Q s + b * wp x R s \<ominus> c)
              (a * wp y Q s + b * wp y R s \<ominus> c) \<le>
          min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
              (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
      by(auto)
  }
  finally show "a * min (wp x Q s) (wp y Q s) +
                b * min (wp x R s) (wp y R s) \<ominus> c \<le>
               min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
                   (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
qed

text {* As for continuity, we insist on a finite support. *}
lemma sublinear_wp_SetPC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes slp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sublinear (wp (p a))"
      and sum: "\<And>s. (\<Sum>a\<in>supp (P s). P s a) \<le> 1"
      and nnP: "\<And>s a. 0 \<le> P s a"
      and fin: "\<And>s. finite (supp (P s))"
  shows "sublinear (wp (SetPC p P))"
proof(rule sublinearI, simp add:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
  have "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
        b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c =
        (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus> c"
    by(simp add:field_simps setsum_right_distrib setsum.distrib)
  also have "... \<le>
             (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus>
             (\<Sum>a'\<in>supp (P s). P s a' * c)"
  proof(rule tminus_right_antimono)
    have "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> (\<Sum>a'\<in>supp (P s). P s a') * c"
      by(simp add:setsum_left_distrib)
    also from sum and nnc have "... \<le> 1 * c"
      by(rule mult_right_mono)
    finally show "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> c" by(simp)
  qed
  also from fin
  have "... \<le> (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s) \<ominus> P s a' * c)"
    by(blast intro:tminus_setsum_mono)
  also have "... = (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c))"
    by(simp add:nnP tminus_left_distrib)
  also {
    from slp sQ sR nna nnb nnc
    have "\<And>a'. a' \<in> supp (P s) \<Longrightarrow> a * wp (p a') Q s + b * wp (p a') R s \<ominus> c \<le>
                                    wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    with nnP
    have "(\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c)) \<le>
          (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
      by(blast intro:setsum_mono mult_left_mono)
  }
  finally
  show "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
        b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c \<le>
        (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
qed

lemma sublinear_wp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes slp: "\<And>s a. a \<in> S s \<Longrightarrow> sublinear (wp (p a))"
      and hp:  "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
      and ne:  "\<And>s. S s \<noteq> {}"
  shows "sublinear (wp (SetDC p S))"
proof(rule sublinearI, simp add:wp_eval del:Inf_image_eq, rule cInf_greatest)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s and x y
  and a::real and b::real and c::real
  assume sP: "sound P" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  from ne show "(\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s \<noteq> {}" by(auto)

  assume yin: "y \<in> (\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s"
  then obtain x where xin: "x \<in> S s" and rwy: "y = wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
    by(auto)

  from xin hp sP nna
  have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) \<le> a * wp (p x) P s"
    by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
  moreover from xin hp sQ nnb
  have "b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<le> b * wp (p x) Q s"
    by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
  ultimately
  have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) +
        b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le>
        a * wp (p x) P s + b * wp (p x) Q s \<ominus> c"
    by(blast intro:tminus_left_mono add_mono)

  also from xin slp sP sQ nna nnb nnc
  have "... \<le> wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
    by(blast)

  finally show "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) + b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le> y"
    by(simp add:rwy)
qed

lemma sublinear_wp_Embed:
  "sublinear t \<Longrightarrow> sublinear (wp (Embed t))"
  by(simp add:wp_eval)

lemma sublinear_wp_repeat:
  "\<lbrakk> sublinear (wp p); healthy (wp p) \<rbrakk> \<Longrightarrow> sublinear (wp (repeat n p))"
  by(induct n, simp_all add:sublinear_wp_Seq sublinear_wp_Skip healthy_wp_repeat)

lemma sublinear_wp_Bind:
  "\<lbrakk> \<And>s. sublinear (wp (a (f s))) \<rbrakk> \<Longrightarrow> sublinear (wp (Bind f a))"
  by(rule sublinearI, simp add:wp_eval, auto)

subsection {* Sublinearity for Loops *}

text {* We break the proof of sublinearity loops into separate proofs of sub-distributivity and
sub-additivity.  The first follows by transfinite induction. *}
lemma sub_distrib_wp_loop:
  fixes body::"'s prog"
  assumes sdb: "sub_distrib (wp body)"
      and hb:  "healthy (wp body)"
      and nhb: "nearly_healthy (wlp body)"
  shows "sub_distrib (wp (do G \<longrightarrow> body od))"
proof -
  have "\<forall>P s. sound P \<longrightarrow> wp (do G \<longrightarrow> body od) P s \<ominus> 1 \<le>
                          wp (do G \<longrightarrow> body od) (\<lambda>s. P s \<ominus> 1) s"
  proof(rule loop_induct[OF hb nhb], safe)
    fix S::"('s trans \<times> 's trans) set" and P::"'s expect" and s::'s
    assume saS: "\<forall>x\<in>S. \<forall>P s. sound P \<longrightarrow> fst x P s \<ominus> 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s"
       and sP: "sound P"
       and fS: "\<forall>x\<in>S. feasible (fst x)"

    from sP have sPm: "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)

    have nnSup: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
    proof(cases "S={}", simp add:Sup_trans_def Sup_exp_def)
      fix s
      assume "S \<noteq> {}"
      then obtain x where xin: "x\<in>S" by(auto)
      with fS sPm have "0 \<le> fst x (\<lambda>s. P s \<ominus> 1) s" by(auto)
      also from xin fS sPm have "... \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
        by(auto intro!: le_funD[OF Sup_trans_upper2])
      finally show "?thesis s" .
    qed

    have "\<And>x s. fst x P s \<le> (fst x P s \<ominus> 1) + 1" by(simp add:tminus_def)
    also from saS sP
    have "\<And>x s. x\<in>S \<Longrightarrow> (fst x P s \<ominus> 1) + 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto intro:add_right_mono)
    also {
      from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
      with fS have "\<And>x s. x\<in>S \<Longrightarrow> fst x (\<lambda>s. P s \<ominus> 1) s + 1 \<le>
                                   Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
        by(blast intro!: add_right_mono le_funD[OF Sup_trans_upper2])
    }
    finally have le: "\<And>s. \<forall>x\<in>S. fst x P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto)
    moreover from nnSup have nn: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto intro:add_nonneg_nonneg)
    ultimately
    have leSup: "Sup_trans (fst ` S) P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      unfolding Sup_trans_def
      by(intro le_funD[OF Sup_exp_least], auto)

    show "Sup_trans (fst ` S) P s \<ominus> 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
    proof(cases "Sup_trans (fst ` S) P s \<le> 1", simp_all add:nnSup)
      from leSup have "Sup_trans (fst ` S) P s - 1 \<le>
                       Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1 - 1"
        by(auto)
      thus "Sup_trans (fst ` S) P s - 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s" by(simp)
    qed
  next
    fix t::"'s trans" and P::"'s expect" and s::'s
    assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
       and ft: "feasible t"
       and sP: "sound P"

     from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
     with ft have s2: "sound (t (\<lambda>s. P s \<ominus> 1))" by(auto)
     from sP ft have "sound (t P)" by(auto)
     hence s3: "sound (\<lambda>s. t P s \<ominus> 1)" by(auto intro!:tminus_sound)

    show "wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P s \<ominus> 1 \<le>
          wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (\<lambda>a. P a \<ominus> 1) s"
    proof(simp add:wp_eval)
      have "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 =
            \<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
        by(simp)
      also have "... \<le> (\<guillemotleft>G\<guillemotright> s * wp body (t P) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
                        ((1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
        by(rule tminus_add_mono)
      also have "... = \<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
        by(simp add:tminus_left_distrib)
      also {
        from ft sP have "wp body (t P) s \<ominus> 1 \<le> wp body (\<lambda>s. t P s \<ominus> 1) s"
          by(auto intro:sub_distribD[OF sdb])
        also {
          from IH sP have "\<lambda>s. t P s \<ominus> 1 \<tturnstile> t (\<lambda>s. P s \<ominus> 1)" by(auto)
          with sP ft s2 s3 have "wp body (\<lambda>s. t P s \<ominus> 1) s \<le> wp body (t (\<lambda>s. P s \<ominus> 1)) s"
            by(blast intro:le_funD[OF mono_transD, OF healthy_monoD, OF hb])
        }
        finally have "\<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1) \<le>
                      \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
          by(auto intro:add_right_mono mult_left_mono)
      }
      finally show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 \<le>
                    \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)" .
    qed
  next
    fix t t'::"'s trans" and P::"'s expect" and s::'s
    assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
       and eq: "equiv_trans t t'" and sP: "sound P"

    from sP have "t' P s \<ominus> 1 = t P s \<ominus> 1" by(simp add:equiv_transD[OF eq])
    also from sP IH have "... \<le> t (\<lambda>s. P s \<ominus> 1) s" by(auto)
    also {
      from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(simp add:tminus_sound)
      hence "t (\<lambda>s. P s \<ominus> 1) s = t' (\<lambda>s. P s \<ominus> 1) s" by(simp add:equiv_transD[OF eq])
    }
    finally show "t' P s \<ominus> 1 \<le> t' (\<lambda>s. P s \<ominus> 1) s" .
  qed
  thus ?thesis by(auto intro!:sub_distribI)
qed

text {* For sub-additivity, we again use the limit-of-iterates characterisation.  Firstly, all
iterates are sublinear: *}
lemma sublinear_iterates:
  assumes hb: "healthy (wp body)"
      and sb: "sublinear (wp body)"
  shows "sublinear (iterates body G i)"
  by(induct i, auto intro!:sublinear_wp_PC sublinear_wp_Seq sublinear_wp_Skip sublinear_wp_Embed
                           assms healthy_intros iterates_healthy)

text {* From this, sub-additivity follows for the limit (i.e. the loop), by appealing to the
property at all steps. *}
lemma sub_add_wp_loop:
  fixes body::"'s prog"
  assumes sb: "sublinear (wp body)"
      and cb:  "bd_cts (wp body)"
      and hwp:  "healthy (wp body)"
  shows "sub_add (wp (do G \<longrightarrow> body od))"
proof
  fix P Q::"'s expect" and s::'s
  assume sP: "sound P" and sQ: "sound Q"

  from hwp cb sP have "(\<lambda>i. iterates body G i P s) ----> wp do G \<longrightarrow> body od P s"
    by(rule loop_iterates)
  moreover
  from hwp cb sQ have "(\<lambda>i. iterates body G i Q s) ----> wp do G \<longrightarrow> body od Q s"
    by(rule loop_iterates)
  ultimately
  have "(\<lambda>i. iterates body G i P s + iterates body G i Q s) ---->
        wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s"
    by(rule tendsto_add)
  moreover {
    from sublinear_subadd[OF sublinear_iterates, OF hwp sb,
                          OF healthy_feasibleD[OF iterates_healthy, OF hwp]] sP sQ
    have "\<And>i. iterates body G i P s + iterates body G i Q s \<le> iterates body G i (\<lambda>s. P s + Q s) s"
      by(rule sub_addD)
  }
  moreover {
    from sP sQ have "sound (\<lambda>s. P s + Q s)" by(blast intro:sound_intros)
    with hwp cb have "(\<lambda>i. iterates body G i (\<lambda>s. P s + Q s) s) ---->
                           wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
      by(blast intro:loop_iterates)
  }
  ultimately
  show "wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s \<le> wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
    by(blast intro:LIMSEQ_le)
qed

lemmas sublinear_intros =
  sublinear_wp_Abort
  sublinear_wp_Skip
  sublinear_wp_Apply
  sublinear_wp_Seq
  sublinear_wp_PC
  sublinear_wp_DC
  sublinear_wp_SetPC
  sublinear_wp_SetDC
  sublinear_wp_Embed
  sublinear_wp_repeat
  sublinear_wp_Bind
  sublinear_wp_loop

end


(*  Title:      HOL/IMPP/Hoare.thy
    Author:     David von Oheimb
    Copyright   1999 TUM
*)

section \<open>Inductive definition of Hoare logic for partial correctness\<close>

theory Hoare
imports Natural
begin

text \<open>
  Completeness is taken relative to completeness of the underlying logic.

  Two versions of completeness proof: nested single recursion
  vs. simultaneous recursion in call rule
\<close>

type_synonym 'a assn = "'a => state => bool"
translations
  (type) "'a assn" <= (type) "'a => state => bool"

definition
  state_not_singleton :: bool where
  "state_not_singleton = (\<exists>s t::state. s ~= t)" (* at least two elements *)

definition
  peek_and :: "'a assn => (state => bool) => 'a assn" (infixr "&>" 35) where
  "peek_and P p = (%Z s. P Z s & p s)"

datatype 'a triple =
  triple "'a assn"  com  "'a assn"       ("{(1_)}./ (_)/ .{(1_)}" [3,60,3] 58)

definition
  triple_valid :: "nat => 'a triple     => bool" ( "|=_:_" [0 , 58] 57) where
  "|=n:t = (case t of {P}.c.{Q} =>
             !Z s. P Z s --> (!s'. <c,s> -n-> s' --> Q Z s'))"
abbreviation
  triples_valid :: "nat => 'a triple set => bool" ("||=_:_" [0 , 58] 57) where
  "||=n:G == Ball G (triple_valid n)"

definition
  hoare_valids :: "'a triple set => 'a triple set => bool" ("_||=_"  [58, 58] 57) where
  "G||=ts = (!n. ||=n:G --> ||=n:ts)"
abbreviation
  hoare_valid :: "'a triple set => 'a triple     => bool" ("_|=_"   [58, 58] 57) where
  "G |=t == G||={t}"

(* Most General Triples *)
definition
  MGT :: "com => state triple"            ("{=}._.{->}" [60] 58) where
  "{=}.c.{->} = {%Z s0. Z = s0}. c .{%Z s1. <c,Z> -c-> s1}"

inductive
  hoare_derivs :: "'a triple set => 'a triple set => bool" ("_||-_"  [58, 58] 57) and
  hoare_deriv :: "'a triple set => 'a triple     => bool" ("_|-_"   [58, 58] 57)
where
  "G |-t == G||-{t}"

| empty:    "G||-{}"
| insert: "[| G |-t;  G||-ts |]
        ==> G||-insert t ts"

| asm:      "ts <= G ==>
             G||-ts" (* {P}.BODY pn.{Q} instead of (general) t for SkipD_lemma *)

| cut:   "[| G'||-ts; G||-G' |] ==> G||-ts" (* for convenience and efficiency *)

| weaken: "[| G||-ts' ; ts <= ts' |] ==> G||-ts"

| conseq: "!Z s. P  Z  s --> (? P' Q'. G|-{P'}.c.{Q'} &
                                   (!s'. (!Z'. P' Z' s --> Q' Z' s') --> Q Z s'))
          ==> G|-{P}.c.{Q}"

| Skip:  "G|-{P}. SKIP .{P}"

| Ass:   "G|-{%Z s. P Z (s[X::=a s])}. X:==a .{P}"

| Local: "G|-{P}. c .{%Z s. Q Z (s[Loc X::=s'<X>])}
      ==> G|-{%Z s. s'=s & P Z (s[Loc X::=a s])}. LOCAL X:=a IN c .{Q}"

| Comp:  "[| G|-{P}.c.{Q};
             G|-{Q}.d.{R} |]
         ==> G|-{P}. (c;;d) .{R}"

| If:    "[| G|-{P &>        b }.c.{Q};
             G|-{P &> (Not o b)}.d.{Q} |]
         ==> G|-{P}. IF b THEN c ELSE d .{Q}"

| Loop:  "G|-{P &> b}.c.{P} ==>
          G|-{P}. WHILE b DO c .{P &> (Not o b)}"

(*
  BodyN: "(insert ({P}. BODY pn  .{Q}) G)
           |-{P}.  the (body pn) .{Q} ==>
          G|-{P}.       BODY pn  .{Q}"
*)
| Body:  "[| G Un (%p. {P p}.      BODY p  .{Q p})`Procs
               ||-(%p. {P p}. the (body p) .{Q p})`Procs |]
         ==>  G||-(%p. {P p}.      BODY p  .{Q p})`Procs"

| Call:     "G|-{P}. BODY pn .{%Z s. Q Z (setlocs s (getlocs s')[X::=s<Res>])}
         ==> G|-{%Z s. s'=s & P Z (setlocs s newlocs[Loc Arg::=a s])}.
             X:=CALL pn(a) .{Q}"

section \<open>Soundness and relative completeness of Hoare rules wrt operational semantics\<close>

lemma single_stateE:
  "state_not_singleton ==> !t. (!s::state. s = t) --> False"
apply (unfold state_not_singleton_def)
apply clarify
apply (case_tac "ta = t")
apply blast
apply (blast dest: not_sym)
done

declare peek_and_def [simp]

subsection "validity"

lemma triple_valid_def2:
  "|=n:{P}.c.{Q} = (!Z s. P Z s --> (!s'. <c,s> -n-> s' --> Q Z s'))"
apply (unfold triple_valid_def)
apply auto
done

lemma Body_triple_valid_0: "|=0:{P}. BODY pn .{Q}"
apply (simp (no_asm) add: triple_valid_def2)
apply clarsimp
done

(* only ==> direction required *)
lemma Body_triple_valid_Suc: "|=n:{P}. the (body pn) .{Q} = |=Suc n:{P}. BODY pn .{Q}"
apply (simp (no_asm) add: triple_valid_def2)
apply force
done

lemma triple_valid_Suc [rule_format (no_asm)]: "|=Suc n:t --> |=n:t"
apply (unfold triple_valid_def)
apply (induct_tac t)
apply simp
apply (fast intro: evaln_Suc)
done

lemma triples_valid_Suc: "||=Suc n:ts ==> ||=n:ts"
apply (fast intro: triple_valid_Suc)
done

subsection "derived rules"

lemma conseq12: "[| G|-{P'}.c.{Q'}; !Z s. P Z s -->
                         (!s'. (!Z'. P' Z' s --> Q' Z' s') --> Q Z s') |]
       ==> G|-{P}.c.{Q}"
apply (rule hoare_derivs.conseq)
apply blast
done

lemma conseq1: "[| G|-{P'}.c.{Q}; !Z s. P Z s --> P' Z s |] ==> G|-{P}.c.{Q}"
apply (erule conseq12)
apply fast
done

lemma conseq2: "[| G|-{P}.c.{Q'}; !Z s. Q' Z s --> Q Z s |] ==> G|-{P}.c.{Q}"
apply (erule conseq12)
apply fast
done

lemma Body1: "[| G Un (%p. {P p}.      BODY p  .{Q p})`Procs
          ||- (%p. {P p}. the (body p) .{Q p})`Procs;
    pn:Procs |] ==> G|-{P pn}. BODY pn .{Q pn}"
apply (drule hoare_derivs.Body)
apply (erule hoare_derivs.weaken)
apply fast
done

lemma BodyN: "(insert ({P}. BODY pn .{Q}) G) |-{P}. the (body pn) .{Q} ==>
  G|-{P}. BODY pn .{Q}"
apply (rule Body1)
apply (rule_tac [2] singletonI)
apply clarsimp
done

lemma escape: "[| !Z s. P Z s --> G|-{%Z s'. s'=s}.c.{%Z'. Q Z} |] ==> G|-{P}.c.{Q}"
apply (rule hoare_derivs.conseq)
apply fast
done

lemma "constant": "[| C ==> G|-{P}.c.{Q} |] ==> G|-{%Z s. P Z s & C}.c.{Q}"
apply (rule hoare_derivs.conseq)
apply fast
done

lemma LoopF: "G|-{%Z s. P Z s & ~b s}.WHILE b DO c.{P}"
apply (rule hoare_derivs.Loop [THEN conseq2])
apply  (simp_all (no_asm))
apply (rule hoare_derivs.conseq)
apply fast
done

(*
Goal "[| G'||-ts; G' <= G |] ==> G||-ts"
by (etac hoare_derivs.cut 1);
by (etac hoare_derivs.asm 1);
qed "thin";
*)
lemma thin [rule_format]: "G'||-ts ==> !G. G' <= G --> G||-ts"
apply (erule hoare_derivs.induct)
apply                (tactic \<open>ALLGOALS (EVERY'[clarify_tac @{context}, REPEAT o smp_tac @{context} 1])\<close>)
apply (rule hoare_derivs.empty)
apply               (erule (1) hoare_derivs.insert)
apply              (fast intro: hoare_derivs.asm)
apply             (fast intro: hoare_derivs.cut)
apply            (fast intro: hoare_derivs.weaken)
apply           (rule hoare_derivs.conseq, intro strip, tactic "smp_tac @{context} 2 1", clarify, tactic "smp_tac @{context} 1 1",rule exI, rule exI, erule (1) conjI)
prefer 7
apply          (rule_tac hoare_derivs.Body, drule_tac spec, erule_tac mp, fast)
apply         (tactic \<open>ALLGOALS (resolve_tac @{context} ((funpow 5 tl) @{thms hoare_derivs.intros}) THEN_ALL_NEW (fast_tac @{context}))\<close>)
done

lemma weak_Body: "G|-{P}. the (body pn) .{Q} ==> G|-{P}. BODY pn .{Q}"
apply (rule BodyN)
apply (erule thin)
apply auto
done

lemma derivs_insertD: "G||-insert t ts ==> G|-t & G||-ts"
apply (fast intro: hoare_derivs.weaken)
done

lemma finite_pointwise [rule_format (no_asm)]: "[| finite U;
  !p. G |-     {P' p}.c0 p.{Q' p}       --> G |-     {P p}.c0 p.{Q p} |] ==>
      G||-(%p. {P' p}.c0 p.{Q' p}) ` U --> G||-(%p. {P p}.c0 p.{Q p}) ` U"
apply (erule finite_induct)
apply simp
apply clarsimp
apply (drule derivs_insertD)
apply (rule hoare_derivs.insert)
apply  auto
done

subsection "soundness"

lemma Loop_sound_lemma:
 "G|={P &> b}. c .{P} ==>
  G|={P}. WHILE b DO c .{P &> (Not o b)}"
apply (unfold hoare_valids_def)
apply (simp (no_asm_use) add: triple_valid_def2)
apply (rule allI)
apply (subgoal_tac "!d s s'. <d,s> -n-> s' --> d = WHILE b DO c --> ||=n:G --> (!Z. P Z s --> P Z s' & ~b s') ")
apply  (erule thin_rl, fast)
apply ((rule allI)+, rule impI)
apply (erule evaln.induct)
apply (simp_all (no_asm))
apply fast
apply fast
done

lemma Body_sound_lemma:
   "[| G Un (%pn. {P pn}.      BODY pn  .{Q pn})`Procs
         ||=(%pn. {P pn}. the (body pn) .{Q pn})`Procs |] ==>
        G||=(%pn. {P pn}.      BODY pn  .{Q pn})`Procs"
apply (unfold hoare_valids_def)
apply (rule allI)
apply (induct_tac n)
apply  (fast intro: Body_triple_valid_0)
apply clarsimp
apply (drule triples_valid_Suc)
apply (erule (1) notE impE)
apply (simp add: ball_Un)
apply (drule spec, erule impE, erule conjI, assumption)
apply (fast intro!: Body_triple_valid_Suc [THEN iffD1])
done

lemma hoare_sound: "G||-ts ==> G||=ts"
apply (erule hoare_derivs.induct)
apply              (tactic \<open>TRYALL (eresolve_tac @{context} [@{thm Loop_sound_lemma}, @{thm Body_sound_lemma}] THEN_ALL_NEW assume_tac @{context})\<close>)
apply            (unfold hoare_valids_def)
apply            blast
apply           blast
apply          (blast) (* asm *)
apply         (blast) (* cut *)
apply        (blast) (* weaken *)
apply       (tactic \<open>ALLGOALS (EVERY'
  [REPEAT o Rule_Insts.thin_tac @{context} "hoare_derivs _ _" [],
   simp_tac @{context}, clarify_tac @{context}, REPEAT o smp_tac @{context} 1])\<close>)
apply       (simp_all (no_asm_use) add: triple_valid_def2)
apply       (intro strip, tactic "smp_tac @{context} 2 1", blast) (* conseq *)
apply      (tactic \<open>ALLGOALS (clarsimp_tac @{context})\<close>) (* Skip, Ass, Local *)
prefer 3 apply   (force) (* Call *)
apply  (erule_tac [2] evaln_elim_cases) (* If *)
apply   blast+
done

section "completeness"

(* Both versions *)

(*unused*)
lemma MGT_alternI: "G|-MGT c ==>
  G|-{%Z s0. !s1. <c,s0> -c-> s1 --> Z=s1}. c .{%Z s1. Z=s1}"
apply (unfold MGT_def)
apply (erule conseq12)
apply auto
done

(* requires com_det *)
lemma MGT_alternD: "state_not_singleton ==>
  G|-{%Z s0. !s1. <c,s0> -c-> s1 --> Z=s1}. c .{%Z s1. Z=s1} ==> G|-MGT c"
apply (unfold MGT_def)
apply (erule conseq12)
apply auto
apply (case_tac "\<exists>t. <c,s> -c-> t" for s)
apply  (fast elim: com_det)
apply clarsimp
apply (drule single_stateE)
apply blast
done

lemma MGF_complete:
 "{}|-(MGT c::state triple) ==> {}|={P}.c.{Q} ==> {}|-{P}.c.{Q::state assn}"
apply (unfold MGT_def)
apply (erule conseq12)
apply (clarsimp simp add: hoare_valids_def eval_eq triple_valid_def2)
done

declare WTs_elim_cases [elim!]
declare not_None_eq [iff]
(* requires com_det, escape (i.e. hoare_derivs.conseq) *)
lemma MGF_lemma1 [rule_format (no_asm)]: "state_not_singleton ==>
  !pn:dom body. G|-{=}.BODY pn.{->} ==> WT c --> G|-{=}.c.{->}"
apply (induct_tac c)
apply        (tactic \<open>ALLGOALS (clarsimp_tac @{context})\<close>)
prefer 7 apply        (fast intro: domI)
apply (erule_tac [6] MGT_alternD)
apply       (unfold MGT_def)
apply       (drule_tac [7] bspec, erule_tac [7] domI)
apply       (rule_tac [7] escape, tactic \<open>clarsimp_tac @{context} 7\<close>,
  rename_tac [7] "fun" y Z,
  rule_tac [7] P1 = "%Z' s. s= (setlocs Z newlocs) [Loc Arg ::= fun Z]" in hoare_derivs.Call [THEN conseq1], erule_tac [7] conseq12)
apply        (erule_tac [!] thin_rl)
apply (rule hoare_derivs.Skip [THEN conseq2])
apply (rule_tac [2] hoare_derivs.Ass [THEN conseq1])
apply        (rule_tac [3] escape, tactic \<open>clarsimp_tac @{context} 3\<close>,
  rename_tac [3] loc "fun" y Z,
  rule_tac [3] P1 = "%Z' s. s= (Z[Loc loc::=fun Z])" in hoare_derivs.Local [THEN conseq1],
  erule_tac [3] conseq12)
apply         (erule_tac [5] hoare_derivs.Comp, erule_tac [5] conseq12)
apply         (tactic \<open>(resolve_tac @{context} @{thms hoare_derivs.If} THEN_ALL_NEW
                eresolve_tac @{context} @{thms conseq12}) 6\<close>)
apply          (rule_tac [8] hoare_derivs.Loop [THEN conseq2], erule_tac [8] conseq12)
apply           auto
done

(* Version: nested single recursion *)

lemma nesting_lemma [rule_format]:
  assumes "!!G ts. ts <= G ==> P G ts"
    and "!!G pn. P (insert (mgt_call pn) G) {mgt(the(body pn))} ==> P G {mgt_call pn}"
    and "!!G c. [| wt c; !pn:U. P G {mgt_call pn} |] ==> P G {mgt c}"
    and "!!pn. pn : U ==> wt (the (body pn))"
  shows "finite U ==> uG = mgt_call`U ==>
  !G. G <= uG --> n <= card uG --> card G = card uG - n --> (!c. wt c --> P G {mgt c})"
apply (induct_tac n)
apply  (tactic \<open>ALLGOALS (clarsimp_tac @{context})\<close>)
apply  (subgoal_tac "G = mgt_call ` U")
prefer 2
apply   (simp add: card_seteq)
apply  simp
apply  (erule assms(3-)) (*MGF_lemma1*)
apply (rule ballI)
apply  (rule assms) (*hoare_derivs.asm*)
apply  fast
apply (erule assms(3-)) (*MGF_lemma1*)
apply (rule ballI)
apply (case_tac "mgt_call pn : G")
apply  (rule assms) (*hoare_derivs.asm*)
apply  fast
apply (rule assms(2-)) (*MGT_BodyN*)
apply (drule spec, erule impE, erule_tac [2] impE, drule_tac [3] spec, erule_tac [3] mp)
apply   (erule_tac [3] assms(4-))
apply   fast
apply (drule finite_subset)
apply (erule finite_imageI)
apply (simp (no_asm_simp))
done

lemma MGT_BodyN: "insert ({=}.BODY pn.{->}) G|-{=}. the (body pn) .{->} ==>
  G|-{=}.BODY pn.{->}"
apply (unfold MGT_def)
apply (rule BodyN)
apply (erule conseq2)
apply force
done

(* requires BodyN, com_det *)
lemma MGF: "[| state_not_singleton; WT_bodies; WT c |] ==> {}|-MGT c"
apply (rule_tac P = "%G ts. G||-ts" and U = "dom body" in nesting_lemma)
apply (erule hoare_derivs.asm)
apply (erule MGT_BodyN)
apply (rule_tac [3] finite_dom_body)
apply (erule MGF_lemma1)
prefer 2 apply (assumption)
apply       blast
apply      clarsimp
apply     (erule (1) WT_bodiesD)
apply (rule_tac [3] le_refl)
apply    auto
done

(* Version: simultaneous recursion in call rule *)

(* finiteness not really necessary here *)
lemma MGT_Body: "[| G Un (%pn. {=}.      BODY pn  .{->})`Procs
                          ||-(%pn. {=}. the (body pn) .{->})`Procs;
  finite Procs |] ==>   G ||-(%pn. {=}.      BODY pn  .{->})`Procs"
apply (unfold MGT_def)
apply (rule hoare_derivs.Body)
apply (erule finite_pointwise)
prefer 2 apply (assumption)
apply clarify
apply (erule conseq2)
apply auto
done

(* requires empty, insert, com_det *)
lemma MGF_lemma2_simult [rule_format (no_asm)]: "[| state_not_singleton; WT_bodies;
  F<=(%pn. {=}.the (body pn).{->})`dom body |] ==>
     (%pn. {=}.     BODY pn .{->})`dom body||-F"
apply (frule finite_subset)
apply (rule finite_dom_body [THEN finite_imageI])
apply (rotate_tac 2)
apply (tactic "make_imp_tac @{context} 1")
apply (erule finite_induct)
apply  (clarsimp intro!: hoare_derivs.empty)
apply (clarsimp intro!: hoare_derivs.insert simp del: range_composition)
apply (erule MGF_lemma1)
prefer 2 apply  (fast dest: WT_bodiesD)
apply clarsimp
apply (rule hoare_derivs.asm)
apply (fast intro: domI)
done

(* requires Body, empty, insert, com_det *)
lemma MGF': "[| state_not_singleton; WT_bodies; WT c |] ==> {}|-MGT c"
apply (rule MGF_lemma1)
apply assumption
prefer 2 apply (assumption)
apply clarsimp
apply (subgoal_tac "{}||- (%pn. {=}. BODY pn .{->}) `dom body")
apply (erule hoare_derivs.weaken)
apply  (fast intro: domI)
apply (rule finite_dom_body [THEN [2] MGT_Body])
apply (simp (no_asm))
apply (erule (1) MGF_lemma2_simult)
apply (rule subset_refl)
done

(* requires Body+empty+insert / BodyN, com_det *)
lemmas hoare_complete = MGF' [THEN MGF_complete]

subsection "unused derived rules"

lemma falseE: "G|-{%Z s. False}.c.{Q}"
apply (rule hoare_derivs.conseq)
apply fast
done

lemma trueI: "G|-{P}.c.{%Z s. True}"
apply (rule hoare_derivs.conseq)
apply (fast intro!: falseE)
done

lemma disj: "[| G|-{P}.c.{Q}; G|-{P'}.c.{Q'} |]
        ==> G|-{%Z s. P Z s | P' Z s}.c.{%Z s. Q Z s | Q' Z s}"
apply (rule hoare_derivs.conseq)
apply (fast elim: conseq12)
done (* analogue conj non-derivable *)

lemma hoare_SkipI: "(!Z s. P Z s --> Q Z s) ==> G|-{P}. SKIP .{Q}"
apply (rule conseq12)
apply (rule hoare_derivs.Skip)
apply fast
done

subsection "useful derived rules"

lemma single_asm: "{t}|-t"
apply (rule hoare_derivs.asm)
apply (rule subset_refl)
done

lemma export_s: "[| !!s'. G|-{%Z s. s'=s & P Z s}.c.{Q} |] ==> G|-{P}.c.{Q}"
apply (rule hoare_derivs.conseq)
apply auto
done

lemma weak_Local: "[| G|-{P}. c .{Q}; !k Z s. Q Z s --> Q Z (s[Loc Y::=k]) |] ==>
    G|-{%Z s. P Z (s[Loc Y::=a s])}. LOCAL Y:=a IN c .{Q}"
apply (rule export_s)
apply (rule hoare_derivs.Local)
apply (erule conseq2)
apply (erule spec)
done

(*
Goal "!Q. G |-{%Z s. ~(? s'. <c,s> -c-> s')}. c .{Q}"
by (induct_tac "c" 1);
by Auto_tac;
by (rtac conseq1 1);
by (rtac hoare_derivs.Skip 1);
force 1;
by (rtac conseq1 1);
by (rtac hoare_derivs.Ass 1);
force 1;
by (defer_tac 1);
###
by (rtac hoare_derivs.Comp 1);
by (dtac spec 2);
by (dtac spec 2);
by (assume_tac 2);
by (etac conseq1 2);
by (Clarsimp_tac 2);
force 1;
*)

end